new module: Resource.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
new file mode 100644 (file)
index 0000000..b3c6d07
--- /dev/null
+++ b/Network/HTTP/Lucu/Resource/Dispatcher.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE
+    ExistentialQuantification
+  , FlexibleInstances
+  , UnicodeSyntax
+  #-}
+-- |FIXME: doc
+module Network.HTTP.Lucu.Resource.Dispatcher
+    ( Dispatchable(..)
+    , Dispatcher
+    )
+    where
+import Control.Applicative
+import Data.ByteString (ByteString)
+import Data.CaseInsensitive (CI)
+import Data.Monoid
+import Data.Text (Text)
+import Network.HTTP.Lucu.Resource.Internal
+import Prelude.Unicode
+
+-- |FIXME: docs
+class Dispatchable α where
+    findResource ∷ α
+                 → CI Text
+                 → [ByteString]
+                 → IO (Maybe ([ByteString], ResourceDef))
+
+    dispatcher ∷ α → Dispatcher
+    {-# INLINE dispatcher #-}
+    dispatcher = Dispatcher
+
+-- |FIXME: doc
+data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α
+
+instance Dispatchable Dispatcher where
+    findResource (Dispatcher α) = findResource α
+    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 β)
+        = 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 ∘ (((<$>) ∘ (<$>)) ((,) []) ∘)
+
+instance Dispatchable ([ByteString]
+                       → Maybe ResourceDef) where
+    findResource = const ∘ ((return ∘ ((,) [] <$>)) ∘)
+
+instance Dispatchable (IO (Maybe ([ByteString], ResourceDef))) where
+    findResource = const ∘ const
+
+instance Dispatchable ([ByteString], ResourceDef) where
+    findResource = const ∘ const ∘ return ∘ Just
+
+instance Dispatchable (IO (Maybe ResourceDef)) where
+    findResource = const ∘ const ∘ ((<$>) ∘ (<$>)) ((,) [])
+
+instance Dispatchable ResourceDef where
+    findResource = const ∘ const ∘ return ∘ Just ∘ (,) []