getRequestURI should always return an absolute URI

[Lucu.git] / Network / HTTP / Lucu / Interaction.hs

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 491c029b60ffbd51e2e7e425e3911325409cf389..88cded5c339209fc2f1d023a50c28318747ca4fa 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,15 +1,17 @@
+-- #hide
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
-    , newInteractionQueue -- IO InteractionQueue
-    , newInteraction      -- Config -> HostName -> Maybe Request -> IO Interaction
-
-    , writeItr   -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
-    , readItr    -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
-    , readItrF   -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-    , updateItr  -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
-    , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+    , newInteractionQueue
+    , newInteraction
+    , defaultPageContentType
+
+    , writeItr
+    , readItr
+    , readItrF
+    , updateItr
+    , updateItrF
     )
     where
 
@@ -20,15 +22,21 @@ import qualified Data.Sequence as S
 import           Data.Sequence (Seq)
 import           Network
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 
 data Interaction = Interaction {
-      itrConfig      :: Config
-    , itrRemoteHost  :: HostName
-    , itrRequest     :: Maybe Request
-    , itrResponse    :: TVar (Maybe Response)
-
+      itrConfig       :: Config
+    , itrRemoteHost   :: HostName
+    , itrResourcePath :: Maybe [String]
+    , itrRequest      :: TVar (Maybe Request)
+    , itrResponse     :: TVar Response
+
+    -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
+    -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
+    -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
+    -- からにすべき。
     , itrRequestHasBody    :: TVar Bool
     , itrRequestIsChunked  :: TVar Bool
     , itrExpectedContinue  :: TVar Bool
@@ -55,9 +63,8 @@ data Interaction = Interaction {
     }
 
 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingHeader (リクエストボディが有る時) または
--- DecidingHeader (無い時)。終了状態は常に Done
-data InteractionState = ExaminingHeader
+-- 状態は ExaminingRequest。
+data InteractionState = ExaminingRequest
                       | GettingBody
                       | DecidingHeader
                       | DecidingBody
@@ -71,9 +78,18 @@ newInteractionQueue :: IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
 
+defaultPageContentType :: String
+defaultPageContentType = "application/xhtml+xml"
+
+
 newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
 newInteraction conf host req
-    = do responce <- newTVarIO Nothing
+    = do request  <- newTVarIO $ req
+         responce <- newTVarIO $ Response {
+                       resVersion = HttpVersion 1 1
+                     , resStatus  = Ok
+                     , resHeaders = [("Content-Type", defaultPageContentType)]
+                     }
 
          requestHasBody     <- newTVarIO False
          requestIsChunked   <- newTVarIO False
@@ -94,16 +110,17 @@ newInteraction conf host req
          bodyToSend <- newTVarIO B.empty
          bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 
-         state <- newTVarIO undefined
+         state <- newTVarIO ExaminingRequest
 
          wroteContinue <- newTVarIO False
          wroteHeader   <- newTVarIO False
 
          return $ Interaction {
-                      itrConfig     = conf
-                    , itrRemoteHost = host
-                    , itrRequest    = req
-                    , itrResponse   = responce
+                      itrConfig       = conf
+                    , itrRemoteHost   = host
+                    , itrResourcePath = Nothing
+                    , itrRequest      = request
+                    , itrResponse     = responce
 
                     , itrRequestHasBody    = requestHasBody
                     , itrRequestIsChunked  = requestIsChunked