staticFile

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 3ac8fb9cc1560bc293c8a93e1a1945700c5c2119..28ce4628901a8380a3e48e578657b143cf778a0d 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,6 +1,7 @@
 module Network.HTTP.Lucu.Resource
     ( Resource
 
+    , getConfig -- Resource Config
     , getMethod -- Resource Method
     , getHeader -- String -> Resource (Maybe String)
     , getAccept -- Resource [MIMEType]
@@ -61,6 +62,11 @@ 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
@@ -124,8 +130,9 @@ foundETag tag
                               -- tags の中に一致するものが無ければ
                               -- PreconditionFailed で終了。
                               -> when (not $ any (== tag) tags)
-                                 $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list)
-                          _   -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch)
+                                 $ 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
@@ -136,12 +143,12 @@ foundETag tag
          ifNoneMatch <- getHeader "If-None-Match"
          case ifNoneMatch of
            Nothing   -> return ()
-           Just "*"  -> abort statusForNoneMatch [] ("The entity tag matches: *")
+           Just "*"  -> abort statusForNoneMatch [] $ Just ("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)
+                                 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
+                          _   -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
 
          driftTo GettingBody
 
@@ -165,7 +172,8 @@ foundTimeStamp timeStamp
            Just str -> case parseHTTPDateTime str of
                          Just lastTime
                              -> when (timeStamp <= lastTime)
-                                $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str)
+                                $ abort statusForIfModSince []
+                                      $ Just ("The entity has not been modified since " ++ str)
                          Nothing
                              -> return () -- 不正な時刻は無視
            Nothing  -> return ()
@@ -176,7 +184,8 @@ foundTimeStamp timeStamp
            Just str -> case parseHTTPDateTime str of
                          Just lastTime
                              -> when (timeStamp > lastTime)
-                                $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str)
+                                $ abort PreconditionFailed []
+                                      $ Just  ("The entity has not been modified since " ++ str)
                          Nothing
                              -> return () -- 不正な時刻は無視
            Nothing  -> return ()
@@ -188,17 +197,15 @@ 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
+              $ abort NotFound [] msgM
 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- If-Match: 條件も滿たさない。
          ifMatch <- getHeader "If-Match"
          when (ifMatch /= Nothing)
-                  $ abort PreconditionFailed [] msg
+                  $ abort PreconditionFailed [] msgM
 
          driftTo GettingBody
 
@@ -265,8 +272,8 @@ inputBS limit
 
       tooLarge :: Int -> STM ()
       tooLarge lim = abortSTM RequestEntityTooLarge []
-                     ("Request body must be smaller than "
-                      ++ show lim ++ " bytes.")
+                     $ Just ("Request body must be smaller than "
+                             ++ show lim ++ " bytes.")
          
 
 inputChunk :: Int -> Resource String
@@ -363,7 +370,7 @@ redirect :: StatusCode -> URI -> Resource ()
 redirect code uri
     = do when (code == NotModified || not (isRedirection code))
                   $ abort InternalServerError []
-                        $ "Attempted to redirect with status " ++ show code
+                        $ Just ("Attempted to redirect with status " ++ show code)
          setStatus code
          setHeader "Location" (uriToString id uri $ "")
 
@@ -398,14 +405,43 @@ 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
-                       itr <- ask
-                       liftIO $ atomically $
-                              do updateItr itr itrBodyToSend (flip B.append str)
-                                 unless (B.null str)
-                                            $ writeItr itr itrBodyIsNull False
+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
 
 {-