X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FDispatcher.hs;h=ffaba2d1ec114e49a3a22eb900a1bc81d286055e;hp=b3c6d0758be3f18d379d620dbbc00034146d8362;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=24d6b6e25e79495eaa00eb6eacdb707d181d0770 diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs index b3c6d07..ffaba2d 100644 --- a/Network/HTTP/Lucu/Resource/Dispatcher.hs +++ b/Network/HTTP/Lucu/Resource/Dispatcher.hs @@ -19,82 +19,63 @@ import Prelude.Unicode -- |FIXME: docs class Dispatchable α where - findResource ∷ α - → CI Text - → [ByteString] - → IO (Maybe ([ByteString], ResourceDef)) + dispatch ∷ α + → CI Text + → [ByteString] + → IO (Maybe ([ByteString], 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 +-- |@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 f - where - f ∷ CI Text → [ByteString] → IO (Maybe ([ByteString], ResourceDef)) - f _ _ = return Nothing + mempty = dispatcher () {-# INLINEABLE mappend #-} mappend (Dispatcher α) (Dispatcher β) = dispatcher - $ \host path → do r ← findResource α host path + $ \host path → do r ← dispatch α host path case r of Just _ → return r - Nothing → findResource β host path + Nothing → dispatch β host path +-- |An IO-based dispatcher returning resource paths as well as +-- 'Resource's. 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 ∘) + → IO (Maybe ([ByteString], Resource))) where + dispatch = id -instance Dispatchable ([ByteString] - → IO (Maybe ResourceDef)) where - findResource = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘) +-- |An IO-based dispatcher. +instance Dispatchable (CI Text → [ByteString] → IO (Maybe Resource)) where + dispatch = ((((<$>) ∘ (<$>)) ((,) []) ∘) ∘) -instance Dispatchable ([ByteString] - → Maybe ResourceDef) where - findResource = const ∘ ((return ∘ ((,) [] <$>)) ∘) +-- |A pure dispatcher. +instance Dispatchable (CI Text → [ByteString] → Maybe Resource) where + dispatch = (((return ∘ ((,) [] <$>)) ∘) ∘) -instance Dispatchable (IO (Maybe ([ByteString], ResourceDef))) where - findResource = const ∘ const +-- |An IO-based dispatcher ignoring host names. +instance Dispatchable ([ByteString] → IO (Maybe Resource)) where + dispatch = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘) -instance Dispatchable ([ByteString], ResourceDef) where - findResource = const ∘ const ∘ return ∘ Just +-- |A pure dispatcher ignoring host names. +instance Dispatchable ([ByteString] → Maybe Resource) where + dispatch = const ∘ ((return ∘ ((,) [] <$>)) ∘) -instance Dispatchable (IO (Maybe ResourceDef)) where - findResource = const ∘ const ∘ ((<$>) ∘ (<$>)) ((,) []) +-- |The constant dispatcher returning always the same 'Resource'. +instance Dispatchable Resource where + dispatch = const ∘ const ∘ return ∘ Just ∘ (,) [] -instance Dispatchable ResourceDef where - findResource = const ∘ const ∘ return ∘ Just ∘ (,) [] +-- |The empty dispatcher returning always 'Nothing'. +instance Dispatchable () where + dispatch _ _ _ = return Nothing