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.Maybe
  25 import Data.Monoid.Unicode
  26 import Network.HTTP.Lucu.Parser.Http
  27 import Network.HTTP.Lucu.Utils
  28 import Prelude.Unicode
  29
  30 -- |Authorization challenge to be sent to client with
  31 -- \"WWW-Authenticate\" header. See
  32 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
  33 data AuthChallenge
  34     = BasicAuthChallenge Realm
  35       deriving (Eq)
  36
  37 -- |'Realm' is just a string which must not contain any non-ASCII letters.
  38 type Realm = Ascii
  39
  40 -- |Authorization credential to be sent by client with
  41 -- \"Authorization\" header. See
  42 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
  43 data AuthCredential
  44     = BasicAuthCredential UserID Password
  45       deriving (Show, Eq)
  46
  47 -- |'UserID' is just a string which must not contain colon and any
  48 -- non-ASCII letters.
  49 type UserID   = Ascii
  50
  51 -- |'Password' is just a string which must not contain any non-ASCII
  52 -- letters.
  53 type Password = Ascii
  54
  55 -- |Convert an 'AuthChallenge' to 'Ascii'.
  56 printAuthChallenge ∷ AuthChallenge → Ascii
  57 printAuthChallenge (BasicAuthChallenge realm)
  58     = A.fromAsciiBuilder $
  59       A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
  60
  61 authCredentialP ∷ Parser AuthCredential
  62 authCredentialP
  63     = try $
  64       do _ ← string "Basic"
  65          skipMany1 lws
  66          b64 ← takeWhile1 base64
  67          case C8.break (≡ ':') (B64.decodeLenient b64) of
  68            (user, cPassword)
  69                | C8.null cPassword
  70                    → fail "no colons in the basic auth credential"
  71                | otherwise
  72                    → let u = fromJust $ A.fromByteString user
  73                          p = fromJust $ A.fromByteString (C8.tail cPassword)
  74                      in
  75                        return (BasicAuthCredential u p)
  76     where
  77       base64 ∷ Char → Bool
  78       base64 = inClass "a-zA-Z0-9+/="