, RecordWildCards
, UnicodeSyntax
#-}
-{-# OPTIONS_HADDOCK prune #-}
-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
, runResource
)
where
-import Control.Arrow
+import Control.Arrow
import Control.Applicative
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as LT
-import Data.List
+import Data.List
import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Maybe
+import Data.Map (Map)
+import Data.Maybe
import Data.Monoid.Unicode
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers (fromHeaders)
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Utils
-import Network.URI hiding (path)
-import System.IO
-import Prelude hiding (catch)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers (fromHeaders)
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Utils
+import Network.URI hiding (path)
+import System.IO
+import Prelude hiding (catch)
import Prelude.Unicode
-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
-- ]
-- @
+--
+-- Note that the request path in an incoming HTTP request is always
+-- treated as an URI-encoded UTF-8 string.
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
+ setHeader "Content-Type" defaultPageContentType
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