getRequestURI should always return an absolute URI

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

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 802338c46dddbf7df1fb9fbe06c25620f5aa6075..c1f1a8b8dacc9c8e91cc21907f3053c3a55a7cda 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -8,16 +8,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 +31,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 にする。
 
@@ -48,41 +51,88 @@ import GHC.Conc (unsafeIOToSTM)
 
 preprocess :: Interaction -> STM ()
 preprocess itr
-    = do let req    = fromJust $ itrRequest itr
-             reqVer = reqVersion req
+    = 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
+      setStatus :: StatusCode -> STM ()
+      setStatus status
           = updateItr itr itrResponse
             $ \ res -> res {
                          resStatus = status
                        }
 
+      completeAuthority :: Request -> STM ()
+      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
+                                  _            -> 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
+          = updateItr itr itrRequest
+            $ \ (Just req) -> Just req {
+                                reqURI = let uri = reqURI req
+                                         in uri {
+                                              uriAuthority = Just URIAuth {
+                                                                  uriUserInfo = ""
+                                                                , uriRegName  = host
+                                                                , uriPort     = portStr
+                                                                }
+                                            }
+                              }
+                
+
       preprocessHeader itr (name, value)
           = case map toLower name of
 
@@ -90,13 +140,13 @@ preprocess itr
                   -> 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 +154,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