Many improvements: still in early development

darcs-hash:20070325114005-62b54-2cf24fc0b33bbe817bc9ece8067c40da5e63a1c4.gz

diff --git a/Lucu.cabal b/Lucu.cabal
index b04dc16d27ab1bd3939ec275ab5472b449f7b92d..121740b45911e2ce0ba118075d8f36b9c2f5385a 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -6,7 +6,7 @@ Author: PHO
 Homepage: http://ccm.sherry.jp/
 Category: Incomplete
 Build-Depends:
 Homepage: http://ccm.sherry.jp/
 Category: Incomplete
 Build-Depends:

-         base, mtl, network
+         base, mtl, network, stm, parsec

 Exposed-Modules:
         Network.HTTP.Lucu.Config
         Network.HTTP.Lucu.Headers
 Exposed-Modules:
         Network.HTTP.Lucu.Config
         Network.HTTP.Lucu.Headers


@@ -15,7 +15,9 @@ Exposed-Modules:
         Network.HTTP.Lucu.Response
         Network.HTTP.Lucu.Resource
         Network.HTTP.Lucu.Request
         Network.HTTP.Lucu.Response
         Network.HTTP.Lucu.Resource
         Network.HTTP.Lucu.Request

+ghc-options: -threaded

 
 Executable: HelloWorld
 Main-Is: HelloWorld.hs
 Hs-Source-Dirs: ., examples
 
 Executable: HelloWorld
 Main-Is: HelloWorld.hs
 Hs-Source-Dirs: ., examples

+ghc-options: -threaded
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs
index 919e1344a8950ad4f445a07cf3bc041f1d3c7fc6..2d37022d54072c6ec374d9aee909dfb765538f9c 100644 (file)
--- a/Network/HTTP/Lucu/Config.hs
+++ b/Network/HTTP/Lucu/Config.hs
@@ -7,13 +7,15 @@ module Network.HTTP.Lucu.Config
 import Network
 
 data Config = Config {
 import Network
 
 data Config = Config {

-      cnfServerPort      :: PortID
-    , cnfMaxEntityLength :: Integer
-    , cnfMaxURILength    :: Int
+      cnfServerPort       :: PortID
+    , cnfMaxPipelineDepth :: Int
+    , cnfMaxEntityLength  :: Integer
+    , cnfMaxURILength     :: Int

     }
 
 defaultConfig = Config {
     }
 
 defaultConfig = Config {

-                  cnfServerPort      = Service "http"
-                , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
-                , cnfMaxURILength    = 4 * 1024         -- 4 KiB
+                  cnfServerPort       = Service "http"
+                , cnfMaxPipelineDepth = 100
+                , cnfMaxEntityLength  = 16 * 1024 * 1024 -- 16 MiB
+                , cnfMaxURILength     = 4 * 1024         -- 4 KiB

                 }
\ No newline at end of file
                 }
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index fbab8563852c1efc56e6bab72006257934340938..655252cc4b656c39abcb92252a276ffc1d94e638 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,34 +1,38 @@
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)

-    , emptyHeaders   -- Headers
+    , emptyHeaders -- Headers
+    , headersP     -- Parser Headers
+    , hPutHeaders  -- Handle -> Headers -> IO ()

     )
     where
 
     )
     where
 

-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)

 import           Data.Char
 import           Data.List
 import           Data.Char
 import           Data.List

+import           Network.HTTP.Lucu.Parser
+import           Network.HTTP.Lucu.Parser.Http
+import           Network.HTTP.Lucu.Utils
+import           System.IO

 
 

-type Headers = [ (ByteString, ByteString) ]
+type Headers = [ (String, String) ]

 
 class HasHeaders a where
     getHeaders :: a -> Headers
     setHeaders :: a -> Headers -> a
 
 
 class HasHeaders a where
     getHeaders :: a -> Headers
     setHeaders :: a -> Headers -> a
 

-    getHeader :: a -> ByteString -> Maybe ByteString
+    getHeader :: a -> String -> Maybe String

     getHeader a key
         = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
 
     getHeader a key
         = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
 

-    deleteHeader :: a -> ByteString -> a
+    deleteHeader :: a -> String -> a

     deleteHeader a key
         = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
 
     deleteHeader a key
         = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
 

-    addHeader :: a -> ByteString -> ByteString -> a
+    addHeader :: a -> String -> String -> a

     addHeader a key val
         = setHeaders a $ (getHeaders a) ++ [(key, val)]
 
     addHeader a key val
         = setHeaders a $ (getHeaders a) ++ [(key, val)]
 

-    setHeader :: a -> ByteString -> ByteString -> a
+    setHeader :: a -> String -> String -> a

     setHeader a key val
         = let list    = getHeaders a
               deleted = filter (not . noCaseEq key . fst) list
     setHeader a key val
         = let list    = getHeaders a
               deleted = filter (not . noCaseEq key . fst) list


@@ -36,10 +40,53 @@ class HasHeaders a where
           in 
             setHeaders a added
 
           in 
             setHeaders a added
 

-noCaseEq :: ByteString -> ByteString -> Bool
-noCaseEq a b
-    = (B.map toLower a) == (B.map toLower b)
+emptyHeaders :: Headers
+emptyHeaders = []

 
 
 
 

-emptyHeaders :: Headers
-emptyHeaders = []
\ No newline at end of file
+{-
+  message-header = field-name ":" [ field-value ]
+  field-name     = token
+  field-value    = *( field-content | LWS )
+  field-content  = <field-value を構成し、*TEXT あるいは
+                    token, separators, quoted-string を連結
+                    したものから成る OCTET>
+
+  field-value の先頭および末尾にある LWS は全て削除され、それ以外の
+  LWS は單一の SP に變換される。
+-}
+headersP :: Parser Headers
+headersP = do xs <- many header
+              crlf
+              return xs
+    where
+      header :: Parser (String, String)
+      header = do name <- token
+                  char ':'
+                  -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
+                  -- の記述はひどく曖昧であり、この動作が本當に間違って
+                  -- ゐるのかどうかも良く分からない。例へば
+                  -- quoted-string の内部にある空白は纏めていいのか惡い
+                  -- のか？直勸的には駄目さうに思へるが、そんな記述は見
+                  -- 付からない。
+                  contents <- many (lws <|> many1 text)
+                  crlf
+                  let value = foldr (++) "" contents
+                  return (name, normalize value)
+
+      normalize :: String -> String
+      normalize = trimBody . trim isWhiteSpace
+
+      trimBody = nubBy (\ a b -> a == ' ' && b == ' ')
+                 . map (\ c -> if isWhiteSpace c
+                               then ' '
+                               else c)
+
+
+hPutHeaders :: Handle -> Headers -> IO ()
+hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
+    where
+      putH (name, value) = do hPutStr h name
+                              hPutStr h ": "
+                              hPutStr h value
+                              hPutStr h "\r\n"

diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
index 88dc24e5b61673726da5f31e70d184e42b9cf48f..9b955d37fd9644beb912feb1808a1f2982dd97b9 100644 (file)
--- a/Network/HTTP/Lucu/HttpVersion.hs
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -1,15 +1,20 @@
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)

-    , httpVersionP -- Parser HttpVersion
+    , httpVersionP    -- Parser HttpVersion
+    , hPutHttpVersion -- Handle -> HttpVersion -> IO ()

     )
     where
 
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Network.HTTP.Lucu.Parser
     )
     where
 
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Network.HTTP.Lucu.Parser

+import           System.IO

 
 data HttpVersion = HttpVersion Int Int
 
 data HttpVersion = HttpVersion Int Int

-                   deriving (Show, Eq)
+                   deriving (Eq)
+
+instance Show HttpVersion where
+    show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min

 
 instance Ord HttpVersion where
     (HttpVersion majA minA) `compare` (HttpVersion majB minB)
 
 instance Ord HttpVersion where
     (HttpVersion majA minA) `compare` (HttpVersion majB minB)


@@ -27,3 +32,10 @@ httpVersionP = do string "HTTP/"
                   minor <- many1 digit
                   return $ HttpVersion (read major) (read minor)
 
                   minor <- many1 digit
                   return $ HttpVersion (read major) (read minor)
 

+
+hPutHttpVersion :: Handle -> HttpVersion -> IO ()
+hPutHttpVersion h (HttpVersion maj min)
+    = do hPutStr  h "HTTP/"
+         hPutStr  h (show maj)
+         hPutChar h '.'
+         hPutStr  h (show min)
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
index 70df37766c209bbd6c0e5cbde3bb115e46beecfe..8fc36ac3c50b24500a1f1f6f824c9bd866321863 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -1,32 +1,22 @@
 module Network.HTTP.Lucu.Httpd
 module Network.HTTP.Lucu.Httpd

-    ( ResourceTable
-    , mkResourceTable -- [ ([String], Resource ()) ] -> ResourceTable
-    , runHttpd        -- Config -> ResourceTable -> IO ()
+    ( runHttpd        -- Config -> ResTree -> IO ()

     )
     where
 
 import           Control.Concurrent
     )
     where
 
 import           Control.Concurrent

+import           Control.Concurrent.STM

 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)

-import           Data.Map as M
-import           Data.Map (Map)

 import           Network
 import           Network.HTTP.Lucu.Config
 import           Network
 import           Network.HTTP.Lucu.Config

-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Request
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.RequestReader

 import           Network.HTTP.Lucu.Resource
 import           Network.HTTP.Lucu.Resource

-import           Network.HTTP.Lucu.Response
+import           Network.HTTP.Lucu.ResponseWriter

 import           System.IO
 
 
 import           System.IO
 
 

-type ResourceTable = Map [String] (Resource ())
-
-
-mkResourceTable :: [ ([String], Resource ()) ] -> ResourceTable
-mkResourceTable = M.fromList
-
-
-runHttpd :: Config -> ResourceTable -> IO ()
+runHttpd :: Config -> ResTree -> IO ()

 runHttpd cnf table
     = withSocketsDo $
       do so <- listenOn (cnfServerPort cnf)
 runHttpd cnf table
     = withSocketsDo $
       do so <- listenOn (cnfServerPort cnf)


@@ -34,19 +24,8 @@ runHttpd cnf table
     where
       loop :: Socket -> IO ()
       loop so
     where
       loop :: Socket -> IO ()
       loop so

-          = do (h, host, port) <- accept so
-               forkIO $ service h host port
+          = do (h, host, _) <- accept so
+               tQueue       <- newInteractionQueue
+               forkIO $ requestReader cnf table h host tQueue
+               forkIO $ responseWriter h tQueue

                loop so
                loop so

-
-
-service :: Handle -> HostName -> PortNumber -> IO ()
-service h host port
-    = do input <- B.hGetContents h
-         loop input
-    where
-      loop :: ByteString -> IO ()
-      loop input = case parse requestP input of
-                     Nothing
-                         -> fail "FIXME"
-                     Just (req, input')
-                         -> print req

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
new file mode 100644 (file)
index 0000000..44f4243
--- /dev/null
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -0,0 +1,101 @@
+module Network.HTTP.Lucu.Interaction
+    ( Interaction(..)
+    , InteractionState(..)
+    , InteractionQueue
+    , newInteractionQueue -- IO InteractionQueue
+    , newInteraction      -- HostName -> Maybe Request -> IO Interaction
+    )
+    where
+
+import           Control.Concurrent.STM
+import qualified Data.ByteString.Lazy.Char8 as B
+import           Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.Sequence as S
+import           Data.Sequence (Seq)
+import           Network
+import           Network.HTTP.Lucu.Request
+import           Network.HTTP.Lucu.Response
+
+data Interaction = Interaction {
+      itrRemoteHost  :: HostName
+    , itrRequest     :: Maybe Request
+    , itrResponse    :: TVar (Maybe Response)
+
+    , itrRequestHasBody    :: TVar Bool
+    , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
+    , itrRequestIsChunked  :: TVar Bool
+    , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
+    
+    , itrExpectedContinue  :: TVar Bool
+
+    , itrWillChunkBody    :: TVar Bool
+    , itrWillDiscardBody  :: TVar Bool
+    , itrWillClose        :: TVar Bool
+    , itrBodyToSend       :: TVar ByteString
+
+    , itrState :: TVar InteractionState
+
+    , itrWroteContinue :: TVar Bool
+    , itrWroteHeader   :: TVar Bool
+    }
+
+-- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
+-- 状態は ExaminingHeader (リクエストボディが有る時) または
+-- DecidingHeader (無い時)。終了状態は常に Done
+data InteractionState = ExaminingHeader
+                      | GettingBody
+                      | DecidingHeader
+                      | DecidingBody
+                      | Done
+                        deriving (Show, Eq, Ord)
+
+type InteractionQueue = TVar (Seq Interaction)
+
+
+newInteractionQueue :: IO InteractionQueue
+newInteractionQueue = newTVarIO S.empty
+
+
+newInteraction :: HostName -> Maybe Request -> IO Interaction
+newInteraction host req
+    = do responce <- newTVarIO Nothing
+
+         requestHasBody    <- newTVarIO False
+         requestBodyLength <- newTVarIO Nothing
+         requestIsChunked  <- newTVarIO False
+         receivedBody      <- newTVarIO B.empty
+
+         expectedContinue <- newTVarIO False
+
+         willChunkBody   <- newTVarIO False
+         willDiscardBody <- newTVarIO False
+         willClose       <- newTVarIO False
+         bodyToSend      <- newTVarIO B.empty
+
+         state <- newTVarIO undefined
+
+         wroteContinue <- newTVarIO False
+         wroteHeader   <- newTVarIO False
+
+         return $ Interaction {
+                      itrRemoteHost = host
+                    , itrRequest    = req
+                    , itrResponse   = responce
+
+                    , itrRequestHasBody    = requestHasBody
+                    , itrRequestBodyLength = requestBodyLength
+                    , itrRequestIsChunked  = requestIsChunked
+                    , itrReceivedBody      = receivedBody
+
+                    , itrExpectedContinue = expectedContinue
+
+                    , itrWillChunkBody    = willChunkBody
+                    , itrWillDiscardBody  = willDiscardBody
+                    , itrWillClose        = willClose
+                    , itrBodyToSend       = bodyToSend
+                    
+                    , itrState = state
+                    
+                    , itrWroteContinue = wroteContinue
+                    , itrWroteHeader   = wroteHeader
+                    }

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 7a51ddcab435aa75cfcfc2904370bd104f8caef9..3fa4c150e669dd088112efaf4f7f457fb36add83 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -13,7 +13,9 @@ module Network.HTTP.Lucu.Parser
     , many1     -- Parser a -> Parser [a]
     , manyTill  -- Parser a -> Parser end -> Parser [a]
     , many1Till -- Parser a -> Parser end -> Parser [a]
     , many1     -- Parser a -> Parser [a]
     , manyTill  -- Parser a -> Parser end -> Parser [a]
     , many1Till -- Parser a -> Parser end -> Parser [a]

+    , option    -- a -> Parser a -> Parser a

     , sp        -- Parser Char
     , sp        -- Parser Char

+    , ht        -- Parser Char

     , crlf      -- Parser String
     )
     where
     , crlf      -- Parser String
     )
     where


@@ -121,9 +123,17 @@ many1Till p end = many1 $ do x <- p
                              return x
 
 
                              return x
 
 

+option :: a -> Parser a -> Parser a
+option def p = p <|> return def
+
+

 sp :: Parser Char
 sp = char ' '
 
 
 sp :: Parser Char
 sp = char ' '
 
 

+ht :: Parser Char
+ht = char '\t'
+
+

 crlf :: Parser String
 crlf = string "\x0d\x0a"
 crlf :: Parser String
 crlf = string "\x0d\x0a"

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index 021ced85d9856cef8d48d7ffb3bcef4575854ffa..c1b30fc208c1d6bbbb787911f642c52de7ef3288 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,7 +1,12 @@
 module Network.HTTP.Lucu.Parser.Http
     ( isCtl       -- Char -> Bool
     , isSeparator -- Char -> Bool
 module Network.HTTP.Lucu.Parser.Http
     ( isCtl       -- Char -> Bool
     , isSeparator -- Char -> Bool

-    , token       -- Parser Char
+    , isChar      -- Char -> Bool
+    , token       -- Parser String
+    , lws         -- Parser String
+    , text        -- Parser Char
+    , separator   -- Parser Char
+    , quotedStr   -- Parser String

     )
     where
 
     )
     where
 


@@ -21,5 +26,41 @@ isSeparator :: Char -> Bool
 isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
 
 
 isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
 
 

-token :: Parser Char
-token = satisfy (\ c -> not (isCtl c || isSeparator c))
+isChar :: Char -> Bool
+isChar c
+    | c <= '\x7f' = True
+    | otherwise   = False
+
+
+token :: Parser String
+token = many1 $ satisfy (\ c -> not (isCtl c || isSeparator c))
+
+
+lws :: Parser String
+lws = do s  <- option "" crlf
+         xs <- many1 (sp <|> ht)
+         return (s ++ xs)
+
+
+text :: Parser Char
+text = satisfy (\ c -> not (isCtl c))
+
+
+separator :: Parser Char
+separator = satisfy isSeparator
+
+
+quotedStr :: Parser String
+quotedStr = do char '"'
+               xs <- many (qdtext <|> quotedPair)
+               char '"'
+               return $ foldr (++) "" (["\""] ++ xs ++ ["\""])
+    where
+      qdtext = char '"' >> fail ""
+               <|>
+               do c <- text
+                  return [c]
+
+      quotedPair = do q <- char '\\'
+                      c <- satisfy isChar
+                      return [q, c]

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
new file mode 100644 (file)
index 0000000..b7b910f
--- /dev/null
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -0,0 +1,139 @@
+module Network.HTTP.Lucu.Postprocess
+    ( postprocess -- Interaction -> STM ()
+    , completeUnconditionalHeaders -- Response -> IO Response
+    )
+    where
+
+import           Control.Concurrent.STM
+import           Control.Monad
+import           Data.Char
+import           Data.Maybe
+import           GHC.Conc (unsafeIOToSTM)
+import           Network.HTTP.Lucu.Headers
+import           Network.HTTP.Lucu.HttpVersion
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.RFC1123DateTime
+import           Network.HTTP.Lucu.Request
+import           Network.HTTP.Lucu.Response
+import           Network.HTTP.Lucu.Utils
+import           System.Time
+
+{-
+  
+  * Response が未設定なら、HTTP/1.1 500 Internal Server Error にする。
+
+  * Content-Length があれば、それを削除する。
+
+  * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の
+    最後の要素が chunked でなければ 500 Internal Error にする。
+    Transfer-Encoding が未設定であれば、chunked に設定する。
+
+  * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
+    Error にする。但し identity だけは許す。
+
+  * body を持つ事が出來る時、Content-Type が無ければ
+    application/octet-stream にする。出來ない時、HEAD でなければ
+    Content-Type を削除する。
+
+  * body を持つ事が出來ない時、body 破棄フラグを立てる。
+
+  * Connection: close が設定されてゐる時、切斷フラグを立てる。
+
+  * 切斷フラグが立ってゐる時、Connection: close を設定する。
+
+  * Server が無ければ設定。
+
+  * Date が無ければ設定。
+
+-}
+
+{- Postprocess は body を補完した後で實行する事 -}
+
+postprocess :: Interaction -> STM ()
+postprocess itr
+    = do res <- readTVar (itrResponse itr)
+
+         when (res == Nothing)
+              $ setStatus itr InternalServerError
+
+         when (itrRequest itr /= Nothing)
+              $ relyOnRequest itr
+
+         do oldRes <- readTVar (itrResponse itr)
+            newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
+            setRes itr newRes
+    where
+      relyOnRequest itr
+          = do resM <- readTVar (itrResponse itr)
+
+               let req         = fromJust $ itrRequest itr
+                   reqVer      = reqVersion req
+                   res         = fromJust resM
+                   status      = resStatus res
+                   canHaveBody = if reqMethod req == HEAD then
+                                     False
+                                 else
+                                     isInformational status ||
+                                     status == NoContent    ||
+                                     status == ResetContent ||
+                                     status == NotModified
+
+               setRes itr (deleteHeader res "Content-Length")
+
+               if canHaveBody then
+                   do if reqVer == HttpVersion 1 1 then
+
+                          case getHeader res "Transfer-Encoding" of
+                            Nothing -> setRes itr (setHeader res "Transfer-Encoding" "chunked")
+                            Just te -> let teList = [trim isWhiteSpace x
+                                                         | x <- splitBy (== ',') (map toLower te)]
+                                       in
+                                         when (teList == [] || last teList /= "chunked")
+                                                  $ setStatus itr InternalServerError
+                        else
+                          case getHeader res "Transfer-Encoding" of
+                            Nothing         -> return ()
+                            Just "identity" -> return ()
+                            _               -> setStatus itr InternalServerError
+                
+                      when (getHeader res "Content-Type" == Nothing)
+                               $ setRes itr (setHeader res "Content-Type" "application/octet-stream")
+                 else
+                   -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
+                   do setRes itr (deleteHeader res "Transfer-Encoding")
+                      when (reqMethod req /= HEAD)
+                               $ setRes itr (deleteHeader res "Content-Type")
+
+               if fmap (map toLower) (getHeader res "Connection") == Just "close" then
+                   writeTVar (itrWillClose itr) True
+                 else
+                   setRes itr (setHeader res "Connection" "close")
+
+               when (reqMethod req == HEAD || not canHaveBody)
+                        $ writeTVar (itrWillDiscardBody itr) True
+
+      setStatus itr status
+          = writeTVar (itrResponse itr) (Just $ Response {
+                                                    resVersion = HttpVersion 1 1
+                                                  , resStatus  = status
+                                                  , resHeaders = []
+                                                  })
+
+      setRes itr res
+          = writeTVar (itrResponse itr) (Just res)
+
+
+completeUnconditionalHeaders :: Response -> IO Response
+completeUnconditionalHeaders res
+    = return res >>= compServer >>= compDate >>= return
+      where
+        compServer res
+            = case getHeader res "Server" of
+                Nothing -> return $ addHeader res "Server" "Lucu/1.0"
+                Just _  -> return res
+
+        compDate res
+            = case getHeader res "Date" of
+                Nothing -> do time <- getClockTime
+                              return $ addHeader res "Date" $ formatHTTPDateTime time
+                Just _  -> return res
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
new file mode 100644 (file)
index 0000000..e8fdfc6
--- /dev/null
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -0,0 +1,122 @@
+module Network.HTTP.Lucu.Preprocess
+    ( preprocess -- Interaction -> STM ()
+    )
+    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
+
+{-
+
+  * Expect: に問題があった場合は 417 Expectation Failed に設定。
+    100-continue 以外のものは全部 417 に。
+
+  * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
+    体的には、identity でも chunked でもなければ 501 Not Implemented に
+    する。
+
+  * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
+    場合には 400 Bad Request にする。
+
+  * メソッドが 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 その他の變數を設定する。
+
+-}
+
+import GHC.Conc (unsafeIOToSTM)
+
+preprocess :: Interaction -> STM ()
+preprocess itr
+    = do let req    = fromJust $ itrRequest itr
+             reqVer = reqVersion req
+
+         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
+
+                case reqMethod req of
+                  GET  -> return ()
+                  HEAD -> writeTVar (itrWillDiscardBody itr) True
+                  POST -> ensureHavingBody itr
+                  PUT  -> ensureHavingBody itr
+                  _    -> 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

diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs
new file mode 100644 (file)
index 0000000..9c58e51
--- /dev/null
+++ b/Network/HTTP/Lucu/RFC1123DateTime.hs
@@ -0,0 +1,75 @@
+module Network.HTTP.Lucu.RFC1123DateTime
+    ( formatRFC1123DateTime -- CalendarTime -> String
+    , formatHTTPDateTime    -- ClockTime -> String
+    , parseHTTPDateTime     -- String -> Maybe ClockTime
+    )
+    where
+
+import Control.Monad
+import System.Time
+import System.Locale
+import Text.ParserCombinators.Parsec
+import Text.Printf
+
+month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
+week  = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+
+formatRFC1123DateTime :: CalendarTime -> String
+formatRFC1123DateTime time
+    = printf "%s, %02d %s %04d %02d:%02d:%02d %s"
+      (week     !! fromEnum (ctWDay  time))
+      (ctDay    time)
+      (month    !! fromEnum (ctMonth time))
+      (ctYear   time)
+      (ctHour   time)
+      (ctMin    time)
+      (ctSec    time)
+      (ctTZName time)
+
+
+formatHTTPDateTime :: ClockTime -> String
+formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime
+
+
+parseHTTPDateTime :: String -> Maybe ClockTime
+parseHTTPDateTime src
+    = case parse httpDateTime "" src of
+        Right ct  -> Just ct
+        Left  err -> Nothing
+
+httpDateTime :: Parser ClockTime
+httpDateTime = do foldl (<|>) (unexpected "") (map (try . string) week)
+                  char ','
+                  char ' '
+                  day  <- liftM read (count 2 digit)
+                  char ' '
+                  mon  <- foldl (<|>) (unexpected "") (map tryEqToFst (zip month [1..]))
+                  char ' '
+                  year <- liftM read (count 4 digit)
+                  char ' '
+                  hour <- liftM read (count 2 digit)
+                  char ':'
+                  min  <- liftM read (count 2 digit)
+                  char ':'
+                  sec  <- liftM read (count 2 digit)
+                  char ' '
+                  string "GMT"
+                  eof
+                  return $ toClockTime $ CalendarTime {
+                               ctYear    = year
+                             , ctMonth   = toEnum (mon - 1)
+                             , ctDay     = day
+                             , ctHour    = hour
+                             , ctMin     = min
+                             , ctSec     = sec
+                             , ctPicosec = 0
+                             , ctTZ      = 0
+                             , ctWDay    = undefined
+                             , ctYDay    = undefined
+                             , ctTZName  = undefined
+                             , ctIsDST   = undefined
+                             }
+    where
+      tryEqToFst :: (String, a) -> Parser a
+      tryEqToFst (str, a) = try $ string str >> return a
+      
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index 3c235eb6e6888e55d088312cedcc3f25a6e59b98..f8b1c93504bd34cacba81fb6b9c100547fd36025 100644 (file)
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -1,6 +1,6 @@
 module Network.HTTP.Lucu.Request
     ( Method(..)
 module Network.HTTP.Lucu.Request
     ( Method(..)

-    , Request
+    , Request(..)

     , requestP -- Parser Request
     )
     where
     , requestP -- Parser Request
     )
     where


@@ -16,6 +16,7 @@ import           Network.URI
 data Method = OPTIONS
             | GET
             | HEAD
 data Method = OPTIONS
             | GET
             | HEAD

+            | POST

             | PUT
             | DELETE
             | TRACE
             | PUT
             | DELETE
             | TRACE


@@ -30,9 +31,8 @@ data Request
       , reqURI     :: URI
       , reqVersion :: HttpVersion
       , reqHeaders :: Headers
       , reqURI     :: URI
       , reqVersion :: HttpVersion
       , reqHeaders :: Headers

-      , reqBody    :: Maybe ByteString

       }
       }

-    deriving (Show)
+    deriving (Show, Eq)

 
 instance HasHeaders Request where
     getHeaders = reqHeaders
 
 instance HasHeaders Request where
     getHeaders = reqHeaders


@@ -42,14 +42,13 @@ instance HasHeaders Request where
 requestP :: Parser Request
 requestP = do many crlf
               (method, uri, version) <- requestLineP
 requestP :: Parser Request
 requestP = do many crlf
               (method, uri, version) <- requestLineP

-              let req = Request {
-                          reqMethod  = method
-                        , reqURI     = uri
-                        , reqVersion = version
-                        , reqHeaders = emptyHeaders -- FIXME
-                        , reqBody    = Nothing      -- FIXME
-                        }
-              return req
+              headers                <- headersP
+              return Request {
+                           reqMethod  = method
+                         , reqURI     = uri
+                         , reqVersion = version
+                         , reqHeaders = headers
+                         }

 
 
 requestLineP :: Parser (Method, URI, HttpVersion)
 
 
 requestLineP :: Parser (Method, URI, HttpVersion)


@@ -66,6 +65,7 @@ methodP :: Parser Method
 methodP = (let methods = [ ("OPTIONS", OPTIONS)
                          , ("GET"    , GET    )
                          , ("HEAD"   , HEAD   )
 methodP = (let methods = [ ("OPTIONS", OPTIONS)
                          , ("GET"    , GET    )
                          , ("HEAD"   , HEAD   )

+                         , ("POST"   , POST   )

                          , ("PUT"    , PUT    )
                          , ("DELETE" , DELETE )
                          , ("TRACE"  , TRACE  )
                          , ("PUT"    , PUT    )
                          , ("DELETE" , DELETE )
                          , ("TRACE"  , TRACE  )


@@ -74,7 +74,7 @@ methodP = (let methods = [ ("OPTIONS", OPTIONS)
            in foldl (<|>) (fail "") $ map (\ (str, mth)
                                            -> string str >> return mth) methods)
           <|>
            in foldl (<|>) (fail "") $ map (\ (str, mth)
                                            -> string str >> return mth) methods)
           <|>

-          many1 token >>= return . ExtensionMethod
+          token >>= return . ExtensionMethod

 
 
 uriP :: Parser URI
 
 
 uriP :: Parser URI

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
new file mode 100644 (file)
index 0000000..4f63f28
--- /dev/null
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -0,0 +1,128 @@
+module Network.HTTP.Lucu.RequestReader
+    ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
+    )
+    where
+
+import           Control.Concurrent.STM
+import           Control.Exception
+import           Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as B
+import           Data.ByteString.Lazy.Char8 (ByteString)
+import           Data.Map as M
+import           Data.Map (Map)
+import           Data.Maybe
+import qualified Data.Sequence as S
+import           Data.Sequence (Seq, (<|), ViewR(..))
+import           Network
+import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.HttpVersion
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.Parser
+import           Network.HTTP.Lucu.Postprocess
+import           Network.HTTP.Lucu.Preprocess
+import           Network.HTTP.Lucu.Request
+import           Network.HTTP.Lucu.Response
+import           Network.HTTP.Lucu.Resource
+import           Prelude hiding (catch)
+import           System.IO
+
+import GHC.Conc (unsafeIOToSTM)
+
+requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
+requestReader cnf tree h host tQueue
+    = do input <- B.hGetContents h
+         catch (acceptRequest input) $ \ exc ->
+             case exc of
+               IOException _ -> return ()
+               _             -> print exc
+    where
+      acceptRequest :: ByteString -> IO ()
+      acceptRequest input
+          -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
+          -- 時は、それが限度以下になるまで待つ。
+          = do action
+                   <- atomically $
+                      do queue    <- readTVar tQueue
+                         when (S.length queue >= cnfMaxPipelineDepth cnf)
+                              retry
+
+                         -- リクエストを讀む。パースできない場合は直ち
+                         -- に 400 Bad Request 應答を設定し、それを出力
+                         -- してから切斷するやうに ResponseWriter に通
+                         -- 知する。
+                         case parse requestP input of
+                           Nothing            -> return acceptNonparsableRequest
+                           Just (req, input') -> return $ acceptParsableRequest req input'
+               action
+      
+      acceptNonparsableRequest :: IO ()
+      acceptNonparsableRequest 
+          = do itr <- newInteraction host Nothing
+               let res = Response {
+                           resVersion = HttpVersion 1 1
+                         , resStatus  = BadRequest
+                         , resHeaders = []
+                         }
+               atomically $ do writeTVar (itrResponse  itr) $ Just res
+                               writeTVar (itrWillClose itr) True
+                               writeTVar (itrState     itr) Done
+                               postprocess itr
+                               enqueue itr
+
+      acceptParsableRequest :: Request -> ByteString -> IO ()
+      acceptParsableRequest req input'
+          = do itr <- newInteraction host (Just req)
+               action
+                   <- atomically $
+                      do preprocess itr
+                         res <- readTVar (itrResponse itr)
+                         if fmap isError (fmap resStatus res) == Just True then
+                             acceptSemanticallyInvalidRequest itr input'
+                           else
+                             case findResource tree $ (reqURI . fromJust . itrRequest) itr of
+                               Nothing -- Resource が無かった
+                                   -> acceptRequestForNonexistentResource itr input'
+
+                               Just rsrcDef -- あった
+                                   -> acceptRequestForExistentResource itr input' rsrcDef
+               action
+
+      acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
+      acceptSemanticallyInvalidRequest itr input
+          = do writeTVar (itrState itr) Done
+               postprocess itr
+               enqueue itr
+               return $ acceptRequest input
+
+      acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
+      acceptRequestForNonexistentResource itr input
+          = do let res = Response {
+                           resVersion = HttpVersion 1 1
+                         , resStatus  = NotFound
+                         , resHeaders = []
+                         }
+               writeTVar (itrResponse  itr) $ Just res
+               writeTVar (itrState     itr) Done
+               postprocess itr
+               enqueue itr
+               return $ acceptRequest input
+
+      acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
+      acceptRequestForExistentResource itr input rsrcDef
+          = do requestHasBody <- readTVar (itrRequestHasBody itr)
+               writeTVar (itrState itr) (if requestHasBody
+                                         then ExaminingHeader
+                                         else DecidingHeader)
+               enqueue itr
+               return $ do runResource rsrcDef itr
+                           if requestHasBody then
+                               observeRequest itr input
+                             else
+                               acceptRequest input
+
+      observeRequest :: Interaction -> ByteString -> IO ()
+      observeRequest itr input = fail "FIXME: Not Implemented"
+
+      enqueue :: Interaction -> STM ()
+      enqueue itr = do queue <- readTVar tQueue
+                       writeTVar tQueue (itr <| queue)
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bc4bf3336389d959aa5bfedefcb857bf0e13b163..2e4d46e858f447fcec98601b1fc016e6f0272fd9 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,14 +1,109 @@
 module Network.HTTP.Lucu.Resource
 module Network.HTTP.Lucu.Resource

-    ( Resource
+    ( ResourceDef(..)
+    , Resource
+    , ResTree
+    , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree
+    , findResource -- ResTree -> URI -> Maybe ResourceDef
+    , runResource  -- ResourceDef -> Interaction -> IO ThreadId

     )
     where
 
     )
     where
 

-import           Control.Monad.State
+import           Control.Concurrent
+import           Control.Monad.Reader

 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)

+import           Data.List
+import qualified Data.Map as M
+import           Data.Map (Map)
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.Utils
+import           Network.URI

 
 

-data ResState = ResState -- FIXME

 
 

-type ResourceT m a = StateT ResState m a
+type Resource a = ReaderT Interaction IO a

 
 

-type Resource a = ResourceT IO a
+
+{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
+   れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
+   /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
+   される。 -}
+data ResourceDef = ResourceDef {
+      resUsesNativeThread :: Bool
+    , resIsGreedy         :: Bool
+    , resResource         :: Resource ()
+    }
+type ResTree    = ResNode -- root だから Map ではない
+type ResSubtree = Map String ResNode
+data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
+
+
+mkResTree :: [ ([String], ResourceDef) ] -> ResTree
+mkResTree list = processRoot list
+    where
+      processRoot :: [ ([String], ResourceDef) ] -> ResTree
+      processRoot list
+          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
+                children = processNonRoot nonRoots
+            in
+              if null roots then
+                  -- / にリソースが定義されない。/foo とかにはあるかも。
+                  ResNode Nothing children
+              else
+                  -- / がある。
+                  let (_, def) = last roots
+                  in 
+                    ResNode (Just def) children
+
+      processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
+      processNonRoot list
+          = let subtree    = M.fromList [(name, node name)
+                                             | name <- childNames]
+                childNames = [name | (name:_, _) <- list]
+                node name  = let defs = [def | (path, def) <- list, path == [name]]
+                             in
+                               if null defs then
+                                   -- この位置にリソースが定義されない。
+                                   -- もっと下にはあるかも。
+                                   ResNode Nothing children
+                               else
+                                   -- この位置にリソースがある。
+                                   ResNode (Just $ last defs) children
+                children   = processNonRoot [(path, def)
+                                                 | (_:path, def) <- list, not (null path)]
+            in
+              subtree
+
+
+findResource :: ResTree -> URI -> Maybe ResourceDef
+findResource (ResNode rootDefM subtree) uri
+    = let pathStr = uriPath uri
+          path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
+      in
+        if null path then
+            rootDefM
+        else
+            walkTree subtree path
+    where
+      walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
+
+      walkTree subtree (name:[])
+          = case M.lookup name subtree of
+              Nothing               -> Nothing
+              Just (ResNode defM _) -> defM
+
+      walkTree subtree (x:xs)
+          = case M.lookup x subtree of
+              Nothing                      -> Nothing
+              Just (ResNode defM children) -> case defM of
+                                                Just (ResourceDef { resIsGreedy = True })
+                                                    -> defM
+                                                _   -> walkTree children xs
+
+
+runResource :: ResourceDef -> Interaction -> IO ThreadId
+runResource def itr = fork $ runReaderT rsrc itr -- FIXME: 例外をcatch
+    where
+      fork = if (resUsesNativeThread def)
+             then forkOS
+             else forkIO
+      rsrc = resResource def
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index e61a6a50242779b91c665218ea565cbb85d69955..0e6fbe2d8f2bb120b9f229cc5290db9610cb5957 100644 (file)
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,13 +1,16 @@
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)

+    , hPutResponse    -- Handle -> Response -> IO ()
+    , isInformational -- StatusCode -> Bool
+    , isError         -- StatusCode -> Bool

     )
     where
 
     )
     where
 

-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)

 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion

+import           System.IO
+import           Text.Printf

 
 data StatusCode = Continue
                 | SwitchingProtocols
 
 data StatusCode = Continue
                 | SwitchingProtocols


@@ -59,14 +62,96 @@ data StatusCode = Continue
                 | GatewayTimeout
                 | HttpVersionNotSupported
                 | InsufficientStorage
                 | GatewayTimeout
                 | HttpVersionNotSupported
                 | InsufficientStorage

+                  deriving (Eq)
+
+instance Show StatusCode where
+    show sc = let (num, msg) = statusCode sc
+              in
+                printf "%03d %s" num msg
+

 
 data Response = Response {
       resVersion :: HttpVersion
     , resStatus  :: StatusCode
     , resHeaders :: Headers
 
 data Response = Response {
       resVersion :: HttpVersion
     , resStatus  :: StatusCode
     , resHeaders :: Headers

-    , resBody    :: Maybe ByteString

     }
     }

+                deriving (Show, Eq)

 
 instance HasHeaders Response where
     getHeaders = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }
 
 instance HasHeaders Response where
     getHeaders = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }

+
+
+hPutResponse :: Handle -> Response -> IO ()
+hPutResponse h res = do hPutHttpVersion h (resVersion res)
+                        hPutChar        h ' '
+                        hPutStatus      h (resStatus  res)
+                        hPutStr         h "\r\n"
+                        hPutHeaders     h (resHeaders res)
+
+hPutStatus :: Handle -> StatusCode -> IO ()
+hPutStatus h sc = let (num, msg) = statusCode sc
+                  in
+                    hPrintf h "%03d %s" num msg
+
+
+isInformational :: StatusCode -> Bool
+isInformational sc = let (num, _) = statusCode sc
+                     in num < 200
+
+isError :: StatusCode -> Bool
+isError sc = let (num, _) = statusCode sc
+             in num >= 400
+
+
+statusCode :: StatusCode -> (Int, String)
+statusCode Continue                    = (100, "Continue")
+statusCode SwitchingProtocols          = (101, "Switching Protocols")
+statusCode Processing                  = (102, "Processing")
+--
+statusCode Ok                          = (200, "OK")
+statusCode Created                     = (201, "Created")
+statusCode Accepted                    = (202, "Accepted")
+statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information")
+statusCode NoContent                   = (204, "No Content")
+statusCode ResetContent                = (205, "Reset Content")
+statusCode PartialContent              = (206, "Partial Content")
+statusCode MultiStatus                 = (207, "Multi Status")
+--
+statusCode MultipleChoices             = (300, "Multiple Choices")
+statusCode MovedPermanently            = (301, "Moved Permanently")
+statusCode Found                       = (302, "Found")
+statusCode SeeOther                    = (303, "See Other")
+statusCode NotModified                 = (304, "Not Modified")
+statusCode UseProxy                    = (305, "Use Proxy")
+statusCode TemporaryRedirect           = (306, "Temporary Redirect")
+--
+statusCode BadRequest                  = (400, "Bad Request")
+statusCode Unauthorized                = (401, "Unauthorized")
+statusCode PaymentRequired             = (402, "Payment Required")
+statusCode Forbidden                   = (403, "Forbidden")
+statusCode NotFound                    = (404, "Not Found")
+statusCode MethodNotAllowed            = (405, "Method Not Allowed")
+statusCode NotAcceptable               = (406, "Not Acceptable")
+statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required")
+statusCode RequestTimeout              = (408, "Request Timeout")
+statusCode Conflict                    = (409, "Conflict")
+statusCode Gone                        = (410, "Gone")
+statusCode LengthRequired              = (411, "Length Required")
+statusCode PreconditionFailed          = (412, "Precondition Failed")
+statusCode RequestEntityTooLarge       = (413, "Request Entity Too Large")
+statusCode RequestURITooLarge          = (414, "Request URI Too Large")
+statusCode UnsupportedMediaType        = (415, "Unsupported Media Type")
+statusCode RequestRangeNotSatisfiable  = (416, "Request Range Not Satisfiable")
+statusCode ExpectationFailed           = (417, "Expectation Failed")
+statusCode UnprocessableEntitiy        = (422, "Unprocessable Entity")
+statusCode Locked                      = (423, "Locked")
+statusCode FailedDependency            = (424, "Failed Dependency")
+--
+statusCode InternalServerError         = (500, "Internal Server Error")
+statusCode NotImplemented              = (501, "Not Implemented")
+statusCode BadGateway                  = (502, "Bad Gateway")
+statusCode ServiceUnavailable          = (503, "Service Unavailable")
+statusCode GatewayTimeout              = (504, "Gateway Timeout")
+statusCode HttpVersionNotSupported     = (505, "HTTP Version Not Supported")
+statusCode InsufficientStorage         = (507, "Insufficient Storage")
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
new file mode 100644 (file)
index 0000000..f874478
--- /dev/null
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -0,0 +1,119 @@
+module Network.HTTP.Lucu.ResponseWriter
+    ( responseWriter -- Handle -> InteractionQueue -> IO ()
+    )
+    where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+import           Data.ByteString.Lazy.Char8 (ByteString)
+import           Control.Concurrent.STM
+import           Control.Exception
+import           Control.Monad
+import           Data.Maybe
+import qualified Data.Sequence as S
+import           Data.Sequence (Seq, ViewR(..))
+import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.Response
+import           Prelude hiding (catch)
+import           System.IO
+
+import Debug.Trace
+
+
+responseWriter :: Handle -> InteractionQueue -> IO ()
+responseWriter h tQueue
+    = catch awaitSomethingToWrite $ \ exc
+    -> case exc of
+         IOException _ -> return ()
+         _             -> print exc
+    where
+      awaitSomethingToWrite :: IO ()
+      awaitSomethingToWrite 
+          = do action
+                   <- atomically $
+                      do -- キューが空でなくなるまで待つ
+                         queue <- readTVar tQueue
+                         when (S.null queue)
+                              retry
+                         let _ :> itr = S.viewr queue
+                            
+                         -- GettingBody 状態にあり、Continue が期待され
+                         -- てゐて、それがまだ送信前なのであれば、
+                         -- Continue を送信する。
+                         state <- readTVar (itrState itr)
+
+                         if state == GettingBody then
+                             writeContinueIfNecessary itr
+                           else
+                             if state >= DecidingBody then
+                                 writeHeaderOrBodyIfNecessary itr
+                             else
+                                 retry
+               action
+
+      writeContinueIfNecessary :: Interaction -> STM (IO ())
+      writeContinueIfNecessary itr
+          = do expectedContinue <- readTVar (itrExpectedContinue itr)
+               if expectedContinue then
+
+                   do wroteContinue <- readTVar $ itrWroteContinue itr
+                      if wroteContinue then
+                          -- 既に Continue を書込み濟
+                          retry
+                        else
+                          return $ writeContinue itr
+                 else
+                   retry
+
+      writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
+      writeHeaderOrBodyIfNecessary itr
+          -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
+          -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
+          -- 空でなければ、それを出力する。空である時は、もし状態が
+          -- Done であれば後処理をする。
+          = do wroteHeader <- readTVar (itrWroteHeader itr)
+               
+               if not wroteHeader then
+                   return $ writeHeader itr
+                 else
+                   do bodyToSend <- readTVar (itrBodyToSend itr)
+
+                      if B.null bodyToSend then
+                          do state <- readTVar (itrState itr)
+
+                             if state == Done then
+                                 return $ finalize itr
+                               else
+                                 retry
+                        else
+                          return $ writeBodyChunk itr
+
+      writeContinue :: Interaction -> IO ()
+      writeContinue itr = fail "FIXME: not implemented"
+
+      writeHeader :: Interaction -> IO ()
+      writeHeader itr
+          = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
+                                      readTVar  (itrResponse    itr)
+               hPutResponse h (fromJust res)
+               hFlush h
+               awaitSomethingToWrite
+      
+      writeBodyChunk :: Interaction -> IO ()
+      writeBodyChunk itr = fail "FIXME: not implemented"
+
+      finishBodyChunk :: Interaction -> IO ()
+      finishBodyChunk itr = return () -- FIXME: not implemented
+
+      finalize :: Interaction -> IO ()
+      finalize itr
+          = do finishBodyChunk itr
+               willClose <- atomically $ do queue <- readTVar tQueue
+
+                                            let (remaining :> _) = S.viewr queue
+                                            writeTVar tQueue remaining
+
+                                            readTVar $ itrWillClose itr
+               if willClose then
+                   hClose h
+                 else
+                   awaitSomethingToWrite

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
new file mode 100644 (file)
index 0000000..7d6eeeb
--- /dev/null
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -0,0 +1,33 @@
+module Network.HTTP.Lucu.Utils
+    ( splitBy      -- (a -> Bool) -> [a] -> [[a]]
+    , trim         -- (a -> Bool) -> [a] -> [a]
+    , noCaseEq     -- String -> String -> Bool
+    , isWhiteSpace -- Char -> Bool
+    )
+    where
+
+import Data.Char
+import Data.List
+
+
+splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy isSeparator src
+    = case break isSeparator src
+      of (last , []      ) -> last  : []
+         (first, sep:rest) -> first : splitBy isSeparator rest
+
+
+trim :: (a -> Bool) -> [a] -> [a]
+trim p = trimTail . trimHead
+    where
+      trimHead = dropWhile p
+      trimTail = reverse . trimHead . reverse
+
+
+noCaseEq :: String -> String -> Bool
+noCaseEq a b
+    = (map toLower a) == (map toLower b)
+
+
+isWhiteSpace :: Char -> Bool
+isWhiteSpace = flip elem " \t\r\n"

diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
index 52ceceb14f34b937951288940a5b962502769335..d5b8d701318b5a5bccb7e7e275a3fab108c29733 100644 (file)
--- a/examples/HelloWorld.hs
+++ b/examples/HelloWorld.hs
@@ -1,9 +1,10 @@
 import Network
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Httpd
 import Network
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Httpd

+import Network.HTTP.Lucu.Resource

 
 main :: IO ()
 main = let config    = defaultConfig { cnfServerPort = PortNumber 9999 }
 
 main :: IO ()
 main = let config    = defaultConfig { cnfServerPort = PortNumber 9999 }

-           resources = mkResourceTable []
+           resources = mkResTree []

        in
          runHttpd config resources
\ No newline at end of file
        in
          runHttpd config resources
\ No newline at end of file