8 -- | Repository of the resources in httpd.
9 module Network.HTTP.Lucu.Resource.Tree
18 import Data.ByteString (ByteString)
19 import qualified Data.ByteString as BS
23 import qualified Data.Map as M
26 import Data.Monoid.Unicode
27 import Data.Sequence (Seq)
28 import Network.HTTP.Lucu.Resource.Internal
29 import Network.HTTP.Lucu.Utils
30 import Network.URI hiding (path)
32 import Prelude hiding (catch)
33 import Prelude.Unicode
35 -- |'FallbackHandler' is an extra resource handler for resources which
36 -- can't be statically located anywhere in the resource tree. The Lucu
37 -- httpd first searches for a resource in the tree, and then calls
38 -- fallback handlers to ask them for a resource. If all of the
39 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
40 type FallbackHandler = [ByteString] → IO (Maybe ResourceDef)
42 -- |'ResTree' is an opaque structure which is a map from resource path
44 newtype ResTree = ResTree ResNode -- root だから Map ではない
45 type ResSubtree = Map ByteString ResNode
46 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
48 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
51 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
52 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
56 -- Note that path components are always represented as octet streams
57 -- in this system. Lucu automatically decodes percent-encoded URIs but
58 -- has no involvement in character encodings such as UTF-8, since RFC
59 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
60 -- in \"http\" and \"https\" URI schemas.
61 mkResTree ∷ [ ([ByteString], ResourceDef) ] → ResTree
62 mkResTree = processRoot ∘ map (first canonicalisePath)
64 canonicalisePath ∷ [ByteString] → [ByteString]
65 canonicalisePath = filter ((¬) ∘ BS.null)
67 processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree
69 = let (roots, nonRoots) = partition (\(path, _) → null path) list
70 children = processNonRoot nonRoots
73 -- The root has no resources. Maybe there's one at
74 -- somewhere like "/foo".
75 ResTree (ResNode Nothing children)
77 -- There is a root resource.
78 let (_, def) = last roots
80 ResTree (ResNode (Just def) children)
82 processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree
84 = let subtree = M.fromList [(name, node name)
86 childNames = [name | (name:_, _) ← list]
87 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
90 -- No resources are defined
91 -- here. Maybe there's one at
92 -- somewhere below this node.
93 ResNode Nothing children
95 -- There is a resource here.
96 ResNode (Just $ last defs) children
97 children = processNonRoot [(path, def)
98 | (_:path, def) ← list]
102 findResource ∷ ResTree
105 → IO (Maybe ([ByteString], ResourceDef))
106 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
107 = do let path = splitPathInfo uri
108 hasGreedyRoot = maybe False resIsGreedy rootDefM
109 foundInTree = if hasGreedyRoot ∨ null path then
113 walkTree subtree path (∅)
114 if isJust foundInTree then
119 walkTree ∷ ResSubtree
122 → Maybe ([ByteString], ResourceDef)
125 = error "Internal error: should not reach here."
127 walkTree tree (name:[]) soFar
128 = do ResNode defM _ ← M.lookup name tree
130 return (toList $ soFar ⊳ name, def)
132 walkTree tree (x:xs) soFar
133 = do ResNode defM sub ← M.lookup x tree
135 Just (ResourceDef { resIsGreedy = True })
137 return (toList $ soFar ⊳ x, def)
138 _ → walkTree sub xs (soFar ⊳ x)
140 fallback ∷ [ByteString]
142 → IO (Maybe ([ByteString], ResourceDef))
143 fallback _ [] = return Nothing
144 fallback path (x:xs) = do m ← x path
146 Just def → return $ Just ([], def)
147 Nothing → fallback path xs