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

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index ef66898..7704727 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,172 +1,208 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Preprocess
-    ( preprocess
+    ( AugmentedRequest(..)
+    , RequestBodyLength(..)
+    , preprocess
     )
     where
-
-import           Control.Concurrent.STM
-import           Control.Monad
-import           Data.ByteString.Base (ByteString)
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State.Strict
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
-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
-import           Network.URI
-
-{-
-
-  * 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
-    = itr `seq`
-      do req <- readItr itr itrRequest fromJust
-
-         let reqVer = reqVersion req
-
-         if reqVer /= HttpVersion 1 0 &&
-            reqVer /= HttpVersion 1 1 then
-
-             do setStatus HttpVersionNotSupported
-                writeItr itr itrWillClose True
-
-           else
-             -- 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 NotImplemented
-                  
-                preprocessHeader itr req
+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 qualified Data.Text.Encoding as T
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.Socket
+import Network.URI
+import Prelude.Unicode
+
+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
-      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 (C8.pack str)
-                       -- FIXME: このエラーの原因は、listen してゐるソ
-                       -- ケットが INET でない故にポート番號が分からな
-                       -- い事だが、その事をどうにかして通知した方が良
-                       -- いと思ふ。stderr？
-                       Nothing  -> setStatus InternalServerError
-              else
-                  do case getHeader (C8.pack "Host") req of
-                       Just str -> let (host, portStr) = parseHost str
-                                   in updateAuthority host portStr
-                       Nothing  -> setStatus BadRequest
-
-
-      parseHost :: ByteString -> (ByteString, ByteString)
-      parseHost = C8.break (== ':')
-
-
-      updateAuthority :: ByteString -> ByteString -> 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  = C8.unpack host
-                                                                 , uriPort     = C8.unpack portStr
-                                                              }
-                                             }
-                               }
-                
-
-      preprocessHeader :: Interaction -> Request -> STM ()
-      preprocessHeader itr req
-          = itr `seq` req `seq`
-            do case getHeader (C8.pack "Expect") req of
-                 Nothing    -> return ()
-                 Just value -> if value `noCaseEq` C8.pack "100-continue" then
-                                   writeItr itr itrExpectedContinue True
-                               else
-                                   setStatus ExpectationFailed
-
-               case getHeader (C8.pack "Transfer-Encoding") req of
-                 Nothing    -> return ()
-                 Just value -> if value `noCaseEq` C8.pack "identity" then
-                                   return ()
-                               else
-                                   if value `noCaseEq` C8.pack "chunked" then
-                                       writeItr itr itrRequestIsChunked True
-                                   else
-                                       setStatus NotImplemented
-
-               case getHeader (C8.pack "Content-Length") req of
-                 Nothing    -> return ()
-                 Just value -> if C8.all isDigit value then
-                                   do let Just (len, _) = C8.readInt value
-                                      writeItr itr itrReqChunkLength    $ Just len
-                                      writeItr itr itrReqChunkRemaining $ Just len
-                               else
-                                   setStatus BadRequest
-
-               case getHeader (C8.pack "Connection") req of
-                 Nothing    -> return ()
-                 Just value -> if value `noCaseEq` C8.pack "close" then
-                                   writeItr itr itrWillClose True
-                               else
-                                   return ()
+      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 → case C8.readInt value of
+                           Just (len, garbage)
+                               | C8.null garbage ∧ len ≥ 0
+                                   → setBodyLength $ Just $ Fixed len
+                           _       → setStatus BadRequest
+
+         case getCIHeader "Connection" req of
+           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