X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=d0454c4c630d047a419f335a37ecfeb1c64211cb;hb=72a3e24;hp=b7f76f8d986a9849d6c8dea2905a8d7285ea84d8;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index b7f76f8..d0454c4 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -6,7 +6,6 @@ , 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 @@ -70,7 +69,7 @@ module Network.HTTP.Lucu.Resource -- * Types Resource , FormData(..) - , runRes -- private + , runRes -- * Actions @@ -138,7 +137,6 @@ module Network.HTTP.Lucu.Resource , driftTo -- private ) where -import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM @@ -155,7 +153,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) @@ -167,7 +164,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 @@ -212,7 +208,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. @@ -236,9 +232,7 @@ 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 $ fromJust <$> readTVar (itrRequest itr) +getRequest = (fromJust ∘ itrRequest) <$> getInteraction -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -255,7 +249,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: @@ -265,9 +259,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"] @@ -459,7 +453,9 @@ foundETag tag 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.") @@ -608,8 +604,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr - chunk ← if hasBody then + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -627,13 +622,7 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readTVar itrReqChunkLength - writeTVar itrWillReceiveBody True - if ((> actualLimit) <$> chunkLen) ≡ Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeTVar itrReqBodyWanted (Just actualLimit) + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically $ do chunkLen ← readTVar itrReceivedBodyLen @@ -683,27 +672,25 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody 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 (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 writeTVar itrReqBodyWanted (Just actualLimit) - writeTVar itrWillReceiveBody True + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically $ do chunkLen ← readTVar itrReceivedBodyLen @@ -793,15 +780,12 @@ defaultLimit = (-1) -- | 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 +setStatus sc = do driftTo DecidingHeader itr ← getInteraction - liftIO $ atomically - $ do res ← readTVar $ itrResponse itr - let res' = res { - resStatus = code - } - writeTVar (itrResponse itr) res' + liftIO + $ atomically + $ setResponseStatus itr sc -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be @@ -828,6 +812,8 @@ setHeader' name value $ do res ← readTVar $ itrResponse itr let res' = H.setHeader name value res writeTVar (itrResponse itr) res' + when (name ≡ "Content-Type") + $ writeTVar (itrResponseHasCType itr) True -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy @@ -847,8 +833,8 @@ redirect code uri -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType ∷ MIMEType → Resource () -setContentType - = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType +{-# INLINE setContentType #-} +setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. @@ -888,6 +874,9 @@ setWWWAuthenticate challenge -- | Write a 'Lazy.ByteString' to the response body, and then transit -- to the /Done/ state. It is safe to apply 'output' to an infinite -- string, such as the lazy stream of \/dev\/random. +-- +-- Note that you must first set the \"Content-Type\" response header +-- before applying this function. See: 'setContentType' output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} output str = outputChunk str *> driftTo Done @@ -895,53 +884,19 @@ output str = outputChunk str *> driftTo Done -- | Write a 'Lazy.ByteString' to the response body. This action can -- be repeated as many times as you want. It is safe to apply -- 'outputChunk' to an infinite string. +-- +-- Note that you must first set the \"Content-Type\" response header +-- before applying this function. See: 'setContentType' outputChunk ∷ Lazy.ByteString → Resource () -outputChunk wholeChunk +outputChunk str = 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 $ readTVar $ itrWillDiscardBody itr - unless (discardBody) - $ sendChunks itr wholeChunk limit - - unless (Lazy.null wholeChunk) - $ liftIO $ atomically $ - writeTVar (itrSentNoBody itr) False - where - sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource () - sendChunks itr@(Interaction {..}) str limit - | Lazy.null str = return () - | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str - liftIO $ atomically - $ putTMVar itrBodyToSend (chunkToBuilder chunk) - sendChunks itr remaining limit - - chunkToBuilder ∷ Lazy.ByteString → Builder - chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - - - [DecidingHeader からそれ以降の状態に遷移する時] - - postprocess する。 - - - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} + liftIO $ atomically + $ do hasCType ← readTVar $ itrResponseHasCType itr + unless hasCType + $ abortSTM InternalServerError [] + $ Just "outputChunk: Content-Type has not been set." + putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str) driftTo ∷ InteractionState → Resource () driftTo newState @@ -959,7 +914,7 @@ driftTo newState where throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a throwStateError Done DecidingBody - = fail "It makes no sense to output something after finishing to output." + = fail "It makes no sense to output something after finishing outputs." throwStateError old new = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) @@ -968,9 +923,5 @@ driftTo newState = writeTVar itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr - drift itr@(Interaction {..}) _ Done - = do bodyIsNull ← readTVar itrSentNoBody - when bodyIsNull - $ writeDefaultPage itr drift _ _ _ = return ()