From 3baf479eba12bc3e9c4ef966df770cd70aa5cd81 Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 26 Nov 2011 13:14:03 +0900 Subject: [PATCH] HelloWorld works again. Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- Network/HTTP/Lucu.hs | 4 ++ Network/HTTP/Lucu/Dispatcher/Internal.hs | 17 ++++- Network/HTTP/Lucu/Httpd.hs | 2 +- Network/HTTP/Lucu/Implant/PrettyPrint.hs | 4 +- Network/HTTP/Lucu/Interaction.hs | 8 +++ Network/HTTP/Lucu/RequestReader.hs | 8 +-- Network/HTTP/Lucu/Resource.hs | 1 - Network/HTTP/Lucu/Resource/Internal.hs | 82 ++++++++++++++---------- Network/HTTP/Lucu/StaticFile.hs | 13 ++-- examples/HelloWorld.hs | 55 +++++++++------- 10 files changed, 119 insertions(+), 75 deletions(-) diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 8ef80d9..6a827d0 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -46,6 +46,9 @@ module Network.HTTP.Lucu , module Network.HTTP.Lucu.Resource -- ** Things to be used in the Resource monad + -- *** 'Method' + , Method(..) + -- *** 'StatusCode' , module Network.HTTP.Lucu.StatusCode @@ -82,6 +85,7 @@ import Network.HTTP.Lucu.Httpd import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.MIMEType hiding (mimeType) import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.StaticFile diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs index 7258920..eea8d46 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -26,13 +26,14 @@ import Control.Applicative hiding (empty) import Control.Monad.Trans.Maybe import Control.Monad.Unicode import Data.Collections +import qualified Data.Collections.Newtype.TH as C import qualified Data.Map as M import Data.Monoid import Data.Monoid.Unicode import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Utils import Network.URI hiding (path) -import Prelude hiding (filter, lookup, null) +import Prelude hiding (filter, foldr, lookup, null) import Prelude.Unicode -- |FIXME: docs @@ -81,7 +82,12 @@ data ResourceNode = Greedy { nResource ∷ !Resource } | NonGreedy { nResource ∷ !Resource } --- |FIXME: doc +-- |Make a greedy resource node. +-- +-- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is +-- no resource node at the path. If there are greedy resource nodes at +-- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a +-- fallback. Greedy resource nodes are searched in depth-first order. greedy ∷ Resource → ResourceNode {-# INLINE CONLIKE greedy #-} greedy = Greedy @@ -204,6 +210,13 @@ canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c {-# INLINEABLE canonPath #-} canonPath = filter ((¬) ∘ null) +C.derive [d| instance Foldable ResourceTree (Path, ResourceNode) + |] + +instance Collection ResourceTree (Path, ResourceNode) where + {-# INLINE filter #-} + filter f (Tree m) = Tree $ filter f m + -- |'findResource' performs the longest prefix match on the tree, -- finding the most specific one. instance ResourceMapper ResourceTree where diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index fb87d82..ac1dc77 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -48,7 +48,7 @@ import Prelude.Unicode -- > } -- -- FIXME: update the above example -runHttpd ∷ Config → HostMap → IO () +runHttpd ∷ HostMapper α ⇒ Config → α → IO () runHttpd cnf hm = do let launchers = catMaybes diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index c79b4d4..bcb6f04 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -20,6 +20,7 @@ import qualified Data.ByteString.Lazy as L import Data.Char import Data.Collections import Data.List (intersperse) +import Data.Monoid import Data.Ratio import Data.Time import Language.Haskell.TH.Lib @@ -152,7 +153,7 @@ resourceDecl i symName = [] resourceE ∷ Input → Q Exp -resourceE i = [| emptyResource { +resourceE i = [| mempty { resGet = $(resGetE i) , resHead = $(resHeadE i) } @@ -239,6 +240,7 @@ rules = [ qualifyAll "Codec.Compression.GZip" "G" , unqualifyAll "Network.HTTP.Lucu.MIMEParams" "Network.HTTP.Lucu" , unqualifyAll "Network.HTTP.Lucu.MIMEType" "Network.HTTP.Lucu" , unqualify 'when "Control.Monad" + , unqualify 'mempty "Data.Monoid" , unqualify '(%) "Data.Ratio" , unqualify ''DiffTime "Data.Time" , unqualifyIn 'ModifiedJulianDay ''Day "Data.Time" diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 0f3e7bf..f5ccd83 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -123,6 +123,14 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..}) let res = setHeader "Server" cnfServerSoftware $ setHeader "Date" date $ setHeader "Content-Type" defaultPageContentType $ + ( if arWillChunkBody + then setHeader "Transfer-Encoding" "chunked" + else id + ) $ + ( if arWillClose + then setHeader "Connection" "close" + else id + ) $ emptyResponse arInitialStatus body = getDefaultPage config (Just arRequest) res return SEI { diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index d793703..2cdc45d 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -53,17 +53,17 @@ data ChunkReceivingState | InChunk !Int -- ^Number of remaining octets in the current -- chunk. It's always positive. -requestReader ∷ HandleLike h +requestReader ∷ (HostMapper hm, HandleLike h) ⇒ Config - → HostMap + → hm → h → PortNumber → SockAddr → InteractionQueue → IO () -requestReader cnf sm h port addr tQueue +requestReader cnf hm h port addr tQueue = do input ← hGetLBS h - acceptRequest (Context cnf sm h port addr tQueue) input + acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input `catches` [ Handler handleAsyncE , Handler handleOthers diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 64e69fb..0ff5081 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -71,7 +71,6 @@ module Network.HTTP.Lucu.Resource ( -- * Types Resource(..) - , emptyResource , Rsrc , FormData(..) 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 {..}) diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 5b5eb97..5ed214a 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -15,6 +15,7 @@ import Control.Monad.Unicode import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Monoid.Unicode import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -35,7 +36,7 @@ import System.FilePath -- @fpath@ on the filesystem. staticFile ∷ FilePath → Resource staticFile path - = emptyResource { + = (∅) { resGet = Just $ handleStaticFile True path , resHead = Just $ handleStaticFile False path } @@ -71,18 +72,16 @@ handleStaticFile sendContent path $ liftIO (LBS.readFile path) ≫= putChunks -- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@ --- and its subdirectories on the filesystem to the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. +-- and its subdirectories on the filesystem to the resource tree. -- -- Note that 'staticDir' currently doesn't have a directory-listing -- capability. Requesting the content of a directory will end up being -- replied with /403 Forbidden/. staticDir ∷ FilePath → Resource staticDir path - = emptyResource { - resIsGreedy = True - , resGet = Just $ handleStaticDir True path - , resHead = Just $ handleStaticDir False path + = (∅) { + resGet = Just $ handleStaticDir True path + , resHead = Just $ handleStaticDir False path } -- TODO: implement directory listing. diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index f8a4721..6a73256 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -6,35 +6,42 @@ import Control.Applicative import Control.Monad.Unicode import qualified Data.ByteString.Lazy.Char8 as Lazy +import qualified Data.Collections as C +import Data.Monoid.Unicode import Network.HTTP.Lucu +import Prelude.Unicode main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } - resources = mkResTree - [ ([] , helloWorld ) - , (["urandom"], staticFile "/dev/urandom") - , (["inc" ], staticDir "/usr/include" ) - ] - fallbacks = [ \ path → case path of - ["hello"] → return $ Just helloWorld - _ → return Nothing + mapper = resourceMap resources ⊕ resourceMap fallbacks + resources ∷ ResourceTree + resources = C.fromList + [ ([] , nonGreedy helloWorld) + , (["urandom" ], nonGreedy $ staticFile "/dev/urandom") + , (["inc" ], greedy $ staticDir "/usr/include") + , (["inc", "t"], nonGreedy $ staticFile "/usr/include/time.h") ] + fallbacks ∷ Path → Maybe (Path, Resource) + fallbacks path + | path ≡ ["hello"] = Just (path, helloWorld) + | otherwise = Nothing in do putStrLn "Access http://localhost:9999/ with your browser." - runHttpd config resources fallbacks + runHttpd config mapper -helloWorld ∷ ResourceDef -helloWorld - = emptyResource { - resGet - = Just $ do setContentType [mimeType| text/hello |] - putChunk "Hello, " - putChunk "World!\n" - putChunks =≪ Lazy.pack <$> getRemoteAddr' - , resPost - = Just $ do str1 ← getChunk 3 - str2 ← getChunk 3 - str3 ← getChunk 3 - setContentType [mimeType| text/hello |] - putChunks $ Lazy.fromChunks ["[", str1, " - ", str2, "#", str3, "]"] - } +helloWorld ∷ Resource +helloWorld = C.fromList + [ ( GET + , do setContentType [mimeType| text/hello |] + putChunk "Hello, " + putChunk "World!\n" + putChunks =≪ Lazy.pack <$> getRemoteAddr' + ) + , ( POST + , do str1 ← getChunk 3 + str2 ← getChunk 3 + str3 ← getChunk 3 + setContentType [mimeType| text/hello |] + putChunks $ Lazy.fromChunks ["[", str1, " - ", str2, "#", str3, "]"] + ) + ] -- 2.40.0