From 24d6b6e25e79495eaa00eb6eacdb707d181d0770 Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 14 Nov 2011 14:38:40 +0900 Subject: [PATCH] new module: Resource.Dispatcher Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- Lucu.cabal | 2 + Network/HTTP/Lucu/Config.hs | 6 +- Network/HTTP/Lucu/DefaultPage.hs | 3 +- Network/HTTP/Lucu/Preprocess.hs | 14 +-- Network/HTTP/Lucu/Resource/Dispatcher.hs | 100 ++++++++++++++++++ ...12227f40a0fa92d4c5d69a64dad473f54389a.yaml | 6 +- 6 files changed, 121 insertions(+), 10 deletions(-) create mode 100644 Network/HTTP/Lucu/Resource/Dispatcher.hs diff --git a/Lucu.cabal b/Lucu.cabal index a1a2279..b424b73 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -57,6 +57,7 @@ Library 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.*, @@ -102,6 +103,7 @@ Library 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 diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 7549ae5..5e7246e 100644 --- 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) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI 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\". - , cnfServerHost ∷ !Text + , cnfServerHost ∷ !(CI Text) -- |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" - , cnfServerHost = T.pack (unsafePerformIO getHostName) + , cnfServerHost = CI.mk $ T.pack $ unsafePerformIO getHostName , 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 1ae5abd..076ad10 100644 --- 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 qualified Data.CaseInsensitive as CI 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 " - , T.unpack (cnfServerHost conf) + , T.unpack $ CI.original $ cnfServerHost conf ] in ( eelem "/" += ( eelem "html" diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 3a02ad8..1284f2b 100644 --- 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.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Maybe import Data.Text (Text) import qualified Data.Text as T @@ -44,7 +46,7 @@ data RequestBodyLength | Chunked deriving (Eq, Show) -preprocess ∷ Text → PortNumber → Request → AugmentedRequest +preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest preprocess localHost localPort req@(Request {..}) = execState go initialAR where @@ -104,7 +106,7 @@ examineMethod 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) $ @@ -133,22 +135,22 @@ examineAuthority localHost localPort -- 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. - hText = T.decodeUtf8 h + hText = CI.mk $ T.decodeUtf8 h 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 = "" - , uriRegName = T.unpack host + , uriRegName = T.unpack $ CI.original host , uriPort = A.toString port } } diff --git a/Network/HTTP/Lucu/Resource/Dispatcher.hs b/Network/HTTP/Lucu/Resource/Dispatcher.hs new file mode 100644 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 1dfd5b4..353706d 100644 --- a/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml +++ b/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-10-17 02:46:21.854704 Z references: [] @@ -24,4 +24,8 @@ log_events: - PHO - 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 + - changed status from unstarted to in_progress + - "" git_branch: -- 2.40.0