Network.HTTP.Lucu.Abortion
Network.HTTP.Lucu.Authentication
Network.HTTP.Lucu.Config
+ Network.HTTP.Lucu.Dispatcher
Network.HTTP.Lucu.ETag
Network.HTTP.Lucu.HandleLike
Network.HTTP.Lucu.Headers
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.StaticFile
Network.HTTP.Lucu.Chunk
Network.HTTP.Lucu.ContentCoding
Network.HTTP.Lucu.DefaultPage
+ Network.HTTP.Lucu.Dispatcher.Internal
Network.HTTP.Lucu.Interaction
Network.HTTP.Lucu.MIMEParams.Internal
Network.HTTP.Lucu.OrphanInstances
-- * 'Config'uration
, module Network.HTTP.Lucu.Config
- -- * 'Dispatcher'
- , module Network.HTTP.Lucu.Resource.Dispatcher
+ -- * URI-related data types
+ , Scheme
+ , Host
+ , PathSegments
- -- ** 'Resource' Tree
- , ResTree
- , mkResTree
+ -- * 'Resource' dispatcher
+ , module Network.HTTP.Lucu.Dispatcher
-- * 'Rsrc' Monad
, module Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Authentication
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Dispatcher
import Network.HTTP.Lucu.ETag
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.Resource
-import Network.HTTP.Lucu.Resource.Dispatcher
-import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.StaticFile
import Network.HTTP.Lucu.StatusCode
+import Network.HTTP.Lucu.Utils
--- /dev/null
+-- |Repository of resources that are handled by httpd.
+module Network.HTTP.Lucu.Dispatcher
+ ( SchemeMapper(..)
+ , SchemeMap
+ , HostMapper(..)
+ , HostMap
+ , ResourceMapper(..)
+ , ResourceTree
+ , ResourceNode
+ , ResourceMap
+ )
+ where
+import Network.HTTP.Lucu.Dispatcher.Internal
--- /dev/null
+{-# LANGUAGE
+ DoAndIfThenElse
+ , ExistentialQuantification
+ , FlexibleInstances
+ , OverlappingInstances
+ , MultiParamTypeClasses
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UndecidableInstances
+ , UnicodeSyntax
+ #-}
+module Network.HTTP.Lucu.Dispatcher.Internal
+ ( SchemeMapper(..)
+ , SchemeMap
+ , HostMapper(..)
+ , HostMap
+ , ResourceMapper(..)
+ , ResourceMap
+ , ResourceTree
+ , ResourceNode
+
+ , dispatch
+ )
+ where
+import Control.Applicative hiding (empty)
+import Control.Monad.Trans.Maybe
+import Control.Monad.Unicode
+import Data.Collections
+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.Unicode
+
+-- |FIXME: docs
+--
+-- Minimal complete definition: 'findHostMap'
+class SchemeMapper α where
+ findHostMap ∷ Scheme → α → MaybeT IO HostMap
+ schemeMap ∷ α → SchemeMap
+ {-# INLINE schemeMap #-}
+ schemeMap = SMap
+
+-- |Container type for the 'SchemeMapper' type class.
+data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
+
+-- |FIXME: docs
+--
+-- Minimal complete definition: 'findResourceMap'
+class HostMapper α where
+ findResourceMap ∷ Host → α → MaybeT IO ResourceMap
+ hostMap ∷ α → HostMap
+ {-# INLINE hostMap #-}
+ hostMap = HMap
+
+-- |Container type for the 'HostMapper' type class.
+data HostMap = ∀α. HostMapper α ⇒ HMap α
+
+-- |FIXME: docs
+--
+-- Minimal complete definition: 'findResource'
+class ResourceMapper α where
+ findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
+ resourceMap ∷ α → ResourceMap
+ {-# INLINE resourceMap #-}
+ resourceMap = RMap
+
+-- |Container type for the 'ResourceMapper' type class.
+data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
+
+-- FIXME: doc
+newtype ResourceTree = Root ResourceNode
+
+-- FIXME: docs
+data ResourceNode
+ = Greedy !Resource
+ | NonGreedy !Resource !ResourceTree
+ | Branch !ResourceTree
+
+-- Instances of SchemeMapper --------------------------------------------------
+instance SchemeMapper SchemeMap where
+ {-# INLINE findHostMap #-}
+ findHostMap s (SMap α) = findHostMap s α
+ {-# INLINE schemeMap #-}
+ schemeMap = id
+
+-- |'HostMap's are also 'SchemeMapper's too, which matches to any
+-- schemes.
+instance SchemeMapper HostMap where
+ {-# INLINE findHostMap #-}
+ findHostMap = const return
+
+-- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
+-- schemes and hosts.
+instance SchemeMapper ResourceMap where
+ {-# INLINE findHostMap #-}
+ findHostMap _ r = return $ hostMap f
+ where
+ f ∷ Host → Maybe ResourceMap
+ {-# INLINE f #-}
+ f = const $ Just r
+
+-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
+instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
+ {-# INLINE insert #-}
+ insert a (SMap b) = schemeMap c
+ where
+ c ∷ Scheme → MaybeT IO HostMap
+ {-# INLINEABLE c #-}
+ c s = findHostMap s a <|> findHostMap s b
+ {-# INLINE empty #-}
+ empty = (∅)
+ {-# INLINE singleton #-}
+ singleton = schemeMap
+
+-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+instance Monoid SchemeMap where
+ {-# INLINE mempty #-}
+ mempty = schemeMap e
+ where
+ e ∷ Scheme → MaybeT IO HostMap
+ {-# INLINE e #-}
+ e = const (fail (⊥))
+ {-# INLINE mappend #-}
+ mappend = insert
+
+instance Map α Scheme HostMap ⇒ SchemeMapper α where
+ {-# INLINE findHostMap #-}
+ findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
+
+-- |An IO-based scheme mapper.
+instance SchemeMapper (Scheme → MaybeT IO HostMap) where
+ {-# INLINE findHostMap #-}
+ findHostMap = flip id
+
+-- |A pure scheme mapper.
+instance SchemeMapper (Scheme → Maybe HostMap) where
+ {-# INLINE findHostMap #-}
+ findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
+
+
+-- Instances of HostMapper ----------------------------------------------------
+instance HostMapper HostMap where
+ {-# INLINE findResourceMap #-}
+ findResourceMap h (HMap α) = findResourceMap h α
+ {-# INLINE hostMap #-}
+ hostMap = id
+
+-- |'ResourceMap's are also 'HostMapper's too, which matches to any
+-- hosts.
+instance HostMapper ResourceMap where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = const return
+
+-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
+instance HostMapper α ⇒ Unfoldable HostMap α where
+ {-# INLINE insert #-}
+ insert a (HMap b) = hostMap c
+ where
+ c ∷ Host → MaybeT IO ResourceMap
+ {-# INLINEABLE c #-}
+ c h = findResourceMap h a <|> findResourceMap h b
+ {-# INLINE empty #-}
+ empty = (∅)
+ {-# INLINE singleton #-}
+ singleton = hostMap
+
+-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+instance Monoid HostMap where
+ {-# INLINE mempty #-}
+ mempty = hostMap e
+ where
+ e ∷ Host → MaybeT IO ResourceMap
+ {-# INLINE e #-}
+ e = const (fail (⊥))
+ {-# INLINE mappend #-}
+ mappend = insert
+
+instance Map α Host ResourceMap ⇒ HostMapper α where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
+
+-- |An IO-based host mapper.
+instance HostMapper (Host → MaybeT IO ResourceMap) where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = flip id
+
+-- |A pure host mapper.
+instance HostMapper (Host → Maybe ResourceMap) where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
+
+-- Instances of ResourceMapper ------------------------------------------------
+instance ResourceMapper ResourceMap where
+ {-# INLINE findResource #-}
+ findResource s (RMap α) = findResource s α
+ {-# INLINE resourceMap #-}
+ resourceMap = id
+
+-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
+instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
+ {-# INLINE insert #-}
+ insert a (RMap b) = resourceMap c
+ where
+ c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+ {-# INLINEABLE c #-}
+ c s = findResource s a <|> findResource s b
+ {-# INLINE empty #-}
+ empty = (∅)
+ {-# INLINE singleton #-}
+ singleton = resourceMap
+
+-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+instance Monoid ResourceMap where
+ {-# INLINE mempty #-}
+ mempty = resourceMap e
+ where
+ e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+ {-# INLINE e #-}
+ e = const (fail (⊥))
+ {-# INLINE mappend #-}
+ mappend = insert
+
+instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
+ {-# INLINE findResource #-}
+ findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
+
+-- |An IO-based resource mapper.
+instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
+ {-# INLINE findResource #-}
+ findResource = flip id
+
+-- |A pure resource mapper.
+instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
+ {-# INLINE findResource #-}
+ findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
+
+-- Instances of ResourceTree --------------------------------------------------
+{-
+instance (Functor m, MonadIO m)
+ ⇒ Unfoldable (ResourceTree m) ([PathSegment], ResourceNode m) where
+ {-# INLINE insert #-}
+ insert e (Root root) = Root $ insert e root
+ {-# INLINE empty #-}
+ empty = (∅)
+
+instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) where
+ {-# INLINE mempty #-}
+ mempty = Root (∅)
+ {-# INLINE mappend #-}
+ mappend (Root a) (Root b)
+ = Root (a ⊕ b)
+-}
+
+-- Instances of ResourceNode --------------------------------------------------
+{-
+instance (Functor m, MonadIO m)
+ ⇒ Unfoldable (ResourceNode m) ([PathSegment], ResourceNode m) where
+ {-# INLINEABLE insert #-}
+ insert (p, a) b = insertNodeAt (canonPath p) a b
+ {-# INLINE empty #-}
+ empty = Branch (∅)
+
+canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
+{-# INLINEABLE canonPath #-}
+canonPath = filter ((¬) ∘ null)
+
+insertNodeAt ∷ (Functor m, MonadIO m)
+ ⇒ [PathSegment]
+ → ResourceNode m
+ → ResourceNode m
+ → ResourceNode m
+{-# INLINEABLE insertNodeAt #-}
+insertNodeAt [] a b = a ⊕ b
+insertNodeAt (x:[]) a b = Branch (singleton (x, a)) ⊕ b
+insertNodeAt (x:xs) a b = insertNodeAt xs a (∅) ⊕ b
+
+instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where
+ {-# INLINE mempty #-}
+ mempty = Branch (∅)
+ {-# INLINEABLE mappend #-}
+ mappend _ (Greedy r ) = Greedy r
+ mappend (Greedy _ ) (NonGreedy r n) = NonGreedy r n
+ mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
+ mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
+ mappend (Greedy r ) (Branch _) = Greedy r
+ mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n)
+ mappend (Branch m) (Branch n) = Branch (m ⊕ n)
+-}
+
+-- dispatch -------------------------------------------------------------------
+dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
+dispatch uri
+ = (findResource (uriPathSegments uri) =≪)
+ ∘ (findResourceMap (uriHost uri) =≪)
+ ∘ findHostMap (uriCIScheme uri)
+
+{-
+-- |'ResTree' is an opaque structure which is a map from resource path
+-- to 'Resource'.
+newtype ResTree = ResTree ResNode -- root だから Map ではない
+type ResSubtree = Map ByteString ResNode
+data ResNode = ResNode (Maybe Resource) ResSubtree
+
+-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
+--
+-- @
+-- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
+-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
+-- ]
+-- @
+--
+-- Note that path components are always represented as octet streams
+-- in this system. Lucu automatically decodes percent-encoded URIs but
+-- has no involvement in character encodings such as UTF-8, since RFC
+-- 2616 (HTTP/1.1) says nothing about character encodings to be used
+-- in \"http\" and \"https\" URI schemas.
+mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
+mkResTree = processRoot ∘ map (first canonicalisePath)
+ where
+ canonicalisePath ∷ [ByteString] → [ByteString]
+ canonicalisePath = filter ((¬) ∘ BS.null)
+
+ processRoot ∷ [ ([ByteString], Resource) ] → ResTree
+ processRoot list
+ = let (roots, nonRoots) = partition (\(path, _) → null path) list
+ children = processNonRoot nonRoots
+ in
+ if null roots then
+ -- The root has no resources. Maybe there's one at
+ -- somewhere like "/foo".
+ ResTree (ResNode Nothing children)
+ else
+ -- There is a root resource.
+ let (_, def) = last roots
+ in
+ ResTree (ResNode (Just def) children)
+
+ processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
+ processNonRoot list
+ = let subtree = M.fromList [(name, node name)
+ | name ← childNames]
+ childNames = [name | (name:_, _) ← list]
+ node name = let defs = [def | (path, def) ← list, path ≡ [name]]
+ in
+ if null defs then
+ -- No resources are defined
+ -- here. Maybe there's one at
+ -- somewhere below this node.
+ ResNode Nothing children
+ else
+ -- There is a resource here.
+ ResNode (Just $ last defs) children
+ children = processNonRoot [(path, def)
+ | (_:path, def) ← list]
+ in
+ subtree
+-}
\ No newline at end of file
#-}
-- |The entry point of Lucu httpd.
module Network.HTTP.Lucu.Httpd
- ( FallbackHandler
- , runHttpd
+ ( runHttpd
)
where
import Control.Concurrent
import Network.BSD
import Network.Socket
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Dispatcher
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.RequestReader
-import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.ResponseWriter
import Network.HTTP.Lucu.SocketLike as SL
import Prelude.Unicode
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE QuasiQuotes #-}
-- > module Main where
+-- > import Network
-- > import Network.HTTP.Lucu
-- >
-- > main :: IO ()
-- > main = let config = defaultConfig
-- > resources = mkResTree [ ([], helloWorld) ]
-- > in
--- > runHttpd config resourcees []
+-- > withSocketsDo $ runHttpd config resourcees []
-- >
-- > helloWorld :: Resource
-- > helloWorld = emptyResource {
-- > = Just $ do setContentType [mimeType| text/plain |]
-- > putChunk "Hello, world!"
-- > }
-runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
-runHttpd cnf tree fbs
- = withSocketsDo $
- do let launchers
+-- FIXME: update the above example
+runHttpd ∷ Config → SchemeMap → IO ()
+runHttpd cnf sm
+ = do let launchers
= catMaybes
[ do addr ← cnfServerV4Addr cnf
return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf)
addrs ← getAddrInfo (Just hints) (Just host) (Just srv)
let addr = head addrs
bracketOnError
- (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+ (socket (addrFamily addr)
+ (addrSocketType addr)
+ (addrProtocol addr))
sClose
(\ sock →
do setSocketOption sock ReuseAddr 1
httpLoop port so
= do (h, addr) ← SL.accept so
tQueue ← mkInteractionQueue
- readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue
+ readerTID ← forkIO $ requestReader cnf sm h port addr tQueue
_writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
httpLoop port so
waitForever ∷ IO ()
- waitForever = forever (threadDelay 1000000)
+ waitForever = forever $ threadDelay 1000000
import Control.Applicative
import Control.Concurrent.STM
import Data.Ascii (Ascii)
-import qualified Data.ByteString as Strict
+import Data.ByteString (ByteString)
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import Data.Time
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
#if defined(HAVE_SSL)
import OpenSSL.X509
#endif
, niRemoteCert ∷ !(Maybe X509)
#endif
, niRequest ∷ !Request
- , niResourcePath ∷ ![Strict.ByteString]
+ , niResourcePath ∷ !PathSegments
, niExpectedContinue ∷ !Bool
, niReqBodyLength ∷ !(Maybe RequestBodyLength)
, niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
- , niReceivedBody ∷ !(TMVar Strict.ByteString)
+ , niReceivedBody ∷ !(TMVar ByteString)
, niResponse ∷ !(TVar Response)
, niSendContinue ∷ !(TMVar Bool)
→ Maybe X509
#endif
→ AugmentedRequest
- → [Strict.ByteString]
+ → PathSegments
→ IO NormalInteraction
#if defined(HAVE_SSL)
mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
import Control.Concurrent.STM
import Control.Exception hiding (block)
import Control.Monad
+import Control.Monad.Trans.Maybe
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
+import Network.HTTP.Lucu.Dispatcher.Internal
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Internal
-import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Utils
import Network.Socket
import Prelude.Unicode
data Context h
= Context {
cConfig ∷ !Config
- , cResTree ∷ !ResTree
- , cFallbacks ∷ ![FallbackHandler]
+ , cSchemeMap ∷ !SchemeMap
, cHandle ∷ !h
, cPort ∷ !PortNumber
, cAddr ∷ !SockAddr
requestReader ∷ HandleLike h
⇒ Config
- → ResTree
- → [FallbackHandler]
+ → SchemeMap
→ h
→ PortNumber
→ SockAddr
→ InteractionQueue
→ IO ()
-requestReader cnf tree fbs h port addr tQueue
+requestReader cnf sm h port addr tQueue
= do input ← hGetLBS h
- acceptRequest (Context cnf tree fbs h port addr tQueue) input
+ acceptRequest (Context cnf sm h port addr tQueue) input
`catches`
[ Handler handleAsyncE
, Handler handleOthers
if isError $ arInitialStatus ar then
acceptSemanticallyInvalidRequest ctx ar input
else
- do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+ do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cSchemeMap
case rsrc of
Nothing
→ do let ar' = ar {
+++ /dev/null
-{-# LANGUAGE
- ExistentialQuantification
- , FlexibleInstances
- , MultiParamTypeClasses
- , UndecidableInstances
- , UnicodeSyntax
- #-}
--- |FIXME: doc
-module Network.HTTP.Lucu.Resource.Dispatcher
- ( Dispatchable(..)
- , Dispatcher
- , uriHost
- , uriPathSegments
- )
- where
-import Data.CaseInsensitive (CI)
-import Data.Collections
-import Data.Monoid
-import Data.Text (Text)
-import Network.HTTP.Lucu.Resource.Internal
-import Network.HTTP.Lucu.Utils
-import Network.URI
-import Prelude.Unicode
-
--- |FIXME: docs
---
--- Minimal complete definition: 'dispatch'
-class Dispatchable α where
- dispatch ∷ α → URI → IO (Maybe Resource)
-
- dispatcher ∷ α → Dispatcher
- {-# INLINE dispatcher #-}
- dispatcher = Dispatcher
-
--- |Container type for 'Dispatchable' type class.
-data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α
-
-instance Dispatchable Dispatcher where
- dispatch (Dispatcher α) = dispatch α
- dispatcher = id
-
--- |@insert a b@ first tries @a@, and then tries @b@. @insertMany bs
--- a@ first tries @a@, and then tries each one in @bs@ from head to
--- tail.
-instance Dispatchable α ⇒ Unfoldable Dispatcher α where
- {-# INLINEABLE insert #-}
- insert a (Dispatcher b)
- = dispatcher
- $ \uri → do r ← dispatch a uri
- case r of
- Just _ → return r
- Nothing → dispatch b uri
- {-# INLINE empty #-}
- empty = dispatcher e
- where
- e ∷ URI → IO (Maybe Resource)
- {-# INLINE e #-}
- e = return ∘ const Nothing
- {-# INLINE singleton #-}
- singleton = dispatcher
-
--- |@a `'mappend'` b@ first tries @a@, and then tries @b@.
-instance Monoid Dispatcher where
- {-# INLINE mempty #-}
- mempty = empty
- {-# INLINE mappend #-}
- mappend = insert
-
--- |An IO-based dispatcher.
-instance Dispatchable (URI → IO (Maybe Resource)) where
- dispatch = id
-
--- |A pure dispatcher.
-instance Dispatchable (URI → Maybe Resource) where
- dispatch = (return ∘)
-
--- |The constant dispatcher returning always the same 'Resource'.
-instance Dispatchable Resource where
- dispatch = const ∘ return ∘ Just
-
--- |FIXME: doc
-uriHost ∷ URI → CI Text
-uriHost = error "FIXME"
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
-import qualified Data.ByteString as Strict
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import Data.Collections
import Data.List (intersperse, nub)
import Data.Maybe
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
import Network.Socket
#if defined(HAVE_SSL)
import OpenSSL.X509
-- > -- pathInfo == ["bar", "baz"]
-- > ...
-- > }
-getResourcePath ∷ Rsrc [Strict.ByteString]
+getResourcePath ∷ Rsrc PathSegments
getResourcePath = niResourcePath <$> getInteraction
-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
-- bytes. You can incrementally read the request body by repeatedly
-- calling this function. If there is nothing to be read anymore,
--- 'getChunk' returns 'Strict.empty' and makes 'Rsrc' transit to
--- the /Deciding Header/ state.
-getChunk ∷ Int → Rsrc Strict.ByteString
+-- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
+-- /Deciding Header/ state.
+getChunk ∷ Int → Rsrc ByteString
getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
-getChunk' ∷ Int → Rsrc Strict.ByteString
+getChunk' ∷ Int → Rsrc ByteString
getChunk' n
| n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n)
| n ≡ 0 = return (∅)
else
driftTo DecidingHeader *> return (∅)
where
- askForInput ∷ NormalInteraction → Rsrc Strict.ByteString
+ askForInput ∷ NormalInteraction → Rsrc ByteString
askForInput (NI {..})
= do -- Ask the RequestReader to get a chunk.
liftIO $ atomically
$ atomically
$ takeTMVar niReceivedBody
-- Have we got an EOF?
- when (Strict.null chunk)
+ when (BS.null chunk)
$ driftTo DecidingHeader
return chunk
+++ /dev/null
-{-# LANGUAGE
- DoAndIfThenElse
- , OverloadedStrings
- , RecordWildCards
- , UnicodeSyntax
- #-}
-
--- | Repository of the resources in httpd.
-module Network.HTTP.Lucu.Resource.Tree
- ( ResTree
- , FallbackHandler
-
- , mkResTree
- , findResource
- )
- where
-import Control.Arrow
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import Control.Monad
-import Data.Foldable
-import Data.List
-import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Maybe
-import Data.Monoid.Unicode
-import Data.Sequence (Seq)
-import Network.HTTP.Lucu.Resource.Internal
-import Network.HTTP.Lucu.Utils
-import Network.URI hiding (path)
-import System.IO
-import Prelude hiding (catch)
-import Prelude.Unicode
-
--- |'FallbackHandler' is an extra resource handler for resources which
--- can't be statically located anywhere in the resource tree. The Lucu
--- httpd first searches for a resource in the tree, and then calls
--- fallback handlers to ask them for a resource. If all of the
--- handlers returned 'Nothing', the httpd responds with 404 Not Found.
-type FallbackHandler = [ByteString] → IO (Maybe Resource)
-
--- |'ResTree' is an opaque structure which is a map from resource path
--- to 'Resource'.
-newtype ResTree = ResTree ResNode -- root だから Map ではない
-type ResSubtree = Map ByteString ResNode
-data ResNode = ResNode (Maybe Resource) ResSubtree
-
--- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
---
--- @
--- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
--- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
--- ]
--- @
---
--- Note that path components are always represented as octet streams
--- in this system. Lucu automatically decodes percent-encoded URIs but
--- has no involvement in character encodings such as UTF-8, since RFC
--- 2616 (HTTP/1.1) says nothing about character encodings to be used
--- in \"http\" and \"https\" URI schemas.
-mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
-mkResTree = processRoot ∘ map (first canonicalisePath)
- where
- canonicalisePath ∷ [ByteString] → [ByteString]
- canonicalisePath = filter ((¬) ∘ BS.null)
-
- processRoot ∷ [ ([ByteString], Resource) ] → ResTree
- processRoot list
- = let (roots, nonRoots) = partition (\(path, _) → null path) list
- children = processNonRoot nonRoots
- in
- if null roots then
- -- The root has no resources. Maybe there's one at
- -- somewhere like "/foo".
- ResTree (ResNode Nothing children)
- else
- -- There is a root resource.
- let (_, def) = last roots
- in
- ResTree (ResNode (Just def) children)
-
- processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
- processNonRoot list
- = let subtree = M.fromList [(name, node name)
- | name ← childNames]
- childNames = [name | (name:_, _) ← list]
- node name = let defs = [def | (path, def) ← list, path ≡ [name]]
- in
- if null defs then
- -- No resources are defined
- -- here. Maybe there's one at
- -- somewhere below this node.
- ResNode Nothing children
- else
- -- There is a resource here.
- ResNode (Just $ last defs) children
- children = processNonRoot [(path, def)
- | (_:path, def) ← list]
- in
- subtree
-
-findResource ∷ ResTree
- → [FallbackHandler]
- → URI
- → IO (Maybe ([ByteString], Resource))
-findResource (ResTree (ResNode rootDefM subtree)) fbs uri
- = do let path = uriPathSegments uri
- hasGreedyRoot = maybe False resIsGreedy rootDefM
- foundInTree = if hasGreedyRoot ∨ null path then
- do def ← rootDefM
- return ([], def)
- else
- walkTree subtree path (∅)
- if isJust foundInTree then
- return foundInTree
- else
- fallback path fbs
- where
- walkTree ∷ ResSubtree
- → [ByteString]
- → Seq ByteString
- → Maybe ([ByteString], Resource)
-
- walkTree _ [] _
- = error "Internal error: should not reach here."
-
- walkTree tree (name:[]) soFar
- = do ResNode defM _ ← M.lookup name tree
- def ← defM
- return (toList $ soFar ⊳ name, def)
-
- walkTree tree (x:xs) soFar
- = do ResNode defM sub ← M.lookup x tree
- case defM of
- Just (Resource { resIsGreedy = True })
- → do def ← defM
- return (toList $ soFar ⊳ x, def)
- _ → walkTree sub xs (soFar ⊳ x)
-
- fallback ∷ [ByteString]
- → [FallbackHandler]
- → IO (Maybe ([ByteString], Resource))
- fallback _ [] = return Nothing
- fallback path (x:xs) = do m ← x path
- case m of
- Just def → return $ Just ([], def)
- Nothing → fallback path xs
#-}
-- |Utility functions used internally in this package.
module Network.HTTP.Lucu.Utils
- ( splitBy
+ ( Scheme
+ , Host
+ , PathSegment
+ , PathSegments
+
+ , splitBy
, quoteStr
, parseWWWFormURLEncoded
+ , uriCIScheme
+ , uriHost
, uriPathSegments
, trim
where
import Control.Applicative hiding (empty)
import Control.Monad hiding (mapM)
-import Data.Ascii (Ascii, AsciiBuilder)
+import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as Strict
+import qualified Data.ByteString.Char8 as BS
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
import Data.Char
import Data.Collections
import Data.Collections.BaseInstances ()
+import Data.Maybe
import Data.Monoid.Unicode
import Data.Ratio
+import Data.Text (Text)
+import qualified Data.Text as T
import Data.Time
import Data.Time.Clock.POSIX
import Network.URI
import System.Directory
import System.Time (ClockTime(..))
+-- |'Scheme' represents an URI scheme.
+type Scheme = CIAscii
+
+-- |'Host' represents an IP address or a host name in an URI
+-- authority.
+type Host = CI Text
+
+-- |'PathSegment' represents an URI path segment, split by slashes and
+-- percent-decoded.
+type PathSegment = ByteString
+
+-- |'PathSegments' is a list of URI path segments.
+type PathSegments = [PathSegment]
+
-- |>>> splitBy (== ':') "ab:c:def"
-- ["ab", "c", "def"]
splitBy ∷ (a → Bool) → [a] → [[a]]
go (A.toByteString str) (∅) ⊕
A.toAsciiBuilder "\""
where
- go ∷ Strict.ByteString → AsciiBuilder → AsciiBuilder
+ go ∷ ByteString → AsciiBuilder → AsciiBuilder
go bs ab
- = case Strict.break (≡ '"') bs of
+ = case BS.break (≡ '"') bs of
(x, y)
- | Strict.null y
+ | BS.null y
→ ab ⊕ b2ab x
| otherwise
- → go (Strict.tail y)
+ → go (BS.tail y)
(ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"")
- b2ab ∷ Strict.ByteString → AsciiBuilder
+ b2ab ∷ ByteString → AsciiBuilder
b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
-- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
)
where
unescape ∷ String → ByteString
- unescape = Strict.pack ∘ unEscapeString ∘ (plusToSpace <$>)
+ unescape = BS.pack ∘ unEscapeString ∘ (plusToSpace <$>)
plusToSpace ∷ Char → Char
plusToSpace '+' = ' '
plusToSpace c = c
+-- |>>> uriCIScheme "http://example.com/foo/bar"
+-- "http"
+uriCIScheme ∷ URI → Scheme
+{-# INLINE uriCIScheme #-}
+uriCIScheme = A.toCIAscii ∘ A.unsafeFromString ∘ uriScheme
+
+-- |>>> uriHost "http://example.com/foo/bar"
+-- "example.com"
+uriHost ∷ URI → Host
+{-# INLINE uriHost #-}
+uriHost = CI.mk ∘ T.pack ∘ uriRegName ∘ fromJust ∘ uriAuthority
+
-- |>>> uriPathSegments "http://example.com/foo/bar"
-- ["foo", "bar"]
-uriPathSegments ∷ URI → [ByteString]
+uriPathSegments ∷ URI → PathSegments
uriPathSegments uri
= let reqPathStr = uriPath uri
- reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
+ reqPath = [ unEscapeString x
+ | x ← splitBy (≡ '/') reqPathStr, (¬) (null x) ]
in
- Strict.pack <$> reqPath
+ BS.pack <$> reqPath
-- |>>> trim " ab c d "
-- "ab c d"
projects / Lucu.git / commitdiff