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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | 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 Control.Exception (try)
import Data.Aeson
( Value,
decode,
eitherDecode,
object,
(.=),
)
import Data.ByteString.Lazy (fromStrict)
import qualified Data.ByteString.Lazy as LBS
import Data.Data (Proxy (..))
import Data.Default
import Data.Swagger (Swagger)
import Data.Text (Text)
import Minilang.API (Challenge, LambdaAPI, defaultChallenges)
import Minilang.App (Env (..), lambdaApp, makeEnv, runApp)
import Minilang.Log
import Minilang.OpenApi (lambdaSwagger)
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 Servant (Get, JSON, hoistServer, (:<|>) (..), (:>))
import Servant.Server (serve)
import System.Log.FastLogger (fromLogStr)
import System.Random (newStdGen)
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
challenges <- readChallenges logger
env <- newStdGen >>= (`makeEnv` challenges)
let app =
loggerMiddleware $
runNetREPL logger envs (serveAPI env)
(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))
}
readChallenges :: LoggerEnv IO -> IO [Challenge]
readChallenges logger = do
file <- try $ LBS.readFile "challenges.json"
case file of
Left (_ :: IOError) -> do
logInfo logger $ object ["action" .= ("NoChallengesFile" :: Text)]
pure defaultChallenges
Right content -> case eitherDecode content of
Right challenges -> do
logInfo logger $ object ["action" .= ("LoadedChallenges" :: Text), "count" .= length challenges]
pure challenges
Left err -> do
logError logger $ object ["action" .= ("FailedToLoadChallenges" :: Text), "error" .= show err]
pure defaultChallenges
serveAPI :: Env -> Application
serveAPI env =
serve fullApiProxy $
hoistServer fullApiProxy (runApp env) (pure lambdaSwagger :<|> lambdaApp)
type FullAPI =
"api.json" :> Get '[JSON] Swagger
:<|> LambdaAPI
apiProxy :: Proxy LambdaAPI
apiProxy = Proxy
fullApiProxy :: Proxy FullAPI
fullApiProxy = Proxy
stopServer :: Server -> IO ()
stopServer (Server (Just th) _) = cancel th
stopServer _ = pure ()
waitServer :: Server -> IO ()
waitServer (Server (Just th) _) = wait th
waitServer _ = pure ()
|
