)
where
import Control.Arrow
-import Control.Applicative
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import Control.Monad
-import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Foldable
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
import Data.Monoid.Unicode
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
-import Network.HTTP.Lucu.Headers (fromHeaders)
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Interaction
+import Data.Sequence (Seq)
+import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
import System.IO
-- 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 = [Text] → IO (Maybe ResourceDef)
+type FallbackHandler = [ByteString] → IO (Maybe Resource)
-- |'ResTree' is an opaque structure which is a map from resource path
--- to 'ResourceDef'.
+-- to 'Resource'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
-type ResSubtree = Map Text ResNode
-data ResNode = ResNode (Maybe ResourceDef) ResSubtree
+type ResSubtree = Map ByteString ResNode
+data ResNode = ResNode (Maybe Resource) ResSubtree
-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
--
-- ]
-- @
--
--- Note that the request path in an incoming HTTP request is always
--- treated as an URI-encoded UTF-8 string.
-mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
+-- 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 ∷ [Text] → [Text]
- canonicalisePath = filter (≢ "")
+ canonicalisePath ∷ [ByteString] → [ByteString]
+ canonicalisePath = filter ((¬) ∘ BS.null)
- processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
+ processRoot ∷ [ ([ByteString], Resource) ] → ResTree
processRoot list
= let (roots, nonRoots) = partition (\(path, _) → null path) list
children = processNonRoot nonRoots
in
ResTree (ResNode (Just def) children)
- processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
+ processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
processNonRoot list
= let subtree = M.fromList [(name, node name)
| name ← childNames]
in
subtree
-findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
+findResource ∷ ResTree
+ → [FallbackHandler]
+ → URI
+ → IO (Maybe ([ByteString], Resource))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
= do let path = splitPathInfo uri
hasGreedyRoot = maybe False resIsGreedy rootDefM
do def ← rootDefM
return ([], def)
else
- walkTree subtree path []
+ walkTree subtree path (∅)
if isJust foundInTree then
return foundInTree
else
fallback path fbs
where
- walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
+ 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 (soFar ⧺ [name], def)
+ return (toList $ soFar ⊳ name, def)
walkTree tree (x:xs) soFar
= do ResNode defM sub ← M.lookup x tree
case defM of
- Just (ResourceDef { resIsGreedy = True })
+ Just (Resource { resIsGreedy = True })
→ do def ← defM
- return (soFar ⧺ [x], def)
- _ â\86\92 walkTree sub xs (soFar ⧺ [x])
+ return (toList $ soFar ⊳ x, def)
+ _ â\86\92 walkTree sub xs (soFar â\8a³ x)
- fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
+ fallback ∷ [ByteString]
+ → [FallbackHandler]
+ → IO (Maybe ([ByteString], Resource))
fallback _ [] = return Nothing
fallback path (x:xs) = do m ← x path
case m of