X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=9f9fa0d68c3b83f187c6316213cc100f39cdc5cf;hp=6191273183347674fbaaf348565e5b3e76ee040d;hb=8bdd1da1ee1f3e453dbe2bce246618e12e26d30c;hpb=e4afb8c074c14a06f9c738e0d2d9380e19b42583

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 6191273..9f9fa0d 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE
+    BangPatterns
+  #-}
 module Network.HTTP.Lucu.Preprocess
     ( preprocess
     )
@@ -15,7 +18,6 @@ import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
-import           Network
 import           Network.URI
 
 {-
@@ -48,9 +50,8 @@ import           Network.URI
 -}
 
 preprocess :: Interaction -> STM ()
-preprocess itr
-    = itr `seq`
-      do req <- readItr itr itrRequest fromJust
+preprocess !itr
+    = do req <- readItr itr itrRequest fromJust
 
          let reqVer = reqVersion req
 
@@ -79,41 +80,30 @@ preprocess itr
                 preprocessHeader req
     where
       setStatus :: StatusCode -> STM ()
-      setStatus status
-          = status `seq`
-            updateItr itr itrResponse
+      setStatus !status
+          = updateItr itr itrResponse
             $! \ res -> res {
                           resStatus = status
                         }
 
       completeAuthority :: Request -> STM ()
-      completeAuthority req
-          = req `seq`
-            when (uriAuthority (reqURI req) == Nothing)
+      completeAuthority !req
+          = when (uriAuthority (reqURI req) == Nothing)
             $ if reqVersion req == HttpVersion 1 0 then
                   -- HTTP/1.0 なので Config から補完
                   do let conf = itrConfig itr
                          host = cnfServerHost conf
-                         port = case cnfServerPort conf of
-                                  PortNumber n -> Just (fromIntegral n :: Int)
-                                  _            -> Nothing
+                         port = itrLocalPort itr
                          portStr
                               = case port of
-                                  Just 80 -> Just ""
-                                  Just n  -> Just $ ":" ++ show n
-                                  Nothing -> Nothing
-                     case portStr of
-                       Just str -> updateAuthority host (C8.pack str)
-                       -- FIXME: このエラーの原因は、listen してゐるソ
-                       -- ケットが INET でない故にポート番號が分からな
-                       -- い事だが、その事をどうにかして通知した方が良
-                       -- いと思ふ。stderr？
-                       Nothing  -> setStatus InternalServerError
+                                  80 -> ""
+                                  n  -> ':' : show n
+                     updateAuthority host (C8.pack portStr)
               else
-                  do case getHeader (C8.pack "Host") req of
-                       Just str -> let (host, portStr) = parseHost str
-                                   in updateAuthority host portStr
-                       Nothing  -> setStatus BadRequest
+                  case getHeader (C8.pack "Host") req of
+                    Just str -> let (host, portStr) = parseHost str
+                                in updateAuthority host portStr
+                    Nothing  -> setStatus BadRequest
 
 
       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
@@ -121,9 +111,8 @@ preprocess itr
 
 
       updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
-      updateAuthority host portStr
-          = host `seq` portStr `seq`
-            updateItr itr itrRequest
+      updateAuthority !host !portStr
+          = updateItr itr itrRequest
             $! \ (Just req) -> Just req {
                                  reqURI = let uri = reqURI req
                                           in uri {
@@ -137,9 +126,8 @@ preprocess itr
                 
 
       preprocessHeader :: Request -> STM ()
-      preprocessHeader req
-          = req `seq`
-            do case getHeader (C8.pack "Expect") req of
+      preprocessHeader !req
+          = do case getHeader (C8.pack "Expect") req of
                  Nothing    -> return ()
                  Just value -> if value `noCaseEq` C8.pack "100-continue" then
                                    writeItr itr itrExpectedContinue True
@@ -148,13 +136,11 @@ preprocess itr
 
                case getHeader (C8.pack "Transfer-Encoding") req of
                  Nothing    -> return ()
-                 Just value -> if value `noCaseEq` C8.pack "identity" then
-                                   return ()
-                               else
-                                   if value `noCaseEq` C8.pack "chunked" then
-                                       writeItr itr itrRequestIsChunked True
-                                   else
-                                       setStatus NotImplemented
+                 Just value -> unless (value `noCaseEq` C8.pack "identity")
+                                   $ if value `noCaseEq` C8.pack "chunked" then
+                                         writeItr itr itrRequestIsChunked True
+                                     else
+                                         setStatus NotImplemented
 
                case getHeader (C8.pack "Content-Length") req of
                  Nothing    -> return ()
@@ -167,7 +153,5 @@ preprocess itr
 
                case getHeader (C8.pack "Connection") req of
                  Nothing    -> return ()
-                 Just value -> if value `noCaseEq` C8.pack "close" then
-                                   writeItr itr itrWillClose True
-                               else
-                                   return ()
+                 Just value -> when (value `noCaseEq` C8.pack "close")
+                                   $ writeItr itr itrWillClose True