X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=37b1a75ad997dbc7cfe14cf5fca0b91c5b4b287b;hb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;hp=802338c46dddbf7df1fb9fbe06c25620f5aa6075;hpb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 802338c..37b1a75 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.Preprocess
     ( preprocess
     )
@@ -8,16 +7,22 @@ import           Control.Concurrent.STM
 import           Control.Monad
 import           Data.Char
 import           Data.Maybe
+import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Headers
 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
 
 {-
 
+  * URI にホスト名が存在しない時、
+    [1] HTTP/1.0 ならば Config を使って補完
+    [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
+
   * Expect: に問題があった場合は 417 Expectation Failed に設定。
     100-continue 以外のものは全部 417 に。
 
@@ -25,9 +30,6 @@ import           Network.URI
     体的には、identity でも chunked でもなければ 501 Not Implemented に
     する。
 
-  * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
-    場合には 400 Bad Request にする。
-
   * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
     Not Implemented にする。
 
@@ -44,59 +46,110 @@ import           Network.URI
 
 -}
 
-import GHC.Conc (unsafeIOToSTM)
-
 preprocess :: Interaction -> STM ()
 preprocess itr
-    = do let req    = fromJust $ itrRequest itr
-             reqVer = reqVersion req
+    = itr `seq`
+      do req <- readItr itr itrRequest fromJust
+
+         let reqVer = reqVersion req
 
          if reqVer /= HttpVersion 1 0 &&
             reqVer /= HttpVersion 1 1 then
 
-             do setStatus itr HttpVersionNotSupported
+             do setStatus HttpVersionNotSupported
                 writeItr itr itrWillClose True
 
            else
-             do if reqVer == HttpVersion 1 0 then
-                    -- HTTP/1.0 では Keep-Alive できない
-                    writeItr itr itrWillClose True
-                  else
-                    -- URI または Host: ヘッダのどちらかにホストが無ければ
-                    -- ならない。
-                    when (uriAuthority (reqURI req) == Nothing &&
-                          getHeader "Host" req      == Nothing)
-                             $ setStatus itr BadRequest
+             -- HTTP/1.0 では Keep-Alive できない
+             do when (reqVer == HttpVersion 1 0)
+                     $ writeItr itr itrWillClose True
+
+                -- ホスト部の補完
+                completeAuthority req
 
                 case reqMethod req of
                   GET  -> return ()
                   HEAD -> writeItr itr itrWillDiscardBody True
                   POST -> writeItr itr itrRequestHasBody True
                   PUT  -> writeItr itr itrRequestHasBody True
-                  _    -> setStatus itr NotImplemented
+                  _    -> setStatus NotImplemented
                   
                 mapM_ (preprocessHeader itr) (reqHeaders req)
     where
-      setStatus itr status
-          = updateItr itr itrResponse
-            $ \ res -> res {
-                         resStatus = status
-                       }
-
+      setStatus :: StatusCode -> STM ()
+      setStatus status
+          = status `seq`
+            updateItr itr itrResponse
+            $! \ res -> res {
+                          resStatus = status
+                        }
+
+      completeAuthority :: Request -> STM ()
+      completeAuthority req
+          = 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
+                                  _            -> Nothing
+                         portStr
+                              = case port of
+                                  Just 80 -> Just ""
+                                  Just n  -> Just $ ":" ++ show n
+                                  Nothing -> Nothing
+                     case portStr of
+                       Just str -> updateAuthority host 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
+
+
+      parseHost :: String -> (String, String)
+      parseHost = break (== ':')
+
+
+      updateAuthority :: String -> String -> STM ()
+      updateAuthority host portStr
+          = host `seq` portStr `seq`
+            updateItr itr itrRequest
+            $! \ (Just req) -> Just req {
+                                 reqURI = let uri = reqURI req
+                                          in uri {
+                                               uriAuthority = Just URIAuth {
+                                                                   uriUserInfo = ""
+                                                                 , uriRegName  = host
+                                                                 , uriPort     = portStr
+                                                              }
+                                             }
+                               }
+                
+
+      preprocessHeader :: Interaction -> (String, String) -> STM ()
       preprocessHeader itr (name, value)
-          = case map toLower name of
+          = itr `seq` name `seq` value `seq`
+            case map toLower name of
 
               "expect"
-                  -> if value `noCaseEq` "100-continue" then
+                  -> if value `noCaseEq'` "100-continue" then
                          writeItr itr itrExpectedContinue True
                      else
-                         setStatus itr ExpectationFailed
+                         setStatus ExpectationFailed
 
               "transfer-encoding"
                   -> case map toLower value of
                        "identity" -> return ()
                        "chunked"  -> writeItr itr itrRequestIsChunked True
-                       _          -> setStatus itr NotImplemented
+                       _          -> setStatus NotImplemented
 
               "content-length"
                   -> if all isDigit value then
@@ -104,7 +157,7 @@ preprocess itr
                             writeItr itr itrReqChunkLength    $ Just len
                             writeItr itr itrReqChunkRemaining $ Just len
                      else
-                         setStatus itr BadRequest
+                         setStatus BadRequest
 
               "connection"
                   -> case map toLower value of