X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=ec5818c1e9cbbe877ad9106397abc5ee4a30c6e1;hb=195fd2318fb0ad21c2fd60f61e7df72a8f25d12c;hp=d3967edf8ab5224c7e08dd2e1285669223f26944;hpb=ee292ed7f669b5f49fcdf035389fedf7d8742621;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d3967ed..ec5818c 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) @@ -163,6 +165,7 @@ 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 は全部一致してゐるに決まってゐる(でな @@ -292,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 $ snd $ splitAt 1 $ 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 @@ -706,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 @@ -723,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 @@ -732,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")