X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=f6d17b6b2f367e32d4956cdccd68431165414db2;hp=96f6c2af51a43819485264578c80d2baf7d8543a;hb=3baf479eba12bc3e9c4ef966df770cd70aa5cd81;hpb=57b93dc50655857941cc176aed2fc085e6555ff7

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index 96f6c2a..f6d17b6 100644
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -1,15 +1,16 @@
 {-# LANGUAGE
     CPP
   , DoAndIfThenElse
+  , FlexibleInstances
   , GeneralizedNewtypeDeriving
   , OverloadedStrings
+  , MultiParamTypeClasses
   , RecordWildCards
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Resource.Internal
     ( Rsrc
     , Resource(..)
-    , emptyResource
     , spawnRsrc
 
     , getConfig
@@ -64,7 +65,7 @@ import Network.Socket
 #if defined(HAVE_SSL)
 import OpenSSL.X509
 #endif
-import Prelude hiding (catch, concat, mapM_, tail)
+import Prelude hiding (catch, concat, filter, mapM_, tail)
 import Prelude.Unicode
 import System.IO
 
@@ -82,14 +83,6 @@ runRsrc = runReaderT ∘ unRsrc
 -- |'Resource' is basically a set of 'Rsrc' monadic computations for
 -- each HTTP methods.
 data Resource = Resource {
-    -- | Whether to be greedy or not.
-    --
-    -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
-    -- greedy resource at \/aaa\/bbb, it is always chosen even if
-    -- there is another resource at \/aaa\/bbb\/ccc. If the resource
-    -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
-    -- resources are like CGI scripts.
-      resIsGreedy         ∷ !Bool
     -- |A 'Rsrc' to be run when a GET request comes for the
     -- resource path. If 'resGet' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for GET requests.
@@ -97,7 +90,7 @@ data Resource = Resource {
     -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
     -- that case 'putChunk' and such don't actually write a response
     -- body.
-    , resGet              ∷ !(Maybe (Rsrc ()))
+      resGet              ∷ !(Maybe (Rsrc ()))
     -- |A 'Rsrc' to be run when a HEAD request comes for the
     -- resource path. If 'resHead' is Nothing, the system runs
     -- 'resGet' instead. If 'resGet' is also Nothing, the system
@@ -117,30 +110,49 @@ data Resource = Resource {
     , resDelete           ∷ !(Maybe (Rsrc ()))
     }
 
--- |'emptyResource' is a resource definition with no actual
--- handlers. You can construct a 'Resource' by selectively overriding
--- 'emptyResource'. It is defined as follows:
---
--- @
---   emptyResource = Resource {
---                     resUsesNativeThread = False
---                   , resIsGreedy         = False
---                   , resGet              = Nothing
---                   , resHead             = Nothing
---                   , resPost             = Nothing
---                   , resPut              = Nothing
---                   , resDelete           = Nothing
---                   }
--- @
-emptyResource ∷ Resource
-emptyResource = Resource {
-                  resIsGreedy         = False
-                , resGet              = Nothing
-                , resHead             = Nothing
-                , resPost             = Nothing
-                , resPut              = Nothing
-                , resDelete           = Nothing
-                }
+instance Monoid Resource where
+    {-# INLINE mempty #-}
+    mempty
+        = Resource {
+            resGet    = Nothing
+          , resHead   = Nothing
+          , resPost   = Nothing
+          , resPut    = Nothing
+          , resDelete = Nothing
+          }
+    {-# INLINEABLE mappend #-}
+    mappend a b
+        = Resource {
+            resGet    = resGet    a <|> resGet    b
+          , resHead   = resHead   a <|> resHead   b
+          , resPost   = resPost   a <|> resPost   b
+          , resPut    = resPut    a <|> resPut    b
+          , resDelete = resDelete a <|> resDelete b
+          }
+
+instance Unfoldable Resource (Method, Rsrc ()) where
+    {-# INLINEABLE insert #-}
+    insert (GET   , a) r = r { resGet    = Just a }
+    insert (HEAD  , a) r = r { resHead   = Just a }
+    insert (POST  , a) r = r { resPost   = Just a }
+    insert (PUT   , a) r = r { resPut    = Just a }
+    insert (DELETE, a) r = r { resDelete = Just a }
+    insert _           r = r
+    {-# INLINE empty #-}
+    empty = (∅)
+
+instance Foldable Resource (Method, Rsrc ()) where
+    {-# INLINEABLE foldMap #-}
+    foldMap f (Resource {..})
+        = maybe (∅) (f ∘ ((,) GET   )) resGet  ⊕
+          maybe (∅) (f ∘ ((,) HEAD  )) resHead ⊕
+          maybe (∅) (f ∘ ((,) POST  )) resPost ⊕
+          maybe (∅) (f ∘ ((,) PUT   )) resPut  ⊕
+          maybe (∅) (f ∘ ((,) DELETE)) resDelete
+
+instance Collection Resource (Method, Rsrc ()) where
+    {-# INLINE filter #-}
+    filter = (fromList ∘) ∘ (∘ fromFoldable) ∘ filter
 
 spawnRsrc ∷ Resource → NormalInteraction → IO ThreadId
 spawnRsrc (Resource {..}) ni@(NI {..})