X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=08fb6f19ce50b434457d42f0deef09710f6c31f1;hb=37b2602949bdb71894852304753f3aab34de191b;hp=a8d8011fdbb3b971b0aeb01b3edc6ac9efa5bbc0;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index a8d8011..08fb6f1 100644
--- 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'
@@ -60,8 +60,9 @@
 
 module Network.HTTP.Lucu.Resource
     (
-    -- * Monad
-    Resource
+    -- * Types
+      Resource
+    , FormData(..)
     , runRes -- private
 
     -- * Actions
@@ -73,6 +74,8 @@ module Network.HTTP.Lucu.Resource
     , getConfig
     , getRemoteAddr
     , getRemoteAddr'
+    , getRemoteHost
+    , getRemoteCertificate
     , getRequest
     , getMethod
     , getRequestURI
@@ -85,6 +88,7 @@ module Network.HTTP.Lucu.Resource
     , getAcceptEncoding
     , isEncodingAcceptable
     , getContentType
+    , getAuthorization
 
     -- ** Finding an entity
 
@@ -117,6 +121,7 @@ module Network.HTTP.Lucu.Resource
     , setContentType
     , setLocation
     , setContentEncoding
+    , setWWWAuthenticate
 
     -- ** Writing a response body
 
@@ -133,7 +138,6 @@ module Network.HTTP.Lucu.Resource
 
 import           Control.Concurrent.STM
 import           Control.Monad.Reader
-import           Data.Bits
 import qualified Data.ByteString as Strict (ByteString)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
@@ -142,7 +146,9 @@ import           Data.Char
 import           Data.List
 import           Data.Maybe
 import           Data.Time
+import qualified Data.Time.HTTP as HTTP
 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
@@ -153,13 +159,13 @@ import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.MultipartForm
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
-import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.MIMEType
 import           Network.HTTP.Lucu.Utils
 import           Network.Socket hiding (accept)
 import           Network.URI hiding (path)
+import           OpenSSL.X509
 
 -- |The 'Resource' monad. This monad implements
 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
@@ -206,21 +212,29 @@ getRemoteAddr = do itr <- getInteraction
 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
 -- use 'getRemoteAddr'.
 getRemoteAddr' :: Resource String
-getRemoteAddr' = do addr <- getRemoteAddr
-                    case addr of
-                      -- Network.Socket は IPv6 を考慮してゐないやうだ…
-                      SockAddrInet _ v4addr
-                          -> let b1 = (v4addr `shiftR` 24) .&. 0xFF
-                                 b2 = (v4addr `shiftR` 16) .&. 0xFF
-                                 b3 = (v4addr `shiftR`  8) .&. 0xFF
-                                 b4 =  v4addr              .&. 0xFF
-                             in
-                               return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]
-                      SockAddrUnix path
-                          -> return path
-                      _
-                          -> undefined
+getRemoteAddr' = do addr          <- getRemoteAddr
+                    (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
+                    return str
 
+-- |Resolve an address to the remote host.
+getRemoteHost :: Resource String
+getRemoteHost = do addr          <- getRemoteAddr
+                   (Just str, _) <- liftIO $! getNameInfo [] True False addr
+                   return str
+
+-- | Return the X.509 certificate of the client, or 'Nothing' if:
+--
+--   * This request didn't came through an SSL stream.
+--
+--   * The client didn't send us its certificate.
+--
+--   * The 'OpenSSL.Session.VerificationMode' of
+--     'OpenSSL.Session.SSLContext' in
+--     'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
+--     'OpenSSL.Session.VerifyPeer'.
+getRemoteCertificate :: Resource (Maybe X509)
+getRemoteCertificate = do itr <- getInteraction
+                          return $! itrRemoteCert itr
 
 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
 -- the request header. In general you don't have to use this action.
@@ -271,14 +285,15 @@ getResourcePath = do itr <- getInteraction
                      return $! fromJust $! itrResourcePath itr
 
 
--- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
--- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
--- greedy. See 'getResourcePath'.
+-- |This is an analogy of CGI PATH_INFO. The result is
+-- URI-unescaped. It is always @[]@ if the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
+-- 'getResourcePath'.
 getPathInfo :: Resource [String]
 getPathInfo = do rsrcPath <- getResourcePath
                  uri      <- getRequestURI
                  let reqPathStr = uriPath uri
-                     reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
+                     reqPath    = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]
                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
@@ -289,9 +304,17 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- | Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it. This action
 -- doesn't parse the request body. See 'inputForm'.
-getQueryForm :: Resource [(String, String)]
+getQueryForm :: Resource [FormData]
 getQueryForm = do uri <- getRequestURI
-                  return $! parseWWWFormURLEncoded $ uriQuery uri
+                  return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
+
+pairToFormData :: (String, String) -> FormData
+pairToFormData (name, value)
+    = FormData {
+        fdName     = name
+      , fdFileName = Nothing
+      , fdContent  = L8.pack value
+      }
 
 -- |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 +388,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
@@ -388,7 +425,7 @@ foundEntity tag timeStamp
 
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
+                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
          when (method == POST)
                   $ abort InternalServerError []
                         (Just "Illegal computation of foundEntity for POST request.")
@@ -470,7 +507,7 @@ foundTimeStamp timeStamp
 
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
+                  $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
          when (method == POST)
                   $ abort InternalServerError []
                         (Just "Illegal computation of foundTimeStamp for POST request.")
@@ -483,7 +520,7 @@ foundTimeStamp timeStamp
          -- If-Modified-Since があればそれを見る。
          ifModSince <- getHeader (C8.pack "If-Modified-Since")
          case ifModSince of
-           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
+           Just str -> case HTTP.parse (C8.unpack str) of
                          Just lastTime
                              -> when (timeStamp <= lastTime)
                                 $ abort statusForIfModSince []
@@ -495,7 +532,7 @@ foundTimeStamp timeStamp
          -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
          case ifUnmodSince of
-           Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
+           Just str -> case HTTP.parse (C8.unpack str) of
                          Just lastTime
                              -> when (timeStamp > lastTime)
                                 $ abort PreconditionFailed []
@@ -689,7 +726,7 @@ inputChunkLBS limit
 -- makes 'Resource' abort with status \"415 Unsupported Media
 -- Type\". If the request has no \"Content-Type\", it aborts with
 -- \"400 Bad Request\".
-inputForm :: Int -> Resource [(String, String)]
+inputForm :: Int -> Resource [FormData]
 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType
@@ -706,7 +743,7 @@ inputForm limit
     where
       readWWWFormURLEncoded
           = do src <- input limit
-               return $ parseWWWFormURLEncoded src
+               return $ map pairToFormData $ parseWWWFormURLEncoded src
 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of
@@ -715,7 +752,7 @@ inputForm limit
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of
-                             (# Success pairs, _ #) -> return pairs
+                             (# Success fdList, _ #) -> return fdList
                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 
@@ -806,6 +843,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 時に使用するアクション群 -}