module Network.HTTP.Lucu.Resource ( ResourceDef(..) , Resource , ResTree , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ResourceDef , runResource -- ResourceDef -> Interaction -> IO ThreadId , 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 () , 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 qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess 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) 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 {- Resource モナド -} 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 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 where 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 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) 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 = do driftTo DecidingHeader 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 $ "") 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)