X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=3ac8fb9cc1560bc293c8a93e1a1945700c5c2119;hp=883cc149188a404f2007425cf88d6bcfc8a2b1d8;hb=c6b11025d1f81c668e9995e856b7bb34175230d3;hpb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 883cc14..3ac8fb9 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,16 +1,13 @@ module Network.HTTP.Lucu.Resource - ( ResourceDef(..) - , Resource - , ResTree - , mkResTree -- [ ([String], ResourceDef) ] -> ResTree - , findResource -- ResTree -> URI -> Maybe ResourceDef - , runResource -- ResourceDef -> Interaction -> IO ThreadId + ( Resource , getMethod -- Resource Method , getHeader -- String -> Resource (Maybe String) + , getAccept -- Resource [MIMEType] + , getContentType -- Resource (Maybe MIMEType) - , foundEntity -- Bool -> String -> ClockTime -> Resource () - , foundETag -- Bool -> String -> Resource () + , foundEntity -- ETag -> ClockTime -> Resource () + , foundETag -- ETag -> Resource () , foundTimeStamp -- ClockTime -> Resource () , foundNoEntity -- Maybe String -> Resource () @@ -23,26 +20,24 @@ module Network.HTTP.Lucu.Resource , setStatus -- StatusCode -> Resource () , setHeader -- String -> String -> Resource () , redirect -- StatusCode -> URI -> Resource () - , setETag -- Bool -> String -> Resource () + , setETag -- ETag -> Resource () , setLastModified -- ClockTime -> Resource () + , setContentType -- MIMEType -> Resource () , output -- String -> Resource () , outputChunk -- String -> Resource () , outputBS -- ByteString -> Resource () , outputChunkBS -- ByteString -> Resource () + + , driftTo -- InteractionState -> Resource () ) where -import Control.Concurrent import Control.Concurrent.STM -import Control.Exception import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Dynamic import Data.List -import qualified Data.Map as M -import Data.Map (Map) import Data.Maybe import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion @@ -57,174 +52,15 @@ import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.URI -import Prelude hiding (catch) -import System.IO -import System.IO.Error hiding (catch) import System.Time type Resource a = ReaderT Interaction IO a -{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ - れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず - /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視 - される。 -} -data ResourceDef = ResourceDef { - resUsesNativeThread :: Bool - , resIsGreedy :: Bool - , resGet :: Maybe (Resource ()) - , resHead :: Maybe (Resource ()) - , resPost :: Maybe (Resource ()) - , resPut :: Maybe (Resource ()) - , resDelete :: Maybe (Resource ()) - } -type ResTree = ResNode -- root だから Map ではない -type ResSubtree = Map String ResNode -data ResNode = ResNode (Maybe ResourceDef) ResSubtree - - -mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = processRoot list - where - processRoot :: [ ([String], ResourceDef) ] -> ResTree - processRoot list - = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list - children = processNonRoot nonRoots - in - if null roots then - -- / にリソースが定義されない。/foo とかにはあるかも。 - ResNode Nothing children - else - -- / がある。 - let (_, def) = last roots - in - 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 -> URI -> Maybe ResourceDef -findResource (ResNode rootDefM subtree) uri - = let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - in - if null path then - rootDefM - else - walkTree subtree path - where - walkTree :: ResSubtree -> [String] -> Maybe ResourceDef - - walkTree subtree (name:[]) - = case M.lookup name subtree of - Nothing -> Nothing - Just (ResNode defM _) -> defM - - walkTree subtree (x:xs) - = case M.lookup x subtree of - Nothing -> Nothing - Just (ResNode defM children) -> case defM of - Just (ResourceDef { resIsGreedy = True }) - -> defM - _ -> walkTree children xs - - -runResource :: ResourceDef -> Interaction -> IO ThreadId -runResource def itr - = fork - $ catch ( runReaderT ( do fromMaybe notAllowed rsrc - driftTo Done - ) itr - ) - $ \ exc -> processException (itrConfig itr) exc - where - fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) - then forkOS - else forkIO - - rsrc :: Maybe (Resource ()) - rsrc = case reqMethod $ fromJust $ itrRequest itr 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 - - notAllowed :: Resource () - notAllowed = do setStatus MethodNotAllowed - setHeader "Allow" $ 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 -> [] - - processException :: Config -> Exception -> IO () - processException conf exc - = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] msg - IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo - Nothing - -> Abortion InternalServerError [] - $ show exc - _ -> Abortion InternalServerError [] $ show exc - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state <- atomically $ readItr itr itrState id - if state <= DecidingHeader then - flip runReaderT itr - $ do setStatus $ aboStatus abo - -- FIXME: 同じ名前で複數の値があった時は、こ - -- れではまずいと思ふ。 - mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setHeader "Content-Type" "application/xhtml+xml" - output $ aboPage conf abo - else - hPutStrLn stderr $ show abo - - flip runReaderT itr $ driftTo Done - - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE - else - show ioE - - getMethod :: Resource Method getMethod = do itr <- ask return $ reqMethod $ fromJust $ itrRequest itr @@ -235,25 +71,44 @@ getHeader name = do itr <- ask return $ H.getHeader name $ fromJust $ itrRequest itr +getAccept :: Resource [MIMEType] +getAccept = do accept <- getHeader "Accept" + if accept == Nothing then + return [] + else + case parseStr mimeTypeListP $ fromJust accept of + (Success xs, _) -> return xs + _ -> return [] + + +getContentType :: Resource (Maybe MIMEType) +getContentType = do cType <- getHeader "Content-Type" + if cType == Nothing then + return Nothing + else + case parseStr mimeTypeP $ fromJust cType of + (Success t, _) -> return $ Just t + _ -> return Nothing + + + {- ExaminingRequest 時に使用するアクション群 -} -foundEntity :: Bool -> String -> ClockTime -> Resource () -foundEntity isWeak token timeStamp +foundEntity :: ETag -> ClockTime -> Resource () +foundEntity tag timeStamp = do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp - foundETag isWeak token + foundETag tag driftTo GettingBody -foundETag :: Bool -> String -> Resource () -foundETag isWeak token +foundETag :: ETag -> Resource () +foundETag tag = do driftTo ExaminingRequest - - let tag = mkETag isWeak token method <- getMethod when (method == GET || method == HEAD) @@ -513,9 +368,9 @@ redirect code uri setHeader "Location" (uriToString id uri $ "") -setETag :: Bool -> String -> Resource () -setETag isWeak token - = setHeader "ETag" $ show $ mkETag isWeak token +setETag :: ETag -> Resource () +setETag tag + = setHeader "ETag" $ show tag setLastModified :: ClockTime -> Resource () @@ -523,6 +378,11 @@ setLastModified lastmod = setHeader "Last-Modified" $ formatHTTPDateTime lastmod +setContentType :: MIMEType -> Resource () +setContentType mType + = setHeader "Content-Type" $ show mType + + {- DecidingBody 時に使用するアクション群 -} output :: String -> Resource ()