{-# LANGUAGE
    FlexibleInstances
  , MultiParamTypeClasses
  , OverloadedStrings
  , TemplateHaskell
  , TypeSynonymInstances
  , UnicodeSyntax
  #-}
-- |An internal module for HTTP authentication.
module Network.HTTP.Lucu.Authentication
    ( AuthChallenge(..)
    , AuthCredential(..)
    , Realm
    , UserID
    , Password
    )
    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.Default
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 |])
               ]

instance Default (Parser AuthCredential) where
    def = 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"