X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=de5efaae4ac5bce5d23bab1658609092a95f8df4;hb=f62b6f07bbf1eefcf552163d8f7daa6e0862ed5d;hp=c1f1a8b8dacc9c8e91cc21907f3053c3a55a7cda;hpb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index c1f1a8b..de5efaa 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.Preprocess
     ( preprocess
     )
@@ -6,6 +5,8 @@ module Network.HTTP.Lucu.Preprocess
 
 import           Control.Concurrent.STM
 import           Control.Monad
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 import           Data.Char
 import           Data.Maybe
 import           Network.HTTP.Lucu.Config
@@ -14,7 +15,6 @@ import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
-import           Network.HTTP.Lucu.Utils
 import           Network
 import           Network.URI
 
@@ -47,11 +47,10 @@ import           Network.URI
 
 -}
 
-import GHC.Conc (unsafeIOToSTM)
-
 preprocess :: Interaction -> STM ()
 preprocess itr
-    = do req <- readItr itr itrRequest fromJust
+    = itr `seq`
+      do req <- readItr itr itrRequest fromJust
 
          let reqVer = reqVersion req
 
@@ -70,95 +69,101 @@ preprocess itr
                 completeAuthority req
 
                 case reqMethod req of
-                  GET  -> return ()
-                  HEAD -> writeItr itr itrWillDiscardBody True
-                  POST -> writeItr itr itrRequestHasBody True
-                  PUT  -> writeItr itr itrRequestHasBody True
-                  _    -> setStatus NotImplemented
+                  GET    -> return ()
+                  HEAD   -> writeItr itr itrWillDiscardBody True
+                  POST   -> writeItr itr itrRequestHasBody True
+                  PUT    -> writeItr itr itrRequestHasBody True
+                  DELETE -> return ()
+                  _      -> setStatus NotImplemented
                   
-                mapM_ (preprocessHeader itr) (reqHeaders req)
+                preprocessHeader req
     where
       setStatus :: StatusCode -> STM ()
       setStatus status
-          = updateItr itr itrResponse
-            $ \ res -> res {
-                         resStatus = status
-                       }
+          = status `seq`
+            updateItr itr itrResponse
+            $! \ res -> res {
+                          resStatus = status
+                        }
 
       completeAuthority :: Request -> STM ()
       completeAuthority req
-          = when (uriAuthority (reqURI req) == Nothing)
+          = req `seq`
+            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
+                                  PortNumber n -> Just (fromIntegral n :: Int)
                                   _            -> Nothing
                          portStr
                               = case port of
                                   Just 80 -> Just ""
-                                  Just n  -> Just $ ":" ++ show n
+                                  Just n  -> Just $ ':' : show n
                                   Nothing -> Nothing
                      case portStr of
-                       Just str -> updateAuthority host str
+                       Just str -> updateAuthority host (C8.pack str)
                        -- FIXME: このエラーの原因は、listen してゐるソ
                        -- ケットが INET でない故にポート番號が分からな
                        -- い事だが、その事をどうにかして通知した方が良
                        -- いと思ふ。stderr？
                        Nothing  -> setStatus InternalServerError
               else
-                  do case getHeader "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 :: String -> (String, String)
-      parseHost = break (== ':')
+      parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
+      parseHost = C8.break (== ':')
 
 
-      updateAuthority :: String -> String -> STM ()
+      updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
       updateAuthority host portStr
-          = updateItr itr itrRequest
-            $ \ (Just req) -> Just req {
-                                reqURI = let uri = reqURI req
-                                         in uri {
-                                              uriAuthority = Just URIAuth {
-                                                                  uriUserInfo = ""
-                                                                , uriRegName  = host
-                                                                , uriPort     = portStr
-                                                                }
-                                            }
-                              }
+          = host `seq` portStr `seq`
+            updateItr itr itrRequest
+            $! \ (Just req) -> Just req {
+                                 reqURI = let uri = reqURI req
+                                          in uri {
+                                               uriAuthority = Just URIAuth {
+                                                                   uriUserInfo = ""
+                                                                 , uriRegName  = C8.unpack host
+                                                                 , uriPort     = C8.unpack portStr
+                                                              }
+                                             }
+                               }
                 
 
-      preprocessHeader itr (name, value)
-          = case map toLower name of
-
-              "expect"
-                  -> if value `noCaseEq` "100-continue" then
-                         writeItr itr itrExpectedContinue True
-                     else
-                         setStatus ExpectationFailed
-
-              "transfer-encoding"
-                  -> case map toLower value of
-                       "identity" -> return ()
-                       "chunked"  -> writeItr itr itrRequestIsChunked True
-                       _          -> setStatus NotImplemented
-
-              "content-length"
-                  -> if all isDigit value then
-                         do let len = read value
-                            writeItr itr itrReqChunkLength    $ Just len
-                            writeItr itr itrReqChunkRemaining $ Just len
-                     else
-                         setStatus BadRequest
-
-              "connection"
-                  -> case map toLower value of
-                       "close"      -> writeItr itr itrWillClose True
-                       _            -> return ()
-
-              _ -> return ()
\ No newline at end of file
+      preprocessHeader :: Request -> STM ()
+      preprocessHeader req
+          = req `seq`
+            do case getHeader (C8.pack "Expect") req of
+                 Nothing    -> return ()
+                 Just value -> if value `noCaseEq` C8.pack "100-continue" then
+                                   writeItr itr itrExpectedContinue True
+                               else
+                                   setStatus ExpectationFailed
+
+               case getHeader (C8.pack "Transfer-Encoding") req of
+                 Nothing    -> return ()
+                 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 ()
+                 Just value -> if C8.all isDigit value then
+                                   do let Just (len, _) = C8.readInt value
+                                      writeItr itr itrReqChunkLength    $ Just len
+                                      writeItr itr itrReqChunkRemaining $ Just len
+                               else
+                                   setStatus BadRequest
+
+               case getHeader (C8.pack "Connection") req of
+                 Nothing    -> return ()
+                 Just value -> when (value `noCaseEq` C8.pack "close")
+                                   $ writeItr itr itrWillClose True