Lucu 0.6

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 071ab56b1ea3f7e5f8770e803268f166c24c2c4d..0bd33ed1b00fc17b8f27a260cb57f88743e5972c 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,4 +1,3 @@
--- #hide

 module Network.HTTP.Lucu.Postprocess
     ( postprocess
     , completeUnconditionalHeaders
 module Network.HTTP.Lucu.Postprocess
     ( postprocess
     , completeUnconditionalHeaders


@@ -7,19 +6,21 @@ module Network.HTTP.Lucu.Postprocess
 
 import           Control.Concurrent.STM
 import           Control.Monad
 
 import           Control.Concurrent.STM
 import           Control.Monad

-import           Data.Char
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
+import           Data.IORef

 import           Data.Maybe
 import           Data.Maybe

+import           Data.Time
+import qualified Data.Time.HTTP as HTTP

 import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction

-import           Network.HTTP.Lucu.RFC1123DateTime

 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response

-import           Network.HTTP.Lucu.Utils
-import           System.Time
+import           System.IO.Unsafe

 
 {-
   
 
 {-
   


@@ -55,26 +56,25 @@ import           System.Time
 -}
 
 postprocess :: Interaction -> STM ()
 -}
 
 postprocess :: Interaction -> STM ()

-postprocess itr
+postprocess !itr

     = do reqM <- readItr itr itrRequest id
          res  <- readItr itr itrResponse id
          let sc = resStatus res
 
     = do reqM <- readItr itr itrRequest id
          res  <- readItr itr itrResponse id
          let sc = resStatus res
 

-         when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
+         unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])

                   $ abortSTM InternalServerError []
                         $ Just ("The status code is not good for a final status: "
                                 ++ show sc)
 
                   $ abortSTM InternalServerError []
                         $ Just ("The status code is not good for a final status: "
                                 ++ show sc)
 

-         when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
+         when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)

                   $ abortSTM InternalServerError []
                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
 
                   $ abortSTM InternalServerError []
                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
 

-         when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
+         when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)

                   $ abortSTM InternalServerError []
                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
 
                   $ abortSTM InternalServerError []
                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
 

-         when (reqM /= Nothing)
-              $ relyOnRequest itr
+         when (reqM /= Nothing) relyOnRequest

 
          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
          -- 能性が高い。
 
          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
          -- 能性が高い。


@@ -83,8 +83,8 @@ postprocess itr
                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
             writeItr itr itrResponse newRes
     where
                       $ completeUnconditionalHeaders (itrConfig itr) oldRes
             writeItr itr itrResponse newRes
     where

-      relyOnRequest :: Interaction -> STM ()
-      relyOnRequest itr
+      relyOnRequest :: STM ()
+      relyOnRequest

           = do status <- readItr itr itrResponse resStatus
                req    <- readItr itr itrRequest fromJust
 
           = do status <- readItr itr itrResponse resStatus
                req    <- readItr itr itrRequest fromJust
 


@@ -97,56 +97,80 @@ postprocess itr
                                           status == ResetContent ||
                                           status == NotModified    )
 
                                           status == ResetContent ||
                                           status == NotModified    )
 

-               updateRes itr $ deleteHeader "Content-Length"
-               updateRes itr $ deleteHeader "Transfer-Encoding"
+               updateRes $! deleteHeader (C8.pack "Content-Length")
+               updateRes $! deleteHeader (C8.pack "Transfer-Encoding")

 
 

-               cType <- readHeader itr "Content-Type"
+               cType <- readHeader (C8.pack "Content-Type")

                when (cType == Nothing)
                when (cType == Nothing)

-                        $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
+                        $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType

 
                if canHaveBody then
                    when (reqVer == HttpVersion 1 1)
 
                if canHaveBody then
                    when (reqVer == HttpVersion 1 1)

-                            $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+                            $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")

                                  writeItr itr itrWillChunkBody True
                  else
                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
                    when (reqMethod req /= HEAD)
                                  writeItr itr itrWillChunkBody True
                  else
                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
                    when (reqMethod req /= HEAD)

-                            $ do updateRes itr $ deleteHeader "Content-Type"
-                                 updateRes itr $ deleteHeader "Etag"
-                                 updateRes itr $ deleteHeader "Last-Modified"
+                            $ do updateRes $! deleteHeader (C8.pack "Content-Type")
+                                 updateRes $! deleteHeader (C8.pack "Etag")
+                                 updateRes $! deleteHeader (C8.pack "Last-Modified")

 
 

-               conn <- readHeader itr "Connection"
-               case fmap (map toLower) conn of
-                 Just "close" -> writeItr itr itrWillClose True
-                 _            -> return ()
+               conn <- readHeader (C8.pack "Connection")
+               case conn of
+                 Nothing    -> return ()
+                 Just value -> when (value `noCaseEq` C8.pack "close")
+                                   $ writeItr itr itrWillClose True

 
                willClose <- readItr itr itrWillClose id
                when willClose
 
                willClose <- readItr itr itrWillClose id
                when willClose

-                        $ updateRes itr $ setHeader "Connection" "close"
+                        $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")

 
                when (reqMethod req == HEAD || not canHaveBody)
                         $ writeTVar (itrWillDiscardBody itr) True
 
 
                when (reqMethod req == HEAD || not canHaveBody)
                         $ writeTVar (itrWillDiscardBody itr) True
 

-      readHeader :: Interaction -> String -> STM (Maybe String)
-      readHeader itr name
+      readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
+      readHeader !name

           = readItr itr itrResponse $ getHeader name
 
           = readItr itr itrResponse $ getHeader name
 

-      updateRes :: Interaction -> (Response -> Response) -> STM ()
-      updateRes itr updator 
+      updateRes :: (Response -> Response) -> STM ()
+      updateRes !updator 

           = updateItr itr itrResponse updator
 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response
           = updateItr itr itrResponse updator
 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response

-completeUnconditionalHeaders conf res
-    = return res >>= compServer >>= compDate >>= return
+completeUnconditionalHeaders !conf !res
+    = compServer res >>= compDate

       where
       where

-        compServer res
-            = case getHeader "Server" res of
-                Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
-                Just _  -> return res
-
-        compDate res
-            = case getHeader "Date" res of
-                Nothing -> do time <- getClockTime
-                              return $ addHeader "Date" (formatHTTPDateTime time) res
-                Just _  -> return res
\ No newline at end of file
+        compServer res'
+            = case getHeader (C8.pack "Server") res' of
+                Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
+                Just _  -> return res'
+
+        compDate res'
+            = case getHeader (C8.pack "Date") res' of
+                Nothing -> do date <- getCurrentDate
+                              return $ setHeader (C8.pack "Date") date res'
+                Just _  -> return res'
+
+
+cache :: IORef (UTCTime, Strict.ByteString)
+cache = unsafePerformIO $
+        newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
+{-# NOINLINE cache #-}
+
+getCurrentDate :: IO Strict.ByteString
+getCurrentDate = do now                     <- getCurrentTime
+                    (cachedTime, cachedStr) <- readIORef cache
+
+                    if now `mostlyEq` cachedTime then
+                        return cachedStr
+                      else
+                        do let dateStr = C8.pack $ HTTP.format now
+                           writeIORef cache (now, dateStr)
+                           return dateStr
+    where
+      mostlyEq :: UTCTime -> UTCTime -> Bool
+      mostlyEq a b
+          = (utctDay a == utctDay b)
+            &&
+            (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))