Fixed breakage on GHC 6.10.1

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index a8d8011fdbb3b971b0aeb01b3edc6ac9efa5bbc0..f1186b7170635c4a4d7181cf84da509b2b24e08a 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,4 +1,4 @@
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
 
 -- |This is the Resource Monad; monadic actions to define the behavior
 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
@@ -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
@@ -291,7 +294,7 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- doesn't parse the request body. See 'inputForm'.
 getQueryForm :: Resource [(String, String)]
 getQueryForm = do uri <- getRequestURI
-                  return $! parseWWWFormURLEncoded $ uriQuery uri
+                  return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used
@@ -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 時に使用するアクション群 -}