X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=ec5818c1e9cbbe877ad9106397abc5ee4a30c6e1;hb=195fd2318fb0ad21c2fd60f61e7df72a8f25d12c;hp=33eaa621a23236dba28302c6911a3d435bbe5a5d;hpb=e53a2f3202f763e844de725712f1bf26b82cd41f;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 33eaa62..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 @@ -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,14 +138,16 @@ module Network.HTTP.Lucu.Resource import Control.Concurrent.STM import Control.Monad.Reader -import Data.Bits -import Data.ByteString.Base (ByteString, LazyByteString(..)) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Char8 as C8 hiding (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Char 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 @@ -156,9 +163,9 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils -import Network.Socket -import Network.URI -import System.Time +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' @@ -205,19 +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 +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. @@ -268,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 - reqURI <- getRequestURI - let reqPathStr = uriPath reqURI - reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] + uri <- getRequestURI + let reqPathStr = uriPath uri + reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""] -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな @@ -286,15 +304,23 @@ 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 = do reqURI <- getRequestURI - return $! parseWWWFormURLEncoded $ uriQuery reqURI +getQueryForm :: Resource [FormData] +getQueryForm = do uri <- getRequestURI + 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 -- so frequently: there should be actions like 'getContentType' for -- every common headers. -getHeader :: ByteString -> Resource (Maybe ByteString) +getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString) getHeader name = name `seq` do req <- getRequest return $! H.getHeader name req @@ -307,7 +333,7 @@ getAccept = do acceptM <- getHeader (C8.pack "Accept") Nothing -> return [] Just accept - -> case parse mimeTypeListP (LPS [accept]) of + -> case parse mimeTypeListP (L8.fromChunks [accept]) of (# Success xs, _ #) -> return xs (# _ , _ #) -> abort BadRequest [] (Just $ "Unparsable Accept: " ++ C8.unpack accept) @@ -328,12 +354,13 @@ getAcceptEncoding case ver of HttpVersion 1 0 -> return [("identity", Nothing)] HttpVersion 1 1 -> return [("*" , Nothing)] + _ -> undefined Just value -> if C8.null value then -- identity のみが許される。 return [("identity", Nothing)] else - case parse acceptEncodingListP (LPS [value]) of + case parse acceptEncodingListP (L8.fromChunks [value]) of (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x (# _ , _ #) -> abort BadRequest [] (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value) @@ -355,12 +382,26 @@ getContentType Nothing -> return Nothing Just cType - -> case parse mimeTypeP (LPS [cType]) of + -> case parse mimeTypeP (L8.fromChunks [cType]) of (# Success t, _ #) -> return $ Just t (# _ , _ #) -> abort BadRequest [] (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 @@ -377,7 +418,7 @@ getContentType -- -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. -foundEntity :: ETag -> ClockTime -> Resource () +foundEntity :: ETag -> UTCTime -> Resource () foundEntity tag timeStamp = tag `seq` timeStamp `seq` do driftTo ExaminingRequest @@ -418,7 +459,7 @@ foundETag tag Just value -> if value == C8.pack "*" then return () else - case parse eTagListP (LPS [value]) of + case parse eTagListP (L8.fromChunks [value]) of (# Success tags, _ #) -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 @@ -440,7 +481,7 @@ foundETag tag Just value -> if value == C8.pack "*" then abort statusForNoneMatch [] $! Just ("The entity tag matches: *") else - case parse eTagListP (LPS [value]) of + case parse eTagListP (L8.fromChunks [value]) of (# Success tags, _ #) -> when (any (== tag) tags) $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value) @@ -459,7 +500,7 @@ foundETag tag -- -- This action is not preferred. You should use 'foundEntity' whenever -- possible. -foundTimeStamp :: ClockTime -> Resource () +foundTimeStamp :: UTCTime -> Resource () foundTimeStamp timeStamp = timeStamp `seq` do driftTo ExaminingRequest @@ -479,7 +520,7 @@ foundTimeStamp timeStamp -- If-Modified-Since があればそれを見る。 ifModSince <- getHeader (C8.pack "If-Modified-Since") case ifModSince of - Just str -> case parseHTTPDateTime (LPS [str]) of + Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] @@ -491,7 +532,7 @@ foundTimeStamp timeStamp -- If-Unmodified-Since があればそれを見る。 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since") case ifUnmodSince of - Just str -> case parseHTTPDateTime (LPS [str]) of + Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] @@ -550,13 +591,12 @@ input limit = limit `seq` -- | This is mostly the same as 'input' but is more --- efficient. 'inputLBS' returns a --- 'Data.ByteString.Base.LazyByteString' but it's not really lazy: --- reading from the socket just happens at the computation of --- 'inputLBS', not at the evaluation of the --- 'Data.ByteString.Base.LazyByteString'. The same goes for +-- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString' +-- but it's not really lazy: reading from the socket just happens at +-- the computation of 'inputLBS', not at the evaluation of the +-- 'Data.ByteString.Lazy.ByteString'. The same goes for -- 'inputChunkLBS'. -inputLBS :: Int -> Resource LazyByteString +inputLBS :: Int -> Resource Lazy.ByteString inputLBS limit = limit `seq` do driftTo GettingBody @@ -569,14 +609,14 @@ inputLBS limit return L8.empty return chunk where - askForInput :: Interaction -> Resource LazyByteString + askForInput :: Interaction -> Resource Lazy.ByteString askForInput itr = itr `seq` - do let defaultLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then - defaultLimit - else - limit + do let confLimit = cnfMaxEntityLength $ itrConfig itr + actualLimit = if limit <= 0 then + confLimit + else + limit when (actualLimit <= 0) $ fail ("inputLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト @@ -636,7 +676,7 @@ inputChunk limit = limit `seq` -- | This is mostly the same as 'inputChunk' but is more -- efficient. See 'inputLBS'. -inputChunkLBS :: Int -> Resource LazyByteString +inputChunkLBS :: Int -> Resource Lazy.ByteString inputChunkLBS limit = limit `seq` do driftTo GettingBody @@ -649,12 +689,12 @@ inputChunkLBS limit return L8.empty return chunk where - askForInput :: Interaction -> Resource LazyByteString + askForInput :: Interaction -> Resource Lazy.ByteString askForInput itr = itr `seq` - do let defaultLimit = cnfMaxEntityLength $! itrConfig itr - actualLimit = if limit < 0 then - defaultLimit + do let confLimit = cnfMaxEntityLength $! itrConfig itr + actualLimit = if limit < 0 then + confLimit else limit when (actualLimit <= 0) @@ -686,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 @@ -703,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 @@ -712,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") @@ -752,13 +792,13 @@ setStatus code -- 20 bytes long. In this case the client shall only accept the first -- 10 bytes of response body and thinks that the residual 10 bytes is -- a part of header of the next response. -setHeader :: ByteString -> ByteString -> Resource () +setHeader :: Strict.ByteString -> Strict.ByteString -> Resource () setHeader name value = name `seq` value `seq` driftTo DecidingHeader >> setHeader' name value -setHeader' :: ByteString -> ByteString -> Resource () +setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource () setHeader' name value = name `seq` value `seq` do itr <- getInteraction @@ -800,8 +840,15 @@ setContentEncoding codings let tr = case ver of HttpVersion 1 0 -> unnormalizeCoding HttpVersion 1 1 -> id + _ -> 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 時に使用するアクション群 -} @@ -817,7 +864,7 @@ output str = outputLBS $! L8.pack str {-# INLINE output #-} -- | This is mostly the same as 'output' but is more efficient. -outputLBS :: LazyByteString -> Resource () +outputLBS :: Lazy.ByteString -> Resource () outputLBS str = do outputChunkLBS str driftTo Done {-# INLINE outputLBS #-} @@ -834,9 +881,9 @@ outputChunk str = outputChunkLBS $! L8.pack str {-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkLBS :: LazyByteString -> Resource () -outputChunkLBS str - = str `seq` +outputChunkLBS :: Lazy.ByteString -> Resource () +outputChunkLBS wholeChunk + = wholeChunk `seq` do driftTo DecidingBody itr <- getInteraction @@ -849,18 +896,18 @@ outputChunkLBS str readItr itr itrWillDiscardBody id unless (discardBody) - $ sendChunks str limit + $ sendChunks wholeChunk limit - unless (L8.null str) + unless (L8.null wholeChunk) $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま + -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま -- ResponseWriter に渡したりすると大變な事が起こる。何故なら -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 -- く爲にチャンクの大きさを測る。 - sendChunks :: LazyByteString -> Int -> Resource () + sendChunks :: Lazy.ByteString -> Int -> Resource () sendChunks str limit | L8.null str = return () | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str