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 6f76e88811734508c1da16337712f7b7760577f3..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

 
 {-
   
 
 {-
   


@@ -54,98 +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

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

-         do oldRes <- readItr itr itrResponse id
-            newRes <- unsafeIOToSTM
-                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
+         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 itr $ deleteHeader "Transfer-Encoding"
+               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

-                   when (reqVer == HttpVersion 1 1)
-                            $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+                   when (reqVer ≡ HttpVersion 1 1)
+                            $ do updateRes $ setHeader "Transfer-Encoding" "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 "Content-Type"
+                                 updateRes $ deleteHeader "Etag"
+                                 updateRes $ deleteHeader "Last-Modified"

 
 

-               conn <- readHeader itr "Connection"
-               case fmap (map toLower) conn of
-                 Just "close" -> writeItr itr itrWillClose True
-                 _            -> return ()
+               conn ← readHeader "Connection"
+               case conn of
+                 Nothing    → return ()
+                 Just value → when (A.toCIAscii value ≡ "close")
+                                   $ writeItr itr itrWillClose True

 
 

-               willClose <- readItr itr itrWillClose id
+               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