X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=9321b6bc78e4570b0745334e9994866fcf0185f2;hb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;hp=e8fdfc630b20bf4dea3de677f6daeb392d7fd852;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index e8fdfc6..9321b6b 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,21 +1,40 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Preprocess
-    ( preprocess -- Interaction -> STM ()
+    ( preprocess
     )
     where
-
-import           Control.Concurrent.STM
-import           Control.Monad
-import           Data.Char
-import           Data.Maybe
-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.URI
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as C8
+import Data.Char
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+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.URI
+import Prelude.Unicode
 
 {-
+  TODO: Tanslate this memo into English. It doesn't make sense to
+  non-Japanese speakers.
+
+  * URI にホスト名が存在しない時、
+    [1] HTTP/1.0 ならば Config を使って補完
+    [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
 
   * Expect: に問題があった場合は 417 Expectation Failed に設定。
     100-continue 以外のものは全部 417 に。
@@ -24,9 +43,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 にする。
 
@@ -40,83 +56,107 @@ import           Network.URI
     Request にする。
 
   * willDiscardBody その他の變數を設定する。
-
 -}
 
-import GHC.Conc (unsafeIOToSTM)
+preprocess ∷ Interaction → STM ()
+preprocess itr@(Interaction {..})
+    = do req ← fromJust <$> readTVar itrRequest
 
-preprocess :: Interaction -> STM ()
-preprocess itr
-    = do let req    = fromJust $ itrRequest itr
-             reqVer = reqVersion req
+         let reqVer = reqVersion req
 
-         if reqVer /= HttpVersion 1 0 &&
-            reqVer /= HttpVersion 1 1 then
+         if reqVer ≢ HttpVersion 1 0 ∧
+            reqVer ≢ HttpVersion 1 1 then
 
              do setStatus itr HttpVersionNotSupported
-                writeTVar (itrWillClose itr) True
-
-           else
-             do if reqVer == HttpVersion 1 0 then
-                    -- HTTP/1.0 では Keep-Alive できない
-                    writeTVar (itrWillClose itr) True
-                  else
-                    -- URI または Host: ヘッダのどちらかにホストが無ければ
-                    -- ならない。
-                    when (uriAuthority (reqURI req) == Nothing &&
-                          getHeader req "Host"      == Nothing)
-                             $ setStatus itr BadRequest
+                writeTVar itrWillClose True
+
+         else
+             -- HTTP/1.0 では Keep-Alive できない
+             do when (reqVer ≡ HttpVersion 1 0)
+                     $ writeTVar itrWillClose True
+
+                -- ホスト部の補完
+                completeAuthority itr req
 
                 case reqMethod req of
-                  GET  -> return ()
-                  HEAD -> writeTVar (itrWillDiscardBody itr) True
-                  POST -> ensureHavingBody itr
-                  PUT  -> ensureHavingBody itr
-                  _    -> setStatus itr NotImplemented
+                  GET    → return ()
+                  HEAD   → writeTVar itrWillDiscardBody True
+                  POST   → writeTVar itrRequestHasBody  True
+                  PUT    → writeTVar itrRequestHasBody  True
+                  DELETE → return ()
+                  _      → setStatus itr NotImplemented
                   
-                mapM_ (preprocessHeader itr) (reqHeaders req)
-    where
-      ensureHavingBody itr
-          = let req = fromJust $ itrRequest itr
-            in
-              if getHeader req "Content-Length"    == Nothing &&
-                 getHeader req "Transfer-Encoding" == Nothing then
-
-                  setStatus itr LengthRequired
-              else
-                  writeTVar (itrRequestHasBody itr) True
-
-      setStatus itr status
-          = writeTVar (itrResponse itr) (Just $ Response {
-                                                    resVersion = HttpVersion 1 1
-                                                  , resStatus  = status
-                                                  , resHeaders = []
-                                                  })
-
-      preprocessHeader itr (name, value)
-          = case map toLower name of
-
-              "expect"
-                  -> if value `noCaseEq` "100-continue" then
-                         writeTVar (itrExpectedContinue itr) True
-                     else
-                         setStatus itr ExpectationFailed
-
-              "transfer-encoding"
-                  -> case map toLower value of
-                       "identity" -> return ()
-                       "chunked"  -> writeTVar (itrRequestIsChunked itr) True
-                       _          -> setStatus itr NotImplemented
-
-              "content-length"
-                  -> if all isDigit value then
-                         writeTVar (itrRequestBodyLength itr) (Just $ read value)
-                     else
-                         setStatus itr BadRequest
-
-              "connection"
-                  -> case map toLower value of
-                       "close"      -> writeTVar (itrWillClose itr) True
-                       _            -> return ()
-
-              _ -> return ()
\ No newline at end of file
+                preprocessHeader itr req
+
+setStatus ∷ Interaction → StatusCode → STM ()
+setStatus (Interaction {..}) sc
+    = do res ← readTVar itrResponse
+         let res' = res {
+                      resStatus = sc
+                    }
+         writeTVar itrResponse res'
+
+completeAuthority ∷ Interaction → Request → STM ()
+completeAuthority itr@(Interaction {..}) req
+    = when (isNothing $ uriAuthority $ reqURI req)
+          $ if reqVersion req == HttpVersion 1 0 then
+                -- HTTP/1.0 なので Config から補完
+                do let host    = cnfServerHost itrConfig
+                       portStr = case itrLocalPort of
+                                   80 → ""
+                                   n  → ':' : show n
+                   updateAuthority host $ A.unsafeFromString portStr
+            else
+                case getHeader "Host" req of
+                  Just str → let (host, portStr) = parseHost str
+                             in
+                               updateAuthority host portStr
+                  Nothing  → setStatus itr BadRequest
+
+parseHost ∷ Ascii → (Text, Ascii)
+parseHost = C8.break (≡ ':')
+
+updateAuthority ∷ Text → Ascii → STM ()
+updateAuthority host portStr
+    = do Just req ← readTVar itrRequest
+         let uri  = reqURI req
+             uri' = uri {
+                      uriAuthority = Just URIAuth {
+                                       uriUserInfo = ""
+                                     , uriRegName  = T.unpack host
+                                     , uriPort     = A.toString portStr
+                                     }
+                    }
+             req' = req { reqURI = uri' }
+         writeTVar itrRequest $ Just req'
+
+preprocessHeader ∷ Interaction → Request → STM ()
+preprocessHeader (Interaction {..}) req
+    = do case getCIHeader "Expect" req of
+           Nothing    → return ()
+           Just value → if value ≡ "100-continue" then
+                             writeTVar itrExpectedContinue True
+                         else
+                             setStatus ExpectationFailed
+
+         case getCIHeader "Transfer-Encoding" req of
+           Nothing    → return ()
+           Just value → unless (value ≡ "identity")
+                            $ if value ≡ "chunked" then
+                                  writeTVar itrRequestIsChunked True
+                              else
+                                  setStatus NotImplemented
+
+         case getHeader "Content-Length" req of
+           Nothing    → return ()
+           Just value → if C8.all isDigit value then
+                            do let Just (len, _) = C8.readInt value
+                               writeTVar itrReqChunkLength    $ Just len
+                               writeTVar itrReqChunkRemaining $ Just len
+                        else
+                            setStatus BadRequest
+
+         case getCIHeader "Connection" req of
+           Nothing    → return ()
+           Just value → when (value ≡ "close")
+                            $ writeTVar itrWillClose True