, module Network.HTTP.Lucu.Resource
-- ** Things to be used in the Resource monad
+ -- *** 'Method'
+ , Method(..)
+
-- *** 'StatusCode'
, module Network.HTTP.Lucu.StatusCode
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
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
= 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
{-# 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
-- > }
--
-- FIXME: update the above example
-runHttpd ∷ Config → HostMap → IO ()
+runHttpd ∷ HostMapper α ⇒ Config → α → IO ()
runHttpd cnf hm
= do let launchers
= catMaybes
import Data.Char
import Data.Collections
import Data.List (intersperse)
+import Data.Monoid
import Data.Ratio
import Data.Time
import Language.Haskell.TH.Lib
= []
resourceE ∷ Input → Q Exp
-resourceE i = [| emptyResource {
+resourceE i = [| mempty {
resGet = $(resGetE i)
, resHead = $(resHeadE i)
}
, 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"
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 {
| 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
(
-- * Types
Resource(..)
- , emptyResource
, Rsrc
, FormData(..)
{-# LANGUAGE
CPP
, DoAndIfThenElse
+ , FlexibleInstances
, GeneralizedNewtypeDeriving
, OverloadedStrings
+ , MultiParamTypeClasses
, RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Resource.Internal
( Rsrc
, Resource(..)
- , emptyResource
, spawnRsrc
, getConfig
#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
-- |'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.
-- 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
, 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 {..})
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
-- @fpath@ on the filesystem.
staticFile ∷ FilePath → Resource
staticFile path
- = emptyResource {
+ = (∅) {
resGet = Just $ handleStaticFile True path
, resHead = Just $ handleStaticFile False 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.
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, "]"]
+ )
+ ]
projects / Lucu.git / commitdiff