7 {-# OPTIONS_HADDOCK prune #-}
9 -- | Repository of the resources in httpd.
10 module Network.HTTP.Lucu.Resource.Tree
24 import Control.Applicative
25 import Data.Ascii (Ascii)
26 import qualified Data.Ascii as A
27 import Control.Concurrent
28 import Control.Concurrent.STM
29 import Control.Exception
31 import Data.Text (Text)
32 import qualified Data.Text as T
33 import qualified Data.Text.Lazy.Encoding as LT
35 import qualified Data.Map as M
38 import Data.Monoid.Unicode
39 import Network.HTTP.Lucu.Abortion
40 import Network.HTTP.Lucu.Config
41 import Network.HTTP.Lucu.Headers (fromHeaders)
42 import Network.HTTP.Lucu.Request
43 import Network.HTTP.Lucu.Resource
44 import Network.HTTP.Lucu.Response
45 import Network.HTTP.Lucu.Interaction
46 import Network.HTTP.Lucu.Utils
47 import Network.URI hiding (path)
49 import Prelude hiding (catch)
50 import Prelude.Unicode
53 -- |'FallbackHandler' is an extra resource handler for resources which
54 -- can't be statically located anywhere in the resource tree. The Lucu
55 -- httpd first searches for a resource in the tree, and then calls
56 -- fallback handlers to ask them for a resource. If all of the
57 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
58 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
61 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
62 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
63 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
66 -- | 'ResourceDef' is basically a set of 'Resource' monads for each
68 data ResourceDef = ResourceDef {
69 -- |Whether to run a 'Resource' on a native thread (spawned by
70 -- 'forkOS') or to run it on a user thread (spanwed by
71 -- 'forkIO'). Generally you don't need to set this field to
73 resUsesNativeThread ∷ !Bool
74 -- | Whether to be greedy or not.
76 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
77 -- greedy resource at \/aaa\/bbb, it is always chosen even if
78 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
79 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
80 -- resources are like CGI scripts.
82 -- | A 'Resource' to be run when a GET request comes for the
83 -- resource path. If 'resGet' is Nothing, the system responds
84 -- \"405 Method Not Allowed\" for GET requests.
86 -- It also runs for HEAD request if the 'resHead' is Nothing. In
87 -- this case 'output' and such like don't actually write a
89 , resGet ∷ !(Maybe (Resource ()))
90 -- | A 'Resource' to be run when a HEAD request comes for the
91 -- resource path. If 'resHead' is Nothing, the system runs
92 -- 'resGet' instead. If 'resGet' is also Nothing, the system
93 -- responds \"405 Method Not Allowed\" for HEAD requests.
94 , resHead ∷ !(Maybe (Resource ()))
95 -- | A 'Resource' to be run when a POST request comes for the
96 -- resource path. If 'resPost' is Nothing, the system responds
97 -- \"405 Method Not Allowed\" for POST requests.
98 , resPost ∷ !(Maybe (Resource ()))
99 -- | A 'Resource' to be run when a PUT request comes for the
100 -- resource path. If 'resPut' is Nothing, the system responds
101 -- \"405 Method Not Allowed\" for PUT requests.
102 , resPut ∷ !(Maybe (Resource ()))
103 -- | A 'Resource' to be run when a DELETE request comes for the
104 -- resource path. If 'resDelete' is Nothing, the system responds
105 -- \"405 Method Not Allowed\" for DELETE requests.
106 , resDelete ∷ !(Maybe (Resource ()))
109 -- |'emptyResource' is a resource definition with no actual
110 -- handlers. You can construct a 'ResourceDef' by selectively
111 -- overriding 'emptyResource'. It is defined as follows:
114 -- emptyResource = ResourceDef {
115 -- resUsesNativeThread = False
116 -- , resIsGreedy = False
117 -- , resGet = Nothing
118 -- , resHead = Nothing
119 -- , resPost = Nothing
120 -- , resPut = Nothing
121 -- , resDelete = Nothing
124 emptyResource ∷ ResourceDef
125 emptyResource = ResourceDef {
126 resUsesNativeThread = False
127 , resIsGreedy = False
132 , resDelete = Nothing
135 -- |'ResTree' is an opaque structure which is a map from resource path
137 newtype ResTree = ResTree ResNode -- root だから Map ではない
138 type ResSubtree = Map Text ResNode
139 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
141 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
144 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
145 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
148 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
149 mkResTree = processRoot . map (first canonicalisePath)
151 canonicalisePath ∷ [Text] → [Text]
152 canonicalisePath = filter (≢ "")
154 processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
156 = let (roots, nonRoots) = partition (\ (path, _) → path == []) list
157 children = processNonRoot nonRoots
160 -- The root has no resources. Maybe there's one at
161 -- somewhere like "/foo".
162 ResTree (ResNode Nothing children)
164 -- There is a root resource.
165 let (_, def) = last roots
167 ResTree (ResNode (Just def) children)
169 processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
171 = let subtree = M.fromList [(name, node name)
173 childNames = [name | (name:_, _) ← list]
174 node name = let defs = [def | (path, def) ← list, path == [name]]
177 -- No resources are defined
178 -- here. Maybe there's one at
179 -- somewhere below this node.
180 ResNode Nothing children
182 -- There is a resource here.
183 ResNode (Just $ last defs) children
184 children = processNonRoot [(path, def)
185 | (_:path, def) ← list]
190 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
191 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
192 = do let path = splitPathInfo uri
193 haveGreedyRoot = case rootDefM of
194 Just def → resIsGreedy def
196 foundInTree = if haveGreedyRoot ∨ null path then
200 walkTree subtree path []
201 if isJust foundInTree then
206 walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
209 = error "Internal error: should not reach here."
211 walkTree tree (name:[]) soFar
212 = case M.lookup name tree of
214 Just (ResNode defM _) → do def ← defM
215 return (soFar ⧺ [name], def)
217 walkTree tree (x:xs) soFar
218 = case M.lookup x tree of
220 Just (ResNode defM children) → case defM of
221 Just (ResourceDef { resIsGreedy = True })
223 return (soFar ++ [x], def)
224 _ → walkTree children xs (soFar ++ [x])
226 fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
227 fallback _ [] = return Nothing
228 fallback path (x:xs) = do m ← x path
230 Just def → return $! Just ([], def)
231 Nothing → fallback path xs
234 runResource ∷ ResourceDef → Interaction → IO ThreadId
235 runResource (ResourceDef {..}) itr@(Interaction {..})
236 = fork $ ( runRes ( do req ← getRequest
237 fromMaybe notAllowed $ rsrc req
244 fork ∷ IO () → IO ThreadId
245 fork | resUsesNativeThread = forkOS
248 rsrc ∷ Request → Maybe (Resource ())
250 = case reqMethod req of
252 HEAD → case resHead of
258 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
260 notAllowed ∷ Resource ()
262 = setStatus MethodNotAllowed
264 (setHeader "Allow" $ A.fromAsciiBuilder
266 $ map A.toAsciiBuilder allowedMethods)
268 allowedMethods ∷ [Ascii]
269 allowedMethods = nub $ concat [ methods resGet ["GET"]
270 , methods resHead ["GET", "HEAD"]
271 , methods resPost ["POST"]
272 , methods resPut ["PUT"]
273 , methods resDelete ["DELETE"]
276 methods ∷ Maybe a → [Ascii] → [Ascii]
282 toAbortion ∷ SomeException → Abortion
284 = case fromException e of
285 Just abortion → abortion
286 Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
288 processException ∷ SomeException → IO ()
290 = do let abo = toAbortion exc
291 -- まだ DecidingHeader 以前の状態だったら、この途中終了
292 -- を應答に反映させる餘地がある。さうでなければ stderr
294 state ← atomically $ readTVar itrState
295 reqM ← atomically $ readTVar itrRequest
296 res ← atomically $ readTVar itrResponse
297 if state ≤ DecidingHeader then
299 do setStatus $ aboStatus abo
300 mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
301 output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo
303 when (cnfDumpTooLateAbortionToStderr itrConfig)
304 $ hPutStrLn stderr $ show abo
306 runRes (driftTo Done) itr