blob: 5c34db43a36deeee1f4f6a834ba15f274c6a184d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
{-# 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.Application.Static
import Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.RequestLogger.JSON
import System.Log.FastLogger (fromLogStr)
import Control.Concurrent.Async
data Server = Server
{ serverThread :: Maybe (Async ())
-- ^If the server is running, this will contain the underlying
, serverPort :: Int
-- ^The actual port this server is listening on. Useful when
}
-- | 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 staticResources
(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))
}
stopServer :: Server -> IO ()
stopServer (Server (Just th) _) = cancel th
stopServer _ = pure ()
waitServer :: Server -> IO ()
waitServer (Server (Just th) _) = wait th
waitServer _ = pure ()
-- | Serve static resources under `public/` directory
staticResources :: Application
staticResources = staticApp (defaultFileServerSettings "public")
|
