-- ]
-- @
mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
-mkResTree = processRoot . map (first canonicalisePath)
+mkResTree = processRoot ∘ map (first canonicalisePath)
where
canonicalisePath ∷ [Text] → [Text]
canonicalisePath = filter (≢ "")
processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
processRoot list
- = let (roots, nonRoots) = partition (\ (path, _) → path == []) list
+ = let (roots, nonRoots) = partition (\(path, _) → null path) list
children = processNonRoot nonRoots
in
if null roots then
= let subtree = M.fromList [(name, node name)
| name ← childNames]
childNames = [name | (name:_, _) ← list]
- node name = let defs = [def | (path, def) ← list, path == [name]]
+ node name = let defs = [def | (path, def) ← list, path ≡ [name]]
in
if null defs then
-- No resources are defined
in
subtree
-
findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
- = do let path = splitPathInfo uri
- haveGreedyRoot = case rootDefM of
- Just def → resIsGreedy def
- Nothing → False
- foundInTree = if haveGreedyRoot ∨ null path then
+ = do let path = splitPathInfo uri
+ hasGreedyRoot = maybe False resIsGreedy rootDefM
+ foundInTree = if hasGreedyRoot ∨ null path then
do def ← rootDefM
return ([], def)
else
= error "Internal error: should not reach here."
walkTree tree (name:[]) soFar
- = case M.lookup name tree of
- Nothing → Nothing
- Just (ResNode defM _) → do def ← defM
- return (soFar ⧺ [name], def)
+ = do ResNode defM _ ← M.lookup name tree
+ def ← defM
+ return (soFar ⧺ [name], def)
walkTree tree (x:xs) soFar
- = case M.lookup x tree of
- Nothing → Nothing
- Just (ResNode defM children) → case defM of
- Just (ResourceDef { resIsGreedy = True })
- → do def ← defM
- return (soFar ++ [x], def)
- _ → walkTree children xs (soFar ++ [x])
+ = do ResNode defM sub ← M.lookup x tree
+ case defM of
+ Just (ResourceDef { resIsGreedy = True })
+ → do def ← defM
+ return (soFar ⧺ [x], def)
+ _ → walkTree sub xs (soFar ⧺ [x])
fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
fallback _ [] = return Nothing
fallback path (x:xs) = do m ← x path
case m of
- Just def → return $! Just ([], def)
+ Just def → return $ Just ([], def)
Nothing → fallback path xs
runResource ∷ ResourceDef → Interaction → IO ThreadId
runResource (ResourceDef {..}) itr@(Interaction {..})
- = fork $ ( runRes ( do req ← getRequest
- fromMaybe notAllowed $ rsrc req
- driftTo Done
- ) itr
- )
- `catch`
- processException
+ = fork $ run `catch` processException
where
fork ∷ IO () → IO ThreadId
fork | resUsesNativeThread = forkOS
| otherwise = forkIO
+
+ run ∷ IO ()
+ run = flip runRes itr $
+ do req ← getRequest
+ fromMaybe notAllowed $ rsrc req
+ driftTo Done
rsrc ∷ Request → Maybe (Resource ())
rsrc req
methods ∷ Maybe a → [Ascii] → [Ascii]
methods m xs
- = case m of
- Just _ → xs
- Nothing → []
+ | isJust m = xs
+ | otherwise = []
toAbortion ∷ SomeException → Abortion
toAbortion e
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
state ← atomically $ readTVar itrState
- reqM ← atomically $ readTVar itrRequest
res ← atomically $ readTVar itrResponse
if state ≤ DecidingHeader then
flip runRes itr $
do setStatus $ aboStatus abo
mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
- output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo
- else
+ output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
+ else
when (cnfDumpTooLateAbortionToStderr itrConfig)
- $ hPutStrLn stderr $ show abo
-
+ $ hPutStrLn stderr $ show abo
runRes (driftTo Done) itr