new module: Resource.Dispatcher

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Lucu.cabal b/Lucu.cabal
index a1a22795c7be8a3753398eae71894e6b46246799..b424b730f6c31279ce66051bca8dcb60101251c8 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -57,6 +57,7 @@ Library
         base64-bytestring          == 0.1.*,
         blaze-builder              == 0.3.*,
         bytestring                 == 0.9.*,
         base64-bytestring          == 0.1.*,
         blaze-builder              == 0.3.*,
         bytestring                 == 0.9.*,

+        case-insensitive           == 0.3.*,

         containers                 == 0.4.*,
         containers-unicode-symbols == 0.3.*,
         directory                  == 1.1.*,
         containers                 == 0.4.*,
         containers-unicode-symbols == 0.3.*,
         directory                  == 1.1.*,


@@ -102,6 +103,7 @@ Library
         Network.HTTP.Lucu.Parser
         Network.HTTP.Lucu.Request
         Network.HTTP.Lucu.Resource
         Network.HTTP.Lucu.Parser
         Network.HTTP.Lucu.Request
         Network.HTTP.Lucu.Resource

+        Network.HTTP.Lucu.Resource.Dispatcher

         Network.HTTP.Lucu.Resource.Tree
         Network.HTTP.Lucu.Response
         Network.HTTP.Lucu.SocketLike
         Network.HTTP.Lucu.Resource.Tree
         Network.HTTP.Lucu.Response
         Network.HTTP.Lucu.SocketLike

diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs
index 7549ae5c0e07d33886b6cb5ed64b741f45ecde7f..5e7246e8947259dc2c33d8fd91532e2a3272868a 100644 (file)
--- a/Network/HTTP/Lucu/Config.hs
+++ b/Network/HTTP/Lucu/Config.hs
@@ -13,6 +13,8 @@ module Network.HTTP.Lucu.Config
     )
     where
 import Data.Ascii (Ascii)
     )
     where
 import Data.Ascii (Ascii)

+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI

 import Data.Text (Text)
 import qualified Data.Text as T
 import Network
 import Data.Text (Text)
 import qualified Data.Text as T
 import Network


@@ -33,7 +35,7 @@ data Config = Config {
 
     -- |The host name of the server. This value will be used in
     -- built-in pages like \"404 Not Found\".
 
     -- |The host name of the server. This value will be used in
     -- built-in pages like \"404 Not Found\".

-    , cnfServerHost ∷ !Text
+    , cnfServerHost ∷ !(CI Text)

 
     -- |A port number (or a service name) to listen to HTTP clients.
     , cnfServerPort ∷ !ServiceName
 
     -- |A port number (or a service name) to listen to HTTP clients.
     , cnfServerPort ∷ !ServiceName


@@ -105,7 +107,7 @@ data SSLConfig
 defaultConfig ∷ Config
 defaultConfig = Config {
                   cnfServerSoftware              = "Lucu/1.0"
 defaultConfig ∷ Config
 defaultConfig = Config {
                   cnfServerSoftware              = "Lucu/1.0"

-                , cnfServerHost                  = T.pack (unsafePerformIO getHostName)
+                , cnfServerHost                  = CI.mk $ T.pack $ unsafePerformIO getHostName

                 , cnfServerPort                  = "http"
                 , cnfServerV4Addr                = Just "0.0.0.0"
                 , cnfServerV6Addr                = Just "::"
                 , cnfServerPort                  = "http"
                 , cnfServerV4Addr                = Just "0.0.0.0"
                 , cnfServerV6Addr                = Just "::"

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 1ae5abd9589bd2f697f849b5f1189ecc6e0c3bcf..076ad1059e029b85bab761e9ada6537a2a94061a 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -18,6 +18,7 @@ import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import Control.Arrow.Unicode
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A

+import qualified Data.CaseInsensitive as CI

 import Data.Maybe
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Config
 import Data.Maybe
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Config


@@ -56,7 +57,7 @@ mkDefaultPage conf status msgA
     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "
     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "

-                        , T.unpack (cnfServerHost conf)
+                        , T.unpack $ CI.original $ cnfServerHost conf

                         ]
       in ( eelem "/"
            += ( eelem "html"
                         ]
       in ( eelem "/"
            += ( eelem "html"

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 3a02ad8f194c4a0b6e41cd850e59725a0030752f..1284f2b322749e2e69dcd0d69702065a7aa99644 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -16,6 +16,8 @@ import Control.Monad.State.Strict
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8

+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI

 import Data.Maybe
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Maybe
 import Data.Text (Text)
 import qualified Data.Text as T


@@ -44,7 +46,7 @@ data RequestBodyLength
     | Chunked
     deriving (Eq, Show)
 
     | Chunked
     deriving (Eq, Show)
 

-preprocess ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest

 preprocess localHost localPort req@(Request {..})
     = execState go initialAR
     where
 preprocess localHost localPort req@(Request {..})
     = execState go initialAR
     where


@@ -104,7 +106,7 @@ examineMethod
            DELETE → return ()
            _      → setStatus NotImplemented
 
            DELETE → return ()
            _      → setStatus NotImplemented
 

-examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
+examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()

 examineAuthority localHost localPort
     = do req ← gets arRequest
          when (isNothing $ uriAuthority $ reqURI req) $
 examineAuthority localHost localPort
     = do req ← gets arRequest
          when (isNothing $ uriAuthority $ reqURI req) $


@@ -133,22 +135,22 @@ examineAuthority localHost localPort
                -- Should never reach here...
                ver → fail ("internal error: unknown version: " ⧺ show ver)
 
                -- Should never reach here...
                ver → fail ("internal error: unknown version: " ⧺ show ver)
 

-parseHost ∷ Ascii → (Text, Ascii)
+parseHost ∷ Ascii → (CI Text, Ascii)

 parseHost hp
     = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
           -- FIXME: should decode punycode here.
 parseHost hp
     = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
           -- FIXME: should decode punycode here.

-          hText  = T.decodeUtf8 h
+          hText  = CI.mk $ T.decodeUtf8 h

           pAscii = A.unsafeFromByteString p
       in
         (hText, pAscii)
 
           pAscii = A.unsafeFromByteString p
       in
         (hText, pAscii)
 

-updateAuthority ∷ Text → Ascii → Request → Request
+updateAuthority ∷ CI Text → Ascii → Request → Request

 updateAuthority host port req
     = let uri  = reqURI req
           uri' = uri {
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""
 updateAuthority host port req
     = let uri  = reqURI req
           uri' = uri {
                    uriAuthority = Just URIAuth {
                                     uriUserInfo = ""

-                                  , uriRegName  = T.unpack host
+                                  , uriRegName  = T.unpack $ CI.original host

                                   , uriPort     = A.toString port
                                   }
                  }
                                   , uriPort     = A.toString port
                                   }
                  }

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 ∘ (,) []

diff --git a/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml b/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml
index 1dfd5b4d39d0ecdcd60df0b7bcff0dea1f634966..353706df1d21427073f151adf6511522dedde9d7 100644 (file)
--- a/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml
+++ b/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml
@@ -5,7 +5,7 @@ type: :task
 component: Lucu
 release: Lucu-1.0
 reporter: PHO <pho@cielonegro.org>
 component: Lucu
 release: Lucu-1.0
 reporter: PHO <pho@cielonegro.org>

-status: :unstarted
+status: :in_progress

 disposition: 
 creation_time: 2011-10-17 02:46:21.854704 Z
 references: []
 disposition: 
 creation_time: 2011-10-17 02:46:21.854704 Z
 references: []


@@ -24,4 +24,8 @@ log_events:
   - PHO <pho@cielonegro.org>
   - commented
   - FallbackHandler should be either a non-pure function (MonadIO) or a pure function returning Maybe ResourceDef.
   - PHO <pho@cielonegro.org>
   - commented
   - FallbackHandler should be either a non-pure function (MonadIO) or a pure function returning Maybe ResourceDef.

+- - 2011-11-14 02:29:03.053128 Z
+  - PHO <pho@cielonegro.org>
+  - changed status from unstarted to in_progress
+  - ""

 git_branch: 
 git_branch: