, 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
+
+ , 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
data ResourceDef = ResourceDef {
resUsesNativeThread :: Bool
, resIsGreedy :: Bool
- , resResource :: Resource ()
+ , 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
runResource :: ResourceDef -> Interaction -> IO ThreadId
-runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
+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 = resResource def
\ No newline at end of file
+
+ 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
+
+
+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)
\ No newline at end of file
projects / Lucu.git / blobdiff