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.Resource.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
  40 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
  41 data AuthCredential
  42     = BasicAuthCredential !UserID !Password
  43       deriving (Show, Eq)
  44
  45 -- |'UserID' is just an 'Ascii' string containing no colons (\':\').
  46 type UserID = Ascii
  47
  48 -- |'Password' is just an 'Ascii' string.
  49 type Password = Ascii
  50
  51 -- |Convert an 'AuthChallenge' to 'Ascii'.
  52 printAuthChallenge ∷ AuthChallenge → Ascii
  53 printAuthChallenge (BasicAuthChallenge realm)
  54     = A.fromAsciiBuilder $
  55       A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
  56
  57 -- |'Parser' for an 'AuthCredential'.
  58 authCredential ∷ Parser AuthCredential
  59 authCredential
  60     = do void $ string "Basic"
  61          skipMany1 lws
  62          b64 ← takeWhile1 base64
  63          case C8.break (≡ ':') (B64.decodeLenient b64) of
  64            (user, cPassword)
  65                | C8.null cPassword
  66                    → fail "no colons in the basic auth credential"
  67                | otherwise
  68                    → do u ← asc user
  69                         p ← asc (C8.tail cPassword)
  70                         return (BasicAuthCredential u p)
  71     where
  72       base64 ∷ Char → Bool
  73       base64 = inClass "a-zA-Z0-9+/="
  74
  75       asc ∷ C8.ByteString → Parser Ascii
  76       asc bs = case A.fromByteString bs of
  77                  Just as → return as
  78                  Nothing → fail "Non-ascii character in auth credential"