0 | module Network.HTTP.Pool.Worker

  2 | import Network.Socket

  3 | import Network.HTTP.Error

  4 | import Network.HTTP.Scheduler

  5 | import Network.HTTP.Protocol

  6 | import Network.HTTP.Message

  7 | import Network.HTTP.Header

  8 | import Network.HTTP.URL

  9 | import Network.HTTP.Pool.Common

 10 | import Utils.String

 11 | import Network.TLS

 12 | import Network.TLS.Signature

 13 | import Crypto.Random

 14 | import Crypto.Random.C

 15 | import Utils.Handle.C

 16 | import Utils.Handle

 17 | import Utils.Bytes

 18 | import Utils.Streaming

 19 | import Utils.Num

 20 | import Data.List1

 21 | import Data.Nat

 22 | import Data.Fin

 23 | import Data.String

 24 | import System.Concurrency

 25 | import Control.Linear.LIO

 26 | import Network.HTTP.Pool.IOStuff

 27 | import Data.List

 28 | import Data.IORef

 29 | import Utils.Queue

 32 | %hide Network.Socket.close

 34 | WriteOkOrError : Type -> Type -> Type -> Type

 35 | WriteOkOrError e t_ok t_closed = Res Bool $ \ok => if ok then Handle' t_ok t_closed else Res (HttpError e) (const t_closed)

 37 | LogicOkOrError : Type -> Type -> Type

 38 | LogicOkOrError t_ok t_closed = Res Bool $ \ok => if ok then Handle' t_ok t_closed else t_closed

 40 | worker_write : (1 _ : Handle' t_ok t_closed) -> Integer -> Stream (Of (List Bits8)) IO (Either e ()) -> L1 IO (WriteOkOrError e t_ok t_closed)

 41 | worker_write handle remaining stream = do

 42 |   Right (chunk, rest) <- liftIO1 $ next stream

 43 |   | Left (Left r) => do

 44 |     handle <- close handle

 45 |     pure1 (False # ((OtherReason r) # handle))

 46 |   | Left (Right ()) => if remaining <= 0 then pure1 (True # handle) else do

 47 |     handle <- close handle

 48 |     pure1 (False # ((ContentLengthMismatch remaining) # handle))

 49 |   let should_take = min remaining (natToInteger $ length chunk)

 50 |   let chunk = take (integerToNat should_take) chunk

 51 |   (True # handle) <- write handle chunk

 52 |   | (False # (error # handle)) => pure1 (False # ((SocketError error) # handle))

 53 |   worker_write handle (remaining - should_take) rest

 55 | worker_finish : Maybe ConnectionAction -> (1 _ : Handle' t_ok t_closed) -> L1 IO (LogicOkOrError t_ok t_closed)

 56 | worker_finish (Just KeepAlive) handle =

 57 |   pure1 (True # handle)

 58 | worker_finish _ handle = do

 59 |   handle <- close handle

 60 |   pure1 (False # handle)

 62 | worker_read_fixed_length : (1 _ : Handle' t_ok t_closed) -> Integer -> Integer -> Channel (Either (HttpError e) (Maybe (List Bits8))) ->

 63 |                            L1 IO (LogicOkOrError t_ok t_closed)

 64 | worker_read_fixed_length handle remaining chunk_size channel =

 65 |   if remaining <= 0

 66 |   then do

 67 |     liftIO1 $ channelPut channel (Right Nothing)

 68 |     pure1 (True # handle)

 69 |   else do

 70 |     let should_read = min remaining chunk_size

 71 |     (True # (content # handle)) <- read handle (integerToNat should_read)

 72 |     | (False # (error # handle)) => do

 73 |       liftIO1 $ channelPut channel (Left $ SocketError "error while reading response: \{error}")

 74 |       pure1 (False # handle)

 75 |     liftIO1 $ channelPut channel (Right $ Just content)

 76 |     worker_read_fixed_length handle (remaining - should_read) chunk_size channel

 78 | worker_read_chunked_end : (1 _ : Handle' t_ok t_closed) -> Channel (Either (HttpError e) (Maybe (List Bits8))) ->

 79 |                           L1 IO (LogicOkOrError t_ok t_closed)

 80 | worker_read_chunked_end handle channel = do

 81 |   (True # ([char] # handle)) <- read handle 1

 82 |   | (True # (char # handle)) => do

 83 |     handle' <- close handle

 84 |     liftIO1 $ channelPut channel (Left $ SocketError "read chunked body failed, somehow read returns \{show (length char)} bytes instead of 1")

 85 |     pure1 (False # handle')

 86 |   | (False # (error # handle)) => do

 87 |     liftIO1 $ channelPut channel (Left $ SocketError "read chunked body failed: \{error}")

 88 |     pure1 (False # handle)

 89 |   case cast {to=Char} char of

 90 |     '\n' =>

 91 |       pure1 (True # handle)

 92 |     '\r' => do

 93 |       (True # ([10] # handle)) <- read handle 1

 94 |       | (True # ([char] # handle)) => do

 95 |         handle' <- close handle

 96 |         liftIO1 $ channelPut channel (Left $ SocketError "read chunked body failed, \\n expected after \\r, got \{show char} instead")

 97 |         pure1 (False # handle')

 98 |       | (True # (char # handle)) => do

 99 |         handle' <- close handle

100 |         liftIO1 $ channelPut channel (Left $ SocketError "read chunked body failed, somehow read returns \{show (length char)} bytes instead of 1")

101 |         pure1 (False # handle')

102 |       | (False # (error # handle)) => do

103 |         liftIO1 $ channelPut channel (Left $ SocketError "read chunked body failed: \{error}")

104 |         pure1 (False # handle)

105 |       pure1 (True # handle)

106 |     chr => do

107 |       handle <- close handle

108 |       liftIO1 $ channelPut channel (Left $ SocketError "read chunked body tail failed: got \{show chr} instead of \\n or \\r")

109 |       pure1 (False # handle)

111 | worker_read_chunked : (1 _ : Handle' t_ok t_closed) -> Channel (Either (HttpError e) (Maybe (List Bits8))) ->

112 |                       L1 IO (LogicOkOrError t_ok t_closed)

113 | worker_read_chunked handle channel = do

114 |   (True # (length_line # handle)) <- read_line handle

115 |   | (False # (error # handle)) => do

116 |     liftIO1 $ channelPut channel (Left $ SocketError "error while reading response: \{error}")

117 |     pure1 (False # handle)

118 |   let Just (S len) = stringToNat 16 $ toLower length_line

119 |   | Just Z => do

120 |     liftIO1 $ channelPut channel (Right Nothing)

121 |     worker_read_chunked_end handle channel

122 |   | Nothing => do

123 |     handle <- close handle

124 |     liftIO1 $ channelPut channel (Left $ SocketError "invalid chunked header: \{length_line}")

125 |     pure1 (False # handle)

126 |   (True # (content # handle)) <- read handle (S len)

127 |   | (False # (error # handle)) => do

128 |     liftIO1 $ channelPut channel (Left $ SocketError "error while reading chunked body: \{error}")

129 |     pure1 (False # handle)

131 |   liftIO1 $ channelPut channel (Right $ Just content)

132 |   worker_read_chunked_end handle channel

134 | worker_logic : {e : _} -> ScheduleRequest e IO -> (1 _ : Handle' t_ok t_closed) -> L1 IO (LogicOkOrError t_ok t_closed)

135 | worker_logic request handle = do

136 |   let throw = \err => channelPut request.response (Left err)

138 |   let http_message = request.raw_http_message

139 |   let Just content_length = lookup_header http_message.headers ContentLength

140 |   | Nothing => do

141 |     liftIO1 $ throw (MissingHeader "Content-Length")

142 |     pure1 (True # handle)

143 |   (True # handle) <- write handle $ utf8_unpack $ serialize_http_message http_message

144 |   | (False # (error # handle)) => do

145 |     liftIO1 $ throw (SocketError error)

146 |     pure1 (False # handle)

147 |   (True # handle) <- worker_write handle content_length $ chunksOf 0x200 request.content

148 |   | (False # (error # handle)) => do

149 |     liftIO1 $ throw error

150 |     pure1 (False # handle)

151 |   (True # (line # handle)) <- read_until_empty_line handle

152 |   | (False # (error # handle)) => do

153 |     liftIO1 $ throw (SocketError "error while reading response header: \{error}")

154 |     pure1 (False # handle)

156 |   let Right response = deserialize_http_response $ (ltrim line <+> "\n") -- for some reason the end line sometimes is not sent

157 |   | Left err => do

158 |     handle <- close handle

159 |     liftIO1 $ throw (SocketError "error parsing http response headers: \{err}")

160 |     pure1 (False # handle)

161 |   let connection_action = lookup_header response.headers Connection

163 |   channel <- liftIO1 (makeChannel {a=(Either (HttpError e) (Maybe (List Bits8)))})

164 |   let schedule_response = MkScheduleResponse response channel

165 |   liftIO1 $ channelPut request.response (Right schedule_response)

167 |   let encodings = join $ toList (forget <$> lookup_header response.headers TransferEncoding)

168 |   if elem Chunked encodings

169 |     then do

170 |       (True # handle) <- worker_read_chunked handle channel

171 |       | (False # handle) => pure1 (False # handle)

172 |       worker_finish connection_action handle

173 |     else do

174 |       let Just content_length = lookup_header response.headers ContentLength

175 |       | Nothing => do

176 |         handle <- close handle

177 |         liftIO1 $ channelPut channel (Left $ MissingHeader "Content-Length")

178 |         pure1 (False # handle)

179 |       (True # handle) <- worker_read_fixed_length handle content_length 0x2000 channel

180 |       | (False # handle) => pure1 (False # handle)

181 |       worker_finish connection_action handle

183 | worker_loop : {e : _} -> IORef Bool -> IO () -> Queue (Event e) -> (1 _ : Handle' t_ok ()) -> L IO ()

184 | worker_loop idle_ref closer queue handle = do

185 |   liftIO1 $ writeIORef idle_ref True

186 |   Request request <- liftIO1 $ recv queue

187 |   | Kill condition => do

188 |     close handle

189 |     liftIO1 closer

190 |     case condition of

191 |       Just cond => liftIO1 $ conditionBroadcast cond

192 |       Nothing => pure ()

193 |   liftIO1 $ writeIORef idle_ref False

194 |   (True # handle) <- worker_logic request handle

195 |   | (False # ()) => liftIO1 closer

196 |   worker_loop idle_ref closer queue handle

199 | worker_handle : {e : _} -> Socket -> IORef Bool -> IO () -> Queue (Event e) -> (HttpError e -> IO ()) ->

200 |                 (String -> CertificateCheck IO) -> Protocol -> String -> IO ()

201 | worker_handle socket idle_ref closer fetcher throw cert_checker protocol hostname = LIO.run $ do

202 |   let handle = socket_to_handle socket

203 |   case protocol of

204 |     HTTP =>

205 |       worker_loop idle_ref closer fetcher handle

206 |     HTTPS => do

207 |       (True # handle) <-

208 |         tls_handshake hostname

209 |           (X25519 ::: [SECP256r1, SECP384r1])

210 |           supported_signature_algorithms

211 |           (tls13_supported_cipher_suites <+> tls12_supported_cipher_suites)

212 |           handle

213 |           (cert_checker hostname)

214 |       | (False # (err # ())) => liftIO1 $ throw $ SocketError "error during TLS handshake: \{err}"

215 |       worker_loop idle_ref closer fetcher handle