0 | ||| The main engine running the HTTP server, there is nothing about APIs here
  1 | module Stellar.HTTP.Engine
  2 |
  3 | import TyTTP.HTTP
  4 | import TyTTP.Adapter.Node.HTTP
  5 |
  6 | import Node.HTTP.IncomingMessage
  7 |
  8 | import Control.Monad.Continuation
  9 |
 10 | import Stellar.HTTP.Async
 11 | import Stellar.HTTP.Types
 12 |
 13 | %hide Stellar.HTTP.Types.(.body)
 14 |
 15 | ||| Log levels for the application
 16 | public export
 17 | data Logging = Silent | Normal | Debug | Verbose
 18 |
 19 | toNat : Logging -> Nat
 20 | toNat Silent = 0
 21 | toNat Normal = 1
 22 | toNat Debug = 2
 23 | toNat Verbose = 3
 24 |
 25 | export
 26 | Eq Logging where
 27 |   a == b = toNat a == toNat b
 28 |
 29 | export
 30 | Ord Logging where
 31 |   compare a b = compare (toNat a) (toNat b)
 32 |
 33 | public export
 34 | record ServerConfig where
 35 |   constructor MkServerConfig
 36 |   logging : Logging
 37 |   hostname : String
 38 |   port : Int
 39 |
 40 | export
 41 | logLvl : (cfg : ServerConfig) => HasIO io => Logging -> String -> io ()
 42 | logLvl lvl msg = if cfg.logging >= lvl
 43 |                  then putStrLn msg
 44 |                  else pure ()
 45 |
 46 | export
 47 | logDebug : (cfg : ServerConfig) => HasIO io => String -> io ()
 48 | logDebug = logLvl Debug
 49 |
 50 | export
 51 | logVerbose : (cfg : ServerConfig) => HasIO io => String -> io ()
 52 | logVerbose = logLvl Verbose
 53 |
 54 | export
 55 | log : (cfg : ServerConfig) => HasIO io => String -> io ()
 56 | log = logLvl Normal
 57 |
 58 | export
 59 | localhost : (port : Int) -> ServerConfig
 60 | localhost = MkServerConfig Normal "localhost"
 61 |
 62 | fromNodeRequest : IncomingMessage -> RawHttpRequest
 63 | fromNodeRequest nodeReq =
 64 |   let method = parseMethod nodeReq.method
 65 |       path = nodeReq.url
 66 |       headers = nodeReq.headers.asList
 67 |       version = parseVersion nodeReq.httpVersion
 68 |   in mkRequest method path version headers $ MkPublisher $ \s => do
 69 |       nodeReq.onData s.onNext
 70 |       nodeReq.onError s.onFailed
 71 |       nodeReq.onEnd $ s.onSucceded ()
 72 |
 73 | toNodeResponse : GenericHttpResponse Buffer -> ServerResponse -> JSCont ()
 74 | toNodeResponse res nodeRes = do
 75 |   let status = res.status.code
 76 |   headers <- liftIO $ mapHeaders res.headers
 77 |
 78 |   nodeRes.writeHead status headers
 79 |   nodeRes.write res.body Nothing
 80 |   nodeRes.end Nothing
 81 |   where
 82 |     mapHeaders : StringHeaders -> IO Headers
 83 |     mapHeaders h = do
 84 |       newHeaders <- empty
 85 |       foldlM (\hs, (k,v) => hs.setHeader k v) newHeaders h
 86 |
 87 | computeResponse : (PlainRequest -> IO PlainResponse) -> IncomingMessage -> ServerResponse -> JSCont ()
 88 | computeResponse h inc res = do
 89 |   req <- asyncify (fromNodeRequest inc)
 90 |   rawRes <- liftIO $ h req
 91 |   printLn (IncomingMessage.(.method) inc)
 92 |   printLn inc.url
 93 |   toNodeResponse rawRes res
 94 |
 95 | ||| The most basic echo server takes a plein request and returns a plain response
 96 | export
 97 | echo : PlainRequest -> IO PlainResponse
 98 | echo req =
 99 |   pure $ MkResponse OK empty req.body
100 |
101 | parameters (cfg : ServerConfig)
102 |   ||| To create a server, we need a hostname, a port and a handler.
103 |   ||| The server then runs asynchronously on node.
104 |   export
105 |   http : (handler: PlainRequest -> IO PlainResponse) -> IO ()
106 |   http handler = do
107 |     http_ <- Node.HTTP.require
108 |     server <- http_.createServer defaultOptions
109 |     server.listen $
110 |       { port := Just cfg.port , host := Just cfg.hostname }
111 |       Listen.defaultOptions
112 |     log "Listening on port \{show cfg.port}"
113 |     server.onRequest (\inc, out => logDebug "got new request" >> runCont (computeResponse handler inc out) )
114 |