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