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 Data.Sequence.Unicode hiding ((∅))
29 import Network.HTTP.Lucu.Resource.Internal
30 import Network.HTTP.Lucu.Utils
31 import Network.URI hiding (path)
33 import Prelude hiding (catch)
34 import Prelude.Unicode
36 -- |'FallbackHandler' is an extra resource handler for resources which
37 -- can't be statically located anywhere in the resource tree. The Lucu
38 -- httpd first searches for a resource in the tree, and then calls
39 -- fallback handlers to ask them for a resource. If all of the
40 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
41 type FallbackHandler = [ByteString] → IO (Maybe ResourceDef)
43 -- |'ResTree' is an opaque structure which is a map from resource path
45 newtype ResTree = ResTree ResNode -- root だから Map ではない
46 type ResSubtree = Map ByteString ResNode
47 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
49 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
52 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
53 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
57 -- Note that path components are always represented as octet streams
58 -- in this system. Lucu automatically decodes percent-encoded URIs but
59 -- has no involvement in character encodings such as UTF-8, since RFC
60 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
61 -- in \"http\" and \"https\" URI schemas.
62 mkResTree ∷ [ ([ByteString], ResourceDef) ] → ResTree
63 mkResTree = processRoot ∘ map (first canonicalisePath)
65 canonicalisePath ∷ [ByteString] → [ByteString]
66 canonicalisePath = filter ((¬) ∘ BS.null)
68 processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree
70 = let (roots, nonRoots) = partition (\(path, _) → null path) list
71 children = processNonRoot nonRoots
74 -- The root has no resources. Maybe there's one at
75 -- somewhere like "/foo".
76 ResTree (ResNode Nothing children)
78 -- There is a root resource.
79 let (_, def) = last roots
81 ResTree (ResNode (Just def) children)
83 processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree
85 = let subtree = M.fromList [(name, node name)
87 childNames = [name | (name:_, _) ← list]
88 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
91 -- No resources are defined
92 -- here. Maybe there's one at
93 -- somewhere below this node.
94 ResNode Nothing children
96 -- There is a resource here.
97 ResNode (Just $ last defs) children
98 children = processNonRoot [(path, def)
99 | (_:path, def) ← list]
103 findResource ∷ ResTree
106 → IO (Maybe ([ByteString], ResourceDef))
107 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
108 = do let path = splitPathInfo uri
109 hasGreedyRoot = maybe False resIsGreedy rootDefM
110 foundInTree = if hasGreedyRoot ∨ null path then
114 walkTree subtree path (∅)
115 if isJust foundInTree then
120 walkTree ∷ ResSubtree
123 → Maybe ([ByteString], ResourceDef)
126 = error "Internal error: should not reach here."
128 walkTree tree (name:[]) soFar
129 = do ResNode defM _ ← M.lookup name tree
131 return (toList $ soFar ⊳ name, def)
133 walkTree tree (x:xs) soFar
134 = do ResNode defM sub ← M.lookup x tree
136 Just (ResourceDef { resIsGreedy = True })
138 return (toList $ soFar ⊳ x, def)
139 _ → walkTree sub xs (soFar ⊳ x)
141 fallback ∷ [ByteString]
143 → IO (Maybe ([ByteString], ResourceDef))
144 fallback _ [] = return Nothing
145 fallback path (x:xs) = do m ← x path
147 Just def → return $ Just ([], def)
148 Nothing → fallback path xs