From: pho <pho@cielonegro.org>
Date: Thu, 10 Jan 2008 05:54:20 +0000 (+0900)
Subject: added facilities for basic authentication (not tested)
X-Git-Tag: RELEASE-0_2_1~13
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=497cbd0e695fa05a0db8dd17dad7b303321ed1e0

added facilities for basic authentication (not tested)

darcs-hash:20080110055420-62b54-3f799b4e91fe6ad19a36874a0e22ad1c46c935cb.gz
---

diff --git a/Lucu.cabal b/Lucu.cabal
index e545e99..5ee1f72 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -35,6 +35,7 @@ Library
     Exposed-Modules:
         Network.HTTP.Lucu
         Network.HTTP.Lucu.Abortion
+        Network.HTTP.Lucu.Authorization
         Network.HTTP.Lucu.Config
         Network.HTTP.Lucu.ETag
         Network.HTTP.Lucu.HttpVersion
diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
new file mode 100644
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
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index a8d8011..12056ee 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -85,6 +85,7 @@ module Network.HTTP.Lucu.Resource
     , getAcceptEncoding
     , isEncodingAcceptable
     , getContentType
+    , getAuthorization
 
     -- ** Finding an entity
 
@@ -117,6 +118,7 @@ module Network.HTTP.Lucu.Resource
     , setContentType
     , setLocation
     , setContentEncoding
+    , setWWWAuthenticate
 
     -- ** Writing a response body
 
@@ -143,6 +145,7 @@ import           Data.List
 import           Data.Maybe
 import           Data.Time
 import           Network.HTTP.Lucu.Abortion
+import           Network.HTTP.Lucu.Authorization
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.ContentCoding
 import           Network.HTTP.Lucu.DefaultPage
@@ -365,6 +368,20 @@ getContentType
                                           (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
 
 
+-- |Get the header \"Authorization\" as
+-- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
+getAuthorization :: Resource (Maybe AuthCredential)
+getAuthorization
+    = do authM <- getHeader (C8.pack "Authorization")
+         case authM of
+           Nothing
+               -> return Nothing
+           Just auth
+               -> case parse authCredentialP (L8.fromChunks [auth]) of
+                    (# Success a, _ #) -> return $ Just a
+                    (# _        , _ #) -> return Nothing
+
+
 {- ExaminingRequest 時に使用するアクション群 -}
 
 -- |Tell the system that the 'Resource' found an entity for the
@@ -806,6 +823,12 @@ setContentEncoding codings
                     _               -> undefined
          setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
 
+-- |Computation of @'setWWWAuthenticate' challenge@ sets the response
+-- header \"WWW-Authenticate\" to @challenge@.
+setWWWAuthenticate :: AuthChallenge -> Resource ()
+setWWWAuthenticate challenge
+    = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
+
 
 {- DecidingBody 時に使用するアクション群 -}