From: PHO <pho@cielonegro.org>
Date: Wed, 23 Nov 2011 12:46:42 +0000 (+0900)
Subject: It (at least) builds now...
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=667baf9;p=Lucu.git

It (at least) builds now...

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---

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"