Scrap SchemeMapper

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index 849f97ec7b258d292de8ee199bfe4f1885c7b46a..8ef80d94a51f712b7e30fa6b4f33cd5d369e8ef6 100644 (file)
--- 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
     , module Network.HTTP.Lucu.Config
 
       -- * URI-related data types

-    , Scheme

     , Host
     , Host

-    , PathSegments
+    , Path

 
       -- * 'Resource' dispatcher
     , module Network.HTTP.Lucu.Dispatcher
 
       -- * 'Resource' dispatcher
     , module Network.HTTP.Lucu.Dispatcher

diff --git a/Network/HTTP/Lucu/Dispatcher.hs b/Network/HTTP/Lucu/Dispatcher.hs
index 7b0c84003a2c84c14b67184b05a75b3b4dbc55d5..a2d07f127b136325f86c58dc535a62669f4e78e0 100644 (file)
--- 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
 -- |Repository of resources that are handled by httpd.
 module Network.HTTP.Lucu.Dispatcher

-    ( SchemeMapper(..)
-    , SchemeMap
-    , HostMapper(..)
+    ( HostMapper(..)

     , HostMap
     , ResourceMapper(..)
     , ResourceMap
     , HostMap
     , ResourceMapper(..)
     , ResourceMap

diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs
index 35f2f1ed403c81dfa36052d23b20b74995867628..72589200892f3f230cdf644082da384cd16a6dae 100644 (file)
--- 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
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Dispatcher.Internal

-    ( SchemeMapper(..)
-    , SchemeMap
-    , HostMapper(..)
+    ( HostMapper(..)

     , HostMap
     , ResourceMapper(..)
     , ResourceMap
     , HostMap
     , ResourceMapper(..)
     , ResourceMap


@@ -37,18 +35,6 @@ import Network.URI hiding (path)
 import Prelude hiding (filter, lookup, null)
 import Prelude.Unicode
 
 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'
 -- |FIXME: docs
 --
 -- Minimal complete definition: 'findResourceMap'


@@ -65,7 +51,7 @@ data HostMap = ∀α. HostMapper α ⇒ HMap α
 --
 -- Minimal complete definition: 'findResource'
 class ResourceMapper α where
 --
 -- 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
     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.
 -- 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
     deriving Monoid
 
 -- |FIXME: doc


@@ -105,68 +91,6 @@ nonGreedy ∷ Resource → ResourceNode
 {-# INLINE CONLIKE nonGreedy #-}
 nonGreedy = NonGreedy
 
 {-# 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
 
 -- 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
     {-# 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 #-}
           {-# 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
     {-# 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
 
           {-# 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.
     {-# 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.
     {-# 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 --------------------------------------------------
     {-# 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 #-}
     {-# 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
 
             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 (⊥)
 findGreedyResource p m
     = case back p of
         Nothing      → fail (⊥)


@@ -302,8 +226,7 @@ findGreedyResource p m
                           _   → findGreedyResource p' m
 
 -- dispatch -------------------------------------------------------------------
                           _   → findGreedyResource p' m
 
 -- dispatch -------------------------------------------------------------------

-dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
+dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)

 dispatch uri
     = (findResource (uriPathSegments uri) =≪)
 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 e1abcab63d8fc5344262f3cde0f14eec136347b8..fb87d820f13f42a665c1b4a86cc99f6678fdaed4 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -48,8 +48,8 @@ import Prelude.Unicode
 -- >              }
 --
 -- FIXME: update the above example
 -- >              }
 --
 -- 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
     = 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
       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
 
                _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 c131550239468c50e91e32c120203c50cdb92ab5..0f3e7bfeae5492a73edddd387528d9368dca57e8 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -147,7 +147,7 @@ data NormalInteraction
       , niRemoteCert       ∷ !(Maybe X509)
 #endif
       , niRequest          ∷ !Request
       , niRemoteCert       ∷ !(Maybe X509)
 #endif
       , niRequest          ∷ !Request

-      , niResourcePath     ∷ !PathSegments
+      , niResourcePath     ∷ !Path

       , niExpectedContinue ∷ !Bool
       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 
       , niExpectedContinue ∷ !Bool
       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 


@@ -189,7 +189,7 @@ mkNormalInteraction ∷ Config
                     → Maybe X509
 #endif
                     → AugmentedRequest
                     → Maybe X509
 #endif
                     → AugmentedRequest

-                    → PathSegments
+                    → Path

                     → IO NormalInteraction
 #if defined(HAVE_SSL)
 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
                     → 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 55c2166aba9d438cf689ee6e949c851c733d547a..d793703c6c64ff240c8f3aaec1b36bd47be5205e 100644 (file)
--- 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 {
 
 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
       }
 
 data ChunkReceivingState


@@ -55,7 +55,7 @@ data ChunkReceivingState
 
 requestReader ∷ HandleLike h
               ⇒ Config
 
 requestReader ∷ HandleLike h
               ⇒ Config

-              → SchemeMap
+              → HostMap

               → h
               → PortNumber
               → SockAddr
               → h
               → PortNumber
               → SockAddr


@@ -112,7 +112,7 @@ acceptParsableRequest ctx@(Context {..}) req input
          if isError $ arInitialStatus ar then
              acceptSemanticallyInvalidRequest ctx ar input
          else
          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 {
                 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 28c2b3e4af781b3aadb13a1a4200140026a7e394..96f6c2af51a43819485264578c80d2baf7d8543a 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -268,7 +268,7 @@ getRequest = niRequest <$> getInteraction
 -- >                        -- pathInfo           == ["bar", "baz"]
 -- >                        ...
 -- >   }
 -- >                        -- 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@
 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 d36c81b2853cb7e01adf861bed59e344b4181f7c..7623c70e45d7d604beb019aa20f09bfe57987a28 100644 (file)
--- 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
   #-}
 -- |Utility functions used internally in this package.
 module Network.HTTP.Lucu.Utils

-    ( Scheme
-    , Host
+    ( Host

     , PathSegment
     , PathSegment

-    , PathSegments
+    , Path

 
     , splitBy
     , quoteStr
     , parseWWWFormURLEncoded
 
     , splitBy
     , quoteStr
     , parseWWWFormURLEncoded

-    , uriCIScheme

     , uriHost
     , uriPathSegments
     , trim
     , uriHost
     , uriPathSegments
     , trim


@@ -28,7 +26,7 @@ module Network.HTTP.Lucu.Utils
     where
 import Control.Applicative hiding (empty)
 import Control.Monad hiding (mapM)
     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
 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(..))
 
 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
 -- |'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
 
 -- 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"]
 
 -- |>>> splitBy (== ':') "ab:c:def"
 -- ["ab", "c", "def"]


@@ -118,12 +113,6 @@ parseWWWFormURLEncoded src
       plusToSpace '+' = ' '
       plusToSpace c   = c
 
       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
 -- |>>> 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 "http://example.com/foo/bar"
 -- ["foo", "bar"]

-uriPathSegments ∷ URI → PathSegments
+uriPathSegments ∷ URI → Path

 uriPathSegments uri
     = let reqPathStr = uriPath uri
           reqPath    = [ unEscapeString x
 uriPathSegments uri
     = let reqPathStr = uriPath uri
           reqPath    = [ unEscapeString x