Network/HTTP/Lucu/Authorization.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5
   6 -- |Manipulation of WWW authorization.
   7 module Network.HTTP.Lucu.Authorization
   8     ( AuthChallenge(..)
   9     , AuthCredential(..)
  10     , Realm
  11     , UserID
  12     , Password
  13
  14     , printAuthChallenge
  15     , authCredentialP
  16     )
  17     where
  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 -- |Authorization challenge to be sent to client with
  29 -- \"WWW-Authenticate\" header. See
  30 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
  31 data AuthChallenge
  32     = BasicAuthChallenge !Realm
  33       deriving (Eq)
  34
  35 -- |'Realm' is just a string which must not contain any non-ASCII letters.
  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 a string which must not contain colon and any
  46 -- non-ASCII letters.
  47 type UserID   = Ascii
  48
  49 -- |'Password' is just a string which must not contain any non-ASCII
  50 -- letters.
  51 type Password = Ascii
  52
  53 -- |Convert an 'AuthChallenge' to 'Ascii'.
  54 printAuthChallenge ∷ AuthChallenge → Ascii
  55 printAuthChallenge (BasicAuthChallenge realm)
  56     = A.fromAsciiBuilder $
  57       A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
  58
  59 authCredentialP ∷ Parser AuthCredential
  60 authCredentialP
  61     = do _ ← string "Basic"
  62          skipMany1 lws
  63          b64 ← takeWhile1 base64
  64          case C8.break (≡ ':') (B64.decodeLenient b64) of
  65            (user, cPassword)
  66                | C8.null cPassword
  67                    → fail "no colons in the basic auth credential"
  68                | otherwise
  69                    → do u ← asc user
  70                         p ← asc (C8.tail cPassword)
  71                         return (BasicAuthCredential u p)
  72     where
  73       base64 ∷ Char → Bool
  74       base64 = inClass "a-zA-Z0-9+/="
  75
  76       asc ∷ C8.ByteString → Parser Ascii
  77       asc bs = case A.fromByteString bs of
  78                  Just as → return as
  79                  Nothing → fail "Non-ascii character in auth credential"