added facilities for basic authentication (not tested)

[Lucu.git] / Network / HTTP / Lucu / Authorization.hs

diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
new file mode 100644 (file)
index 0000000..bcc8003
--- /dev/null
+++ b/Network/HTTP/Lucu/Authorization.hs
@@ -0,0 +1,66 @@
+-- #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