X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=f6d17b6b2f367e32d4956cdccd68431165414db2;hb=3baf479eba12bc3e9c4ef966df770cd70aa5cd81;hp=d5a14117f267a781d75908619de76592a3ab74c7;hpb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index d5a1411..f6d17b6 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -1,15 +1,16 @@ {-# LANGUAGE CPP , DoAndIfThenElse + , FlexibleInstances , GeneralizedNewtypeDeriving , OverloadedStrings + , MultiParamTypeClasses , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Resource.Internal ( Rsrc , Resource(..) - , emptyResource , spawnRsrc , getConfig @@ -42,7 +43,8 @@ import Control.Monad.Reader (ReaderT, runReaderT, ask) 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 @@ -58,11 +60,12 @@ import Network.HTTP.Lucu.Interaction 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 @@ -80,14 +83,6 @@ 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 - -- 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. @@ -95,7 +90,7 @@ data Resource = Resource { -- 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 @@ -115,30 +110,49 @@ data Resource = Resource { , 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 {..}) @@ -266,18 +280,18 @@ getRequest = niRequest <$> getInteraction -- > -- pathInfo == ["bar", "baz"] -- > ... -- > } -getResourcePath ∷ Rsrc [Strict.ByteString] +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 (∅) @@ -287,7 +301,7 @@ getChunk' n 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 @@ -297,7 +311,7 @@ getChunk' n $ atomically $ takeTMVar niReceivedBody -- Have we got an EOF? - when (Strict.null chunk) + when (BS.null chunk) $ driftTo DecidingHeader return chunk