Rename: Resource --> Rsrc; ResourceDef --> Resource

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index 5a1a9501bc22e60b3e6dd8b8bbac794790044fb0..945f16c10dc4f4b57d4047294f7e11dfd00468bf 100644 (file)
--- 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
 
       -- * 'Config'uration
     , module Network.HTTP.Lucu.Config
 

-      -- * Resource Tree
+      -- * 'Resource' Tree

     , ResTree
     , mkResTree
 
     , ResTree
     , mkResTree
 

-      -- * 'Resource' Monad
+      -- * 'Rsrc' Monad

     , module Network.HTTP.Lucu.Resource
 
       -- ** Things to be used in the Resource 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 c127250d9ededf0a1770c43a6e3d3097e937232c..4d724eb92843f6f9d1fd6c97dc46cef553aaa376 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -40,7 +40,7 @@ import Prelude.Unicode
 -- >        in
 -- >          runHttpd config resourcees []
 -- >
 -- >        in
 -- >          runHttpd config resourcees []
 -- >

--- > helloWorld :: ResourceDef
+-- > helloWorld :: Resource

 -- > helloWorld = emptyResource {
 -- >                resGet
 -- >                  = Just $ do setContentType [mimeType| text/plain |]
 -- > 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 acd1d7f762a1d97181da38764e0864efeb783c1f..c79b4d4b004c5526bd5f605f1c2324389fa3391c 100644 (file)
--- 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
 
 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
                , valD (varP symName) (normalB (resourceE i)) decls
                ]
     where

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 74720b10ad6b9975a7d569379a2249d8a0f9df66..4c59b3e9f8b1ac5a1524d634d2595a339c80c853 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -138,7 +138,7 @@ acceptRequestForResource ∷ HandleLike h
                          → AugmentedRequest
                          → Lazy.ByteString
                          → [Strict.ByteString]
                          → AugmentedRequest
                          → Lazy.ByteString
                          → [Strict.ByteString]

-                         → ResourceDef
+                         → Resource

                          → IO ()
 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
     = do
                          → 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
 #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
          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 4cf43e0c5b7f831a45da2487e7c23fd482bf374d..19a2a0a73a4779e882b02114fcf28805a782eab8 100644 (file)
--- 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
   , 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:
 -- 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
 --   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/ 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
 --   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,
 --   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
 --
 -- 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
 -- computation.
 module Network.HTTP.Lucu.Resource
     (
     -- * Types

-      Resource
-    , ResourceDef(..)
+      Resource(..)

     , emptyResource
     , emptyResource

+    , Rsrc

     , FormData(..)
 
     -- * Getting request header
     -- |These functions can be called regardless of the current state,
     , 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'
     , 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/
 
     -- * 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
     -- state.
     , foundEntity
     , foundETag


@@ -111,7 +110,7 @@ module Network.HTTP.Lucu.Resource
     , foundNoEntity'
 
     -- * Receiving a request body
     , 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
     -- Body/ state.
     , getChunk
     , getChunks


@@ -134,8 +133,8 @@ module Network.HTTP.Lucu.Resource
 
     -- * Sending a response body
 
 
     -- * 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
     , 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'.
 
 -- |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.
 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.
 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.
 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.
 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
 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.
 -- '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
 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.
 -- 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 ∘
 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.
 -- @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.
 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
 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.
 -- |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
 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.
 
 -- |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'.
 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
 getContentType
     = do cTypeM ← getHeader "Content-Type"
          case cTypeM of


@@ -323,7 +322,7 @@ getContentType
 
 -- |Return the value of request header \"Authorization\" as
 -- 'AuthCredential'.
 
 -- |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
 getAuthorization
     = do authM ← getHeader "Authorization"
          case authM of


@@ -334,11 +333,11 @@ getAuthorization
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
                     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
 --
 -- '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.
 -- 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
 
 foundEntity tag timeStamp
     = do driftTo ExaminingRequest
 


@@ -363,14 +362,13 @@ foundEntity tag timeStamp
 
          driftTo ReceivingBody
 
 
          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.
 --
 -- Using this function is discouraged. You should use 'foundEntity'
 -- whenever possible.

-foundETag ∷ ETag → Resource ()
+foundETag ∷ ETag → Rsrc ()

 foundETag tag
     = do driftTo ExaminingRequest
       
 foundETag tag
     = do driftTo ExaminingRequest
       


@@ -433,7 +431,7 @@ foundETag tag
 
          driftTo ReceivingBody
 
 
          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
 -- 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.
 --
 -- Using this function is discouraged. You should use 'foundEntity'
 -- whenever possible.

-foundTimeStamp ∷ UTCTime → Resource ()
+foundTimeStamp ∷ UTCTime → Rsrc ()

 foundTimeStamp timeStamp
     = do driftTo ExaminingRequest
 
 foundTimeStamp timeStamp
     = do driftTo ExaminingRequest
 


@@ -489,15 +487,15 @@ foundTimeStamp timeStamp
 
          driftTo ReceivingBody
 
 
          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\".
 --
 -- 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
 
 foundNoEntity msgM
     = do driftTo ExaminingRequest
 


@@ -516,15 +514,15 @@ foundNoEntity msgM
          driftTo ReceivingBody
 
 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
          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
 {-# 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
 -- 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' 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 (∅)
 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 Nothing
     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 

-getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' ∷ Int → Rsrc Lazy.ByteString

 getChunks' limit = go limit (∅)
     where
 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 (∅)
       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'
 --
 -- 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
 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' 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
 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' 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.
 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
 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' codings@ declares the response header
 -- \"Content-Encoding\" as @codings@.

-setContentEncoding ∷ [CIAscii] → Resource ()
+setContentEncoding ∷ [CIAscii] → Rsrc ()

 setContentEncoding codings
     = do ver ← getRequestVersion
          tr  ← case ver of
 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' 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'
 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
 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'
 -- 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
 putChunks = putBuilder ∘ BB.fromLazyByteString

diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs
index 7b1ac43f485436734a249aa2e6b4228374bae4fe..ffaba2d1ec114e49a3a22eb900a1bc81d286055e 100644 (file)
--- 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]
     dispatch ∷ α
              → CI Text
              → [ByteString]

-             → IO (Maybe ([ByteString], ResourceDef))
+             → IO (Maybe ([ByteString], Resource))

 
     dispatcher ∷ α → Dispatcher
     {-# INLINE dispatcher #-}
 
     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
                               Nothing → dispatch β host path
 
 -- |An IO-based dispatcher returning resource paths as well as

--- 'ResourceDef's.
+-- 'Resource's.

 instance Dispatchable (CI Text
                        → [ByteString]
 instance Dispatchable (CI Text
                        → [ByteString]

-                       → IO (Maybe ([ByteString], ResourceDef))) where
+                       → IO (Maybe ([ByteString], Resource))) where

     dispatch = id
 
 -- |An IO-based dispatcher.
     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.
     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.
     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.
     dispatch = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘)
 
 -- |A pure dispatcher ignoring host names.

-instance Dispatchable ([ByteString] → Maybe ResourceDef) where
+instance Dispatchable ([ByteString] → Maybe Resource) where

     dispatch = const ∘ ((return ∘ ((,) [] <$>)) ∘)
 
     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'.
     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 f8ea1b2aaf5b3b35edad73d7b3da2731d4b08d18..d5a14117f267a781d75908619de76592a3ab74c7 100644 (file)
--- 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
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Resource.Internal

-    ( Resource
-    , ResourceDef(..)
+    ( Rsrc
+    , Resource(..)

     , emptyResource
     , emptyResource

-    , spawnResource
+    , spawnRsrc

 
     , getConfig
     , getRemoteAddr
 
     , getConfig
     , getRemoteAddr


@@ -66,25 +66,20 @@ import Prelude hiding (catch, concat, mapM_, tail)
 import Prelude.Unicode
 import System.IO
 
 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.
 -- 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)
 
       }
     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
     -- | 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.
     -- 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.
     -- 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.
     -- 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.
     -- 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.
     -- 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.
     -- 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
     }
 
 -- |'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
 --                     resUsesNativeThread = False
 --                   , resIsGreedy         = False
 --                   , resGet              = Nothing


@@ -135,10 +130,9 @@ data ResourceDef = ResourceDef {
 --                   , resDelete           = Nothing
 --                   }
 -- @
 --                   , resDelete           = Nothing
 --                   }
 -- @

-emptyResource ∷ ResourceDef
-emptyResource = ResourceDef {
-                  resUsesNativeThread = False
-                , resIsGreedy         = False
+emptyResource ∷ Resource
+emptyResource = Resource {
+                  resIsGreedy         = False

                 , resGet              = Nothing
                 , resHead             = Nothing
                 , resPost             = Nothing
                 , resGet              = Nothing
                 , resHead             = Nothing
                 , resPost             = Nothing


@@ -146,21 +140,17 @@ emptyResource = ResourceDef {
                 , resDelete           = Nothing
                 }
 
                 , 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
     where

-      fork ∷ IO () → IO ThreadId
-      fork | resUsesNativeThread = forkOS
-           | otherwise           = forkIO
-

       run ∷ IO ()
       run ∷ IO ()

-      run = flip runResource ni $
+      run = flip runRsrc ni $

             do req ← getRequest
                fromMaybe notAllowed $ rsrc req
                driftTo Done
 
             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
       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)
 
               DELETE → resDelete
               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 

-      notAllowed ∷ Resource ()
+      notAllowed ∷ Rsrc ()

       notAllowed = do setStatus MethodNotAllowed
                       setHeader "Allow"
                           $ A.fromAsciiBuilder
       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!
                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
                        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
                else
                    when (cnfDumpTooLateAbortionToStderr niConfig)
                        $ dumpAbortion abo

-               runResource (driftTo Done) ni
+               runRsrc (driftTo Done) ni

 
 dumpAbortion ∷ Abortion → IO ()
 dumpAbortion abo
 
 dumpAbortion ∷ Abortion → IO ()
 dumpAbortion abo


@@ -226,15 +216,15 @@ dumpAbortion abo
                , "  ", show abo, "\n"
                ]
 
                , "  ", show abo, "\n"
                ]
 

-getInteraction ∷ Resource NormalInteraction
-getInteraction = Resource ask
+getInteraction ∷ Rsrc NormalInteraction
+getInteraction = Rsrc ask

 
 -- |Get the 'Config' value for this httpd.
 
 -- |Get the 'Config' value for this httpd.

-getConfig ∷ Resource Config
+getConfig ∷ Rsrc Config

 getConfig = niConfig <$> getInteraction
 
 -- |Get the 'SockAddr' of the remote host.
 getConfig = niConfig <$> getInteraction
 
 -- |Get the 'SockAddr' of the remote host.

-getRemoteAddr ∷ Resource SockAddr
+getRemoteAddr ∷ Rsrc SockAddr

 getRemoteAddr = niRemoteAddr <$> getInteraction
 
 #if defined(HAVE_SSL)
 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'.
 --   * 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.
 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
 
 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:
 -- greedy.
 --
 -- Example:


@@ -276,18 +266,18 @@ getRequest = niRequest <$> getInteraction
 -- >                        -- pathInfo           == ["bar", "baz"]
 -- >                        ...
 -- >   }
 -- >                        -- 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,
 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.
 -- the /Deciding Header/ state.

-getChunk ∷ Int → Resource Strict.ByteString
+getChunk ∷ Int → Rsrc Strict.ByteString

 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
 
 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 (∅)
 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
                      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
       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\".
 
 -- |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
 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.
 -- 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 ()
 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' 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 ()
 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'
 -- 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.
 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
 
                      "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 ()
 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 9434cfbbe9f9cbd7e7ad3dbb4a4e2f1cf2f150d8..4a652a7b7aec8ac210f274a8393080ac0fa4ba66 100644 (file)
--- 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.
 -- 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
 
 -- |'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
 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.
 --
 
 -- |'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.
 -- 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)
 
 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
       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)
 
                   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]
       processNonRoot list
           = let subtree    = M.fromList [(name, node name)
                                              | name ← childNames]


@@ -102,7 +102,7 @@ mkResTree = processRoot ∘ map (first canonicalisePath)
 findResource ∷ ResTree
              → [FallbackHandler]
              → URI
 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
 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
       walkTree ∷ ResSubtree
                → [ByteString]
                → Seq ByteString

-               → Maybe ([ByteString], ResourceDef)
+               → Maybe ([ByteString], Resource)

 
       walkTree _ [] _
           = error "Internal error: should not reach here."
 
       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
       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]
                      → 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
       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 39ff39c41ded5da08304e33b1f5cc97f9651bb5e..5b5eb9734e3a68441516f36a86ada99269ea7888 100644 (file)
--- 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
 
 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.
 -- @fpath@ on the filesystem.

-staticFile ∷ FilePath → ResourceDef
+staticFile ∷ FilePath → Resource

 staticFile path
     = emptyResource {
         resGet  = Just $ handleStaticFile True  path
 staticFile path
     = emptyResource {
         resGet  = Just $ handleStaticFile True  path


@@ -43,10 +43,15 @@ staticFile path
 octetStream ∷ MIMEType
 octetStream = [mimeType| application/octet-stream |]
 
 octetStream ∷ MIMEType
 octetStream = [mimeType| application/octet-stream |]
 

-handleStaticFile ∷ Bool → FilePath → Resource ()
+handleStaticFile ∷ Bool → FilePath → Rsrc ()

 handleStaticFile sendContent path
 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
              foundNoEntity'
 
          perms ← liftIO $ getPermissions path


@@ -65,14 +70,14 @@ handleStaticFile sendContent path
          when sendContent
              $ liftIO (LBS.readFile path) ≫= putChunks
 
          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/.
 -- '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
 staticDir path
     = emptyResource {
         resIsGreedy = True


@@ -81,7 +86,7 @@ staticDir path
       }
 
 -- TODO: implement directory listing.
       }
 
 -- TODO: implement directory listing.

-handleStaticDir ∷ Bool → FilePath → Resource ()
+handleStaticDir ∷ Bool → FilePath → Rsrc ()

 handleStaticDir sendContent basePath
     = do extraPath ← getPathInfo
          securityCheck extraPath
 handleStaticDir sendContent basePath
     = do extraPath ← getPathInfo
          securityCheck extraPath