X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=28ce4628901a8380a3e48e578657b143cf778a0d;hb=a44a96d95b5fcbaf24a21c0336046ce0c3bab614;hp=bc4bf3336389d959aa5bfedefcb857bf0e13b163;hpb=9961a721f98b101825ef154a2122c1fc2fa6d1ac;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bc4bf33..28ce462 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,14 +1,518 @@
 module Network.HTTP.Lucu.Resource
     ( Resource
+
+    , getConfig -- Resource Config
+    , 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.Monad.State
+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           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
+
+
+getConfig :: Resource Config
+getConfig = do itr <- ask
+               return $ itrConfig itr
+
+
+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 []
+                                       $ Just ("The entity tag doesn't match: " ++ list)
+                          _   -> abort BadRequest [] $ Just ("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 [] $ Just ("The entity tag matches: *")
+           Just list -> case parseStr eTagListP list of
+                          (Success tags, _)
+                              -> when (any (== tag) tags)
+                                 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
+                          _   -> abort BadRequest [] $ Just ("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 []
+                                      $ Just ("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 []
+                                      $ Just  ("The entity has not been modified since " ++ str)
+                         Nothing
+                             -> return () -- 不正な時刻は無視
+           Nothing  -> return ()
+
+         driftTo GettingBody
+
+
+foundNoEntity :: Maybe String -> Resource ()
+foundNoEntity msgM
+    = do driftTo ExaminingRequest
+
+         method <- getMethod
+         when (method /= PUT)
+              $ abort NotFound [] msgM
+
+         -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+         -- If-Match: 條件も滿たさない。
+         ifMatch <- getHeader "If-Match"
+         when (ifMatch /= Nothing)
+                  $ abort PreconditionFailed [] msgM
+
+         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 []
+                     $ Just ("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 []
+                        $ Just ("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
+
+
+{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
+   B.readFile して作った ByteString をそのまま ResponseWriter に渡した
+   りすると大變な事が起こる。何故なら ResponseWriter は
+   Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
+   測るから、その時に起こるであらう事は言ふまでも無い。 -}
+
+outputChunkBS :: ByteString -> Resource ()
+outputChunkBS str
+    = do driftTo DecidingBody
+         unless (B.null str)
+                    $ do itr <- ask
+
+                         let limit = cnfMaxOutputChunkLength $ itrConfig itr
+                         when (limit <= 0)
+                                  $ fail ("cnfMaxOutputChunkLength must be positive: "
+                                          ++ show limit)
+
+                         sendChunks str limit
+
+                         liftIO $ atomically $
+                                writeItr itr itrBodyIsNull False
+    where
+      sendChunks :: ByteString -> Int -> Resource ()
+      sendChunks str limit
+          | B.null str = return ()
+          | otherwise  = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
+                            itr <- ask
+                            liftIO $ atomically $ 
+                                   do buf <- readItr itr itrBodyToSend id
+                                      if B.null buf then
+                                          -- バッファが消化された
+                                          writeItr itr itrBodyToSend chunk
+                                        else
+                                          -- 消化されるのを待つ
+                                          retry
+                            -- 殘りのチャンクについて繰り返す
+                            sendChunks remaining limit
+
+{-
+
+  [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
+                                       
 
-data ResState = ResState -- FIXME
+      drift _ _ _
+          = return ()
 
-type ResourceT m a = StateT ResState m a
 
-type Resource a = ResourceT IO a
+      readStatus :: Interaction -> STM StatusCode
+      readStatus itr = readItr itr itrResponse (resStatus . fromJust)
\ No newline at end of file