X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=34c1a725634b6485df32d7e5e302238e44cf78b4;hb=8e2a25fd631e17a9c7b3e13c4e62635b2c1259bf;hp=d3967edf8ab5224c7e08dd2e1285669223f26944;hpb=ee292ed7f669b5f49fcdf035389fedf7d8742621;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d3967ed..34c1a72 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 @@ -135,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) @@ -144,6 +146,7 @@ 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 @@ -156,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' @@ -209,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. @@ -274,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,12 +301,26 @@ getPathInfo = do rsrcPath <- getResourcePath -- rsrcPath の長さの分だけ削除すれば良い。 return $! drop (length rsrcPath) reqPath --- | 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 = do uri <- getRequestURI - return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri +-- |Assume the query part of request URI as +-- application\/x-www-form-urlencoded, and parse it to pairs of +-- @(name, formData)@. This action doesn't parse the request body. See +-- 'inputForm'. +getQueryForm :: Resource [(String, FormData)] +getQueryForm = liftM parse' getRequestURI + where + parse' = map toPairWithFormData . + parseWWWFormURLEncoded . + snd . + splitAt 1 . + uriQuery + +toPairWithFormData :: (String, String) -> (String, FormData) +toPairWithFormData (name, value) + = let fd = FormData { + fdFileName = Nothing + , fdContent = L8.pack value + } + in (name, fd) -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used @@ -405,7 +431,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.") @@ -487,7 +513,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.") @@ -500,7 +526,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 [] @@ -512,7 +538,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 [] @@ -706,7 +732,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 [(String, FormData)] inputForm limit = limit `seq` do cTypeM <- getContentType @@ -722,8 +748,7 @@ inputForm limit ++ show cType) where readWWWFormURLEncoded - = do src <- input limit - return $ parseWWWFormURLEncoded src + = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit) readMultipartFormData params = do case find ((== "boundary") . map toLower . fst) params of @@ -732,7 +757,8 @@ inputForm limit Just (_, boundary) -> do src <- inputLBS limit case parse (multipartFormP boundary) src of - (# Success pairs, _ #) -> return pairs + (# Success formList, _ #) + -> return formList (# _, _ #) -> abort BadRequest [] (Just "Unparsable multipart/form-data")