From: PHO Date: Mon, 21 Nov 2011 12:57:19 +0000 (+0900) Subject: Rename: Resource --> Rsrc; ResourceDef --> Resource X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=1ead053;p=Lucu.git Rename: Resource --> Rsrc; ResourceDef --> Resource Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 5a1a950..945f16c 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -35,11 +35,11 @@ module Network.HTTP.Lucu -- * 'Config'uration , module Network.HTTP.Lucu.Config - -- * Resource Tree + -- * 'Resource' Tree , ResTree , mkResTree - -- * 'Resource' Monad + -- * 'Rsrc' Monad , module Network.HTTP.Lucu.Resource -- ** Things to be used in the Resource monad diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index c127250..4d724eb 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -40,7 +40,7 @@ import Prelude.Unicode -- > in -- > runHttpd config resourcees [] -- > --- > helloWorld :: ResourceDef +-- > helloWorld :: Resource -- > helloWorld = emptyResource { -- > resGet -- > = Just $ do setContentType [mimeType| text/plain |] diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index acd1d7f..c79b4d4 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -139,7 +139,7 @@ gzipEncoding = mkName "gzipEncoding" resourceDecl ∷ Input → Name → Q [Dec] resourceDecl i symName - = sequence [ sigD symName [t| ResourceDef |] + = sequence [ sigD symName [t| Resource |] , valD (varP symName) (normalB (resourceE i)) decls ] where diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 74720b1..4c59b3e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -138,7 +138,7 @@ acceptRequestForResource ∷ HandleLike h → AugmentedRequest → Lazy.ByteString → [Strict.ByteString] - → ResourceDef + → Resource → IO () acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef = do @@ -148,7 +148,7 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr #else ni ← mkNormalInteraction cConfig cAddr ar rsrcPath #endif - tid ← spawnResource rsrcDef ni + tid ← spawnRsrc rsrcDef ni enqueue ctx ni if reqMustHaveBody arRequest then waitForReceiveBodyReq ctx ni tid input 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 diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs index 7b1ac43..ffaba2d 100644 --- a/Network/HTTP/Lucu/Resource/Dispatcher.hs +++ b/Network/HTTP/Lucu/Resource/Dispatcher.hs @@ -22,7 +22,7 @@ class Dispatchable α where dispatch ∷ α → CI Text → [ByteString] - → IO (Maybe ([ByteString], ResourceDef)) + → IO (Maybe ([ByteString], Resource)) dispatcher ∷ α → Dispatcher {-# INLINE dispatcher #-} @@ -50,30 +50,30 @@ instance Monoid Dispatcher where Nothing → dispatch β host path -- |An IO-based dispatcher returning resource paths as well as --- 'ResourceDef's. +-- 'Resource's. instance Dispatchable (CI Text → [ByteString] - → IO (Maybe ([ByteString], ResourceDef))) where + → IO (Maybe ([ByteString], Resource))) where dispatch = id -- |An IO-based dispatcher. -instance Dispatchable (CI Text → [ByteString] → IO (Maybe ResourceDef)) where +instance Dispatchable (CI Text → [ByteString] → IO (Maybe Resource)) where dispatch = ((((<$>) ∘ (<$>)) ((,) []) ∘) ∘) -- |A pure dispatcher. -instance Dispatchable (CI Text → [ByteString] → Maybe ResourceDef) where +instance Dispatchable (CI Text → [ByteString] → Maybe Resource) where dispatch = (((return ∘ ((,) [] <$>)) ∘) ∘) -- |An IO-based dispatcher ignoring host names. -instance Dispatchable ([ByteString] → IO (Maybe ResourceDef)) where +instance Dispatchable ([ByteString] → IO (Maybe Resource)) where dispatch = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘) -- |A pure dispatcher ignoring host names. -instance Dispatchable ([ByteString] → Maybe ResourceDef) where +instance Dispatchable ([ByteString] → Maybe Resource) where dispatch = const ∘ ((return ∘ ((,) [] <$>)) ∘) --- |The constant dispatcher returning always the same 'ResourceDef'. -instance Dispatchable ResourceDef where +-- |The constant dispatcher returning always the same 'Resource'. +instance Dispatchable Resource where dispatch = const ∘ const ∘ return ∘ Just ∘ (,) [] -- |The empty dispatcher returning always 'Nothing'. diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index f8ea1b2..d5a1411 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -7,10 +7,10 @@ , UnicodeSyntax #-} module Network.HTTP.Lucu.Resource.Internal - ( Resource - , ResourceDef(..) + ( Rsrc + , Resource(..) , emptyResource - , spawnResource + , spawnRsrc , getConfig , getRemoteAddr @@ -66,25 +66,20 @@ import Prelude hiding (catch, concat, mapM_, tail) import Prelude.Unicode import System.IO --- |The 'Resource' monad. This monad implements 'MonadIO' so it can do +-- |The resource monad. This monad implements 'MonadIO' so it can do -- any 'IO' actions. -newtype Resource a - = Resource { - unResource ∷ ReaderT NormalInteraction IO a +newtype Rsrc a + = Rsrc { + unRsrc ∷ ReaderT NormalInteraction IO a } deriving (Applicative, Functor, Monad, MonadIO) -runResource ∷ Resource a → NormalInteraction → IO a -runResource = runReaderT ∘ unResource - --- |'ResourceDef' is basically a set of 'Resource' monads for each --- HTTP methods. -data ResourceDef = ResourceDef { - -- |Whether to run a 'Resource' on a native thread (spawned by - -- 'forkOS') or to run it on a user thread (spanwed by - -- 'forkIO'). Generally you don't need to set this field to - -- 'True'. - resUsesNativeThread ∷ !Bool +runRsrc ∷ Rsrc a → NormalInteraction → IO a +runRsrc = runReaderT ∘ unRsrc + +-- |'Resource' is basically a set of 'Rsrc' monadic computations for +-- each HTTP methods. +data Resource = Resource { -- | Whether to be greedy or not. -- -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a @@ -92,40 +87,40 @@ data ResourceDef = ResourceDef { -- there is another resource at \/aaa\/bbb\/ccc. If the resource -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy -- resources are like CGI scripts. - , resIsGreedy ∷ !Bool - -- |A 'Resource' to be run when a GET request comes for the + resIsGreedy ∷ !Bool + -- |A 'Rsrc' to be run when a GET request comes for the -- resource path. If 'resGet' is Nothing, the system responds -- \"405 Method Not Allowed\" for GET requests. -- -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In -- that case 'putChunk' and such don't actually write a response -- body. - , resGet ∷ !(Maybe (Resource ())) - -- |A 'Resource' to be run when a HEAD request comes for the + , resGet ∷ !(Maybe (Rsrc ())) + -- |A 'Rsrc' to be run when a HEAD request comes for the -- resource path. If 'resHead' is Nothing, the system runs -- 'resGet' instead. If 'resGet' is also Nothing, the system -- responds \"405 Method Not Allowed\" for HEAD requests. - , resHead ∷ !(Maybe (Resource ())) - -- |A 'Resource' to be run when a POST request comes for the + , resHead ∷ !(Maybe (Rsrc ())) + -- |A 'Rsrc' to be run when a POST request comes for the -- resource path. If 'resPost' is Nothing, the system responds -- \"405 Method Not Allowed\" for POST requests. - , resPost ∷ !(Maybe (Resource ())) - -- |A 'Resource' to be run when a PUT request comes for the + , resPost ∷ !(Maybe (Rsrc ())) + -- |A 'Rsrc' to be run when a PUT request comes for the -- resource path. If 'resPut' is Nothing, the system responds -- \"405 Method Not Allowed\" for PUT requests. - , resPut ∷ !(Maybe (Resource ())) - -- |A 'Resource' to be run when a DELETE request comes for the + , resPut ∷ !(Maybe (Rsrc ())) + -- |A 'Rsrc' to be run when a DELETE request comes for the -- resource path. If 'resDelete' is Nothing, the system responds -- \"405 Method Not Allowed\" for DELETE requests. - , resDelete ∷ !(Maybe (Resource ())) + , resDelete ∷ !(Maybe (Rsrc ())) } -- |'emptyResource' is a resource definition with no actual --- handlers. You can construct a 'ResourceDef' by selectively --- overriding 'emptyResource'. It is defined as follows: +-- handlers. You can construct a 'Resource' by selectively overriding +-- 'emptyResource'. It is defined as follows: -- -- @ --- emptyResource = ResourceDef { +-- emptyResource = Resource { -- resUsesNativeThread = False -- , resIsGreedy = False -- , resGet = Nothing @@ -135,10 +130,9 @@ data ResourceDef = ResourceDef { -- , resDelete = Nothing -- } -- @ -emptyResource ∷ ResourceDef -emptyResource = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False +emptyResource ∷ Resource +emptyResource = Resource { + resIsGreedy = False , resGet = Nothing , resHead = Nothing , resPost = Nothing @@ -146,21 +140,17 @@ emptyResource = ResourceDef { , resDelete = Nothing } -spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId -spawnResource (ResourceDef {..}) ni@(NI {..}) - = fork $ run `catch` processException +spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId +spawnRsrc (Resource {..}) ni@(NI {..}) + = forkIO $ run `catch` processException where - fork ∷ IO () → IO ThreadId - fork | resUsesNativeThread = forkOS - | otherwise = forkIO - run ∷ IO () - run = flip runResource ni $ + run = flip runRsrc ni $ do req ← getRequest fromMaybe notAllowed $ rsrc req driftTo Done - rsrc ∷ Request → Maybe (Resource ()) + rsrc ∷ Request → Maybe (Rsrc ()) rsrc req = case reqMethod req of GET → resGet @@ -172,7 +162,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..}) DELETE → resDelete _ → error $ "Unknown request method: " ⧺ show (reqMethod req) - notAllowed ∷ Resource () + notAllowed ∷ Rsrc () notAllowed = do setStatus MethodNotAllowed setHeader "Allow" $ A.fromAsciiBuilder @@ -207,7 +197,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..}) if state ≤ DecidingHeader then -- We still have a chance to reflect this abortion -- in the response. Hooray! - flip runResource ni $ + flip runRsrc ni $ do setStatus $ aboStatus abo mapM_ (uncurry setHeader) (aboHeaders abo) setHeader "Content-Type" defaultPageContentType @@ -216,7 +206,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..}) else when (cnfDumpTooLateAbortionToStderr niConfig) $ dumpAbortion abo - runResource (driftTo Done) ni + runRsrc (driftTo Done) ni dumpAbortion ∷ Abortion → IO () dumpAbortion abo @@ -226,15 +216,15 @@ dumpAbortion abo , " ", show abo, "\n" ] -getInteraction ∷ Resource NormalInteraction -getInteraction = Resource ask +getInteraction ∷ Rsrc NormalInteraction +getInteraction = Rsrc ask -- |Get the 'Config' value for this httpd. -getConfig ∷ Resource Config +getConfig ∷ Rsrc Config getConfig = niConfig <$> getInteraction -- |Get the 'SockAddr' of the remote host. -getRemoteAddr ∷ Resource SockAddr +getRemoteAddr ∷ Rsrc SockAddr getRemoteAddr = niRemoteAddr <$> getInteraction #if defined(HAVE_SSL) @@ -247,18 +237,18 @@ getRemoteAddr = niRemoteAddr <$> getInteraction -- * The 'OpenSSL.Session.VerificationMode' of -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to -- 'OpenSSL.Session.VerifyPeer'. -getRemoteCertificate ∷ Resource (Maybe X509) +getRemoteCertificate ∷ Rsrc (Maybe X509) getRemoteCertificate = niRemoteCert <$> getInteraction #endif -- |Return the 'Request' value representing the request header. You -- usually don't need to call this function directly. -getRequest ∷ Resource Request +getRequest ∷ Rsrc Request getRequest = niRequest <$> getInteraction --- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in --- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this --- action is the exact path in the tree even when the 'ResourceDef' is +-- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this +-- action is the exact path in the tree even when the 'Resource' is -- greedy. -- -- Example: @@ -276,18 +266,18 @@ getRequest = niRequest <$> getInteraction -- > -- pathInfo == ["bar", "baz"] -- > ... -- > } -getResourcePath ∷ Resource [Strict.ByteString] +getResourcePath ∷ Rsrc [Strict.ByteString] getResourcePath = niResourcePath <$> getInteraction -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@ -- bytes. You can incrementally read the request body by repeatedly -- calling this function. If there is nothing to be read anymore, --- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to +-- 'getChunk' returns 'Strict.empty' and makes 'Rsrc' transit to -- the /Deciding Header/ state. -getChunk ∷ Int → Resource Strict.ByteString +getChunk ∷ Int → Rsrc Strict.ByteString getChunk = (driftTo ReceivingBody *>) ∘ getChunk' -getChunk' ∷ Int → Resource Strict.ByteString +getChunk' ∷ Int → Rsrc Strict.ByteString getChunk' n | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n) | n ≡ 0 = return (∅) @@ -297,7 +287,7 @@ getChunk' n else driftTo DecidingHeader *> return (∅) where - askForInput ∷ NormalInteraction → Resource Strict.ByteString + askForInput ∷ NormalInteraction → Rsrc Strict.ByteString askForInput (NI {..}) = do -- Ask the RequestReader to get a chunk. liftIO $ atomically @@ -313,7 +303,7 @@ getChunk' n -- |Declare the response status code. If you don't call this function, -- the status code will be defaulted to \"200 OK\". -setStatus ∷ StatusCode sc ⇒ sc → Resource () +setStatus ∷ StatusCode sc ⇒ sc → Rsrc () setStatus sc = do ni ← getInteraction liftIO $ atomically @@ -338,7 +328,7 @@ setStatus sc -- case the client shall only accept the first 10 bytes of response -- body and thinks that the residual 10 bytes is a part of the header -- of the next response. -setHeader ∷ CIAscii → Ascii → Resource () +setHeader ∷ CIAscii → Ascii → Rsrc () setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () @@ -353,7 +343,7 @@ setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction -- |@'deleteHeader' name@ deletes a response header @name@ if -- any. This function is not intended to be used so frequently. -deleteHeader ∷ CIAscii → Resource () +deleteHeader ∷ CIAscii → Rsrc () deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction where go ∷ NormalInteraction → STM () @@ -373,7 +363,7 @@ deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction -- Note that you must first declare the response header -- \"Content-Type\" before applying this function. See: -- 'setContentType' -putBuilder ∷ Builder → Resource () +putBuilder ∷ Builder → Rsrc () putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction where -- FIXME: should see if resCanHaveBody. @@ -387,7 +377,7 @@ putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction "putBuilder: Content-Type has not been set." putTMVar niBodyToSend b -driftTo ∷ InteractionState → Resource () +driftTo ∷ InteractionState → Rsrc () driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo' driftTo' ∷ NormalInteraction → InteractionState → STM () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 9434cfb..4a652a7 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -37,13 +37,13 @@ import Prelude.Unicode -- httpd first searches for a resource in the tree, and then calls -- fallback handlers to ask them for a resource. If all of the -- handlers returned 'Nothing', the httpd responds with 404 Not Found. -type FallbackHandler = [ByteString] → IO (Maybe ResourceDef) +type FallbackHandler = [ByteString] → IO (Maybe Resource) -- |'ResTree' is an opaque structure which is a map from resource path --- to 'ResourceDef'. +-- to 'Resource'. newtype ResTree = ResTree ResNode -- root だから Map ではない type ResSubtree = Map ByteString ResNode -data ResNode = ResNode (Maybe ResourceDef) ResSubtree +data ResNode = ResNode (Maybe Resource) ResSubtree -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- @@ -58,13 +58,13 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- has no involvement in character encodings such as UTF-8, since RFC -- 2616 (HTTP/1.1) says nothing about character encodings to be used -- in \"http\" and \"https\" URI schemas. -mkResTree ∷ [ ([ByteString], ResourceDef) ] → ResTree +mkResTree ∷ [ ([ByteString], Resource) ] → ResTree mkResTree = processRoot ∘ map (first canonicalisePath) where canonicalisePath ∷ [ByteString] → [ByteString] canonicalisePath = filter ((¬) ∘ BS.null) - processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree + processRoot ∷ [ ([ByteString], Resource) ] → ResTree processRoot list = let (roots, nonRoots) = partition (\(path, _) → null path) list children = processNonRoot nonRoots @@ -79,7 +79,7 @@ mkResTree = processRoot ∘ map (first canonicalisePath) in ResTree (ResNode (Just def) children) - processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree + processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree processNonRoot list = let subtree = M.fromList [(name, node name) | name ← childNames] @@ -102,7 +102,7 @@ mkResTree = processRoot ∘ map (first canonicalisePath) findResource ∷ ResTree → [FallbackHandler] → URI - → IO (Maybe ([ByteString], ResourceDef)) + → IO (Maybe ([ByteString], Resource)) findResource (ResTree (ResNode rootDefM subtree)) fbs uri = do let path = splitPathInfo uri hasGreedyRoot = maybe False resIsGreedy rootDefM @@ -119,7 +119,7 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri walkTree ∷ ResSubtree → [ByteString] → Seq ByteString - → Maybe ([ByteString], ResourceDef) + → Maybe ([ByteString], Resource) walkTree _ [] _ = error "Internal error: should not reach here." @@ -132,14 +132,14 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri walkTree tree (x:xs) soFar = do ResNode defM sub ← M.lookup x tree case defM of - Just (ResourceDef { resIsGreedy = True }) + Just (Resource { resIsGreedy = True }) → do def ← defM return (toList $ soFar ⊳ x, def) _ → walkTree sub xs (soFar ⊳ x) fallback ∷ [ByteString] → [FallbackHandler] - → IO (Maybe ([ByteString], ResourceDef)) + → IO (Maybe ([ByteString], Resource)) fallback _ [] = return Nothing fallback path (x:xs) = do m ← x path case m of diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 39ff39c..5b5eb97 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -31,9 +31,9 @@ import Prelude.Unicode import System.Directory import System.FilePath --- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at +-- | @'staticFile' fpath@ is a 'Resource' which serves the file at -- @fpath@ on the filesystem. -staticFile ∷ FilePath → ResourceDef +staticFile ∷ FilePath → Resource staticFile path = emptyResource { resGet = Just $ handleStaticFile True path @@ -43,10 +43,15 @@ staticFile path octetStream ∷ MIMEType octetStream = [mimeType| application/octet-stream |] -handleStaticFile ∷ Bool → FilePath → Resource () +handleStaticFile ∷ Bool → FilePath → Rsrc () handleStaticFile sendContent path - = do exists ← liftIO $ doesFileExist path - unless exists + = do isDir ← liftIO $ doesDirectoryExist path + when isDir + $ abort + $ mkAbortion Forbidden [] Nothing + + isFile ← liftIO $ doesFileExist path + unless isFile foundNoEntity' perms ← liftIO $ getPermissions path @@ -65,14 +70,14 @@ handleStaticFile sendContent path when sendContent $ liftIO (LBS.readFile path) ≫= putChunks --- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in --- @dir@ and its subdirectories on the filesystem to the +-- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@ +-- and its subdirectories on the filesystem to the -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. -- -- Note that 'staticDir' currently doesn't have a directory-listing -- capability. Requesting the content of a directory will end up being -- replied with /403 Forbidden/. -staticDir ∷ FilePath → ResourceDef +staticDir ∷ FilePath → Resource staticDir path = emptyResource { resIsGreedy = True @@ -81,7 +86,7 @@ staticDir path } -- TODO: implement directory listing. -handleStaticDir ∷ Bool → FilePath → Resource () +handleStaticDir ∷ Bool → FilePath → Rsrc () handleStaticDir sendContent basePath = do extraPath ← getPathInfo securityCheck extraPath