Unfoldable Dispatcher

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index 945f16c10dc4f4b57d4047294f7e11dfd00468bf..7496e5c9bc84202122c4742537cc5b59993d6fca 100644 (file)
--- a/Network/HTTP/Lucu.hs
+++ b/Network/HTTP/Lucu.hs
@@ -35,7 +35,10 @@ module Network.HTTP.Lucu
       -- * 'Config'uration
     , module Network.HTTP.Lucu.Config
 
-      -- * 'Resource' Tree
+      -- * 'Dispatcher'
+    , module Network.HTTP.Lucu.Resource.Dispatcher
+
+      -- ** 'Resource' Tree
     , ResTree
     , mkResTree
 
@@ -79,6 +82,7 @@ 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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 19a2a0a73a4779e882b02114fcf28805a782eab8..64e69fbd6e9a8762145ec91f73e4569253076aa4 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -220,7 +220,7 @@ getRequestVersion = reqVersion <$> getRequest
 -- Note that the returned path components are URI-decoded.
 getPathInfo ∷ Rsrc [Strict.ByteString]
 getPathInfo = do rsrcPath ← getResourcePath
-                 reqPath  ← splitPathInfo <$> getRequestURI
+                 reqPath  ← uriPathSegments <$> getRequestURI
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as

diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs
index ffaba2d1ec114e49a3a22eb900a1bc81d286055e..029d7b2de6294fb0bc970ae7b951d51932049a3f 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Dispatcher.hs
+++ b/Network/HTTP/Lucu/Resource/Dispatcher.hs
@@ -1,28 +1,32 @@
 {-# LANGUAGE
     ExistentialQuantification
   , FlexibleInstances
+  , MultiParamTypeClasses
+  , UndecidableInstances
   , UnicodeSyntax
   #-}
 -- |FIXME: doc
 module Network.HTTP.Lucu.Resource.Dispatcher
     ( Dispatchable(..)
     , Dispatcher
+    , uriHost
+    , uriPathSegments
     )
     where
-import Control.Applicative
-import Data.ByteString (ByteString)
 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 ∷ α
-             → CI Text
-             → [ByteString]
-             → IO (Maybe ([ByteString], Resource))
+    dispatch ∷ α → URI → IO (Maybe Resource)
 
     dispatcher ∷ α → Dispatcher
     {-# INLINE dispatcher #-}
@@ -35,47 +39,45 @@ instance Dispatchable Dispatcher where
     dispatch (Dispatcher α) = dispatch α
     dispatcher = id
 
--- |@a `'mappend'` b@ first tries to find a resource with @a@, and if
--- it returns 'Nothing', tries @b@ next.
-instance Monoid Dispatcher where
-    {-# INLINE mempty #-}
-    mempty = dispatcher ()
-
-    {-# INLINEABLE mappend #-}
-    mappend (Dispatcher α) (Dispatcher β)
+-- |@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
-          $ \host path → do r ← dispatch α host path
-                            case r of
-                              Just _  → return r
-                              Nothing → dispatch β host path
+          $ \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
 
--- |An IO-based dispatcher returning resource paths as well as
--- 'Resource's.
-instance Dispatchable (CI Text
-                       → [ByteString]
-                       → IO (Maybe ([ByteString], Resource))) where
-    dispatch = id
+-- |@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 (CI Text → [ByteString] → IO (Maybe Resource)) where
-    dispatch = ((((<$>) ∘ (<$>)) ((,) []) ∘) ∘)
+instance Dispatchable (URI → IO (Maybe Resource)) where
+    dispatch = id
 
 -- |A pure dispatcher.
-instance Dispatchable (CI Text → [ByteString] → Maybe Resource) where
-    dispatch = (((return ∘ ((,) [] <$>)) ∘) ∘)
-
--- |An IO-based dispatcher ignoring host names.
-instance Dispatchable ([ByteString] → IO (Maybe Resource)) where
-    dispatch = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘)
-
--- |A pure dispatcher ignoring host names.
-instance Dispatchable ([ByteString] → Maybe Resource) where
-    dispatch = const ∘ ((return ∘ ((,) [] <$>)) ∘)
+instance Dispatchable (URI → Maybe Resource) where
+    dispatch = (return ∘)
 
 -- |The constant dispatcher returning always the same 'Resource'.
 instance Dispatchable Resource where
-    dispatch = const ∘ const ∘ return ∘ Just ∘ (,) []
+    dispatch = const ∘ return ∘ Just
 
--- |The empty dispatcher returning always 'Nothing'.
-instance Dispatchable () where
-    dispatch _ _ _ = return Nothing
+-- |FIXME: doc
+uriHost ∷ URI → CI Text
+uriHost = error "FIXME"

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 4a652a7b7aec8ac210f274a8393080ac0fa4ba66..8150be90ae4097fb636e62a8c72126b856944a2e 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -104,7 +104,7 @@ findResource ∷ ResTree
              → URI
              → IO (Maybe ([ByteString], Resource))
 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
-    = do let path          = splitPathInfo uri
+    = do let path          = uriPathSegments uri
              hasGreedyRoot = maybe False resIsGreedy rootDefM
              foundInTree    = if hasGreedyRoot ∨ null path then
                                   do def ← rootDefM

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index bfa2acfb72282d76a2dad31ed2871c28c0709fed..1070d66f28042193a0337b02f1e9d858d63c9403 100644 (file)
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -8,7 +8,7 @@ module Network.HTTP.Lucu.Utils
     ( splitBy
     , quoteStr
     , parseWWWFormURLEncoded
-    , splitPathInfo
+    , uriPathSegments
     , trim
 
     , (⊲)
@@ -92,10 +92,10 @@ parseWWWFormURLEncoded src
       plusToSpace '+' = ' '
       plusToSpace c   = c
 
--- |>>> splitPathInfo "http://example.com/foo/bar"
+-- |>>> uriPathSegments "http://example.com/foo/bar"
 -- ["foo", "bar"]
-splitPathInfo ∷ URI → [ByteString]
-splitPathInfo uri
+uriPathSegments ∷ URI → [ByteString]
+uriPathSegments uri
     = let reqPathStr = uriPath uri
           reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
       in