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, _) → null 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]
188 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
189 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
190 = do let path = splitPathInfo uri
191 hasGreedyRoot = maybe False resIsGreedy rootDefM
192 foundInTree = if hasGreedyRoot ∨ null path then
196 walkTree subtree path []
197 if isJust foundInTree then
202 walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
205 = error "Internal error: should not reach here."
207 walkTree tree (name:[]) soFar
208 = do ResNode defM _ ← M.lookup name tree
210 return (soFar ⧺ [name], def)
212 walkTree tree (x:xs) soFar
213 = do ResNode defM sub ← M.lookup x tree
215 Just (ResourceDef { resIsGreedy = True })
217 return (soFar ⧺ [x], def)
218 _ → walkTree sub xs (soFar ⧺ [x])
220 fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
221 fallback _ [] = return Nothing
222 fallback path (x:xs) = do m ← x path
224 Just def → return $ Just ([], def)
225 Nothing → fallback path xs
228 runResource ∷ ResourceDef → Interaction → IO ThreadId
229 runResource (ResourceDef {..}) itr@(Interaction {..})
230 = fork $ run `catch` processException
232 fork ∷ IO () → IO ThreadId
233 fork | resUsesNativeThread = forkOS
237 run = flip runRes itr $
239 fromMaybe notAllowed $ rsrc req
242 rsrc ∷ Request → Maybe (Resource ())
244 = case reqMethod req of
246 HEAD → case resHead of
252 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
254 notAllowed ∷ Resource ()
256 = setStatus MethodNotAllowed
258 (setHeader "Allow" $ A.fromAsciiBuilder
260 $ map A.toAsciiBuilder allowedMethods)
262 allowedMethods ∷ [Ascii]
263 allowedMethods = nub $ concat [ methods resGet ["GET"]
264 , methods resHead ["GET", "HEAD"]
265 , methods resPost ["POST"]
266 , methods resPut ["PUT"]
267 , methods resDelete ["DELETE"]
270 methods ∷ Maybe a → [Ascii] → [Ascii]
275 toAbortion ∷ SomeException → Abortion
277 = case fromException e of
278 Just abortion → abortion
279 Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
281 processException ∷ SomeException → IO ()
283 = do let abo = toAbortion exc
284 -- まだ DecidingHeader 以前の状態だったら、この途中終了
285 -- を應答に反映させる餘地がある。さうでなければ stderr
287 state ← atomically $ readTVar itrState
288 res ← atomically $ readTVar itrResponse
289 if state ≤ DecidingHeader then
291 do setStatus $ aboStatus abo
292 mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
293 output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
295 when (cnfDumpTooLateAbortionToStderr itrConfig)
296 $ hPutStrLn stderr $ show abo
297 runRes (driftTo Done) itr