+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
{-# OPTIONS_HADDOCK prune #-}
-- |Manipulation of WWW authorization.
, UserID
, Password
+ , printAuthChallenge
, authCredentialP -- private
)
where
-
-import qualified Codec.Binary.Base64 as B64
-import Data.Maybe
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as C8
+import Data.Monoid.Unicode
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
-- |Authorization challenge to be sent to client with
-- \"WWW-Authenticate\" header. See
deriving (Eq)
-- |'Realm' is just a string which must not contain any non-ASCII letters.
-type Realm = String
+type Realm = Ascii
-- |Authorization credential to be sent by client with
-- \"Authorization\" header. See
-- |'UserID' is just a string which must not contain colon and any
-- non-ASCII letters.
-type UserID = String
+type UserID = Ascii
-- |'Password' is just a string which must not contain any non-ASCII
-- letters.
-type Password = String
-
+type Password = Ascii
-instance Show AuthChallenge where
- show (BasicAuthChallenge realm)
- = "Basic realm=" ++ quoteStr realm
+-- |Convert an 'AuthChallenge' to 'Ascii'.
+printAuthChallenge ∷ AuthChallenge → Ascii
+printAuthChallenge (BasicAuthChallenge realm)
+ = A.fromAsciiBuilder $
+ A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
+authCredentialP ∷ Parser AuthCredential
+authCredentialP
+ = do _ ← string "Basic"
+ skipMany1 lws
+ b64 ← takeWhile1 base64
+ case C8.break (≡ ':') (B64.decodeLenient b64) of
+ (user, cPassword)
+ | C8.null cPassword
+ → fail "no colons in the basic auth credential"
+ | otherwise
+ → do u ← asc user
+ p ← asc (C8.tail cPassword)
+ return (BasicAuthCredential u p)
+ where
+ base64 ∷ Char → Bool
+ base64 = inClass "a-zA-Z0-9+/="
-authCredentialP :: Parser AuthCredential
-authCredentialP = allowEOF $!
- do string "Basic"
- many1 lws
- b64 <- many1
- $ satisfy (\ c -> (c >= 'a' && c <= 'z') ||
- (c >= 'A' && c <= 'Z') ||
- (c >= '0' && c <= '9') ||
- c == '+' ||
- c == '/' ||
- c == '=')
- let decoded = map (toEnum . fromEnum) (fromJust $ B64.decode b64)
- case break (== ':') decoded of
- (uid, ':' : password)
- -> return (BasicAuthCredential uid password)
- _ -> failP
+ asc ∷ C8.ByteString → Parser Ascii
+ asc bs = case A.fromByteString bs of
+ Just as → return as
+ Nothing → fail "Non-ascii character in auth credential"