module Network.HTTP.Lucu.Resource.Tree
( ResourceDef(..)
, ResTree
, FallbackHandler
, mkResTree
, findResource
, runResource
)
where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as C8
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers (emptyHeaders, 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 System.IO.Error hiding (catch)
import Prelude hiding (catch)
type FallbackHandler = [String] -> IO (Maybe ResourceDef)
data ResourceDef = ResourceDef {
resUsesNativeThread :: !Bool
, resIsGreedy :: !Bool
, resGet :: !(Maybe (Resource ()))
, resHead :: !(Maybe (Resource ()))
, resPost :: !(Maybe (Resource ()))
, resPut :: !(Maybe (Resource ()))
, resDelete :: !(Maybe (Resource ()))
}
newtype ResTree = ResTree ResNode
type ResSubtree = Map String ResNode
data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
mkResTree :: [ ([String], ResourceDef) ] -> ResTree
mkResTree xs = xs `seq` processRoot xs
where
processRoot :: [ ([String], ResourceDef) ] -> ResTree
processRoot list
= let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
children = processNonRoot nonRoots
in
if null roots then
ResTree (ResNode Nothing children)
else
let (_, def) = last roots
in
ResTree (ResNode (Just def) children)
processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
processNonRoot list
= let subtree = M.fromList [(name, node name)
| name <- childNames]
childNames = [name | (name:_, _) <- list]
node name = let defs = [def | (path, def) <- list, path == [name]]
in
if null defs then
ResNode Nothing children
else
ResNode (Just $ last defs) children
children = processNonRoot [(path, def)
| (_:path, def) <- list, not (null path)]
in
subtree
findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
= do let pathStr = uriPath uri
path = [x | x <- splitBy (== '/') pathStr, x /= ""]
foundInTree = if null path then
do def <- rootDefM
return (path, def)
else
walkTree subtree path []
if isJust foundInTree then
return foundInTree
else
fallback path fbs
where
walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
walkTree _ [] _
= 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)
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])
fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
fallback _ [] = return Nothing
fallback path (x:xs) = do m <- x path
case m of
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
)
$ \ exc -> processException exc
where
fork :: IO () -> IO ThreadId
fork = if (resUsesNativeThread def)
then forkOS
else forkIO
rsrc :: Request -> Maybe (Resource ())
rsrc req
= case reqMethod req of
GET -> resGet def
HEAD -> case resHead def of
Just r -> Just r
Nothing -> resGet def
POST -> resPost def
PUT -> resPut def
DELETE -> resDelete def
_ -> undefined
notAllowed :: Resource ()
notAllowed = do setStatus MethodNotAllowed
setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
allowedMethods :: [String]
allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
, methods resHead ["GET", "HEAD"]
, methods resPost ["POST"]
, methods resPut ["PUT"]
, methods resDelete ["DELETE"]
]
methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
methods f xs = case f def of
Just _ -> xs
Nothing -> []
toAbortion :: SomeException -> Abortion
toAbortion e = case fromException e of
Just abortion -> abortion
Nothing -> Abortion InternalServerError emptyHeaders (Just (show e))
processException :: SomeException -> IO ()
processException exc
= do let abo = toAbortion exc
conf = itrConfig itr
state <- atomically $ readItr itr itrState id
reqM <- atomically $ readItr itr itrRequest id
res <- atomically $ readItr itr itrResponse id
if state <= DecidingHeader then
flip runRes itr
$ do setStatus $ aboStatus abo
mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo
output $ abortPage conf reqM res abo
else
when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
$ hPutStrLn stderr $ show abo
flip runRes itr $ driftTo Done
formatIOE :: IOError -> String
formatIOE ioE = if isUserError ioE then
ioeGetErrorString ioE
else
show ioE