{-# LANGUAGE
    FlexibleInstances
  , MultiParamTypeClasses
  , OverloadedStrings
  , TemplateHaskell
  , UnicodeSyntax
  #-}
-- |An internal module for HTTP authentication.
module Network.HTTP.Lucu.Authentication
    ( AuthChallenge(..)
    , AuthCredential(..)
    , Realm
    , UserID
    , Password
    , authCredential
    )
    where
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder)
import Data.Attempt
import Data.Attoparsec.Char8
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as C8
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
import Prelude.Unicode

-- |Authentication challenge to be sent to clients with
-- \"WWW-Authenticate\" header field. See
-- 'Network.HTTP.Lucu.setWWWAuthenticate'.
data AuthChallenge
    = BasicAuthChallenge !Realm
      deriving (Eq)

-- |'Realm' is just an 'Ascii' string.
type Realm = Ascii

-- |Authorization credential to be sent by client with
-- \"Authorization\" header. See 'Network.HTTP.Lucu.getAuthorization'.
data AuthCredential
    = BasicAuthCredential !UserID !Password
      deriving (Show, Eq)

-- |'UserID' is just an 'Ascii' string containing no colons (\':\').
type UserID = Ascii

-- |'Password' is just an 'Ascii' string.
type Password = Ascii

instance ConvertSuccess AuthChallenge Ascii where
    {-# INLINE convertSuccess #-}
    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)

instance ConvertSuccess AuthChallenge AsciiBuilder where
    {-# INLINE convertSuccess #-}
    convertSuccess (BasicAuthChallenge realm)
        = cs ("Basic realm=" ∷ Ascii) ⊕ quoteStr realm

deriveAttempts [ ([t| AuthChallenge |], [t| Ascii        |])
               , ([t| AuthChallenge |], [t| AsciiBuilder |])
               ]

-- |'Parser' for an 'AuthCredential'.
authCredential ∷ Parser AuthCredential
authCredential
    = do void $ string "Basic"
         skipMany1 lws
         b64 ← takeWhile1 base64
         case C8.break (≡ ':') (B64.decodeLenient b64) of
           (user, cPassword)
               | C8.null cPassword
                   → fail "no colons in the basic auth credential"
               | otherwise
                   → do u ← asc user
                        p ← asc (C8.tail cPassword)
                        return (BasicAuthCredential u p)
    where
      base64 ∷ Char → Bool
      base64 = inClass "a-zA-Z0-9+/="

      asc ∷ C8.ByteString → Parser Ascii
      asc bs = case ca bs of
                 Success as → return as
                 Failure _  → fail "Non-ascii character in auth credential"