X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=696abf1b1311e55c5f13f4eca54a45ea02ea0146;hb=1f0a19c;hp=c8ca45d00579daff37db145dc98b217ab1f1a3d9;hpb=32a6ebbb18856ab1203e8a114414f235c2abe22b;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index c8ca45d..696abf1 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,13 +1,10 @@ {-# LANGUAGE - BangPatterns - , GeneralizedNewtypeDeriving + GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} -{-# 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' -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is @@ -65,18 +62,13 @@ -- the entire request before starting 'Resource', nor we don't want to -- postpone writing the entire response till the end of 'Resource' -- computation. - module Network.HTTP.Lucu.Resource ( -- * Types Resource , FormData(..) - , runRes -- private - - -- * Actions - - -- ** Getting request header + -- * Getting request header -- |These actions can be computed regardless of the current state, -- and they don't change the state. , getConfig @@ -98,8 +90,7 @@ module Network.HTTP.Lucu.Resource , getContentType , getAuthorization - -- ** Finding an entity - + -- * Finding an entity -- |These actions can be computed only in the /Examining Request/ -- state. After the computation, the 'Resource' transits to -- /Getting Body/ state. @@ -108,42 +99,42 @@ module Network.HTTP.Lucu.Resource , foundTimeStamp , foundNoEntity - -- ** Getting a request body - + -- * Getting a request body -- |Computation of these actions changes the state to /Getting -- Body/. - , input - , inputChunk - , inputForm + , getChunk + , getChunks + , getForm , defaultLimit - -- ** Setting response headers - + -- * Setting response headers -- |Computation of these actions changes the state to /Deciding -- Header/. , setStatus - , setHeader , redirect , setContentType - , setLocation , setContentEncoding , setWWWAuthenticate - -- ** Writing a response body + -- ** Less frequently used functions + , setLocation + , setHeader + , deleteHeader + -- * Writing a response body -- |Computation of these actions changes the state to /Deciding -- Body/. - , output - , outputChunk - - , driftTo -- private + , putChunk + , putChunks + , putBuilder ) where import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM -import Control.Monad.Reader +import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A @@ -156,7 +147,6 @@ import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe -import Data.Monoid import Data.Monoid.Unicode import Data.Sequence (Seq) import Data.Text (Text) @@ -168,7 +158,6 @@ 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 import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion @@ -176,6 +165,7 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.MultipartForm import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils @@ -184,21 +174,6 @@ import Network.URI hiding (path) import OpenSSL.X509 import Prelude.Unicode --- |The 'Resource' monad. This monad implements 'MonadIO' so it can do --- any 'IO' actions. -newtype Resource a - = Resource { - unRes ∷ ReaderT Interaction IO a - } - deriving (Applicative, Functor, Monad, MonadIO) - -runRes ∷ Resource a → Interaction → IO a -runRes r itr - = runReaderT (unRes r) itr - -getInteraction ∷ Resource Interaction -getInteraction = Resource ask - -- |Get the 'Config' value which is used for the httpd. getConfig ∷ Resource Config getConfig = itrConfig <$> getInteraction @@ -213,7 +188,7 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction getRemoteAddr' ∷ Resource HostName getRemoteAddr' = do sa ← getRemoteAddr - (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa + (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa return a -- |Resolve an address to the remote host. @@ -234,13 +209,6 @@ getRemoteHost getRemoteCertificate ∷ Resource (Maybe X509) getRemoteCertificate = itrRemoteCert <$> getInteraction --- |Get the 'Request' value which represents the request header. In --- general you don't have to use this action. -getRequest ∷ Resource Request -getRequest - = do itr ← getInteraction - liftIO $ atomically $ readItr itrRequest fromJust itr - -- |Get the 'Method' value of the request. getMethod ∷ Resource Method getMethod = reqMethod <$> getRequest @@ -256,7 +224,7 @@ getRequestVersion = reqVersion <$> getRequest -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this --- action is the exact path in the tree even if the +-- action is the exact path in the tree even when the -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. -- -- Example: @@ -266,9 +234,9 @@ getRequestVersion = reqVersion <$> getRequest -- > -- > resFoo = ResourceDef { -- > resIsGreedy = True --- > , resGet = Just $ do requestURI ← getRequestURI --- > resourcePath ← getResourcePath --- > pathInfo ← getPathInfo +-- > , resGet = Just $ do requestURI <- getRequestURI +-- > resourcePath <- getResourcePath +-- > pathInfo <- getPathInfo -- > -- uriPath requestURI == "/foo/bar/baz" -- > -- resourcePath == ["foo"] -- > -- pathInfo == ["bar", "baz"] @@ -417,7 +385,7 @@ getAuthorization return ac -{- ExaminingRequest 時に使用するアクション群 -} +-- Finding an entity -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means @@ -434,7 +402,7 @@ getAuthorization -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. foundEntity ∷ ETag → UTCTime → Resource () -foundEntity !tag !timeStamp +foundEntity tag timeStamp = do driftTo ExaminingRequest method ← getMethod @@ -455,12 +423,14 @@ foundEntity !tag !timeStamp -- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundETag ∷ ETag → Resource () -foundETag !tag +foundETag tag = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader' "ETag" (printETag tag) + $ setHeader' "ETag" + $ A.fromAsciiBuilder + $ printETag tag when (method ≡ POST) $ abort InternalServerError [] (Just "Illegal computation of foundETag for POST request.") @@ -588,7 +558,7 @@ foundNoEntity msgM driftTo GettingBody -{- GettingBody 時に使用するアクション群 -} +-- Getting a request body -- | Computation of @'input' limit@ attempts to read the request body -- up to @limit@ bytes, and then make the 'Resource' transit to @@ -609,8 +579,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr - chunk ← if hasBody then + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -618,8 +587,8 @@ input limit return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput itr - = do let confLimit = cnfMaxEntityLength $ itrConfig itr + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit ≤ 0 then confLimit else @@ -628,17 +597,11 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readItr itrReqChunkLength id itr - writeItr itrWillReceiveBody True itr - if ((> actualLimit) <$> chunkLen) ≡ Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itrReqBodyWanted (Just actualLimit) itr + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr - chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkLen ← readTVar itrReceivedBodyLen + chunkIsOver ← readTVar itrReqChunkIsOver if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 @@ -651,9 +614,9 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 - chunk ← readItr itrReceivedBody seqToLBS itr - writeItr itrReceivedBody (∅) itr - writeItr itrReceivedBodyLen 0 itr + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 return chunk driftTo DecidingHeader @@ -684,40 +647,38 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr - chunk ← if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return (∅) + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then + askForInput itr + else + do driftTo DecidingHeader + return (∅) return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput itr - = do let confLimit = cnfMaxEntityLength $ itrConfig itr + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit < 0 then - confLimit - else - limit - when (actualLimit <= 0) + confLimit + else + limit + when (actualLimit ≤ 0) $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do writeItr itrReqBodyWanted (Just actualLimit) itr - writeItr itrWillReceiveBody True itr + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen id itr + $ do chunkLen ← readTVar itrReceivedBodyLen -- 要求された量に滿たなくて、まだ殘りがある -- なら再試行。 when (chunkLen < actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver id itr + $ do chunkIsOver ← readTVar itrReqChunkIsOver unless chunkIsOver $ retry -- 成功 - chunk ← readItr itrReceivedBody seqToLBS itr - writeItr itrReceivedBody (∅) itr - writeItr itrReceivedBodyLen 0 itr + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 return chunk when (Lazy.null chunk) $ driftTo DecidingHeader @@ -789,43 +750,7 @@ defaultLimit ∷ Int defaultLimit = (-1) -{- DecidingHeader 時に使用するアクション群 -} - --- | Set the response status code. If you omit to compute this action, --- the status code will be defaulted to \"200 OK\". -setStatus ∷ StatusCode → Resource () -setStatus code - = do driftTo DecidingHeader - itr ← getInteraction - liftIO $ atomically $ updateItr itrResponse f itr - where - f res = res { - resStatus = code - } - --- | Set a value of given resource 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 'setContentType' --- for every common headers. --- --- Some important headers (especially \"Content-Length\" and --- \"Transfer-Encoding\") may be silently dropped or overwritten by --- the system not to corrupt the interaction with client at the --- viewpoint of HTTP protocol layer. For instance, if we are keeping --- the connection alive, without this process it causes a catastrophe --- to send a header \"Content-Length: 10\" and actually send a body of --- 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 ∷ CIAscii → Ascii → Resource () -setHeader name value - = driftTo DecidingHeader ≫ setHeader' name value - -setHeader' ∷ CIAscii → Ascii → Resource () -setHeader' name value - = do itr ← getInteraction - liftIO $ atomically - $ updateItr itrResponse (H.setHeader name value) itr +-- Setting response headers -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy @@ -849,7 +774,8 @@ setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header --- \"Location\" to @uri@. +-- \"Location\" to @uri@. You usually don't need to call this function +-- directly. setLocation ∷ URI → Resource () setLocation uri = case A.fromChars uriStr of @@ -881,105 +807,13 @@ setWWWAuthenticate challenge = setHeader "WWW-Authenticate" (printAuthChallenge challenge) -{- DecidingBody 時に使用するアクション群 -} - --- | Computation of @'output' str@ writes @str@ as a response body, --- and then make the 'Resource' transit to /Done/ state. It is safe to --- apply 'output' to an infinite string, such as a lazy stream of --- \/dev\/random. -output ∷ Lazy.ByteString → Resource () -{-# INLINE output #-} -output str = outputChunk str *> driftTo Done - --- | Computation of @'outputChunk' str@ writes @str@ as a part of --- response body. You can compute this action multiple times to write --- a body little at a time. It is safe to apply 'outputChunk' to an --- infinite string. -outputChunk ∷ Lazy.ByteString → Resource () -outputChunk wholeChunk - = do driftTo DecidingBody - itr ← getInteraction - - let limit = cnfMaxOutputChunkLength $ itrConfig itr - when (limit ≤ 0) - $ abort InternalServerError [] - (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) - - discardBody ← liftIO $ atomically $ - readItr itrWillDiscardBody id itr - - unless (discardBody) - $ sendChunks wholeChunk limit - - unless (Lazy.null wholeChunk) - $ liftIO $ atomically $ - writeItr itrSentNoBody False itr - where - sendChunks ∷ Lazy.ByteString → Int → Resource () - sendChunks str limit - | Lazy.null str = return () - | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str - itr ← getInteraction - liftIO $ atomically - $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk) - sendChunks remaining limit - - chunkToBuilder ∷ Lazy.ByteString → Builder - chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - - - [DecidingHeader からそれ以降の状態に遷移する時] - - postprocess する。 - +-- Writing a response body - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} - -driftTo ∷ InteractionState → Resource () -driftTo newState - = do itr ← getInteraction - liftIO $ atomically $ do oldState ← readItr itrState id itr - if newState < oldState then - throwStateError oldState newState - else - do let a = [oldState .. newState] - b = tail a - c = zip a b - mapM_ (uncurry $ drift itr) c - writeItr itrState newState itr - where - throwStateError ∷ Monad m => InteractionState → InteractionState → m a - - throwStateError Done DecidingBody - = fail "It makes no sense to output something after finishing to output." - - throwStateError old new - = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) - - - drift ∷ Interaction → InteractionState → InteractionState → STM () - - drift itr GettingBody _ - = writeItr itrReqBodyWasteAll True itr - - drift itr DecidingHeader _ - = postprocess itr - - drift itr _ Done - = do bodyIsNull ← readItr itrSentNoBody id itr - when bodyIsNull - $ writeDefaultPage itr - - drift _ _ _ - = return () +-- | Write a chunk in 'Lazy.ByteString' to the response body. It is +-- safe to apply this function to an infinitely long +-- 'Lazy.ByteString'. +-- +-- Note that you must first set the response header \"Content-Type\" +-- before applying this function. See: 'setContentType' +putChunk ∷ Lazy.ByteString → Resource () +putChunk = putBuilder ∘ BB.fromLazyByteString