+-- #prune
+
+-- |Manipulation of WWW authorization.
+module Network.HTTP.Lucu.Authorization
+ ( AuthChallenge(..)
+ , AuthCredential(..)
+ , Realm
+ , UserID
+ , Password
+
+ , authCredentialP -- private
+ )
+ where
+
+import qualified Codec.Binary.Base64 as B64
+import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+
+-- |Authorization challenge to be sent to client with
+-- \"WWW-Authenticate\" header. See
+-- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
+data AuthChallenge
+ = BasicAuthChallenge Realm
+ deriving (Eq)
+
+-- |'Realm' is just a string which must not contain any non-ASCII letters.
+type Realm = String
+
+-- |Authorization credential to be sent by client with
+-- \"Authorization\" header. See
+-- 'Network.HTTP.Lucu.Resource.getAuthorization'.
+data AuthCredential
+ = BasicAuthCredential UserID Password
+ deriving (Show, Eq)
+
+-- |'UserID' is just a string which must not contain colon and any
+-- non-ASCII letters.
+type UserID = String
+
+-- |'Password' is just a string which must not contain any non-ASCII
+-- letters.
+type Password = String
+
+
+instance Show AuthChallenge where
+ show (BasicAuthChallenge realm)
+ = "Basic realm=" ++ quoteStr realm
+
+
+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) (B64.decode b64)
+ case break (== ':') decoded of
+ (uid, ':' : password)
+ -> return (BasicAuthCredential uid password)
+ _ -> failP