{-# LANGUAGE
CPP
, DoAndIfThenElse
+ , FlexibleInstances
, GeneralizedNewtypeDeriving
, OverloadedStrings
+ , MultiParamTypeClasses
, RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Resource.Internal
( Rsrc
, Resource(..)
- , emptyResource
, spawnRsrc
, getConfig
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
-import qualified Data.ByteString as Strict
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import Data.Collections
import Data.List (intersperse, nub)
import Data.Maybe
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
import Network.Socket
#if defined(HAVE_SSL)
import OpenSSL.X509
#endif
-import Prelude hiding (catch, concat, mapM_, tail)
+import Prelude hiding (catch, concat, filter, mapM_, tail)
import Prelude.Unicode
import System.IO
-- |'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
- -- greedy resource at \/aaa\/bbb, it is always chosen even if
- -- 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 '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 (Rsrc ()))
+ 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
, resDelete ∷ !(Maybe (Rsrc ()))
}
--- |'emptyResource' is a resource definition with no actual
--- handlers. You can construct a 'Resource' by selectively overriding
--- 'emptyResource'. It is defined as follows:
---
--- @
--- emptyResource = Resource {
--- resUsesNativeThread = False
--- , resIsGreedy = False
--- , resGet = Nothing
--- , resHead = Nothing
--- , resPost = Nothing
--- , resPut = Nothing
--- , resDelete = Nothing
--- }
--- @
-emptyResource ∷ Resource
-emptyResource = Resource {
- resIsGreedy = False
- , resGet = Nothing
- , resHead = Nothing
- , resPost = Nothing
- , resPut = Nothing
- , resDelete = Nothing
- }
+instance Monoid Resource where
+ {-# INLINE mempty #-}
+ mempty
+ = Resource {
+ resGet = Nothing
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+ {-# INLINEABLE mappend #-}
+ mappend a b
+ = Resource {
+ resGet = resGet a <|> resGet b
+ , resHead = resHead a <|> resHead b
+ , resPost = resPost a <|> resPost b
+ , resPut = resPut a <|> resPut b
+ , resDelete = resDelete a <|> resDelete b
+ }
+
+instance Unfoldable Resource (Method, Rsrc ()) where
+ {-# INLINEABLE insert #-}
+ insert (GET , a) r = r { resGet = Just a }
+ insert (HEAD , a) r = r { resHead = Just a }
+ insert (POST , a) r = r { resPost = Just a }
+ insert (PUT , a) r = r { resPut = Just a }
+ insert (DELETE, a) r = r { resDelete = Just a }
+ insert _ r = r
+ {-# INLINE empty #-}
+ empty = (∅)
+
+instance Foldable Resource (Method, Rsrc ()) where
+ {-# INLINEABLE foldMap #-}
+ foldMap f (Resource {..})
+ = maybe (∅) (f ∘ ((,) GET )) resGet ⊕
+ maybe (∅) (f ∘ ((,) HEAD )) resHead ⊕
+ maybe (∅) (f ∘ ((,) POST )) resPost ⊕
+ maybe (∅) (f ∘ ((,) PUT )) resPut ⊕
+ maybe (∅) (f ∘ ((,) DELETE)) resDelete
+
+instance Collection Resource (Method, Rsrc ()) where
+ {-# INLINE filter #-}
+ filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
spawnRsrc (Resource {..}) ni@(NI {..})
getRequest = niRequest <$> getInteraction
-- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
+-- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
-- action is the exact path in the tree even when the 'Resource' is
--- greedy.
+-- 'Network.HTTP.Lucu.greedy'.
--
-- Example:
--
--- > main = let tree = mkResTree [ (["foo"], resFoo) ]
--- > in runHttpd defaultConfig tree []
--- >
--- > resFoo = emptyResource {
--- > resIsGreedy = True
--- > , resGet = Just $ do requestURI <- getRequestURI
--- > resourcePath <- getResourcePath
--- > pathInfo <- getPathInfo
--- > -- uriPath requestURI == "/foo/bar/baz"
--- > -- resourcePath == ["foo"]
--- > -- pathInfo == ["bar", "baz"]
--- > ...
--- > }
-getResourcePath ∷ Rsrc [Strict.ByteString]
+-- @
+-- main :: 'IO' ()
+-- main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
+-- tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
+-- in 'Network.withSocketsDo' '.' 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
+--
+-- resFoo :: 'Resource'
+-- resFoo = 'singleton'
+-- ( 'GET'
+-- , do requestURI <- 'getRequestURI'
+-- resourcePath <- 'getResourcePath'
+-- pathInfo <- 'getPathInfo'
+-- -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
+-- -- resourcePath == ["foo"]
+-- -- pathInfo == ["bar", "baz"]
+-- ...
+-- )
+-- @
+getResourcePath ∷ Rsrc Path
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 'Rsrc' transit to
--- the /Deciding Header/ state.
-getChunk ∷ Int → Rsrc Strict.ByteString
+-- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
+-- /Deciding Header/ state.
+getChunk ∷ Int → Rsrc ByteString
getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
-getChunk' ∷ Int → Rsrc Strict.ByteString
+getChunk' ∷ Int → Rsrc ByteString
getChunk' n
| n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
| n ≡ 0 = return (∅)
else
driftTo DecidingHeader *> return (∅)
where
- askForInput ∷ NormalInteraction → Rsrc Strict.ByteString
+ askForInput ∷ NormalInteraction → Rsrc ByteString
askForInput (NI {..})
= do -- Ask the RequestReader to get a chunk.
liftIO $ atomically
$ atomically
$ takeTMVar niReceivedBody
-- Have we got an EOF?
- when (Strict.null chunk)
+ when (BS.null chunk)
$ driftTo DecidingHeader
return chunk
-- |@'setHeader' name value@ declares the value of the response header
-- @name@ as @value@. Note that this function is not intended to be
-- used so frequently: there should be specialised functions like
--- 'setContentType' for every common headers.
+-- 'Network.HTTP.Lucu.setContentType' for every common headers.
--
-- Some important headers (especially \"Content-Length\" and
-- \"Transfer-Encoding\") may be silently dropped or overwritten by
-- infinitely long stream of octets.
--
-- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See:
--- 'setContentType'
+-- \"Content-Type\" before applying this function. See
+-- 'Network.HTTP.Lucu.setContentType'.
putBuilder ∷ Builder → Rsrc ()
putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
where
projects / Lucu.git / blobdiff