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

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 802338c..9321b6b 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,22 +1,40 @@
--- #hide
+{-# LANGUAGE
+    DoAndIfThenElse
+  , OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Preprocess
     ( 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 に。
@@ -25,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 にする。
 
@@ -41,74 +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
-                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
+                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 -> writeItr itr itrWillDiscardBody True
-                  POST -> writeItr itr itrRequestHasBody True
-                  PUT  -> writeItr itr itrRequestHasBody True
-                  _    -> 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
-      setStatus itr status
-          = updateItr itr itrResponse
-            $ \ res -> res {
-                         resStatus = status
-                       }
-
-      preprocessHeader itr (name, value)
-          = case map toLower name of
-
-              "expect"
-                  -> if value `noCaseEq` "100-continue" then
-                         writeItr itr itrExpectedContinue True
-                     else
-                         setStatus itr ExpectationFailed
-
-              "transfer-encoding"
-                  -> case map toLower value of
-                       "identity" -> return ()
-                       "chunked"  -> writeItr itr itrRequestIsChunked True
-                       _          -> setStatus itr 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 itr BadRequest
-
-              "connection"
-                  -> case map toLower value of
-                       "close"      -> writeItr itr itrWillClose 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