8 -- | Repository of the resources in httpd.
9 module Network.HTTP.Lucu.Resource.Tree
18 import Control.Applicative
19 import Data.Ascii (Ascii)
20 import qualified Data.Ascii as A
21 import Control.Concurrent
22 import Control.Concurrent.STM
23 import Control.Exception
25 import Data.Text (Text)
26 import qualified Data.Text as T
28 import qualified Data.Map as M
31 import Data.Monoid.Unicode
32 import Network.HTTP.Lucu.Abortion
33 import Network.HTTP.Lucu.Config
34 import Network.HTTP.Lucu.DefaultPage
35 import Network.HTTP.Lucu.Headers (fromHeaders)
36 import Network.HTTP.Lucu.Request
37 import Network.HTTP.Lucu.Resource
38 import Network.HTTP.Lucu.Response
39 import Network.HTTP.Lucu.Interaction
40 import Network.HTTP.Lucu.Utils
41 import Network.URI hiding (path)
43 import Prelude hiding (catch)
44 import Prelude.Unicode
46 -- |'FallbackHandler' is an extra resource handler for resources which
47 -- can't be statically located anywhere in the resource tree. The Lucu
48 -- httpd first searches for a resource in the tree, and then calls
49 -- fallback handlers to ask them for a resource. If all of the
50 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
51 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
53 -- |'ResTree' is an opaque structure which is a map from resource path
55 newtype ResTree = ResTree ResNode -- root だから Map ではない
56 type ResSubtree = Map Text ResNode
57 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
59 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
62 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
63 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
67 -- Note that the request path in an incoming HTTP request is always
68 -- treated as an URI-encoded UTF-8 string.
69 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
70 mkResTree = processRoot ∘ map (first canonicalisePath)
72 canonicalisePath ∷ [Text] → [Text]
73 canonicalisePath = filter (≢ "")
75 processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
77 = let (roots, nonRoots) = partition (\(path, _) → null path) list
78 children = processNonRoot nonRoots
81 -- The root has no resources. Maybe there's one at
82 -- somewhere like "/foo".
83 ResTree (ResNode Nothing children)
85 -- There is a root resource.
86 let (_, def) = last roots
88 ResTree (ResNode (Just def) children)
90 processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
92 = let subtree = M.fromList [(name, node name)
94 childNames = [name | (name:_, _) ← list]
95 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
98 -- No resources are defined
99 -- here. Maybe there's one at
100 -- somewhere below this node.
101 ResNode Nothing children
103 -- There is a resource here.
104 ResNode (Just $ last defs) children
105 children = processNonRoot [(path, def)
106 | (_:path, def) ← list]
110 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
111 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
112 = do let path = splitPathInfo uri
113 hasGreedyRoot = maybe False resIsGreedy rootDefM
114 foundInTree = if hasGreedyRoot ∨ null path then
118 walkTree subtree path []
119 if isJust foundInTree then
124 walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
127 = error "Internal error: should not reach here."
129 walkTree tree (name:[]) soFar
130 = do ResNode defM _ ← M.lookup name tree
132 return (soFar ⧺ [name], def)
134 walkTree tree (x:xs) soFar
135 = do ResNode defM sub ← M.lookup x tree
137 Just (ResourceDef { resIsGreedy = True })
139 return (soFar ⧺ [x], def)
140 _ → walkTree sub xs (soFar ⧺ [x])
142 fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], 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