{-# LANGUAGE TypeApplications #-} -- | An HTTP server providing a basic REPL and text editor to work -- collaboratively on Minilang code. module Minilang.Server where import Control.Concurrent.Async import Control.Concurrent.STM.TVar import Data.Aeson ( Value, decode, object, (.=), ) import Data.ByteString.Lazy (fromStrict) import Data.Default import Data.Text (Text) import Minilang.Log import Minilang.REPL.Net import Network.Wai import Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger.JSON import Network.Wai.Middleware.Static (addBase, defaultOptions, staticPolicyWithOptions) import Servant.Server (serve) import System.Log.FastLogger (fromLogStr) import Data.Data (Proxy (..)) import Minilang.API (LambdaAPI) import Minilang.App (lambdaApp) data Server = Server { -- | If the server is running, this will contain the underlying serverThread :: Maybe (Async ()), -- | The actual port this server is listening on. Useful when serverPort :: Int } -- | Starts HTTP server on given port. -- This server serves static files from public/ directory and also -- exposes a WebSocket-based REPL under `/repl` path. startServer :: Int -> IO Server startServer serverPort = do envs <- newTVarIO mempty logger <- newLog "minilang" loggerMiddleware <- runHTTPLog logger let app = loggerMiddleware $ runNetREPL logger envs serveAPI (port, action) <- startWarp serverPort app thread <- async action logInfo logger $ object ["action" .= ("Started" :: Text), "port" .= port] pure $ Server (Just thread) port where startWarp 0 app = do (port, socket) <- openFreePort pure (port, Warp.runSettingsSocket defaultSettings socket app) startWarp port app = pure (port, Warp.run port app) runHTTPLog logger = mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON, destination = Callback (\str -> logInfo logger (decode @Value $ fromStrict $ fromLogStr str)) } serveAPI :: Application serveAPI = serve apiProxy lambdaApp apiProxy :: Proxy LambdaAPI apiProxy = Proxy stopServer :: Server -> IO () stopServer (Server (Just th) _) = cancel th stopServer _ = pure () waitServer :: Server -> IO () waitServer (Server (Just th) _) = wait th waitServer _ = pure ()