From: PHO Date: Sat, 26 Nov 2011 02:30:29 +0000 (+0900) Subject: Scrap SchemeMapper X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=57b93dc;p=Lucu.git Scrap SchemeMapper Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 849f97e..8ef80d9 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -36,9 +36,8 @@ module Network.HTTP.Lucu , module Network.HTTP.Lucu.Config -- * URI-related data types - , Scheme , Host - , PathSegments + , Path -- * 'Resource' dispatcher , module Network.HTTP.Lucu.Dispatcher diff --git a/Network/HTTP/Lucu/Dispatcher.hs b/Network/HTTP/Lucu/Dispatcher.hs index 7b0c840..a2d07f1 100644 --- a/Network/HTTP/Lucu/Dispatcher.hs +++ b/Network/HTTP/Lucu/Dispatcher.hs @@ -1,8 +1,6 @@ -- |Repository of resources that are handled by httpd. module Network.HTTP.Lucu.Dispatcher - ( SchemeMapper(..) - , SchemeMap - , HostMapper(..) + ( HostMapper(..) , HostMap , ResourceMapper(..) , ResourceMap diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs index 35f2f1e..7258920 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -10,9 +10,7 @@ , UnicodeSyntax #-} module Network.HTTP.Lucu.Dispatcher.Internal - ( SchemeMapper(..) - , SchemeMap - , HostMapper(..) + ( HostMapper(..) , HostMap , ResourceMapper(..) , ResourceMap @@ -37,18 +35,6 @@ 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' @@ -65,7 +51,7 @@ data HostMap = ∀α. HostMapper α ⇒ HMap α -- -- Minimal complete definition: 'findResource' class ResourceMapper α where - findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource) + findResource ∷ Path → α → MaybeT IO (Path, Resource) resourceMap ∷ α → ResourceMap {-# INLINE resourceMap #-} resourceMap = RMap @@ -87,7 +73,7 @@ data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α -- 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. -newtype ResourceTree = Tree (M.Map PathSegments ResourceNode) +newtype ResourceTree = Tree (M.Map Path ResourceNode) deriving Monoid -- |FIXME: doc @@ -105,68 +91,6 @@ nonGreedy ∷ Resource → ResourceNode {-# INLINE CONLIKE nonGreedy #-} nonGreedy = NonGreedy --- 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 - --- |@'mappend' a 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 - --- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's. -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 @@ -232,7 +156,7 @@ instance ResourceMapper α ⇒ Unfoldable ResourceMap α where {-# INLINE insert #-} insert a (RMap b) = resourceMap c where - c ∷ PathSegments → MaybeT IO (PathSegments, Resource) + c ∷ Path → MaybeT IO (Path, Resource) {-# INLINEABLE c #-} c s = findResource s a <|> findResource s b {-# INLINE empty #-} @@ -245,30 +169,30 @@ instance Monoid ResourceMap where {-# INLINE mempty #-} mempty = resourceMap e where - e ∷ PathSegments → MaybeT IO (PathSegments, Resource) + e ∷ Path → MaybeT IO (Path, Resource) {-# INLINE e #-} e = const (fail (⊥)) {-# INLINE mappend #-} mappend = insert --- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@ --- are also 'ResourceMapper's. -instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where +-- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also +-- 'ResourceMapper's. +instance Map α Path (Path, Resource) ⇒ ResourceMapper α where {-# INLINE findResource #-} findResource = (maybe (fail (⊥)) return ∘) ∘ lookup -- |An IO-based resource mapper. -instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where +instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where {-# INLINE findResource #-} findResource = flip id -- |A pure resource mapper. -instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where +instance ResourceMapper (Path → Maybe (Path, Resource)) where {-# INLINE findResource #-} findResource = (maybe (fail (⊥)) return ∘) ∘ flip id -- Instances of ResourceTree -------------------------------------------------- -instance Unfoldable ResourceTree (PathSegments, ResourceNode) where +instance Unfoldable ResourceTree (Path, ResourceNode) where {-# INLINEABLE insert #-} insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m {-# INLINE empty #-} @@ -289,10 +213,10 @@ instance ResourceMapper ResourceTree where Just n → return (p, nResource n) Nothing → findGreedyResource p m -findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode) - ⇒ PathSegments +findGreedyResource ∷ (Monad m, Map α Path ResourceNode) + ⇒ Path → α - → MaybeT m (PathSegments, Resource) + → MaybeT m (Path, Resource) findGreedyResource p m = case back p of Nothing → fail (⊥) @@ -302,8 +226,7 @@ findGreedyResource p m _ → findGreedyResource p' m -- dispatch ------------------------------------------------------------------- -dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource) +dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource) dispatch uri = (findResource (uriPathSegments uri) =≪) - ∘ (findResourceMap (uriHost uri) =≪) - ∘ findHostMap (uriCIScheme uri) + ∘ findResourceMap (uriHost uri) diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index e1abcab..fb87d82 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -48,8 +48,8 @@ import Prelude.Unicode -- > } -- -- FIXME: update the above example -runHttpd ∷ Config → SchemeMap → IO () -runHttpd cnf sm +runHttpd ∷ Config → HostMap → IO () +runHttpd cnf hm = do let launchers = catMaybes [ do addr ← cnfServerV4Addr cnf @@ -108,7 +108,7 @@ runHttpd cnf sm httpLoop port so = do (h, addr) ← SL.accept so tQueue ← mkInteractionQueue - readerTID ← forkIO $ requestReader cnf sm h port addr tQueue + readerTID ← forkIO $ requestReader cnf hm h port addr tQueue _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID httpLoop port so diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index c131550..0f3e7bf 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -147,7 +147,7 @@ data NormalInteraction , niRemoteCert ∷ !(Maybe X509) #endif , niRequest ∷ !Request - , niResourcePath ∷ !PathSegments + , niResourcePath ∷ !Path , niExpectedContinue ∷ !Bool , niReqBodyLength ∷ !(Maybe RequestBodyLength) @@ -189,7 +189,7 @@ mkNormalInteraction ∷ Config → Maybe X509 #endif → AugmentedRequest - → PathSegments + → Path → 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 55c2166..d793703 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -40,12 +40,12 @@ import System.IO (hPutStrLn, stderr) data Context h = Context { - cConfig ∷ !Config - , cSchemeMap ∷ !SchemeMap - , cHandle ∷ !h - , cPort ∷ !PortNumber - , cAddr ∷ !SockAddr - , cQueue ∷ !InteractionQueue + cConfig ∷ !Config + , cHostMap ∷ !HostMap + , cHandle ∷ !h + , cPort ∷ !PortNumber + , cAddr ∷ !SockAddr + , cQueue ∷ !InteractionQueue } data ChunkReceivingState @@ -55,7 +55,7 @@ data ChunkReceivingState requestReader ∷ HandleLike h ⇒ Config - → SchemeMap + → HostMap → h → PortNumber → SockAddr @@ -112,7 +112,7 @@ acceptParsableRequest ctx@(Context {..}) req input if isError $ arInitialStatus ar then acceptSemanticallyInvalidRequest ctx ar input else - do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cSchemeMap + do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap case rsrc of Nothing → do let ar' = ar { diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index 28c2b3e..96f6c2a 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -268,7 +268,7 @@ getRequest = niRequest <$> getInteraction -- > -- pathInfo == ["bar", "baz"] -- > ... -- > } -getResourcePath ∷ Rsrc PathSegments +getResourcePath ∷ Rsrc Path getResourcePath = niResourcePath <$> getInteraction -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@ diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index d36c81b..7623c70 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -5,15 +5,13 @@ #-} -- |Utility functions used internally in this package. module Network.HTTP.Lucu.Utils - ( Scheme - , Host + ( Host , PathSegment - , PathSegments + , Path , splitBy , quoteStr , parseWWWFormURLEncoded - , uriCIScheme , uriHost , uriPathSegments , trim @@ -28,7 +26,7 @@ module Network.HTTP.Lucu.Utils where import Control.Applicative hiding (empty) import Control.Monad hiding (mapM) -import Data.Ascii (Ascii, AsciiBuilder, CIAscii) +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -50,9 +48,6 @@ 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 @@ -61,8 +56,8 @@ type Host = CI Text -- percent-decoded. type PathSegment = ByteString --- |'PathSegments' is a list of URI path segments. -type PathSegments = [PathSegment] +-- |'Path' is a list of URI path segments. +type Path = [PathSegment] -- |>>> splitBy (== ':') "ab:c:def" -- ["ab", "c", "def"] @@ -118,12 +113,6 @@ parseWWWFormURLEncoded src 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 @@ -132,7 +121,7 @@ uriHost = CI.mk ∘ T.pack ∘ uriRegName ∘ fromJust ∘ uriAuthority -- |>>> uriPathSegments "http://example.com/foo/bar" -- ["foo", "bar"] -uriPathSegments ∷ URI → PathSegments +uriPathSegments ∷ URI → Path uriPathSegments uri = let reqPathStr = uriPath uri reqPath = [ unEscapeString x