Format and others

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 124b66bd2ba3e4c4a4ac9aef92c4f9c76e0957ef..989ad164707ca9afb99f94f55dcc69fe2840e658 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,25 +1,35 @@
--- #hide
+{-# LANGUAGE
+    BangPatterns
+  , OverloadedStrings
+  , UnicodeSyntax
+  #-}

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

-
+import Control.Applicative

 import           Control.Concurrent.STM
 import           Control.Monad
 import           Control.Concurrent.STM
 import           Control.Monad

-import           Data.Char
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+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 Prelude.Unicode
+import           System.IO.Unsafe

 
 {-
   
 
 {-
   


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

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

 
 

-  * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
-    Error にする。但し identity だけは許す。
+  * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
+    chunked に設定する。

 
   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
 
   * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
     出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除


@@ -57,115 +64,98 @@ import           System.Time
 
 -}
 
 
 -}
 

-postprocess :: Interaction -> STM ()
-postprocess itr
-    = do res <- readItr itr itrResponse id
+postprocess ∷ Interaction → STM ()
+postprocess !itr
+    = do reqM ← readItr itr itrRequest id
+         res  ← readItr itr itrResponse id

          let sc = resStatus res
 
          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 (itrRequest itr /= Nothing)
-              $ relyOnRequest itr
+         when (reqM /= Nothing) relyOnRequest

 
 

-         do newRes <- unsafeIOToSTM
-                      $ completeUnconditionalHeaders (itrConfig itr) res
+         -- itrResponse の内容は relyOnRequest によって變へられてゐる可
+         -- 能性が高い。
+         do oldRes ← readItr itr itrResponse id
+            newRes ← unsafeIOToSTM
+                     $ completeUnconditionalHeaders (itrConfig itr) oldRes

             writeItr itr itrResponse newRes
     where
             writeItr itr itrResponse newRes
     where

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

 
 

-               let req         = fromJust $ itrRequest itr
-                   reqVer      = reqVersion req
-                   canHaveBody = if reqMethod req == HEAD then
+               let reqVer      = reqVersion req
+                   canHaveBody = if reqMethod req ≡ HEAD then

                                      False
                                  else
                                      False
                                  else

-                                     not (isInformational status ||
-                                          status == NoContent    ||
-                                          status == ResetContent ||
-                                          status == NotModified    )
+                                     not (isInformational status ∨
+                                          status ≡ NoContent     ∨
+                                          status ≡ ResetContent  ∨
+                                          status ≡ NotModified   )

 
 

-               updateRes itr $ deleteHeader "Content-Length"
+               updateRes $ deleteHeader "Content-Length"
+               updateRes $ deleteHeader "Transfer-Encoding"

 
 

-               cType <- readHeader itr "Content-Type"
-               when (cType == Nothing)
-                        $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
+               cType ← readHeader "Content-Type"
+               when (cType ≡ Nothing)
+                        $ updateRes $ setHeader "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 []
-                                                           $ Just ("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 []
-                                               $ Just ("Transfer-Encoding must be `identity' because "
-                                                       ++ "this is an HTTP/1.0 request: "
-                                                       ++ te)
+                   when (reqVer ≡ HttpVersion 1 1)
+                            $ do updateRes $ setHeader "Transfer-Encoding" "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"
-
-               conn <- readHeader itr "Connection"
-               case fmap (map toLower) conn of
-                 Just "close" -> writeItr itr itrWillClose True
-                 _            -> return ()
-
-               willClose <- readItr itr itrWillClose id
+                   when (reqMethod req /= HEAD)
+                            $ do updateRes $ deleteHeader "Content-Type"
+                                 updateRes $ deleteHeader "Etag"
+                                 updateRes $ deleteHeader "Last-Modified"
+
+               conn ← readHeader "Connection"
+               case conn of
+                 Nothing    → return ()
+                 Just value → when (A.toCIAscii value ≡ "close")
+                                   $ writeItr itr itrWillClose True
+
+               willClose ← readItr itr itrWillClose id

                when willClose
                when willClose

-                        $ updateRes itr $ setHeader "Connection" "close"
+                        $ updateRes $ setHeader "Connection" "close"

 
 

-               when (reqMethod req == HEAD || not canHaveBody)
+               when (reqMethod req ≡ HEAD ∨ not canHaveBody)

                         $ writeTVar (itrWillDiscardBody itr) True
 
                         $ writeTVar (itrWillDiscardBody itr) True
 

-      readHeader :: Interaction -> String -> STM (Maybe String)
-      readHeader itr name
-          = readItr itr itrResponse $ getHeader name
-
-      updateRes :: Interaction -> (Response -> Response) -> STM ()
-      updateRes itr updator 
-          = updateItr itr itrResponse updator
+      readHeader ∷ CIAscii → STM (Maybe Ascii)
+      readHeader = readItr itr itrResponse ∘ getHeader

 
 

+      updateRes ∷ (Response → Response) → STM ()
+      updateRes = updateItr itr itrResponse

 
 

-completeUnconditionalHeaders :: Config -> Response -> IO Response
-completeUnconditionalHeaders conf res
-    = return res >>= compServer >>= compDate >>= return
+completeUnconditionalHeaders ∷ Config → Response → IO Response
+completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer

       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 "Server" res' of
+                Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
+                Just _  → return res'
+
+        compDate res'
+            = case getHeader "Date" res' of
+                Nothing → do date ← getCurrentDate
+                             return $ setHeader "Date" date res'
+                Just _  → return res'
+
+getCurrentDate ∷ IO Ascii
+getCurrentDate = HTTP.format <$> getCurrentTime