0 | module TyTTP.Adapter.Node.HTTPS
  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 Node.HTTP
  8 | import public Node.HTTPS
  9 | import TyTTP
 10 | import public TyTTP.Adapter.Node.Error
 11 | import TyTTP.HTTP
 12 | import TyTTP.URL
 13 |
 14 | %hide Node.HTTP.Server.Server
 15 | %hide Node.Net.Server.Server
 16 |
 17 | public export
 18 | RawHttpRequest : Type
 19 | RawHttpRequest = HttpRequest String StringHeaders $ Publisher IO Error Buffer
 20 |
 21 | public export
 22 | RawHttpResponse : Type
 23 | RawHttpResponse = Response Status StringHeaders $ Publisher IO Error Buffer
 24 |
 25 | public export
 26 | record Options e where
 27 |   constructor MkOptions
 28 |   netServerOptions : Net.CreateServer.Options
 29 |   tlsServerOptions : TLS.CreateServer.Options
 30 |   tlsContextOptions : TLS.CreateSecureContext.Options
 31 |   serverOptions : HTTPS.CreateServer.Options
 32 |   listenOptions : Listen.Options
 33 |   errorHandler : e -> RawHttpResponse
 34 |
 35 | export
 36 | defaultOptions : Error e => HTTPS.Options e
 37 | defaultOptions = MkOptions
 38 |   { netServerOptions = Net.CreateServer.defaultOptions
 39 |   , tlsServerOptions = TLS.CreateServer.defaultOptions
 40 |   , tlsContextOptions = TLS.CreateSecureContext.defaultOptions
 41 |   , serverOptions = HTTPS.CreateServer.defaultOptions
 42 |   , listenOptions =
 43 |     { port := Just 3443
 44 |     , host := Just "localhost"
 45 |     } Listen.defaultOptions
 46 |   , errorHandler = \e => MkResponse
 47 |     { status = INTERNAL_SERVER_ERROR
 48 |     , headers =
 49 |       [ ("Content-Type", "text/plain")
 50 |       , ("Content-Length", show $ length $ TyTTP.Core.Error.message e)
 51 |       ]
 52 |     , body = singleton $ fromString $ TyTTP.Core.Error.message e
 53 |     }
 54 |   }
 55 |
 56 | toNodeResponse : RawHttpResponse -> ServerResponse -> IO ()
 57 | toNodeResponse res nodeRes = do
 58 |   let status = res.status.code
 59 |   headers <- mapHeaders res.headers
 60 |
 61 |   nodeRes.writeHead status headers
 62 |   res.body.subscribe $ MkSubscriber
 63 |         { onNext = \a => nodeRes.write a Nothing }
 64 |         { onFailed = \e => pure () }
 65 |         { onSucceded = \_ => nodeRes.end Nothing {d = Buffer} }
 66 |   where
 67 |     mapHeaders : StringHeaders -> IO Headers
 68 |     mapHeaders h = do
 69 |       newHeaders <- empty
 70 |       foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h
 71 |
 72 | fromPromiseToNodeResponse : Error e
 73 |   => (e -> RawHttpResponse)
 74 |   -> Promise e IO (Context Method String Version StringHeaders Status StringHeaders b $ Publisher IO Error Buffer)
 75 |   -> ServerResponse
 76 |   -> IO ()
 77 | fromPromiseToNodeResponse errorHandler (MkPromise cont) nodeRes =
 78 |   let callbacks = MkCallbacks
 79 |         { onSucceded = \a => toNodeResponse a.response nodeRes }
 80 |         { onFailed = \e => toNodeResponse (errorHandler e) nodeRes }
 81 |   in
 82 |     cont callbacks
 83 |
 84 | fromNodeRequest : IncomingMessage -> RawHttpRequest
 85 | fromNodeRequest nodeReq =
 86 |   let method = parseMethod nodeReq.method
 87 |       path = nodeReq.url
 88 |       headers = nodeReq.headers.asList
 89 |       version = parseVersion nodeReq.httpVersion
 90 |   in mkRequest method path version headers $ MkPublisher $ \s => do
 91 |         nodeReq.onData s.onNext
 92 |         nodeReq.onError s.onFailed
 93 |         nodeReq.onEnd $ s.onSucceded ()
 94 |
 95 | export
 96 | listen : HasIO io
 97 |    => Error e
 98 |    => HTTPSModule
 99 |    -> HTTPS.Options e
100 |    -> (
101 |         Context Method String Version StringHeaders Status StringHeaders (Publisher IO Error Buffer) ()
102 |         -> Promise e IO $ Context Method String Version StringHeaders Status StringHeaders b (Publisher IO Error Buffer)
103 |       )
104 |    -> io Server
105 | listen https options handler = do
106 |   server <- https.createServer $ MkOptions
107 |               { server = options.serverOptions
108 |               , context = options.tlsContextOptions
109 |               , tls = options.tlsServerOptions
110 |               , net = options.netServerOptions
111 |               }
112 |
113 |   server.onRequest $ \req => \res => do
114 |     let handlerReq = fromNodeRequest req
115 |         initialRes = MkResponse OK [] () {h = StringHeaders}
116 |         result = handler $ MkContext handlerReq initialRes
117 |
118 |     fromPromiseToNodeResponse options.errorHandler result res
119 |
120 |   server.listen options.listenOptions
121 |   pure server
122 |