Use base64-bytestring instead of dataenc

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 7d7e147f93be84797d739ca976991a4954ea5929..806ed1c1c9d07529ec3e84e65b367d69d1d881dd 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,24 +1,30 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnicodeSyntax
+  #-}

 module Network.HTTP.Lucu.Postprocess
 module Network.HTTP.Lucu.Postprocess

-    ( postprocess -- Interaction -> STM ()
-    , completeUnconditionalHeaders -- Config -> Response -> IO Response
+    ( postprocess
+    , completeUnconditionalHeaders

     )
     where
 
 import           Control.Concurrent.STM
 import           Control.Monad
     )
     where
 
 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

 
 {-
   
 
 {-
   


@@ -31,18 +37,15 @@ import           System.Time
   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
     する。
 
   * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
     する。
 

-  * Content-Length があれば、それを削除する。
+  * Content-Length があれば、それを削除する。Transfer-Encoding があって
+    も削除する。

 
 

-  * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
-    最後の要素が chunked でなければ 500 Internal Error にする。
-    Transfer-Encoding が未設定であれば、chunked に設定する。
+  * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
+    chunked に設定する。

 
 

-  * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
-    Error にする。但し identity だけは許す。
-
-  * body を持つ事が出來る時、Content-Type が無ければ
-    application/octet-stream にする。出來ない時、HEAD でなければ
-    Content-Type, Etag, Last-Modified を削除する。
+  * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
+    出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
+    する。

 
   * body を持つ事が出來ない時、body 破棄フラグを立てる。
 
 
   * body を持つ事が出來ない時、body 破棄フラグを立てる。
 


@@ -57,45 +60,39 @@ import           System.Time
 -}
 
 postprocess :: Interaction -> STM ()
 -}
 
 postprocess :: Interaction -> STM ()

-postprocess itr
-    = do resM <- readItr itr itrResponse id
-
-         case resM of
-           Nothing  -> writeItr itr itrResponse
-                       $ Just $ Response {
-                               resVersion = HttpVersion 1 1
-                             , resStatus  = Ok
-                             , resHeaders = []
-                             }
-           Just res -> do let sc = resStatus res
-
-                          when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
-                                   $ abortSTM InternalServerError []
-                                         ("The status code is not good for a final status: "
-                                          ++ show sc)
-
-                          when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
-                                   $ abortSTM InternalServerError []
-                                         ("The status was " ++ show sc ++ " but no Allow header.")
-
-                          when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
-                                   $ abortSTM InternalServerError []
-                                         ("The status code was " ++ show sc ++ " but no Location header.")
-
-         when (itrRequest itr /= Nothing)
-              $ relyOnRequest itr
+postprocess !itr
+    = do reqM <- readItr itr itrRequest id
+         res  <- readItr itr itrResponse id
+         let sc = resStatus res
+
+         unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])
+                  $ abortSTM InternalServerError []
+                        $ Just ("The status code is not good for a final status: "
+                                ++ show sc)
+
+         when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
+                  $ abortSTM InternalServerError []
+                        $ Just ("The status was " ++ show sc ++ " but no Allow header.")

 
 

+         when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
+                  $ abortSTM InternalServerError []
+                        $ Just ("The status code was " ++ show sc ++ " but no Location header.")
+
+         when (reqM /= Nothing) relyOnRequest
+
+         -- itrResponse の内容は relyOnRequest によって變へられてゐる可
+         -- 能性が高い。

          do oldRes <- readItr itr itrResponse id
             newRes <- unsafeIOToSTM
          do oldRes <- readItr itr itrResponse id
             newRes <- unsafeIOToSTM

-                      $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes)
-            writeItr itr itrResponse $ Just newRes
+                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
+            writeItr itr itrResponse newRes

     where
     where

-      relyOnRequest :: Interaction -> STM ()
-      relyOnRequest itr
-          = do status <- readItr itr itrResponse (resStatus . fromJust)
+      relyOnRequest :: STM ()
+      relyOnRequest
+          = do status <- readItr itr itrResponse resStatus
+               req    <- readItr itr itrRequest fromJust

 
 

-               let req         = fromJust $ itrRequest itr
-                   reqVer      = reqVersion req
+               let reqVer      = reqVersion req

                    canHaveBody = if reqMethod req == HEAD then
                                      False
                                  else
                    canHaveBody = if reqMethod req == HEAD then
                                      False
                                  else


@@ -104,79 +101,80 @@ postprocess itr
                                           status == ResetContent ||
                                           status == NotModified    )
 
                                           status == ResetContent ||
                                           status == NotModified    )
 

-               updateRes itr $ deleteHeader "Content-Length"
+               updateRes $! deleteHeader (C8.pack "Content-Length")
+               updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
+
+               cType <- readHeader (C8.pack "Content-Type")
+               when (cType == Nothing)
+                        $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType

 
                if canHaveBody then
 
                if canHaveBody then

-                   do teM <- readHeader itr "Transfer-Encoding"
-                      if reqVer == HttpVersion 1 1 then
-
-                          do case teM of
-                               Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
-                               Just te -> let teList = [trim isWhiteSpace x
-                                                            | x <- splitBy (== ',') (map toLower te)]
-                                          in
-                                            when (teList == [] || last teList /= "chunked")
-                                                     $ abortSTM InternalServerError []
-                                                           ("Transfer-Encoding must end with `chunked' "
-                                                            ++ "because this is an HTTP/1.1 request: "
-                                                            ++ te)
-
-                             writeItr itr itrWillChunkBody True
-                        else
-                          case fmap (map toLower) teM of
-                            Nothing         -> return ()
-                            Just "identity" -> return ()
-                            Just te         -> abortSTM InternalServerError []
-                                                      ("Transfer-Encoding must be `identity' because "
-                                                       ++ "this is an HTTP/1.0 request: "
-                                                       ++ te)
-
-                      cType <- readHeader itr "Content-Type"
-                      when (cType == Nothing)
-                               $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
+                   when (reqVer == HttpVersion 1 1)
+                            $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
+                                 writeItr itr itrWillChunkBody True

                  else
                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
                  else
                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す

-                   do updateRes itr $ deleteHeader "Transfer-Encoding"
-                      when (reqMethod req /= HEAD)
-                               $ do updateRes itr $ deleteHeader "Content-Type"
-                                    updateRes itr $ deleteHeader "Etag"
-                                    updateRes itr $ deleteHeader "Last-Modified"
+                   when (reqMethod req /= HEAD)
+                            $ 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
-          = do valueMM <- readItrF itr itrResponse $ getHeader name
-               case valueMM of
-                 Just (Just val) -> return $ Just val
-                 _               -> return Nothing
+      readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
+      readHeader !name
+          = readItr itr itrResponse $ getHeader name

 
 

-      updateRes :: Interaction -> (Response -> Response) -> STM ()
-      updateRes itr updator 
-          = updateItrF itr itrResponse updator
+      updateRes :: (Response -> Response) -> STM ()
+      updateRes !updator 
+          = updateItr itr itrResponse updator

 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response
 
 
 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))