{-# LANGUAGE
DoAndIfThenElse
, OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
-{-# OPTIONS_HADDOCK prune #-}
-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
-- ]
-- @
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 def itr
- = def `seq` itr `seq`
- fork
- $! catch ( runRes ( do req ← getRequest
- fromMaybe notAllowed $ rsrc req
- driftTo Done
- ) itr
- )
- processException
+runResource (ResourceDef {..}) itr@(Interaction {..})
+ = fork $ run `catch` processException
where
fork ∷ IO () → IO ThreadId
- fork = if resUsesNativeThread def
- then forkOS
- else forkIO
+ 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
= case reqMethod req of
- GET → resGet def
- HEAD → case resHead def of
+ GET → resGet
+ HEAD → case resHead of
Just r → Just r
- Nothing → resGet def
- POST → resPost def
- PUT → resPut def
- DELETE → resDelete def
- _ → undefined
+ Nothing → resGet
+ POST → resPost
+ PUT → resPut
+ DELETE → resDelete
+ _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
notAllowed ∷ Resource ()
notAllowed
, methods resDelete ["DELETE"]
]
- methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii]
- methods f xs = case f def of
- Just _ → xs
- Nothing → []
+ methods ∷ Maybe a → [Ascii] → [Ascii]
+ methods m xs
+ | isJust m = xs
+ | otherwise = []
toAbortion ∷ SomeException → Abortion
toAbortion e
processException ∷ SomeException → IO ()
processException exc
= do let abo = toAbortion exc
- conf = itrConfig itr
-- まだ DecidingHeader 以前の状態だったら、この途中終了
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
- state ← atomically $ readItr itrState itr
- reqM ← atomically $ readItr itrRequest itr
- res ← atomically $ readItr itrResponse itr
+ state ← atomically $ readTVar itrState
+ 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 conf reqM res abo
- else
- when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
- $ hPutStrLn stderr $ show abo
-
- flip runRes itr $ driftTo Done
+ flip runRes itr $
+ do setStatus $ aboStatus abo
+ mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
+ output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
+ else
+ when (cnfDumpTooLateAbortionToStderr itrConfig)
+ $ hPutStrLn stderr $ show abo
+ runRes (driftTo Done) itr
projects / Lucu.git / blobdiff