From 667baf9f664ccc093241287ad727b2839290f456 Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 23 Nov 2011 21:46:42 +0900 Subject: [PATCH] It (at least) builds now... Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- Lucu.cabal | 4 +- Network/HTTP/Lucu.hs | 15 +- Network/HTTP/Lucu/Dispatcher.hs | 13 + Network/HTTP/Lucu/Dispatcher/Internal.hs | 361 +++++++++++++++++++++++ Network/HTTP/Lucu/Httpd.hs | 24 +- Network/HTTP/Lucu/Interaction.hs | 9 +- Network/HTTP/Lucu/RequestReader.hs | 15 +- Network/HTTP/Lucu/Resource/Dispatcher.hs | 83 ------ Network/HTTP/Lucu/Resource/Internal.hs | 18 +- Network/HTTP/Lucu/Resource/Tree.hs | 147 --------- Network/HTTP/Lucu/Utils.hs | 63 +++- 11 files changed, 470 insertions(+), 282 deletions(-) create mode 100644 Network/HTTP/Lucu/Dispatcher.hs create mode 100644 Network/HTTP/Lucu/Dispatcher/Internal.hs delete mode 100644 Network/HTTP/Lucu/Resource/Dispatcher.hs delete mode 100644 Network/HTTP/Lucu/Resource/Tree.hs diff --git a/Lucu.cabal b/Lucu.cabal index eecb8a7..8703d04 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -87,6 +87,7 @@ Library Network.HTTP.Lucu.Abortion Network.HTTP.Lucu.Authentication Network.HTTP.Lucu.Config + Network.HTTP.Lucu.Dispatcher Network.HTTP.Lucu.ETag Network.HTTP.Lucu.HandleLike Network.HTTP.Lucu.Headers @@ -105,8 +106,6 @@ Library Network.HTTP.Lucu.Parser Network.HTTP.Lucu.Request Network.HTTP.Lucu.Resource - Network.HTTP.Lucu.Resource.Dispatcher - Network.HTTP.Lucu.Resource.Tree Network.HTTP.Lucu.Response Network.HTTP.Lucu.SocketLike Network.HTTP.Lucu.StaticFile @@ -119,6 +118,7 @@ Library Network.HTTP.Lucu.Chunk Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage + Network.HTTP.Lucu.Dispatcher.Internal Network.HTTP.Lucu.Interaction Network.HTTP.Lucu.MIMEParams.Internal Network.HTTP.Lucu.OrphanInstances diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 7496e5c..849f97e 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -35,12 +35,13 @@ module Network.HTTP.Lucu -- * 'Config'uration , module Network.HTTP.Lucu.Config - -- * 'Dispatcher' - , module Network.HTTP.Lucu.Resource.Dispatcher + -- * URI-related data types + , Scheme + , Host + , PathSegments - -- ** 'Resource' Tree - , ResTree - , mkResTree + -- * 'Resource' dispatcher + , module Network.HTTP.Lucu.Dispatcher -- * 'Rsrc' Monad , module Network.HTTP.Lucu.Resource @@ -76,14 +77,14 @@ module Network.HTTP.Lucu import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Dispatcher import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Httpd import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.MIMEType hiding (mimeType) import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Resource.Dispatcher -import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.StaticFile import Network.HTTP.Lucu.StatusCode +import Network.HTTP.Lucu.Utils diff --git a/Network/HTTP/Lucu/Dispatcher.hs b/Network/HTTP/Lucu/Dispatcher.hs new file mode 100644 index 0000000..555ea85 --- /dev/null +++ b/Network/HTTP/Lucu/Dispatcher.hs @@ -0,0 +1,13 @@ +-- |Repository of resources that are handled by httpd. +module Network.HTTP.Lucu.Dispatcher + ( SchemeMapper(..) + , SchemeMap + , HostMapper(..) + , HostMap + , ResourceMapper(..) + , ResourceTree + , ResourceNode + , ResourceMap + ) + where +import Network.HTTP.Lucu.Dispatcher.Internal diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs new file mode 100644 index 0000000..f8f3b12 --- /dev/null +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE + DoAndIfThenElse + , ExistentialQuantification + , FlexibleInstances + , OverlappingInstances + , MultiParamTypeClasses + , RecordWildCards + , ScopedTypeVariables + , UndecidableInstances + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Dispatcher.Internal + ( SchemeMapper(..) + , SchemeMap + , HostMapper(..) + , HostMap + , ResourceMapper(..) + , ResourceMap + , ResourceTree + , ResourceNode + + , dispatch + ) + where +import Control.Applicative hiding (empty) +import Control.Monad.Trans.Maybe +import Control.Monad.Unicode +import Data.Collections +import qualified Data.Map as M +import Data.Monoid +import Data.Monoid.Unicode +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Utils +import Network.URI hiding (path) +import Prelude hiding (filter, lookup, null) +import Prelude.Unicode + +-- |FIXME: docs +-- +-- Minimal complete definition: 'findHostMap' +class SchemeMapper α where + findHostMap ∷ Scheme → α → MaybeT IO HostMap + schemeMap ∷ α → SchemeMap + {-# INLINE schemeMap #-} + schemeMap = SMap + +-- |Container type for the 'SchemeMapper' type class. +data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α + +-- |FIXME: docs +-- +-- Minimal complete definition: 'findResourceMap' +class HostMapper α where + findResourceMap ∷ Host → α → MaybeT IO ResourceMap + hostMap ∷ α → HostMap + {-# INLINE hostMap #-} + hostMap = HMap + +-- |Container type for the 'HostMapper' type class. +data HostMap = ∀α. HostMapper α ⇒ HMap α + +-- |FIXME: docs +-- +-- Minimal complete definition: 'findResource' +class ResourceMapper α where + findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource) + resourceMap ∷ α → ResourceMap + {-# INLINE resourceMap #-} + resourceMap = RMap + +-- |Container type for the 'ResourceMapper' type class. +data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α + +-- FIXME: doc +newtype ResourceTree = Root ResourceNode + +-- FIXME: docs +data ResourceNode + = Greedy !Resource + | NonGreedy !Resource !ResourceTree + | Branch !ResourceTree + +-- Instances of SchemeMapper -------------------------------------------------- +instance SchemeMapper SchemeMap where + {-# INLINE findHostMap #-} + findHostMap s (SMap α) = findHostMap s α + {-# INLINE schemeMap #-} + schemeMap = id + +-- |'HostMap's are also 'SchemeMapper's too, which matches to any +-- schemes. +instance SchemeMapper HostMap where + {-# INLINE findHostMap #-} + findHostMap = const return + +-- |'ResourceMap's are also 'SchemeMapper's too, which matches to any +-- schemes and hosts. +instance SchemeMapper ResourceMap where + {-# INLINE findHostMap #-} + findHostMap _ r = return $ hostMap f + where + f ∷ Host → Maybe ResourceMap + {-# INLINE f #-} + f = const $ Just r + +-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next. +instance SchemeMapper α ⇒ Unfoldable SchemeMap α where + {-# INLINE insert #-} + insert a (SMap b) = schemeMap c + where + c ∷ Scheme → MaybeT IO HostMap + {-# INLINEABLE c #-} + c s = findHostMap s a <|> findHostMap s b + {-# INLINE empty #-} + empty = (∅) + {-# INLINE singleton #-} + singleton = schemeMap + +-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next. +instance Monoid SchemeMap where + {-# INLINE mempty #-} + mempty = schemeMap e + where + e ∷ Scheme → MaybeT IO HostMap + {-# INLINE e #-} + e = const (fail (⊥)) + {-# INLINE mappend #-} + mappend = insert + +instance Map α Scheme HostMap ⇒ SchemeMapper α where + {-# INLINE findHostMap #-} + findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup + +-- |An IO-based scheme mapper. +instance SchemeMapper (Scheme → MaybeT IO HostMap) where + {-# INLINE findHostMap #-} + findHostMap = flip id + +-- |A pure scheme mapper. +instance SchemeMapper (Scheme → Maybe HostMap) where + {-# INLINE findHostMap #-} + findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id + + +-- Instances of HostMapper ---------------------------------------------------- +instance HostMapper HostMap where + {-# INLINE findResourceMap #-} + findResourceMap h (HMap α) = findResourceMap h α + {-# INLINE hostMap #-} + hostMap = id + +-- |'ResourceMap's are also 'HostMapper's too, which matches to any +-- hosts. +instance HostMapper ResourceMap where + {-# INLINE findResourceMap #-} + findResourceMap = const return + +-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next. +instance HostMapper α ⇒ Unfoldable HostMap α where + {-# INLINE insert #-} + insert a (HMap b) = hostMap c + where + c ∷ Host → MaybeT IO ResourceMap + {-# INLINEABLE c #-} + c h = findResourceMap h a <|> findResourceMap h b + {-# INLINE empty #-} + empty = (∅) + {-# INLINE singleton #-} + singleton = hostMap + +-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next. +instance Monoid HostMap where + {-# INLINE mempty #-} + mempty = hostMap e + where + e ∷ Host → MaybeT IO ResourceMap + {-# INLINE e #-} + e = const (fail (⊥)) + {-# INLINE mappend #-} + mappend = insert + +instance Map α Host ResourceMap ⇒ HostMapper α where + {-# INLINE findResourceMap #-} + findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup + +-- |An IO-based host mapper. +instance HostMapper (Host → MaybeT IO ResourceMap) where + {-# INLINE findResourceMap #-} + findResourceMap = flip id + +-- |A pure host mapper. +instance HostMapper (Host → Maybe ResourceMap) where + {-# INLINE findResourceMap #-} + findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id + +-- Instances of ResourceMapper ------------------------------------------------ +instance ResourceMapper ResourceMap where + {-# INLINE findResource #-} + findResource s (RMap α) = findResource s α + {-# INLINE resourceMap #-} + resourceMap = id + +-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next. +instance ResourceMapper α ⇒ Unfoldable ResourceMap α where + {-# INLINE insert #-} + insert a (RMap b) = resourceMap c + where + c ∷ PathSegments → MaybeT IO (PathSegments, Resource) + {-# INLINEABLE c #-} + c s = findResource s a <|> findResource s b + {-# INLINE empty #-} + empty = (∅) + {-# INLINE singleton #-} + singleton = resourceMap + +-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next. +instance Monoid ResourceMap where + {-# INLINE mempty #-} + mempty = resourceMap e + where + e ∷ PathSegments → MaybeT IO (PathSegments, Resource) + {-# INLINE e #-} + e = const (fail (⊥)) + {-# INLINE mappend #-} + mappend = insert + +instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where + {-# INLINE findResource #-} + findResource = (maybe (fail (⊥)) return ∘) ∘ lookup + +-- |An IO-based resource mapper. +instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where + {-# INLINE findResource #-} + findResource = flip id + +-- |A pure resource mapper. +instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where + {-# INLINE findResource #-} + findResource = (maybe (fail (⊥)) return ∘) ∘ flip id + +-- Instances of ResourceTree -------------------------------------------------- +{- +instance (Functor m, MonadIO m) + ⇒ Unfoldable (ResourceTree m) ([PathSegment], ResourceNode m) where + {-# INLINE insert #-} + insert e (Root root) = Root $ insert e root + {-# INLINE empty #-} + empty = (∅) + +instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) where + {-# INLINE mempty #-} + mempty = Root (∅) + {-# INLINE mappend #-} + mappend (Root a) (Root b) + = Root (a ⊕ b) +-} + +-- Instances of ResourceNode -------------------------------------------------- +{- +instance (Functor m, MonadIO m) + ⇒ Unfoldable (ResourceNode m) ([PathSegment], ResourceNode m) where + {-# INLINEABLE insert #-} + insert (p, a) b = insertNodeAt (canonPath p) a b + {-# INLINE empty #-} + empty = Branch (∅) + +canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c +{-# INLINEABLE canonPath #-} +canonPath = filter ((¬) ∘ null) + +insertNodeAt ∷ (Functor m, MonadIO m) + ⇒ [PathSegment] + → ResourceNode m + → ResourceNode m + → ResourceNode m +{-# INLINEABLE insertNodeAt #-} +insertNodeAt [] a b = a ⊕ b +insertNodeAt (x:[]) a b = Branch (singleton (x, a)) ⊕ b +insertNodeAt (x:xs) a b = insertNodeAt xs a (∅) ⊕ b + +instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where + {-# INLINE mempty #-} + mempty = Branch (∅) + {-# INLINEABLE mappend #-} + mappend _ (Greedy r ) = Greedy r + mappend (Greedy _ ) (NonGreedy r n) = NonGreedy r n + mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n) + mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n) + mappend (Greedy r ) (Branch _) = Greedy r + mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n) + mappend (Branch m) (Branch n) = Branch (m ⊕ n) +-} + +-- dispatch ------------------------------------------------------------------- +dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource) +dispatch uri + = (findResource (uriPathSegments uri) =≪) + ∘ (findResourceMap (uriHost uri) =≪) + ∘ findHostMap (uriCIScheme uri) + +{- +-- |'ResTree' is an opaque structure which is a map from resource path +-- to 'Resource'. +newtype ResTree = ResTree ResNode -- root だから Map ではない +type ResSubtree = Map ByteString ResNode +data ResNode = ResNode (Maybe Resource) ResSubtree + +-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. +-- +-- @ +-- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ +-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd +-- ] +-- @ +-- +-- Note that path components are always represented as octet streams +-- in this system. Lucu automatically decodes percent-encoded URIs but +-- 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], Resource) ] → ResTree +mkResTree = processRoot ∘ map (first canonicalisePath) + where + canonicalisePath ∷ [ByteString] → [ByteString] + canonicalisePath = filter ((¬) ∘ BS.null) + + processRoot ∷ [ ([ByteString], Resource) ] → ResTree + processRoot list + = let (roots, nonRoots) = partition (\(path, _) → null path) list + children = processNonRoot nonRoots + in + if null roots then + -- The root has no resources. Maybe there's one at + -- somewhere like "/foo". + ResTree (ResNode Nothing children) + else + -- There is a root resource. + let (_, def) = last roots + in + ResTree (ResNode (Just def) children) + + processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree + processNonRoot list + = let subtree = M.fromList [(name, node name) + | name ← childNames] + childNames = [name | (name:_, _) ← list] + node name = let defs = [def | (path, def) ← list, path ≡ [name]] + in + if null defs then + -- No resources are defined + -- here. Maybe there's one at + -- somewhere below this node. + ResNode Nothing children + else + -- There is a resource here. + ResNode (Just $ last defs) children + children = processNonRoot [(path, def) + | (_:path, def) ← list] + in + subtree +-} \ No newline at end of file diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 4d724eb..03fde6b 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -4,8 +4,7 @@ #-} -- |The entry point of Lucu httpd. module Network.HTTP.Lucu.Httpd - ( FallbackHandler - , runHttpd + ( runHttpd ) where import Control.Concurrent @@ -16,9 +15,9 @@ import Data.Maybe import Network.BSD import Network.Socket import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Dispatcher import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.RequestReader -import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.ResponseWriter import Network.HTTP.Lucu.SocketLike as SL import Prelude.Unicode @@ -32,13 +31,14 @@ import Prelude.Unicode -- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE QuasiQuotes #-} -- > module Main where +-- > import Network -- > import Network.HTTP.Lucu -- > -- > main :: IO () -- > main = let config = defaultConfig -- > resources = mkResTree [ ([], helloWorld) ] -- > in --- > runHttpd config resourcees [] +-- > withSocketsDo $ runHttpd config resourcees [] -- > -- > helloWorld :: Resource -- > helloWorld = emptyResource { @@ -46,10 +46,10 @@ import Prelude.Unicode -- > = Just $ do setContentType [mimeType| text/plain |] -- > putChunk "Hello, world!" -- > } -runHttpd ∷ Config → ResTree → [FallbackHandler] → IO () -runHttpd cnf tree fbs - = withSocketsDo $ - do let launchers +-- FIXME: update the above example +runHttpd ∷ Config → SchemeMap → IO () +runHttpd cnf sm + = do let launchers = catMaybes [ do addr ← cnfServerV4Addr cnf return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf) @@ -92,7 +92,9 @@ runHttpd cnf tree fbs addrs ← getAddrInfo (Just hints) (Just host) (Just srv) let addr = head addrs bracketOnError - (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (socket (addrFamily addr) + (addrSocketType addr) + (addrProtocol addr)) sClose (\ sock → do setSocketOption sock ReuseAddr 1 @@ -105,9 +107,9 @@ runHttpd cnf tree fbs httpLoop port so = do (h, addr) ← SL.accept so tQueue ← mkInteractionQueue - readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue + readerTID ← forkIO $ requestReader cnf sm h port addr tQueue _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID httpLoop port so waitForever ∷ IO () - waitForever = forever (threadDelay 1000000) + waitForever = forever $ threadDelay 1000000 diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 6aee0f7..c131550 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -32,7 +32,7 @@ import Blaze.ByteString.Builder (Builder) import Control.Applicative import Control.Concurrent.STM import Data.Ascii (Ascii) -import qualified Data.ByteString as Strict +import Data.ByteString (ByteString) import Data.Monoid.Unicode import Data.Sequence (Seq) import Data.Time @@ -45,6 +45,7 @@ import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Utils #if defined(HAVE_SSL) import OpenSSL.X509 #endif @@ -146,12 +147,12 @@ data NormalInteraction , niRemoteCert ∷ !(Maybe X509) #endif , niRequest ∷ !Request - , niResourcePath ∷ ![Strict.ByteString] + , niResourcePath ∷ !PathSegments , niExpectedContinue ∷ !Bool , niReqBodyLength ∷ !(Maybe RequestBodyLength) , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) - , niReceivedBody ∷ !(TMVar Strict.ByteString) + , niReceivedBody ∷ !(TMVar ByteString) , niResponse ∷ !(TVar Response) , niSendContinue ∷ !(TMVar Bool) @@ -188,7 +189,7 @@ mkNormalInteraction ∷ Config → Maybe X509 #endif → AugmentedRequest - → [Strict.ByteString] + → PathSegments → IO NormalInteraction #if defined(HAVE_SSL) mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 4c59b3e..55c2166 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -14,6 +14,7 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception hiding (block) import Control.Monad +import Control.Monad.Trans.Maybe import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy @@ -25,13 +26,13 @@ import qualified Data.Text as T import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk +import Network.HTTP.Lucu.Dispatcher.Internal import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource.Internal -import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Utils import Network.Socket import Prelude.Unicode @@ -40,8 +41,7 @@ import System.IO (hPutStrLn, stderr) data Context h = Context { cConfig ∷ !Config - , cResTree ∷ !ResTree - , cFallbacks ∷ ![FallbackHandler] + , cSchemeMap ∷ !SchemeMap , cHandle ∷ !h , cPort ∷ !PortNumber , cAddr ∷ !SockAddr @@ -55,16 +55,15 @@ data ChunkReceivingState requestReader ∷ HandleLike h ⇒ Config - → ResTree - → [FallbackHandler] + → SchemeMap → h → PortNumber → SockAddr → InteractionQueue → IO () -requestReader cnf tree fbs h port addr tQueue +requestReader cnf sm h port addr tQueue = do input ← hGetLBS h - acceptRequest (Context cnf tree fbs h port addr tQueue) input + acceptRequest (Context cnf sm h port addr tQueue) input `catches` [ Handler handleAsyncE , Handler handleOthers @@ -113,7 +112,7 @@ acceptParsableRequest ctx@(Context {..}) req input if isError $ arInitialStatus ar then acceptSemanticallyInvalidRequest ctx ar input else - do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar + do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cSchemeMap case rsrc of Nothing → do let ar' = ar { diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs deleted file mode 100644 index 029d7b2..0000000 --- a/Network/HTTP/Lucu/Resource/Dispatcher.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE - ExistentialQuantification - , FlexibleInstances - , MultiParamTypeClasses - , UndecidableInstances - , UnicodeSyntax - #-} --- |FIXME: doc -module Network.HTTP.Lucu.Resource.Dispatcher - ( Dispatchable(..) - , Dispatcher - , uriHost - , uriPathSegments - ) - where -import Data.CaseInsensitive (CI) -import Data.Collections -import Data.Monoid -import Data.Text (Text) -import Network.HTTP.Lucu.Resource.Internal -import Network.HTTP.Lucu.Utils -import Network.URI -import Prelude.Unicode - --- |FIXME: docs --- --- Minimal complete definition: 'dispatch' -class Dispatchable α where - dispatch ∷ α → URI → IO (Maybe Resource) - - dispatcher ∷ α → Dispatcher - {-# INLINE dispatcher #-} - dispatcher = Dispatcher - --- |Container type for 'Dispatchable' type class. -data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α - -instance Dispatchable Dispatcher where - dispatch (Dispatcher α) = dispatch α - dispatcher = id - --- |@insert a b@ first tries @a@, and then tries @b@. @insertMany bs --- a@ first tries @a@, and then tries each one in @bs@ from head to --- tail. -instance Dispatchable α ⇒ Unfoldable Dispatcher α where - {-# INLINEABLE insert #-} - insert a (Dispatcher b) - = dispatcher - $ \uri → do r ← dispatch a uri - case r of - Just _ → return r - Nothing → dispatch b uri - {-# INLINE empty #-} - empty = dispatcher e - where - e ∷ URI → IO (Maybe Resource) - {-# INLINE e #-} - e = return ∘ const Nothing - {-# INLINE singleton #-} - singleton = dispatcher - --- |@a `'mappend'` b@ first tries @a@, and then tries @b@. -instance Monoid Dispatcher where - {-# INLINE mempty #-} - mempty = empty - {-# INLINE mappend #-} - mappend = insert - --- |An IO-based dispatcher. -instance Dispatchable (URI → IO (Maybe Resource)) where - dispatch = id - --- |A pure dispatcher. -instance Dispatchable (URI → Maybe Resource) where - dispatch = (return ∘) - --- |The constant dispatcher returning always the same 'Resource'. -instance Dispatchable Resource where - dispatch = const ∘ return ∘ Just - --- |FIXME: doc -uriHost ∷ URI → CI Text -uriHost = error "FIXME" diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index d5a1411..28c2b3e 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -42,7 +42,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,6 +59,7 @@ 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 @@ -266,18 +268,18 @@ getRequest = niRequest <$> getInteraction -- > -- pathInfo == ["bar", "baz"] -- > ... -- > } -getResourcePath ∷ Rsrc [Strict.ByteString] +getResourcePath ∷ Rsrc PathSegments 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 +289,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 +299,7 @@ getChunk' n $ atomically $ takeTMVar niReceivedBody -- Have we got an EOF? - when (Strict.null chunk) + when (BS.null chunk) $ driftTo DecidingHeader return chunk diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs deleted file mode 100644 index 8150be9..0000000 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE - DoAndIfThenElse - , OverloadedStrings - , RecordWildCards - , UnicodeSyntax - #-} - --- | Repository of the resources in httpd. -module Network.HTTP.Lucu.Resource.Tree - ( ResTree - , FallbackHandler - - , mkResTree - , findResource - ) - where -import Control.Arrow -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Control.Monad -import Data.Foldable -import Data.List -import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe -import Data.Monoid.Unicode -import Data.Sequence (Seq) -import Network.HTTP.Lucu.Resource.Internal -import Network.HTTP.Lucu.Utils -import Network.URI hiding (path) -import System.IO -import Prelude hiding (catch) -import Prelude.Unicode - --- |'FallbackHandler' is an extra resource handler for resources which --- can't be statically located anywhere in the resource tree. The Lucu --- 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 Resource) - --- |'ResTree' is an opaque structure which is a map from resource path --- to 'Resource'. -newtype ResTree = ResTree ResNode -- root だから Map ではない -type ResSubtree = Map ByteString ResNode -data ResNode = ResNode (Maybe Resource) ResSubtree - --- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. --- --- @ --- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ --- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd --- ] --- @ --- --- Note that path components are always represented as octet streams --- in this system. Lucu automatically decodes percent-encoded URIs but --- 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], Resource) ] → ResTree -mkResTree = processRoot ∘ map (first canonicalisePath) - where - canonicalisePath ∷ [ByteString] → [ByteString] - canonicalisePath = filter ((¬) ∘ BS.null) - - processRoot ∷ [ ([ByteString], Resource) ] → ResTree - processRoot list - = let (roots, nonRoots) = partition (\(path, _) → null path) list - children = processNonRoot nonRoots - in - if null roots then - -- The root has no resources. Maybe there's one at - -- somewhere like "/foo". - ResTree (ResNode Nothing children) - else - -- There is a root resource. - let (_, def) = last roots - in - ResTree (ResNode (Just def) children) - - processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree - processNonRoot list - = let subtree = M.fromList [(name, node name) - | name ← childNames] - childNames = [name | (name:_, _) ← list] - node name = let defs = [def | (path, def) ← list, path ≡ [name]] - in - if null defs then - -- No resources are defined - -- here. Maybe there's one at - -- somewhere below this node. - ResNode Nothing children - else - -- There is a resource here. - ResNode (Just $ last defs) children - children = processNonRoot [(path, def) - | (_:path, def) ← list] - in - subtree - -findResource ∷ ResTree - → [FallbackHandler] - → URI - → IO (Maybe ([ByteString], Resource)) -findResource (ResTree (ResNode rootDefM subtree)) fbs uri - = do let path = uriPathSegments uri - hasGreedyRoot = maybe False resIsGreedy rootDefM - foundInTree = if hasGreedyRoot ∨ null path then - do def ← rootDefM - return ([], def) - else - walkTree subtree path (∅) - if isJust foundInTree then - return foundInTree - else - fallback path fbs - where - walkTree ∷ ResSubtree - → [ByteString] - → Seq ByteString - → Maybe ([ByteString], Resource) - - walkTree _ [] _ - = error "Internal error: should not reach here." - - walkTree tree (name:[]) soFar - = do ResNode defM _ ← M.lookup name tree - def ← defM - return (toList $ soFar ⊳ name, def) - - walkTree tree (x:xs) soFar - = do ResNode defM sub ← M.lookup x tree - case defM of - Just (Resource { resIsGreedy = True }) - → do def ← defM - return (toList $ soFar ⊳ x, def) - _ → walkTree sub xs (soFar ⊳ x) - - fallback ∷ [ByteString] - → [FallbackHandler] - → IO (Maybe ([ByteString], Resource)) - fallback _ [] = return Nothing - fallback path (x:xs) = do m ← x path - case m of - Just def → return $ Just ([], def) - Nothing → fallback path xs diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 1070d66..d36c81b 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -5,9 +5,16 @@ #-} -- |Utility functions used internally in this package. module Network.HTTP.Lucu.Utils - ( splitBy + ( Scheme + , Host + , PathSegment + , PathSegments + + , splitBy , quoteStr , parseWWWFormURLEncoded + , uriCIScheme + , uriHost , uriPathSegments , trim @@ -21,15 +28,20 @@ module Network.HTTP.Lucu.Utils where import Control.Applicative hiding (empty) import Control.Monad hiding (mapM) -import Data.Ascii (Ascii, AsciiBuilder) +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as Strict +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Char import Data.Collections import Data.Collections.BaseInstances () +import Data.Maybe import Data.Monoid.Unicode import Data.Ratio +import Data.Text (Text) +import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Network.URI @@ -38,6 +50,20 @@ import Prelude.Unicode import System.Directory import System.Time (ClockTime(..)) +-- |'Scheme' represents an URI scheme. +type Scheme = CIAscii + +-- |'Host' represents an IP address or a host name in an URI +-- authority. +type Host = CI Text + +-- |'PathSegment' represents an URI path segment, split by slashes and +-- percent-decoded. +type PathSegment = ByteString + +-- |'PathSegments' is a list of URI path segments. +type PathSegments = [PathSegment] + -- |>>> splitBy (== ':') "ab:c:def" -- ["ab", "c", "def"] splitBy ∷ (a → Bool) → [a] → [[a]] @@ -57,17 +83,17 @@ quoteStr str = A.toAsciiBuilder "\"" ⊕ go (A.toByteString str) (∅) ⊕ A.toAsciiBuilder "\"" where - go ∷ Strict.ByteString → AsciiBuilder → AsciiBuilder + go ∷ ByteString → AsciiBuilder → AsciiBuilder go bs ab - = case Strict.break (≡ '"') bs of + = case BS.break (≡ '"') bs of (x, y) - | Strict.null y + | BS.null y → ab ⊕ b2ab x | otherwise - → go (Strict.tail y) + → go (BS.tail y) (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"") - b2ab ∷ Strict.ByteString → AsciiBuilder + b2ab ∷ ByteString → AsciiBuilder b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" @@ -86,20 +112,33 @@ parseWWWFormURLEncoded src ) where unescape ∷ String → ByteString - unescape = Strict.pack ∘ unEscapeString ∘ (plusToSpace <$>) + unescape = BS.pack ∘ unEscapeString ∘ (plusToSpace <$>) plusToSpace ∷ Char → Char plusToSpace '+' = ' ' plusToSpace c = c +-- |>>> uriCIScheme "http://example.com/foo/bar" +-- "http" +uriCIScheme ∷ URI → Scheme +{-# INLINE uriCIScheme #-} +uriCIScheme = A.toCIAscii ∘ A.unsafeFromString ∘ uriScheme + +-- |>>> uriHost "http://example.com/foo/bar" +-- "example.com" +uriHost ∷ URI → Host +{-# INLINE uriHost #-} +uriHost = CI.mk ∘ T.pack ∘ uriRegName ∘ fromJust ∘ uriAuthority + -- |>>> uriPathSegments "http://example.com/foo/bar" -- ["foo", "bar"] -uriPathSegments ∷ URI → [ByteString] +uriPathSegments ∷ URI → PathSegments uriPathSegments uri = let reqPathStr = uriPath uri - reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] + reqPath = [ unEscapeString x + | x ← splitBy (≡ '/') reqPathStr, (¬) (null x) ] in - Strict.pack <$> reqPath + BS.pack <$> reqPath -- |>>> trim " ab c d " -- "ab c d" -- 2.40.0