-- 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 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 ByteString ResNode
-data ResNode = ResNode (Maybe ResourceDef) ResSubtree
+data ResNode = ResNode (Maybe Resource) ResSubtree
-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
--
-- 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], ResourceDef) ] → ResTree
+mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
mkResTree = processRoot ∘ map (first canonicalisePath)
where
canonicalisePath ∷ [ByteString] → [ByteString]
canonicalisePath = filter ((¬) ∘ BS.null)
- processRoot ∷ [ ([ByteString], 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 ∷ [ ([ByteString], ResourceDef) ] → ResSubtree
+ processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
processNonRoot list
= let subtree = M.fromList [(name, node name)
| name ← childNames]
findResource ∷ ResTree
→ [FallbackHandler]
→ URI
- → IO (Maybe ([ByteString], ResourceDef))
+ → IO (Maybe ([ByteString], Resource))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
= do let path = splitPathInfo uri
hasGreedyRoot = maybe False resIsGreedy rootDefM
walkTree ∷ ResSubtree
→ [ByteString]
→ Seq ByteString
- → Maybe ([ByteString], ResourceDef)
+ → Maybe ([ByteString], Resource)
walkTree _ [] _
= error "Internal error: should not reach here."
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 (toList $ soFar ⊳ x, def)
_ → walkTree sub xs (soFar ⊳ x)
fallback ∷ [ByteString]
→ [FallbackHandler]
- → IO (Maybe ([ByteString], ResourceDef))
+ → IO (Maybe ([ByteString], Resource))
fallback _ [] = return Nothing
fallback path (x:xs) = do m ← x path
case m of