Network/HTTP/Lucu/Authentication.hs

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