6 {-# OPTIONS_HADDOCK prune #-}
8 -- | Repository of the resources in httpd.
9 module Network.HTTP.Lucu.Resource.Tree
23 import Control.Applicative
24 import Data.Ascii (Ascii)
25 import qualified Data.Ascii as A
26 import Control.Concurrent
27 import Control.Concurrent.STM
28 import Control.Exception
30 import Data.Text (Text)
31 import qualified Data.Text as T
32 import qualified Data.Text.Lazy.Encoding as LT
34 import qualified Data.Map as M
37 import Data.Monoid.Unicode
38 import Network.HTTP.Lucu.Abortion
39 import Network.HTTP.Lucu.Config
40 import Network.HTTP.Lucu.Headers (fromHeaders)
41 import Network.HTTP.Lucu.Request
42 import Network.HTTP.Lucu.Resource
43 import Network.HTTP.Lucu.Response
44 import Network.HTTP.Lucu.Interaction
45 import Network.HTTP.Lucu.Utils
46 import Network.URI hiding (path)
48 import Prelude hiding (catch)
49 import Prelude.Unicode
52 -- |'FallbackHandler' is an extra resource handler for resources which
53 -- can't be statically located anywhere in the resource tree. The Lucu
54 -- httpd first searches for a resource in the tree, and then calls
55 -- fallback handlers to ask them for a resource. If all of the
56 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
57 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
60 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
61 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
62 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
65 -- | 'ResourceDef' is basically a set of 'Resource' monads for each
67 data ResourceDef = ResourceDef {
68 -- |Whether to run a 'Resource' on a native thread (spawned by
69 -- 'forkOS') or to run it on a user thread (spanwed by
70 -- 'forkIO'). Generally you don't need to set this field to
72 resUsesNativeThread ∷ !Bool
73 -- | Whether to be greedy or not.
75 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
76 -- greedy resource at \/aaa\/bbb, it is always chosen even if
77 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
78 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
79 -- resources are like CGI scripts.
81 -- | A 'Resource' to be run when a GET request comes for the
82 -- resource path. If 'resGet' is Nothing, the system responds
83 -- \"405 Method Not Allowed\" for GET requests.
85 -- It also runs for HEAD request if the 'resHead' is Nothing. In
86 -- this case 'output' and such like don't actually write a
88 , resGet ∷ !(Maybe (Resource ()))
89 -- | A 'Resource' to be run when a HEAD request comes for the
90 -- resource path. If 'resHead' is Nothing, the system runs
91 -- 'resGet' instead. If 'resGet' is also Nothing, the system
92 -- responds \"405 Method Not Allowed\" for HEAD requests.
93 , resHead ∷ !(Maybe (Resource ()))
94 -- | A 'Resource' to be run when a POST request comes for the
95 -- resource path. If 'resPost' is Nothing, the system responds
96 -- \"405 Method Not Allowed\" for POST requests.
97 , resPost ∷ !(Maybe (Resource ()))
98 -- | A 'Resource' to be run when a PUT request comes for the
99 -- resource path. If 'resPut' is Nothing, the system responds
100 -- \"405 Method Not Allowed\" for PUT requests.
101 , resPut ∷ !(Maybe (Resource ()))
102 -- | A 'Resource' to be run when a DELETE request comes for the
103 -- resource path. If 'resDelete' is Nothing, the system responds
104 -- \"405 Method Not Allowed\" for DELETE requests.
105 , resDelete ∷ !(Maybe (Resource ()))
108 -- |'emptyResource' is a resource definition with no actual
109 -- handlers. You can construct a 'ResourceDef' by selectively
110 -- overriding 'emptyResource'. It is defined as follows:
113 -- emptyResource = ResourceDef {
114 -- resUsesNativeThread = False
115 -- , resIsGreedy = False
116 -- , resGet = Nothing
117 -- , resHead = Nothing
118 -- , resPost = Nothing
119 -- , resPut = Nothing
120 -- , resDelete = Nothing
123 emptyResource ∷ ResourceDef
124 emptyResource = ResourceDef {
125 resUsesNativeThread = False
126 , resIsGreedy = False
131 , resDelete = Nothing
134 -- |'ResTree' is an opaque structure which is a map from resource path
136 newtype ResTree = ResTree ResNode -- root だから Map ではない
137 type ResSubtree = Map Text ResNode
138 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
140 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
143 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
144 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
147 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
148 mkResTree = processRoot . map (first canonicalisePath)
150 canonicalisePath ∷ [Text] → [Text]
151 canonicalisePath = filter (≢ "")
153 processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
155 = let (roots, nonRoots) = partition (\ (path, _) → path == []) list
156 children = processNonRoot nonRoots
159 -- The root has no resources. Maybe there's one at
160 -- somewhere like "/foo".
161 ResTree (ResNode Nothing children)
163 -- There is a root resource.
164 let (_, def) = last roots
166 ResTree (ResNode (Just def) children)
168 processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
170 = let subtree = M.fromList [(name, node name)
172 childNames = [name | (name:_, _) ← list]
173 node name = let defs = [def | (path, def) ← list, path == [name]]
176 -- No resources are defined
177 -- here. Maybe there's one at
178 -- somewhere below this node.
179 ResNode Nothing children
181 -- There is a resource here.
182 ResNode (Just $ last defs) children
183 children = processNonRoot [(path, def)
184 | (_:path, def) ← list]
189 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
190 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
191 = do let path = splitPathInfo uri
192 haveGreedyRoot = case rootDefM of
193 Just def → resIsGreedy def
195 foundInTree = if haveGreedyRoot ∨ null path then
199 walkTree subtree path []
200 if isJust foundInTree then
205 walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
208 = error "Internal error: should not reach here."
210 walkTree tree (name:[]) soFar
211 = case M.lookup name tree of
213 Just (ResNode defM _) → do def ← defM
214 return (soFar ⧺ [name], def)
216 walkTree tree (x:xs) soFar
217 = case M.lookup x tree of
219 Just (ResNode defM children) → case defM of
220 Just (ResourceDef { resIsGreedy = True })
222 return (soFar ++ [x], def)
223 _ → walkTree children xs (soFar ++ [x])
225 fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
226 fallback _ [] = return Nothing
227 fallback path (x:xs) = do m ← x path
229 Just def → return $! Just ([], def)
230 Nothing → fallback path xs
233 runResource ∷ ResourceDef → Interaction → IO ThreadId
235 = def `seq` itr `seq`
237 $! catch ( runRes ( do req ← getRequest
238 fromMaybe notAllowed $ rsrc req
244 fork ∷ IO () → IO ThreadId
245 fork = if resUsesNativeThread def
249 rsrc ∷ Request → Maybe (Resource ())
251 = case reqMethod req of
253 HEAD → case resHead def of
258 DELETE → resDelete def
261 notAllowed ∷ Resource ()
263 = setStatus MethodNotAllowed
265 (setHeader "Allow" $ A.fromAsciiBuilder
267 $ map A.toAsciiBuilder allowedMethods)
269 allowedMethods ∷ [Ascii]
270 allowedMethods = nub $ concat [ methods resGet ["GET"]
271 , methods resHead ["GET", "HEAD"]
272 , methods resPost ["POST"]
273 , methods resPut ["PUT"]
274 , methods resDelete ["DELETE"]
277 methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii]
278 methods f xs = case f def of
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
292 -- まだ DecidingHeader 以前の状態だったら、この途中終了
293 -- を應答に反映させる餘地がある。さうでなければ stderr
295 state ← atomically $ readItr itrState id itr
296 reqM ← atomically $ readItr itrRequest id itr
297 res ← atomically $ readItr itrResponse id itr
298 if state ≤ DecidingHeader then
300 $ do setStatus $ aboStatus abo
301 mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
302 output $ LT.encodeUtf8 $ abortPage conf reqM res abo
304 when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
305 $ hPutStrLn stderr $ show abo
307 flip runRes itr $ driftTo Done