X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=7405975d5f2a0752968ed899a1aeadb6a0250916;hp=2e4d46e858f447fcec98601b1fc016e6f0272fd9;hb=e624f0db8c4610b36da9e4463a656e0cb8a104dd;hpb=1e48e402adec79653203dc19a1800efa7b1c467b

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 2e4d46e..7405975 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -5,19 +5,50 @@ module Network.HTTP.Lucu.Resource
     , 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
@@ -30,7 +61,11 @@ 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
@@ -101,9 +136,306 @@ findResource (ResNode rootDefM subtree) uri
 
 
 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