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
148 -- Note that the request path in an incoming HTTP request is always
149 -- treated as an URI-encoded UTF-8 string.
150 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
151 mkResTree = processRoot ∘ map (first canonicalisePath)
153 canonicalisePath ∷ [Text] → [Text]
154 canonicalisePath = filter (≢ "")
156 processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
158 = let (roots, nonRoots) = partition (\(path, _) → null path) list
159 children = processNonRoot nonRoots
162 -- The root has no resources. Maybe there's one at
163 -- somewhere like "/foo".
164 ResTree (ResNode Nothing children)
166 -- There is a root resource.
167 let (_, def) = last roots
169 ResTree (ResNode (Just def) children)
171 processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
173 = let subtree = M.fromList [(name, node name)
175 childNames = [name | (name:_, _) ← list]
176 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
179 -- No resources are defined
180 -- here. Maybe there's one at
181 -- somewhere below this node.
182 ResNode Nothing children
184 -- There is a resource here.
185 ResNode (Just $ last defs) children
186 children = processNonRoot [(path, def)
187 | (_:path, def) ← list]
191 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
192 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
193 = do let path = splitPathInfo uri
194 hasGreedyRoot = maybe False resIsGreedy rootDefM
195 foundInTree = if hasGreedyRoot ∨ 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 = do ResNode defM _ ← M.lookup name tree
213 return (soFar ⧺ [name], def)
215 walkTree tree (x:xs) soFar
216 = do ResNode defM sub ← M.lookup x tree
218 Just (ResourceDef { resIsGreedy = True })
220 return (soFar ⧺ [x], def)
221 _ → walkTree sub xs (soFar ⧺ [x])
223 fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
224 fallback _ [] = return Nothing
225 fallback path (x:xs) = do m ← x path
227 Just def → return $ Just ([], def)
228 Nothing → fallback path xs
231 runResource ∷ ResourceDef → Interaction → IO ThreadId
232 runResource (ResourceDef {..}) itr@(Interaction {..})
233 = fork $ run `catch` processException
235 fork ∷ IO () → IO ThreadId
236 fork | resUsesNativeThread = forkOS
240 run = flip runRes itr $
242 fromMaybe notAllowed $ rsrc req
245 rsrc ∷ Request → Maybe (Resource ())
247 = case reqMethod req of
249 HEAD → case resHead of
255 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
257 notAllowed ∷ Resource ()
259 = setStatus MethodNotAllowed
261 (setHeader "Allow" $ A.fromAsciiBuilder
263 $ map A.toAsciiBuilder allowedMethods)
265 allowedMethods ∷ [Ascii]
266 allowedMethods = nub $ concat [ methods resGet ["GET"]
267 , methods resHead ["GET", "HEAD"]
268 , methods resPost ["POST"]
269 , methods resPut ["PUT"]
270 , methods resDelete ["DELETE"]
273 methods ∷ Maybe a → [Ascii] → [Ascii]
278 toAbortion ∷ SomeException → Abortion
280 = case fromException e of
281 Just abortion → abortion
282 Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
284 processException ∷ SomeException → IO ()
286 = do let abo = toAbortion exc
287 -- まだ DecidingHeader 以前の状態だったら、この途中終了
288 -- を應答に反映させる餘地がある。さうでなければ stderr
290 state ← atomically $ readTVar itrState
291 res ← atomically $ readTVar itrResponse
292 if state ≤ DecidingHeader then
294 do setStatus $ aboStatus abo
295 mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
296 output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
298 do when (cnfDumpTooLateAbortionToStderr itrConfig)
299 $ hPutStrLn stderr $ show abo
300 atomically $ writeTVar itrWillClose True
301 runRes (driftTo Done) itr