X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=19a2a0a73a4779e882b02114fcf28805a782eab8;hp=4cf43e0c5b7f831a45da2487e7c23fd482bf374d;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=545053db37e71ed18ca59c12467a8ecb10bf5f83 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 4cf43e0..19a2a0a 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -9,7 +9,7 @@ , UnicodeSyntax #-} -- |This is the Resource Monad; monadic actions to define a behavior --- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it +-- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it -- implements 'MonadIO' class, and it is a state machine as well. -- -- Request Processing Flow: @@ -17,68 +17,67 @@ -- 1. A client issues an HTTP request. -- -- 2. If the URI of it matches to any resource, the corresponding --- 'Resource' Monad starts running on a newly spawned thread. +-- 'Rsrc' Monad starts running on a newly spawned thread. -- --- 3. The 'Resource' Monad looks at request headers, find (or not --- find) an entity, receive the request body (if any), send --- response headers, and then send a response body. This process --- will be discussed later. +-- 3. The 'Rsrc' Monad looks at request headers, find (or not find) +-- an entity, receive the request body (if any), send response +-- headers, and then send a response body. This process will be +-- discussed later. -- --- 4. The 'Resource' Monad and its thread stops running. The client --- may or may not be sending us the next request at this point. +-- 4. The 'Rsrc' Monad and its thread stops running. The client may +-- or may not be sending us the next request at this point. -- --- 'Resource' Monad takes the following states. The initial state is +-- 'Rsrc' Monad takes the following states. The initial state is -- /Examining Request/ and the final state is /Done/. -- --- [/Examining Request/] In this state, a 'Resource' looks at the +-- [/Examining Request/] In this state, a 'Rsrc' looks at the -- request header fields and thinks about the corresponding entity --- for it. If there is a suitable entity, the 'Resource' tells the +-- for it. If there is a suitable entity, the 'Rsrc' tells the -- system an entity tag and its last modification time -- ('foundEntity'). If it found no entity, it tells the system so -- ('foundNoEntity'). In case it is impossible to decide the -- existence of entity, which is a typical case for POST requests, --- 'Resource' does nothing in this state. +-- 'Rsrc' does nothing in this state. -- --- [/Receiving Body/] A 'Resource' asks the system to receive a --- request body from the client. Before actually reading from the --- socket, the system sends \"100 Continue\" to the client if need --- be. When a 'Resource' transits to the next state without --- receiving all or part of a request body, the system automatically --- discards it. +-- [/Receiving Body/] A 'Rsrc' asks the system to receive a request +-- body from the client. Before actually reading from the socket, +-- the system sends \"100 Continue\" to the client if need be. When +-- a 'Rsrc' transits to the next state without receiving all or part +-- of a request body, the system automatically discards it. -- --- [/Deciding Header/] A 'Resource' makes a decision of response --- status code and header fields. When it transits to the next --- state, the system validates and completes the header fields and --- then sends them to the client. +-- [/Deciding Header/] A 'Rsrc' makes a decision of response status +-- code and header fields. When it transits to the next state, the +-- system validates and completes the header fields and then sends +-- them to the client. -- --- [/Sending Body/] In this state, a 'Resource' asks the system to --- write some response body to the socket. When it transits to the --- next state without writing any response body, the system --- automatically completes it depending on the status code. (To be --- exact, such completion only occurs when the 'Resource' transits --- to this state without even declaring the \"Content-Type\" header --- field. See: 'setContentType') +-- [/Sending Body/] In this state, a 'Rsrc' asks the system to write +-- some response body to the socket. When it transits to the next +-- state without writing any response body, the system automatically +-- completes it depending on the status code. (To be exact, such +-- completion only occurs when the 'Rsrc' transits to this state +-- without even declaring the \"Content-Type\" header field. See: +-- 'setContentType') -- --- [/Done/] Everything is over. A 'Resource' can do nothing for the --- HTTP interaction anymore. +-- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP +-- interaction anymore. -- -- Note that the state transition is one-way: for instance, it is an -- error to try to read a request body after writing some -- response. This limitation is for efficiency. We don't want to read --- the entire request before starting 'Resource', nor we don't want to --- postpone writing the entire response till the end of 'Resource' +-- the entire request before starting 'Rsrc', nor we don't want to +-- postpone writing the entire response till the end of 'Rsrc' -- computation. module Network.HTTP.Lucu.Resource ( -- * Types - Resource - , ResourceDef(..) + Resource(..) , emptyResource + , Rsrc , FormData(..) -- * Getting request header -- |These functions can be called regardless of the current state, - -- and they don't change the state of 'Resource'. + -- and they don't change the state of 'Rsrc'. , getConfig , getRemoteAddr , getRemoteAddr' @@ -102,7 +101,7 @@ module Network.HTTP.Lucu.Resource -- * Finding an entity -- |These functions can be called only in the /Examining Request/ - -- state. They make the 'Resource' transit to the /Receiving Body/ + -- state. They make the 'Rsrc' transit to the /Receiving Body/ -- state. , foundEntity , foundETag @@ -111,7 +110,7 @@ module Network.HTTP.Lucu.Resource , foundNoEntity' -- * Receiving a request body - -- |These functions make the 'Resource' transit to the /Receiving + -- |These functions make the 'Rsrc' transit to the /Receiving -- Body/ state. , getChunk , getChunks @@ -134,8 +133,8 @@ module Network.HTTP.Lucu.Resource -- * Sending a response body - -- |These functions make the 'Resource' transit to the - -- /Sending Body/ state. + -- |These functions make the 'Rsrc' transit to the /Sending Body/ + -- state. , putChunk , putChunks , putBuilder @@ -188,38 +187,38 @@ import Prelude.Unicode -- |Get the string representation of the address of remote host. If -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. -getRemoteAddr' ∷ Resource HostName +getRemoteAddr' ∷ Rsrc HostName getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr where toNM ∷ SockAddr → IO HostName toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False -- |Resolve an address to the remote host. -getRemoteHost ∷ Resource (Maybe HostName) +getRemoteHost ∷ Rsrc (Maybe HostName) getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr where getHN ∷ SockAddr → IO (Maybe HostName) getHN = (fst <$>) ∘ getNameInfo [] True False -- |Get the 'Method' value of the request. -getMethod ∷ Resource Method +getMethod ∷ Rsrc Method getMethod = reqMethod <$> getRequest -- |Get the URI of the request. -getRequestURI ∷ Resource URI +getRequestURI ∷ Rsrc URI getRequestURI = reqURI <$> getRequest -- |Get the HTTP version of the request. -getRequestVersion ∷ Resource HttpVersion +getRequestVersion ∷ Rsrc HttpVersion getRequestVersion = reqVersion <$> getRequest -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns -- @[]@ if the corresponding --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See: +-- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See: -- 'getResourcePath' -- -- Note that the returned path components are URI-decoded. -getPathInfo ∷ Resource [Strict.ByteString] +getPathInfo ∷ Rsrc [Strict.ByteString] getPathInfo = do rsrcPath ← getResourcePath reqPath ← splitPathInfo <$> getRequestURI return $ drop (length rsrcPath) reqPath @@ -228,7 +227,7 @@ getPathInfo = do rsrcPath ← getResourcePath -- application\/x-www-form-urlencoded, and parse it into pairs of -- @(name, formData)@. This function doesn't read the request -- body. -getQueryForm ∷ Resource [(Strict.ByteString, FormData)] +getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)] getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ @@ -251,13 +250,13 @@ toPairWithFormData (name, value) -- @name@. Comparison of header name is case-insensitive. Note that -- this function is not intended to be used so frequently: there -- should be functions like 'getContentType' for every common headers. -getHeader ∷ CIAscii → Resource (Maybe Ascii) +getHeader ∷ CIAscii → Rsrc (Maybe Ascii) getHeader name = H.getHeader name <$> getRequest -- |Return the list of 'MIMEType' enumerated on the value of request -- header \"Accept\", or @[]@ if absent. -getAccept ∷ Resource [MIMEType] +getAccept ∷ Rsrc [MIMEType] getAccept = do acceptM ← getHeader "Accept" case acceptM of @@ -272,7 +271,7 @@ getAccept -- |Return the list of @(contentCoding, qvalue)@ enumerated on the -- value of request header \"Accept-Encoding\". The list is sorted in -- descending order by qvalue. -getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)] +getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)] getAcceptEncoding = do accEncM ← getHeader "Accept-Encoding" case accEncM of @@ -302,14 +301,14 @@ getAcceptEncoding -- |Return 'True' iff a given content-coding is acceptable by the -- client. -isEncodingAcceptable ∷ CIAscii → Resource Bool +isEncodingAcceptable ∷ CIAscii → Rsrc Bool isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding where doesMatch ∷ (CIAscii, Maybe Double) → Bool doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 -- |Return the value of request header \"Content-Type\" as 'MIMEType'. -getContentType ∷ Resource (Maybe MIMEType) +getContentType ∷ Rsrc (Maybe MIMEType) getContentType = do cTypeM ← getHeader "Content-Type" case cTypeM of @@ -323,7 +322,7 @@ getContentType -- |Return the value of request header \"Authorization\" as -- 'AuthCredential'. -getAuthorization ∷ Resource (Maybe AuthCredential) +getAuthorization ∷ Rsrc (Maybe AuthCredential) getAuthorization = do authM ← getHeader "Authorization" case authM of @@ -334,11 +333,11 @@ getAuthorization Right ac → return $ Just ac Left _ → return Nothing --- |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 --- a datum to be replied. If this is a PUT or DELETE request, it means --- a datum which was stored for the URI until now. For POST requests --- it raises an error. +-- |Tell the system that the 'Rsrc' found an entity for the request +-- URI. If this is a GET or HEAD request, a found entity means a datum +-- to be replied. If this is a PUT or DELETE request, it means a datum +-- which was stored for the URI until now. For POST requests it raises +-- an error. -- -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test -- whenever possible, and if those tests fail, it immediately aborts @@ -348,7 +347,7 @@ getAuthorization -- If the request method is either GET or HEAD, 'foundEntity' -- automatically puts \"ETag\" and \"Last-Modified\" headers into the -- response. -foundEntity ∷ ETag → UTCTime → Resource () +foundEntity ∷ ETag → UTCTime → Rsrc () foundEntity tag timeStamp = do driftTo ExaminingRequest @@ -363,14 +362,13 @@ foundEntity tag timeStamp driftTo ReceivingBody --- |Tell the system that the 'Resource' found an entity for the --- request URI. The only difference from 'foundEntity' is that --- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into --- the response. +-- |Tell the system that the 'Rsrc' found an entity for the request +-- URI. The only difference from 'foundEntity' is that 'foundETag' +-- doesn't (nor can't) put \"Last-Modified\" header into the response. -- -- Using this function is discouraged. You should use 'foundEntity' -- whenever possible. -foundETag ∷ ETag → Resource () +foundETag ∷ ETag → Rsrc () foundETag tag = do driftTo ExaminingRequest @@ -433,7 +431,7 @@ foundETag tag driftTo ReceivingBody --- |Tell the system that the 'Resource' found an entity for the +-- |Tell the system that the 'Rsrc' found an entity for the -- request URI. The only difference from 'foundEntity' is that -- 'foundTimeStamp' performs \"If-Modified-Since\" test or -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or @@ -443,7 +441,7 @@ foundETag tag -- -- Using this function is discouraged. You should use 'foundEntity' -- whenever possible. -foundTimeStamp ∷ UTCTime → Resource () +foundTimeStamp ∷ UTCTime → Rsrc () foundTimeStamp timeStamp = do driftTo ExaminingRequest @@ -489,15 +487,15 @@ foundTimeStamp timeStamp driftTo ReceivingBody --- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found --- no entity for the request URI. @mStr@ is an optional error message --- to be replied to the client. +-- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no +-- entity for the request URI. @mStr@ is an optional error message to +-- be replied to the client. -- -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\" -- test and when that fails it aborts with status \"412 Precondition -- Failed\". If the request method is GET, HEAD, POST or DELETE, -- 'foundNoEntity' always aborts with status \"404 Not Found\". -foundNoEntity ∷ Maybe Text → Resource () +foundNoEntity ∷ Maybe Text → Rsrc () foundNoEntity msgM = do driftTo ExaminingRequest @@ -516,15 +514,15 @@ foundNoEntity msgM driftTo ReceivingBody -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@. -foundNoEntity' ∷ Resource () +foundNoEntity' ∷ Rsrc () {-# INLINE foundNoEntity' #-} foundNoEntity' = foundNoEntity Nothing -- |@'getChunks' limit@ attemts to read the entire request body up to --- @limit@ bytes, and then make the 'Resource' transit to the --- /Deciding Header/ state. When the actual size of the body is larger --- than @limit@ bytes, 'getChunks' immediately aborts with status --- \"413 Request Entity Too Large\". When the request has no body, it +-- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding +-- Header/ state. When the actual size of the body is larger than +-- @limit@ bytes, 'getChunks' immediately aborts with status \"413 +-- Request Entity Too Large\". When the request has no body, it -- returns an empty string. -- -- When the @limit@ is 'Nothing', 'getChunks' uses the default @@ -533,7 +531,7 @@ foundNoEntity' = foundNoEntity Nothing -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really -- lazy: reading from the socket just happens at the computation of -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'. -getChunks ∷ Maybe Int → Resource Lazy.ByteString +getChunks ∷ Maybe Int → Rsrc Lazy.ByteString getChunks (Just n) | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n) | n ≡ 0 = return (∅) @@ -541,10 +539,10 @@ getChunks (Just n) getChunks Nothing = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength -getChunks' ∷ Int → Resource Lazy.ByteString +getChunks' ∷ Int → Rsrc Lazy.ByteString getChunks' limit = go limit (∅) where - go ∷ Int → Builder → Resource Lazy.ByteString + go ∷ Int → Builder → Rsrc Lazy.ByteString go 0 _ = do chunk ← getChunk 1 if Strict.null chunk then return (∅) @@ -571,7 +569,7 @@ getChunks' limit = go limit (∅) -- -- Note that there are currently a few limitations on parsing -- @multipart/form-data@. See: 'parseMultipartFormData' -getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)] +getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)] getForm limit = do cTypeM ← getContentType case cTypeM of @@ -615,7 +613,7 @@ getForm limit -- |@'redirect' code uri@ declares the response status as @code@ and -- \"Location\" header field as @uri@. The @code@ must satisfy -- 'isRedirection' or it raises an error. -redirect ∷ StatusCode sc ⇒ sc → URI → Resource () +redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc () redirect sc uri = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc)) $ abort @@ -630,13 +628,13 @@ redirect sc uri -- |@'setContentType' mType@ declares the response header -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is -- mandatory for sending a response body. -setContentType ∷ MIMEType → Resource () +setContentType ∷ MIMEType → Rsrc () setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType -- |@'setLocation' uri@ declares the response header \"Location\" as -- @uri@. You usually don't need to call this function directly. -setLocation ∷ URI → Resource () +setLocation ∷ URI → Rsrc () setLocation uri = case A.fromChars uriStr of Just a → setHeader "Location" a @@ -647,7 +645,7 @@ setLocation uri -- |@'setContentEncoding' codings@ declares the response header -- \"Content-Encoding\" as @codings@. -setContentEncoding ∷ [CIAscii] → Resource () +setContentEncoding ∷ [CIAscii] → Rsrc () setContentEncoding codings = do ver ← getRequestVersion tr ← case ver of @@ -665,13 +663,13 @@ setContentEncoding codings -- |@'setWWWAuthenticate' challenge@ declares the response header -- \"WWW-Authenticate\" as @challenge@. -setWWWAuthenticate ∷ AuthChallenge → Resource () +setWWWAuthenticate ∷ AuthChallenge → Rsrc () setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge -- |Write a chunk in 'Strict.ByteString' to the response body. You -- must first declare the response header \"Content-Type\" before -- applying this function. See: 'setContentType' -putChunk ∷ Strict.ByteString → Resource () +putChunk ∷ Strict.ByteString → Rsrc () putChunk = putBuilder ∘ BB.fromByteString -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It @@ -680,5 +678,5 @@ putChunk = putBuilder ∘ BB.fromByteString -- Note that you must first declare the response header -- \"Content-Type\" before applying this function. See: -- 'setContentType' -putChunks ∷ Lazy.ByteString → Resource () +putChunks ∷ Lazy.ByteString → Rsrc () putChunks = putBuilder ∘ BB.fromLazyByteString