]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Interaction.hs
46e32a139a37d17b88b0dce43e05540dc0cbd79f
[Lucu.git] / Network / HTTP / Lucu / Interaction.hs
1 {-# LANGUAGE
2     BangPatterns
3   , OverloadedStrings
4   , UnicodeSyntax
5   #-}
6 module Network.HTTP.Lucu.Interaction
7     ( Interaction(..)
8     , InteractionState(..)
9     , InteractionQueue
10     , newInteractionQueue
11     , newInteraction
12     , defaultPageContentType
13
14     , writeItr
15     , readItr
16     , updateItr
17     )
18     where
19 import Blaze.ByteString.Builder (Builder)
20 import Control.Applicative
21 import Control.Concurrent.STM
22 import Data.Ascii (Ascii)
23 import qualified Data.ByteString as BS
24 import Data.Sequence (Seq)
25 import qualified Data.Sequence as S
26 import Data.Text (Text)
27 import Network.Socket
28 import Network.HTTP.Lucu.Config
29 import Network.HTTP.Lucu.Headers
30 import Network.HTTP.Lucu.HttpVersion
31 import Network.HTTP.Lucu.Request
32 import Network.HTTP.Lucu.Response
33 import OpenSSL.X509
34
35 data Interaction = Interaction {
36       itrConfig            ∷ !Config
37     , itrLocalPort         ∷ !PortNumber
38     , itrRemoteAddr        ∷ !SockAddr
39     , itrRemoteCert        ∷ !(Maybe X509)
40     , itrResourcePath      ∷ !(Maybe [Text])
41     , itrRequest           ∷ !(TVar (Maybe Request))
42     , itrResponse          ∷ !(TVar Response)
43
44     , itrRequestHasBody    ∷ !(TVar Bool)
45     , itrRequestIsChunked  ∷ !(TVar Bool)
46     , itrExpectedContinue  ∷ !(TVar Bool)
47
48     , itrReqChunkLength    ∷ !(TVar (Maybe Int))
49     , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
50     , itrReqChunkIsOver    ∷ !(TVar Bool)
51     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
52     , itrReqBodyWasteAll   ∷ !(TVar Bool)
53     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
54     , itrReceivedBodyLen   ∷ !(TVar Int)
55
56     , itrWillReceiveBody   ∷ !(TVar Bool)
57     , itrWillChunkBody     ∷ !(TVar Bool)
58     , itrWillDiscardBody   ∷ !(TVar Bool)
59     , itrWillClose         ∷ !(TVar Bool)
60
61     , itrBodyToSend        ∷ !(TMVar Builder)
62     , itrSentNoBody        ∷ !(TVar Bool)
63
64     , itrState             ∷ !(TVar InteractionState)
65
66     , itrWroteContinue     ∷ !(TVar Bool)
67     , itrWroteHeader       ∷ !(TVar Bool)
68     }
69
70 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
71 -- initial state.
72 data InteractionState = ExaminingRequest
73                       | GettingBody
74                       | DecidingHeader
75                       | DecidingBody
76                       | Done
77                         deriving (Show, Eq, Ord, Enum)
78
79 type InteractionQueue = TVar (Seq Interaction)
80
81 newInteractionQueue ∷ IO InteractionQueue
82 newInteractionQueue = newTVarIO S.empty
83
84 defaultPageContentType ∷ Ascii
85 defaultPageContentType = "application/xhtml+xml"
86
87 newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
88 newInteraction !conf !port !addr !cert !req
89     = do request  ← newTVarIO req
90          responce ← newTVarIO Response {
91                        resVersion = HttpVersion 1 1
92                      , resStatus  = Ok
93                      , resHeaders = toHeaders [("Content-Type", defaultPageContentType)]
94                      }
95
96          requestHasBody     ← newTVarIO False
97          requestIsChunked   ← newTVarIO False
98          expectedContinue   ← newTVarIO False
99          
100          reqChunkLength     ← newTVarIO Nothing -- 現在のチャンク長
101          reqChunkRemaining  ← newTVarIO Nothing -- 現在のチャンクの殘り
102          reqChunkIsOver     ← newTVarIO False   -- 最後のチャンクを讀み終へた
103          reqBodyWanted      ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
104          reqBodyWasteAll    ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
105          receivedBody       ← newTVarIO S.empty
106          receivedBodyLen    ← newTVarIO 0
107
108          willReceiveBody   ← newTVarIO False
109          willChunkBody     ← newTVarIO False
110          willDiscardBody   ← newTVarIO False
111          willClose         ← newTVarIO False
112
113          bodyToSend ← newEmptyTMVarIO
114          sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
115
116          state ← newTVarIO ExaminingRequest
117
118          wroteContinue ← newTVarIO False
119          wroteHeader   ← newTVarIO False
120
121          return Interaction {
122                       itrConfig       = conf
123                     , itrLocalPort    = port
124                     , itrRemoteAddr   = addr
125                     , itrRemoteCert   = cert
126                     , itrResourcePath = Nothing
127                     , itrRequest      = request
128                     , itrResponse     = responce
129
130                     , itrRequestHasBody   = requestHasBody
131                     , itrRequestIsChunked = requestIsChunked
132                     , itrExpectedContinue = expectedContinue
133
134                     , itrReqChunkLength    = reqChunkLength
135                     , itrReqChunkRemaining = reqChunkRemaining
136                     , itrReqChunkIsOver    = reqChunkIsOver
137                     , itrReqBodyWanted     = reqBodyWanted
138                     , itrReqBodyWasteAll   = reqBodyWasteAll
139                     , itrReceivedBody      = receivedBody
140                     , itrReceivedBodyLen   = receivedBodyLen
141
142                     , itrWillReceiveBody   = willReceiveBody
143                     , itrWillChunkBody     = willChunkBody
144                     , itrWillDiscardBody   = willDiscardBody
145                     , itrWillClose         = willClose
146
147                     , itrBodyToSend = bodyToSend
148                     , itrSentNoBody = sentNoBody
149                     
150                     , itrState = state
151                     
152                     , itrWroteContinue = wroteContinue
153                     , itrWroteHeader   = wroteHeader
154                     }
155
156 {-
157 chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
158 {-# INLINE chunksToLBS #-}
159 chunksToLBS = LBS.fromChunks ∘ toList
160
161 chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
162 {-# INLINE chunksFromLBS #-}
163 chunksFromLBS = S.fromList ∘ LBS.toChunks
164 -}
165
166 writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
167 {-# INLINE writeItr #-}
168 writeItr accessor a itr
169     = writeTVar (accessor itr) a
170
171 readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b
172 {-# INLINE readItr #-}
173 readItr accessor reader itr
174     = reader <$> readTVar (accessor itr)
175
176 updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
177 {-# INLINE updateItr #-}
178 updateItr accessor updator itr
179     = do old ← readItr accessor id itr
180          writeItr accessor (updator old) itr