Network/HTTP/Lucu/Authorization.hs

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