X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=3ac8fb9cc1560bc293c8a93e1a1945700c5c2119;hb=c6b11025d1f81c668e9995e856b7bb34175230d3;hp=2e4d46e858f447fcec98601b1fc016e6f0272fd9;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 2e4d46e..3ac8fb9 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,109 +1,482 @@
 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    -- ETag -> ClockTime -> Resource ()
+    , foundETag      -- ETag -> 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   -- 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.Monad.Reader
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 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.MIMEType
 import           Network.HTTP.Lucu.Utils
 import           Network.URI
+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
-    , resResource         :: Resource ()
-    }
-type ResTree    = ResNode -- root だから Map ではない
-type ResSubtree = Map String ResNode
-data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
+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
+
+
+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 :: ETag -> ClockTime -> Resource ()
+foundEntity tag timeStamp
+    = do driftTo ExaminingRequest
+
+         method <- getMethod
+         when (method == GET || method == HEAD)
+                  $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+         foundETag tag
+
+         driftTo GettingBody
+
+
+foundETag :: ETag -> Resource ()
+foundETag tag
+    = do driftTo ExaminingRequest
+      
+         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)
 
-mkResTree :: [ ([String], ResourceDef) ] -> ResTree
-mkResTree list = processRoot 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
-      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
+      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
-                                   -- この位置にリソースがある。
-                                   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
+                                 -- 制限値一杯まで讀むやうに指示したの
+                                 -- にまだ殘ってゐるなら、それは多過ぎ
+                                 -- る。
+                                 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
-      walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
+      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
 
-      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
+defaultLimit :: Int
+defaultLimit = (-1)
 
 
-runResource :: ResourceDef -> Interaction -> IO ThreadId
-runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
+
+{- 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 :: ETag -> Resource ()
+setETag tag
+    = setHeader "ETag" $ show tag
+
+
+setLastModified :: ClockTime -> Resource ()
+setLastModified lastmod
+    = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
+
+
+setContentType :: MIMEType -> Resource ()
+setContentType mType
+    = setHeader "Content-Type" $ show mType
+
+
+{- 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
-      fork = if (resUsesNativeThread def)
-             then forkOS
-             else forkIO
-      rsrc = resResource def
\ No newline at end of file
+      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