Network/HTTP/Lucu/Authentication.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 -- |Manipulation of WWW authentication.
   6 module Network.HTTP.Lucu.Authentication
   7     ( AuthChallenge(..)
   8     , AuthCredential(..)
   9     , Realm
  10     , UserID
  11     , Password
  12
  13     , printAuthChallenge
  14     , authCredentialP
  15     )
  16     where
  17 import Data.Ascii (Ascii)
  18 import qualified Data.Ascii as A
  19 import Data.Attoparsec.Char8
  20 import qualified Data.ByteString.Base64 as B64
  21 import qualified Data.ByteString.Char8 as C8
  22 import Data.Monoid.Unicode
  23 import Network.HTTP.Lucu.Parser.Http
  24 import Network.HTTP.Lucu.Utils
  25 import Prelude.Unicode
  26
  27 -- |Authorization challenge to be sent to client with
  28 -- \"WWW-Authenticate\" header. See
  29 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
  30 data AuthChallenge
  31     = BasicAuthChallenge !Realm
  32       deriving (Eq)
  33
  34 -- |'Realm' is just a string which must not contain any non-ASCII letters.
  35 type Realm = Ascii
  36
  37 -- |Authorization credential to be sent by client with
  38 -- \"Authorization\" header. See
  39 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
  40 data AuthCredential
  41     = BasicAuthCredential !UserID !Password
  42       deriving (Show, Eq)
  43
  44 -- |'UserID' is just a string which must not contain colon and any
  45 -- non-ASCII letters.
  46 type UserID   = Ascii
  47
  48 -- |'Password' is just a string which must not contain any non-ASCII
  49 -- letters.
  50 type Password = Ascii
  51
  52 -- |Convert an 'AuthChallenge' to 'Ascii'.
  53 printAuthChallenge ∷ AuthChallenge → Ascii
  54 printAuthChallenge (BasicAuthChallenge realm)
  55     = A.fromAsciiBuilder $
  56       A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
  57
  58 authCredentialP ∷ Parser AuthCredential
  59 authCredentialP
  60     = do _ ← 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"