Network/HTTP/Lucu/Authentication.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |An internal module for HTTP authentication.
   9 module Network.HTTP.Lucu.Authentication
  10     ( AuthChallenge(..)
  11     , AuthCredential(..)
  12     , Realm
  13     , UserID
  14     , Password
  15     , authCredential
  16     )
  17     where
  18 import Control.Monad
  19 import Data.Ascii (Ascii, AsciiBuilder)
  20 import Data.Attempt
  21 import Data.Attoparsec.Char8
  22 import qualified Data.ByteString.Base64 as B64
  23 import qualified Data.ByteString.Char8 as C8
  24 import Data.Convertible.Base
  25 import Data.Convertible.Instances.Ascii ()
  26 import Data.Convertible.Utils
  27 import Data.Monoid.Unicode
  28 import Network.HTTP.Lucu.Parser.Http
  29 import Network.HTTP.Lucu.Utils
  30 import Prelude.Unicode
  31
  32 -- |Authentication challenge to be sent to clients with
  33 -- \"WWW-Authenticate\" header field. See
  34 -- 'Network.HTTP.Lucu.setWWWAuthenticate'.
  35 data AuthChallenge
  36     = BasicAuthChallenge !Realm
  37       deriving (Eq)
  38
  39 -- |'Realm' is just an 'Ascii' string.
  40 type Realm = Ascii
  41
  42 -- |Authorization credential to be sent by client with
  43 -- \"Authorization\" header. See 'Network.HTTP.Lucu.getAuthorization'.
  44 data AuthCredential
  45     = BasicAuthCredential !UserID !Password
  46       deriving (Show, Eq)
  47
  48 -- |'UserID' is just an 'Ascii' string containing no colons (\':\').
  49 type UserID = Ascii
  50
  51 -- |'Password' is just an 'Ascii' string.
  52 type Password = Ascii
  53
  54 instance ConvertSuccess AuthChallenge Ascii where
  55     {-# INLINE convertSuccess #-}
  56     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  57
  58 instance ConvertSuccess AuthChallenge AsciiBuilder where
  59     {-# INLINE convertSuccess #-}
  60     convertSuccess (BasicAuthChallenge realm)
  61         = cs ("Basic realm=" ∷ Ascii) ⊕ quoteStr realm
  62
  63 deriveAttempts [ ([t| AuthChallenge |], [t| Ascii        |])
  64                , ([t| AuthChallenge |], [t| AsciiBuilder |])
  65                ]
  66
  67 -- |'Parser' for an 'AuthCredential'.
  68 authCredential ∷ Parser AuthCredential
  69 authCredential
  70     = do void $ string "Basic"
  71          skipMany1 lws
  72          b64 ← takeWhile1 base64
  73          case C8.break (≡ ':') (B64.decodeLenient b64) of
  74            (user, cPassword)
  75                | C8.null cPassword
  76                    → fail "no colons in the basic auth credential"
  77                | otherwise
  78                    → do u ← asc user
  79                         p ← asc (C8.tail cPassword)
  80                         return (BasicAuthCredential u p)
  81     where
  82       base64 ∷ Char → Bool
  83       base64 = inClass "a-zA-Z0-9+/="
  84
  85       asc ∷ C8.ByteString → Parser Ascii
  86       asc bs = case ca bs of
  87                  Success as → return as
  88                  Failure _  → fail "Non-ascii character in auth credential"