module Network.HTTP.Lucu.Resource ( ResourceDef(..) , Resource , ResTree , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ResourceDef , runResource -- ResourceDef -> Interaction -> IO ThreadId , getMethod -- Resource Method , getHeader -- String -> Resource (Maybe String) , foundEntity -- Bool -> String -> ClockTime -> Resource () , foundETag -- Bool -> String -> Resource () , foundTimeStamp -- ClockTime -> Resource () , foundNoEntity -- Maybe String -> Resource () , input -- Int -> Resource String , inputChunk -- Int -> Resource String , inputBS -- Int -> Resource ByteString , inputChunkBS -- Int -> Resource ByteString , defaultLimit -- Int , setStatus -- StatusCode -> Resource () , setHeader -- String -> String -> Resource () , redirect -- StatusCode -> URI -> Resource () , setETag -- Bool -> String -> Resource () , setLastModified -- ClockTime -> Resource () , output -- String -> Resource () , outputChunk -- String -> Resource () , outputBS -- ByteString -> Resource () , outputChunkBS -- ByteString -> 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 import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response 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 getHeader :: String -> Resource (Maybe String) getHeader name = do itr <- ask return $ H.getHeader name $ fromJust $ itrRequest itr {- ExaminingRequest 時に使用するアクション群 -} foundEntity :: Bool -> String -> ClockTime -> Resource () foundEntity isWeak token timeStamp = do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp foundETag isWeak token driftTo GettingBody foundETag :: Bool -> String -> Resource () foundETag isWeak token = do driftTo ExaminingRequest let tag = mkETag isWeak token method <- getMethod when (method == GET || method == HEAD) $ setHeader' "ETag" $ show tag -- If-Match があればそれを見る。 ifMatch <- getHeader "If-Match" case ifMatch of Nothing -> return () Just "*" -> return () Just list -> case parseStr eTagListP list of (Success tags, _) -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 -> when (not $ any (== tag) tags) $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list) _ -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-None-Match があればそれを見る。 ifNoneMatch <- getHeader "If-None-Match" case ifNoneMatch of Nothing -> return () Just "*" -> abort statusForNoneMatch [] ("The entity tag matches: *") Just list -> case parseStr eTagListP list of (Success tags, _) -> when (any (== tag) tags) $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list) _ -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list) driftTo GettingBody foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp = do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp let statusForIfModSince = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-Modified-Since があればそれを見る。 ifModSince <- getHeader "If-Modified-Since" case ifModSince of Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () -- If-Unmodified-Since があればそれを見る。 ifUnmodSince <- getHeader "If-Unmodified-Since" case ifUnmodSince of Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () driftTo GettingBody foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM = do driftTo ExaminingRequest let msg = fromMaybe "The requested entity was not found in this server." msgM method <- getMethod when (method /= PUT) $ abort NotFound [] msg -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch <- getHeader "If-Match" when (ifMatch /= Nothing) $ abort PreconditionFailed [] msg driftTo GettingBody {- GettingBody 時に使用するアクション群 -} input :: Int -> Resource String input limit = inputBS limit >>= return . B.unpack -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。 inputBS :: Int -> Resource ByteString inputBS limit = do driftTo GettingBody itr <- ask hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else do driftTo DecidingHeader return B.empty return chunk where askForInput :: Interaction -> Resource ByteString askForInput itr = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit <= 0 then defaultLimit else limit when (actualLimit <= 0) $ fail ("inputBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically $ do chunkLen <- readItr itr itrReqChunkLength id writeItr itr itrWillReceiveBody True if fmap (> actualLimit) chunkLen == Just True then -- 受信前から多過ぎる事が分かってゐる tooLarge actualLimit else writeItr itr itrReqBodyWanted $ Just actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk <- liftIO $ atomically $ do chunk <- readItr itr itrReceivedBody id chunkIsOver <- readItr itr itrReqChunkIsOver id if B.length chunk < fromIntegral actualLimit then -- 要求された量に滿たなくて、まだ殘り -- があるなら再試行。 unless chunkIsOver $ retry else -- 制限値一杯まで讀むやうに指示したの -- にまだ殘ってゐるなら、それは多過ぎ -- る。 unless chunkIsOver $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにす -- るとメモリの無駄になるので除去。 writeItr itr itrReceivedBody B.empty return chunk driftTo DecidingHeader return chunk tooLarge :: Int -> STM () tooLarge lim = abortSTM RequestEntityTooLarge [] ("Request body must be smaller than " ++ show lim ++ " bytes.") inputChunk :: Int -> Resource String inputChunk limit = inputChunkBS limit >>= return . B.unpack -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され -- る。これ以上ボディが殘ってゐなければ空文字列を返す。 inputChunkBS :: Int -> Resource ByteString inputChunkBS limit = do driftTo GettingBody itr <- ask hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else do driftTo DecidingHeader return B.empty return chunk where askForInput :: Interaction -> Resource ByteString askForInput itr = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit < 0 then defaultLimit else limit when (actualLimit <= 0) $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically $ do writeItr itr itrReqBodyWanted $ Just actualLimit writeItr itr itrWillReceiveBody True -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk <- liftIO $ atomically $ do chunk <- readItr itr itrReceivedBody id -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 when (B.length chunk < fromIntegral actualLimit) $ do chunkIsOver <- readItr itr itrReqChunkIsOver id unless chunkIsOver $ retry -- 成功 writeItr itr itrReceivedBody B.empty return chunk when (B.null chunk) $ driftTo DecidingHeader return chunk defaultLimit :: Int defaultLimit = (-1) {- DecidingHeader 時に使用するアクション群 -} setStatus :: StatusCode -> Resource () setStatus code = do driftTo DecidingHeader itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ \ resM -> case resM of Nothing -> Just $ Response { resVersion = HttpVersion 1 1 , resStatus = code , resHeaders = [] } Just res -> Just $ res { resStatus = code } setHeader :: String -> String -> Resource () setHeader name value = driftTo DecidingHeader >> setHeader' name value setHeader' :: String -> String -> Resource() setHeader' name value = do itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ \ resM -> case resM of Nothing -> Just $ Response { resVersion = HttpVersion 1 1 , resStatus = Ok , resHeaders = [ (name, value) ] } Just res -> Just $ H.setHeader name value res redirect :: StatusCode -> URI -> Resource () redirect code uri = do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] $ "Attempted to redirect with status " ++ show code setStatus code setHeader "Location" (uriToString id uri $ "") setETag :: Bool -> String -> Resource () setETag isWeak token = setHeader "ETag" $ show $ mkETag isWeak token setLastModified :: ClockTime -> Resource () setLastModified lastmod = setHeader "Last-Modified" $ formatHTTPDateTime lastmod {- DecidingBody 時に使用するアクション群 -} output :: String -> Resource () output = outputBS . B.pack outputBS :: ByteString -> Resource () outputBS str = do outputChunkBS str driftTo Done outputChunk :: String -> Resource () outputChunk = outputChunkBS . B.pack outputChunkBS :: ByteString -> Resource () outputChunkBS str = do driftTo DecidingBody itr <- ask liftIO $ atomically $ do updateItr itr itrBodyToSend (flip B.append str) unless (B.null str) $ writeItr itr itrBodyIsNull False {- [GettingBody からそれ以降の状態に遷移する時] body を讀み終へてゐなければ、殘りの body を讀み捨てる。 [DecidingHeader からそれ以降の状態に遷移する時] postprocess する。 [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK だった場合は、補完の代はりに 204 No Content に變へる。 -} driftTo :: InteractionState -> Resource () driftTo newState = do itr <- ask liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState else do let a = [oldState .. newState] b = tail a c = zip a b mapM_ (uncurry $ drift itr) c writeItr itr itrState newState where throwStateError :: Monad m => InteractionState -> InteractionState -> m a throwStateError Done DecidingBody = fail "It makes no sense to output something after finishing to output." throwStateError old new = fail ("state error: " ++ show old ++ " ==> " ++ show new) drift :: Interaction -> InteractionState -> InteractionState -> STM () drift itr GettingBody _ = writeItr itr itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr drift itr _ Done = do bodyIsNull <- readItr itr itrBodyIsNull id when bodyIsNull $ do status <- readStatus itr if status == Ok then do updateItrF itr itrResponse $ \ res -> res { resStatus = NoContent } updateItrF itr itrResponse $ H.deleteHeader "Content-Type" updateItrF itr itrResponse $ H.deleteHeader "ETag" updateItrF itr itrResponse $ H.deleteHeader "Last-Modified" else writeDefaultPage itr drift _ _ _ = return () readStatus :: Interaction -> STM StatusCode readStatus itr = readItr itr itrResponse (resStatus . fromJust)