Network/HTTP/Lucu/Authorization.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 {-# OPTIONS_HADDOCK prune #-}
   5
   6 -- |Manipulation of WWW authorization.
   7 module Network.HTTP.Lucu.Authorization
   8     ( AuthChallenge(..)
   9     , AuthCredential(..)
  10     , Realm
  11     , UserID
  12     , Password
  13
  14     , authCredentialP -- private
  15     )
  16     where
  17 import Data.Ascii (Ascii)
  18 import qualified Data.Ascii as A
  19 import qualified Data.ByteString.Base64 as B64
  20 import qualified Data.ByteString.Char8 as C8
  21 import Network.HTTP.Lucu.Parser.Http
  22 import Network.HTTP.Lucu.Utils
  23 import Prelude.Unicode
  24
  25 -- |Authorization challenge to be sent to client with
  26 -- \"WWW-Authenticate\" header. See
  27 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
  28 data AuthChallenge
  29     = BasicAuthChallenge Realm
  30       deriving (Eq)
  31
  32 -- |'Realm' is just a string which must not contain any non-ASCII letters.
  33 type Realm = Ascii
  34
  35 -- |Authorization credential to be sent by client with
  36 -- \"Authorization\" header. See
  37 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
  38 data AuthCredential
  39     = BasicAuthCredential UserID Password
  40       deriving (Show, Eq)
  41
  42 -- |'UserID' is just a string which must not contain colon and any
  43 -- non-ASCII letters.
  44 type UserID   = Ascii
  45
  46 -- |'Password' is just a string which must not contain any non-ASCII
  47 -- letters.
  48 type Password = Ascii
  49
  50 -- FIXME: Don't use String for network output.
  51 instance Show AuthChallenge where
  52     show (BasicAuthChallenge realm)
  53         = "Basic realm=" ⧺ quoteStr realm
  54
  55 authCredentialP ∷ Parser AuthCredential
  56 authCredentialP
  57     = allowEOF $!
  58       do _   ← string "Basic"
  59          _   ← many1 lws
  60          b64 ← many1
  61                $ satisfy (\c → (c ≥ 'a' ∧ c ≤ 'z') ∨
  62                                (c ≥ 'A' ∧ c ≤ 'Z') ∨
  63                                (c ≥ '0' ∧ c ≤ '9') ∨
  64                                 c ≡ '+' ∨
  65                                 c ≡ '/' ∨
  66                                 c ≡ '=')
  67          case break (≡ ':') (decode b64) of
  68            (uid, ':' : password)
  69                → return (BasicAuthCredential uid password)
  70            _   → failP
  71     where
  72       decode ∷ String → String
  73       decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack