Unfoldable Dispatcher

[Lucu.git] / Network / HTTP / Lucu / Resource / Dispatcher.hs

diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs
index b3c6d0758be3f18d379d620dbbc00034146d8362..029d7b2de6294fb0bc970ae7b951d51932049a3f 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Dispatcher.hs
+++ b/Network/HTTP/Lucu/Resource/Dispatcher.hs
@@ -1,100 +1,83 @@
 {-# 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
-    findResource ∷ α
-                 → CI Text
-                 → [ByteString]
-                 → IO (Maybe ([ByteString], ResourceDef))
+    dispatch ∷ α → URI → IO (Maybe Resource)
 
     dispatcher ∷ α → Dispatcher
     {-# INLINE dispatcher #-}
     dispatcher = Dispatcher
 
--- |FIXME: doc
+-- |Container type for 'Dispatchable' type class.
 data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α
 
 instance Dispatchable Dispatcher where
-    findResource (Dispatcher α) = findResource α
+    dispatch (Dispatcher α) = dispatch α
     dispatcher = id
 
--- |FIXME: doc
-instance Monoid Dispatcher where
-    {-# INLINE mempty #-}
-    mempty = dispatcher f
-        where
-          f ∷ CI Text → [ByteString] → IO (Maybe ([ByteString], ResourceDef))
-          f _ _ = return Nothing
-
-    {-# 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 ← findResource α host path
-                            case r of
-                              Just _  → return r
-                              Nothing → findResource β host path
-
-instance Dispatchable (CI Text
-                       → [ByteString]
-                       → IO (Maybe ([ByteString], ResourceDef))) where
-    findResource = id
-
-instance Dispatchable (CI Text
-                       → [ByteString]
-                       → Maybe ([ByteString], ResourceDef)) where
-    findResource = ((return ∘) ∘)
-
-instance Dispatchable (CI Text
-                       → [ByteString]
-                       → IO (Maybe ResourceDef)) where
-    findResource = ((((<$>) ∘ (<$>)) ((,) []) ∘) ∘)
-
-instance Dispatchable (CI Text
-                       → [ByteString]
-                       → Maybe ResourceDef) where
-    findResource = (((return ∘ ((,) [] <$>)) ∘) ∘)
-
-instance Dispatchable ([ByteString]
-                       → IO (Maybe ([ByteString], ResourceDef))) where
-    findResource = const
-
-instance Dispatchable ([ByteString]
-                       → Maybe ([ByteString], ResourceDef)) where
-    findResource = const ∘ (return ∘)
-
-instance Dispatchable ([ByteString]
-                       → IO (Maybe ResourceDef)) where
-    findResource = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘)
+          $ \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
 
-instance Dispatchable ([ByteString]
-                       → Maybe ResourceDef) where
-    findResource = const ∘ ((return ∘ ((,) [] <$>)) ∘)
+-- |@a `'mappend'` b@ first tries @a@, and then tries @b@.
+instance Monoid Dispatcher where
+    {-# INLINE mempty #-}
+    mempty = empty
+    {-# INLINE mappend #-}
+    mappend = insert
 
-instance Dispatchable (IO (Maybe ([ByteString], ResourceDef))) where
-    findResource = const ∘ const
+-- |An IO-based dispatcher.
+instance Dispatchable (URI → IO (Maybe Resource)) where
+    dispatch = id
 
-instance Dispatchable ([ByteString], ResourceDef) where
-    findResource = const ∘ const ∘ return ∘ Just
+-- |A pure dispatcher.
+instance Dispatchable (URI → Maybe Resource) where
+    dispatch = (return ∘)
 
-instance Dispatchable (IO (Maybe ResourceDef)) where
-    findResource = const ∘ const ∘ ((<$>) ∘ (<$>)) ((,) [])
+-- |The constant dispatcher returning always the same 'Resource'.
+instance Dispatchable Resource where
+    dispatch = const ∘ return ∘ Just
 
-instance Dispatchable ResourceDef where
-    findResource = const ∘ const ∘ return ∘ Just ∘ (,) []
+-- |FIXME: doc
+uriHost ∷ URI → CI Text
+uriHost = error "FIXME"