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

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 9321b6b..7704727 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -5,158 +5,204 @@
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Preprocess
-    ( preprocess
+    ( AugmentedRequest(..)
+    , RequestBodyLength(..)
+    , preprocess
     )
     where
 import Control.Applicative
-import Control.Concurrent.STM
 import Control.Monad
+import Control.Monad.State.Strict
 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.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
 import Data.Maybe
 import Data.Text (Text)
 import qualified Data.Text as T
-import Network.HTTP.Lucu.Config
+import qualified Data.Text.Encoding as T
 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.Socket
 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 に。
-
-  * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
-    体的には、identity でも chunked でもなければ 501 Not Implemented に
-    する。
-
-  * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
-    Not Implemented にする。
-
-  * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
-    Version Not Supported を返す。
-
-  * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
-    411 Length Required にする。
-
-  * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
-    Request にする。
-
-  * willDiscardBody その他の變數を設定する。
--}
-
-preprocess ∷ Interaction → STM ()
-preprocess itr@(Interaction {..})
-    = do req ← fromJust <$> readTVar itrRequest
-
-         let reqVer = reqVersion req
-
-         if reqVer ≢ HttpVersion 1 0 ∧
-            reqVer ≢ HttpVersion 1 1 then
-
-             do setStatus itr HttpVersionNotSupported
-                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 True
-                  POST   → writeTVar itrRequestHasBody  True
-                  PUT    → writeTVar itrRequestHasBody  True
-                  DELETE → return ()
-                  _      → setStatus itr NotImplemented
-                  
-                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
+data AugmentedRequest
+    = AugmentedRequest {
+        arRequest          ∷ !Request
+      , arInitialStatus    ∷ !SomeStatusCode
+      , arWillChunkBody    ∷ !Bool
+      , arWillDiscardBody  ∷ !Bool
+      , arWillClose        ∷ !Bool
+      , arExpectedContinue ∷ !Bool
+      , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
+      }
+
+data RequestBodyLength
+    = Fixed !Int
+    | Chunked
+    deriving (Eq, Show)
+
+preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
+preprocess localHost localPort req@(Request {..})
+    = execState go initialAR
+    where
+      initialAR ∷ AugmentedRequest
+      initialAR = AugmentedRequest {
+                    arRequest          = req
+                  , arInitialStatus    = fromStatusCode OK
+                  , arWillChunkBody    = False
+                  , arWillDiscardBody  = False
+                  , arWillClose        = False
+                  , arExpectedContinue = False
+                  , arReqBodyLength    = Nothing
+                  }
+      go ∷ State AugmentedRequest ()
+      go = do examineHttpVersion
+              examineMethod
+              examineAuthority localHost localPort
+              examineHeaders
+              examineBodyLength
+
+setRequest ∷ Request → State AugmentedRequest ()
+setRequest req
+    = modify $ \ar → ar { arRequest = req }
+
+setStatus ∷ StatusCode sc ⇒ sc → State AugmentedRequest ()
+setStatus sc
+    = modify $ \ar → ar { arInitialStatus = fromStatusCode sc }
+
+setWillClose ∷ Bool → State AugmentedRequest ()
+setWillClose b
+    = modify $ \ar → ar { arWillClose = b }
+
+setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength len
+    = modify $ \ar → ar { arReqBodyLength = len }
+
+examineHttpVersion ∷ State AugmentedRequest ()
+examineHttpVersion
+    = do req ← gets arRequest
+         case reqVersion req of
+           -- HTTP/1.0 requests can't Keep-Alive.
+           HttpVersion 1 0
+               → setWillClose True
+           HttpVersion 1 1
+               → modify $ \ar → ar { arWillChunkBody = True }
+           _   → do setStatus    HTTPVersionNotSupported
+                    setWillClose True
+
+examineMethod ∷ State AugmentedRequest ()
+examineMethod
+    = do req ← gets arRequest
+         case reqMethod req of
+           GET    → return ()
+           HEAD   → modify $ \ar → ar { arWillDiscardBody = True }
+           POST   → return ()
+           PUT    → return ()
+           DELETE → return ()
+           _      → setStatus NotImplemented
+
+examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
+examineAuthority localHost localPort
+    = do req ← gets arRequest
+         when (isNothing $ uriAuthority $ reqURI req) $
+             case reqVersion req of
+               -- HTTP/1.0 requests have no Host header so complete it
+               -- with the configuration value.
+               HttpVersion 1 0
+                   → let host = localHost
+                         port = case localPort of
+                                  80 → ""
+                                  n  → A.unsafeFromString $ ':':show n
+                         req' = updateAuthority host port req
+                     in
+                       setRequest req'
+               -- HTTP/1.1 requests MUST have a Host header.
+               HttpVersion 1 1
+                   → case getHeader "Host" req of
+                        Just str
+                            → let (host, port)
+                                       = parseHost str
+                                  req' = updateAuthority host port req
+                              in
+                                setRequest req'
+                        Nothing
+                            → setStatus BadRequest
+               -- Should never reach here...
+               ver → fail ("internal error: unknown version: " ⧺ show ver)
+
+parseHost ∷ Ascii → (CI Text, Ascii)
+parseHost hp
+    = let (h, p) = C8.break (≡ ':') $ cs hp
+          -- FIXME: should decode punycode here.
+          hText  = CI.mk $ T.decodeUtf8 h
+          pAscii = A.unsafeFromByteString p
+      in
+        (hText, pAscii)
+
+updateAuthority ∷ CI Text → Ascii → Request → Request
+updateAuthority host port req
+    = let uri  = reqURI req
+          uri' = uri {
+                   uriAuthority = Just URIAuth {
+                                    uriUserInfo = ""
+                                  , uriRegName  = T.unpack $ CI.original host
+                                  , uriPort     = cs port
+                                  }
+                 }
+      in
+        req { reqURI = uri' }
+
+examineHeaders ∷ State AugmentedRequest ()
+examineHeaders
+    = do req ← gets arRequest
+
+         case getCIHeader "Expect" req of
+           Nothing → return ()
+           Just v
+               | v ≡ "100-continue"
+                   → modify $ \ar → ar { arExpectedContinue = True }
+               | otherwise
+                   → setStatus ExpectationFailed
 
          case getCIHeader "Transfer-Encoding" req of
+           Nothing → return ()
+           Just v
+               | v ≡ "identity"
+                   → return ()
+               | v ≡ "chunked"
+                   → setBodyLength $ Just Chunked
+               | otherwise
+                   → setStatus NotImplemented
+
+         case cs <$> getHeader "Content-Length" 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
+           Just value → case C8.readInt value of
+                           Just (len, garbage)
+                               | C8.null garbage ∧ len ≥ 0
+                                   → setBodyLength $ Just $ Fixed len
+                           _       → setStatus BadRequest
 
          case getCIHeader "Connection" req of
-           Nothing    → return ()
-           Just value → when (value ≡ "close")
-                            $ writeTVar itrWillClose True
+           Just v
+               | v ≡ "close"
+                   → setWillClose True
+           _       → return ()
+
+examineBodyLength ∷ State AugmentedRequest ()
+examineBodyLength
+    = do req ← gets arRequest
+         len ← gets arReqBodyLength
+         if reqMustHaveBody req then
+             -- POST and PUT requests must have an entity body.
+             when (isNothing len)
+                 $ setStatus LengthRequired
+         else
+             -- Other requests must NOT have an entity body.
+             when (isJust len)
+                 $ setStatus BadRequest