Network/HTTP/Lucu/Authorization.hs

   1 -- #prune
   2
   3 -- |Manipulation of WWW authorization.
   4 module Network.HTTP.Lucu.Authorization
   5     ( AuthChallenge(..)
   6     , AuthCredential(..)
   7     , Realm
   8     , UserID
   9     , Password
  10
  11     , authCredentialP -- private
  12     )
  13     where
  14
  15 import qualified Codec.Binary.Base64 as B64
  16 import           Data.Maybe
  17 import           Network.HTTP.Lucu.Parser
  18 import           Network.HTTP.Lucu.Parser.Http
  19 import           Network.HTTP.Lucu.Utils
  20
  21 -- |Authorization challenge to be sent to client with
  22 -- \"WWW-Authenticate\" header. See
  23 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
  24 data AuthChallenge
  25     = BasicAuthChallenge Realm
  26       deriving (Eq)
  27
  28 -- |'Realm' is just a string which must not contain any non-ASCII letters.
  29 type Realm = String
  30
  31 -- |Authorization credential to be sent by client with
  32 -- \"Authorization\" header. See
  33 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
  34 data AuthCredential
  35     = BasicAuthCredential UserID Password
  36       deriving (Show, Eq)
  37
  38 -- |'UserID' is just a string which must not contain colon and any
  39 -- non-ASCII letters.
  40 type UserID   = String
  41
  42 -- |'Password' is just a string which must not contain any non-ASCII
  43 -- letters.
  44 type Password = String
  45
  46
  47 instance Show AuthChallenge where
  48     show (BasicAuthChallenge realm)
  49         = "Basic realm=" ++ quoteStr realm
  50
  51
  52 authCredentialP :: Parser AuthCredential
  53 authCredentialP = allowEOF $!
  54                   do string "Basic"
  55                      many1 lws
  56                      b64 <- many1
  57                             $ satisfy (\ c -> (c >= 'a' && c <= 'z') ||
  58                                               (c >= 'A' && c <= 'Z') ||
  59                                               (c >= '0' && c <= '9') ||
  60                                               c == '+' ||
  61                                               c == '/' ||
  62                                               c == '=')
  63                      let decoded = map (toEnum . fromEnum) (fromJust $ B64.decode b64)
  64                      case break (== ':') decoded of
  65                        (uid, ':' : password)
  66                            -> return (BasicAuthCredential uid password)
  67                        _   -> failP