X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=696abf1b1311e55c5f13f4eca54a45ea02ea0146;hb=1f0a19c;hp=c75421378c89dd1c5eb6b25b5fea31cf354ce5a5;hpb=895341e8b790e969be678c5cfb85c878e321c8fc;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index c754213..696abf1 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -5,7 +5,6 @@ , 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 @@ -63,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 - - -- * 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 @@ -96,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. @@ -106,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 @@ -154,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) @@ -166,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 @@ -174,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 @@ -182,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 @@ -232,11 +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 = (fromJust ∘ itrRequest) <$> getInteraction - -- |Get the 'Method' value of the request. getMethod ∷ Resource Method getMethod = reqMethod <$> getRequest @@ -413,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 @@ -586,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 @@ -607,7 +579,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - chunk ← if reqHasBody $ fromJust $ itrRequest itr then + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -675,7 +647,7 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - chunk ← if reqHasBody $ fromJust $ itrRequest itr then + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then askForInput itr else do driftTo DecidingHeader @@ -778,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 sc - = do driftTo DecidingHeader - itr ← getInteraction - 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 --- 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 - $ do res ← readTVar $ itrResponse itr - let res' = H.setHeader name value res - writeTVar (itrResponse itr) res' +-- Setting response headers -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy @@ -838,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 @@ -870,74 +807,13 @@ setWWWAuthenticate challenge = setHeader "WWW-Authenticate" (printAuthChallenge challenge) -{- DecidingBody 時に使用するアクション群 -} - --- | 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. -output ∷ Lazy.ByteString → Resource () -{-# INLINE output #-} -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. -outputChunk ∷ Lazy.ByteString → Resource () -outputChunk str - = do driftTo DecidingBody - itr ← getInteraction - liftIO $ atomically - $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str) - unless (Lazy.null str) - $ writeTVar (itrSentNoBodySoFar itr) False - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - - - [DecidingHeader からそれ以降の状態に遷移する時] +-- Writing a response body - postprocess する。 - - - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} - -driftTo ∷ InteractionState → Resource () -driftTo newState - = do itr ← getInteraction - liftIO $ atomically - $ do oldState ← readTVar $ itrState 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 - writeTVar (itrState itr) newState - 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 (Interaction {..}) GettingBody _ - = writeTVar itrReqBodyWasteAll True - drift itr DecidingHeader _ - = postprocess itr - drift itr@(Interaction {..}) _ Done - = do bodyIsNull ← readTVar itrSentNoBodySoFar - 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