
   0 | module TyTTP.Adapter.Node.HTTP2
   1 | 
   2 | import public Data.Buffer
   3 | import Data.Buffer.Ext
   4 | import Data.String
   5 | import Data.Maybe
   6 | import public Node.Error
   7 | import public Node.HTTP2
   8 | import Node.JS.Misc
   9 | import Node.JS.Std.JSON
  10 | import TyTTP
  11 | import TyTTP.URL
  12 | import public TyTTP.Adapter.Node.Error
  13 | import TyTTP.HTTP
  14 | 
  15 | namespace Fields
  16 | 
  17 |   public export
  18 |   data RequestPseudoHeaderField
  19 |     = Method
  20 |     | Scheme
  21 |     | Authority
  22 |     | Path
  23 | 
  24 |   public export
  25 |   Show RequestPseudoHeaderField where
  26 |     show f = case f of
  27 |       Method => ":method"
  28 |       Scheme => ":scheme"
  29 |       Authority => ":authority"
  30 |       Path => ":path"
  31 | 
  32 |   public export
  33 |   data ResponsePseudoHeaderField
  34 |     = Status
  35 | 
  36 |   public export
  37 |   Show ResponsePseudoHeaderField where
  38 |     show Status = ":status"
  39 | 
  40 | public export
  41 | RawHttpRequest : Type
  42 | RawHttpRequest = HttpRequest SimpleURL StringHeaders $ Publisher IO Error Buffer
  43 | 
  44 | public export
  45 | RawHttpResponse : Type
  46 | RawHttpResponse = Response Status StringHeaders $ Publisher IO Error Buffer
  47 | 
  48 | public export
  49 | PushContext : Type
  50 | PushContext = Context Method SimpleURL Version StringHeaders Status StringHeaders () $ Publisher IO Error Buffer
  51 | 
  52 | sendResponse : RawHttpResponse -> ServerHttp2Stream -> IO ()
  53 | sendResponse res stream = do
  54 |   let status = res.status.code
  55 |   headers <- mapHeaders res.headers status
  56 | 
  57 |   stream.respond headers
  58 |   res.body.subscribe $ MkSubscriber
  59 |         { onNext = \a => stream.write a Nothing }
  60 |         { onFailed = \e => pure () }
  61 |         { onSucceded = \_ => stream.end Nothing { d = Buffer } }
  62 |   where
  63 |     mapHeaders : StringHeaders -> Int -> IO Headers
  64 |     mapHeaders h s = do
  65 |       let newHeaders = singleton (show Fields.Status) (show s)
  66 |       foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h
  67 | 
  68 | sendResponseFromPromise : Error e
  69 |   => (String -> RawHttpResponse)
  70 |   -> Promise e IO (Context Method SimpleURL Version StringHeaders Status StringHeaders b $ Publisher IO Error Buffer)
  71 |   -> ServerHttp2Stream
  72 |   -> IO ()
  73 | sendResponseFromPromise errorHandler (MkPromise cont) stream =
  74 |   let callbacks = MkCallbacks
  75 |         { onSucceded = \a => sendResponse a.response stream }
  76 |         { onFailed = \e => sendResponse (errorHandler $ TyTTP.Core.Error.message e) stream }
  77 |   in
  78 |     cont callbacks
  79 | 
  80 | parseRequest : ServerHttp2Stream -> Headers -> Either String RawHttpRequest
  81 | parseRequest stream headers =
  82 |   let Just method = parseMethod <$> headers.getHeader (show Fields.Method)
  83 |         | Nothing => Left "Method header is missing from request"
  84 |       scheme = parse <$> headers.getHeader (show Fields.Scheme)
  85 |       authority = headers.getHeader (show Fields.Authority)
  86 |       Just pathAndSearch = headers.getHeader (show Fields.Path)
  87 |         | Nothing => Left "Path header is missing from request"
  88 |       (path, search) = String.break (=='?') pathAndSearch
  89 |       url = MkURL scheme authority path search
  90 |       version = Version_2
  91 |   in Right $ mkRequest method url version headers.asList $ MkPublisher $ \s => do
  92 |         stream.onData s.onNext
  93 |         (Readable.(.onError)) stream s.onFailed
  94 |         stream.onEnd $ s.onSucceded ()
  95 | 
  96 | pusher : HasIO io => ServerHttp2Stream -> Lazy PushContext -> io ()
  97 | pusher parent ctx = do
  98 |   reqHeaders <- mapHeaders $ ctx.request.headers
  99 |     <+> (maybe [] pure $ map ((show Fields.Scheme,) . show) ctx.request.url.scheme)
 100 |     <+> (maybe [] pure $ map (show Fields.Authority,) ctx.request.url.authority)
 101 |     <+> [ (show Fields.Method, show ctx.request.method)
 102 |         , (show Fields.Path, ctx.request.url.path)
 103 |         ]
 104 |   parent.pushStream reqHeaders $ \err, stream, headers => do
 105 |     if truthy err then putStrLn "ERROR: \{JSON.stringify err 2}"
 106 |                   else sendResponse ctx.response stream
 107 |     where
 108 |       mapHeaders : StringHeaders -> io Headers
 109 |       mapHeaders h = do
 110 |         newHeaders <- empty
 111 |         foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h
 112 | 
 113 | public export
 114 | record Options where
 115 |   constructor MkOptions
 116 |   netServerOptions : Net.CreateServer.Options
 117 |   serverOptions : HTTP2.CreateServer.Options
 118 |   listenOptions : Listen.Options
 119 |   errorHandler : String -> RawHttpResponse
 120 | 
 121 | export
 122 | defaultOptions : HTTP2.Options
 123 | defaultOptions = MkOptions
 124 |   { netServerOptions = Net.CreateServer.defaultOptions
 125 |   , serverOptions = HTTP2.CreateServer.defaultOptions
 126 |   , listenOptions =
 127 |     { port := Just 3000
 128 |     , host := Just "localhost"
 129 |     } Listen.defaultOptions
 130 |   , errorHandler = \e => MkResponse
 131 |     { status = INTERNAL_SERVER_ERROR
 132 |     , headers =
 133 |       [ ("Content-Type", "text/plain")
 134 |       , ("Content-Length", show $ length e)
 135 |       ]
 136 |     , body = singleton $ fromString e
 137 |     }
 138 |   }
 139 | 
 140 | export
 141 | listen : HasIO io
 142 |    => HasIO pushIO
 143 |    => Error e
 144 |    => HTTP2Module
 145 |    -> HTTP2.Options
 146 |    -> (
 147 |         (Lazy PushContext -> pushIO ())
 148 |         -> Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) ()
 149 |         -> Promise e IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer)
 150 |       )
 151 |    -> io Http2Server
 152 | listen http2 options handler = do
 153 |   server <- http2.createServer $ MkOptions
 154 |                 { server = options.serverOptions
 155 |                 , net = options.netServerOptions
 156 |                 }
 157 | 
 158 |   server.onStream $ \stream, headers => do
 159 |     let Right req = parseRequest stream headers
 160 |           | Left err => sendResponse (options.errorHandler err) stream
 161 |         initialRes = MkResponse OK [] () {h = StringHeaders}
 162 |         push = if stream.pushAllowed then pusher stream
 163 |                                      else const $ pure ()
 164 |         result = handler push $ MkContext req initialRes
 165 | 
 166 |     sendResponseFromPromise options.errorHandler result stream
 167 | 
 168 |   server.listen options.listenOptions
 169 |   pure server
 170 | 
 171 | export
 172 | listen' : HasIO io
 173 |    => HasIO pushIO
 174 |    => Error e
 175 |    => { auto http2 : HTTP2Module }
 176 |    -> (
 177 |         (Lazy PushContext -> pushIO ())
 178 |         -> Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) ()
 179 |         -> Promise e IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer)
 180 |       )
 181 |    -> io Http2Server
 182 | listen' {http2} handler = listen http2 defaultOptions handler
 183 | 
 184 | namespace Secure
 185 | 
 186 |   public export
 187 |   record Options where
 188 |     constructor MkOptions
 189 |     netServerOptions : Net.CreateServer.Options
 190 |     tlsServerOptions : TLS.CreateServer.Options
 191 |     tlsContextOptions : TLS.CreateSecureContext.Options
 192 |     serverOptions : HTTP2.CreateSecureServer.Options
 193 |     listenOptions : Listen.Options
 194 |     errorHandler : String -> RawHttpResponse
 195 | 
 196 |   export
 197 |   defaultOptions : HTTP2.Secure.Options
 198 |   defaultOptions = MkOptions
 199 |     { netServerOptions = Net.CreateServer.defaultOptions
 200 |     , tlsServerOptions = TLS.CreateServer.defaultOptions
 201 |     , tlsContextOptions = TLS.CreateSecureContext.defaultOptions
 202 |     , serverOptions = HTTP2.CreateSecureServer.defaultOptions
 203 |     , listenOptions =
 204 |       { port := Just 3443
 205 |       , host := Just "localhost"
 206 |       } Listen.defaultOptions
 207 |     , errorHandler = \e => MkResponse
 208 |       { status = INTERNAL_SERVER_ERROR
 209 |       , headers =
 210 |         [ ("Content-Type", "text/plain")
 211 |         , ("Content-Length", show $ length e)
 212 |         ]
 213 |       , body = singleton $ fromString e
 214 |       }
 215 |     }
 216 | 
 217 |   export
 218 |   listen : HasIO io
 219 |      => HasIO pushIO
 220 |      => Error e
 221 |      => HTTP2Module
 222 |      -> HTTP2.Secure.Options
 223 |      -> (
 224 |           (Lazy PushContext -> pushIO ())
 225 |           -> Context Method SimpleURL Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) ()
 226 |           -> Promise e IO $ Context Method SimpleURL Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer)
 227 |         )
 228 |      -> io Http2Server
 229 |   listen http2 options handler = do
 230 |     server <- http2.createSecureServer $ MkOptions
 231 |                   { server = options.serverOptions
 232 |                   , context = options.tlsContextOptions
 233 |                   , tls = options.tlsServerOptions
 234 |                   , net = options.netServerOptions
 235 |                   }
 236 | 
 237 |     server.onStream $ \stream, headers => do
 238 |       let Right req = parseRequest stream headers
 239 |             | Left err => sendResponse (options.errorHandler err) stream
 240 |           initialRes = MkResponse OK [] () {h = StringHeaders}
 241 |           push = if stream.pushAllowed then pusher stream
 242 |                                        else const $ pure ()
 243 |           result = handler push $ MkContext req initialRes
 244 | 
 245 |       sendResponseFromPromise options.errorHandler result stream
 246 | 
 247 |     server.listen options.listenOptions
 248 |     pure server
 249 |