git.iko.soy/rowtype-yoga/psfp
on 191a78d help sign in
rowtype-yoga/psfp/server/src/Main.purs
163 lines 5.4 kB history raw
1module Main where
3import Prelude
5import Control.Parallel (parTraverse)
6import Data.Array ((..))
7import Data.Either (Either(..))
8import Data.Int (fromString)
9import Data.Maybe (Maybe, fromMaybe)
10import Data.Newtype (un)
11import Data.Time.Duration (Seconds(..), fromDuration)
12import Data.Traversable (for)
13import Effect (Effect)
14import Effect.Aff (Aff, launchAff_)
15import Effect.Aff.Class (liftAff)
16import Effect.Class (class MonadEffect, liftEffect)
17import Effect.Class.Console (info, log)
18import Foreign (unsafeToForeign)
19import JobQueue (EnqueueResult(..), NewJob(..), Queue, ResourcePool(..))
20import JobQueue as Q
21import Middleware.JsonBodyParser (jsonBodyParser)
22import Node.Buffer (Buffer)
23import Node.Buffer as Buffer
24import Node.ChildProcess (ExecResult)
25import Node.Encoding (Encoding(..))
26import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
27import Node.Express.App as E
28import Node.Express.Handler (HandlerM(..), Handler)
29import Node.Express.Middleware.Static (static)
30import Node.Express.Request (getBody')
31import Node.Express.Response (setStatus)
32import Node.Express.Response as Response
33import Node.Express.Types (Request, Response)
34import Node.FS.Aff (readTextFile)
35import Node.HTTP (Server)
36import Node.OS (numCpus)
37import Node.Process (lookupEnv)
38import Playground.Playground (Folder(..), copy)
39import PscIdeClient (PscIdeConnection, compileCode, getFolder, mkConnection, execCommand)
40import Shared.Json (readAff)
41import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
42import Shared.Models.Body as Body
43import Simple.JSON (readJSON, read_, write)
45toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
46toBody result =
47 liftEffect
48 $ ado
49 stdout <- Buffer.toString UTF8 result.stdout
50 stderr <- Buffer.toString UTF8 result.stderr
51 let
52 (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
53 in { code, stdout, stderr } ∷ RunResult
55type ErrorWithCode
56 = { code ∷ Maybe Int }
58asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
59asErrorWithCode = read_ <<< unsafeToForeign
61runCode ∷ Folder -> Aff ExecResult
62runCode folder = execCommand folder "node run.js"
64compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
65compileAndRunJob json handle =
66 NewJob \jobId conn -> do
67 responseString <- compileCode json.code conn
68 case ((readJSON responseString) :: _ _ CompileResult) of
69 Right res | res.resultType == "error" -> do
70 handle $ setStatus 422
71 handle $ Response.send $ write res
72 Right res -> do
73 runResult <- runCode (getFolder conn)
74 resultBody <- toBody runResult
75 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
76 Left errs -> do
77 handle $ setStatus 500
78 log $ "Could not decode: " <> responseString <> "\nErrors: " <> show errs
79 handle $ Response.send $ write {}
81compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
82compileAndRunHandler queue = do
83 body <- getBody'
84 json <- readAff body # liftAff
85 HandlerM \req res next -> do
86 let
87 handle = unHandler req res next
89 runJob = compileAndRunJob json handle
90 queueRes <- Q.enqueue runJob queue # liftEffect
91 case queueRes of
92 Enqueued _ -> pure unit
93 QueueFull ->
94 handle do
95 setStatus 500
96 Response.send $ write { error: "Queue full" }
98unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
99unHandler req res next (HandlerM h) = h req res next
101srcFolder ∷ String
102srcFolder = "../playground"
104destFolder ∷ String
105destFolder = "../playgrounds/"
107main ∷ Effect Unit
108main = do
109 launchAff_ do
110 cpus <- numCpus # liftEffect
111 let
112 poolSize = max 2 (cpus / 2) -- use at least 2
114 mkFolder = Folder <<< (destFolder <> _) <<< show
116 connections <- (1 .. poolSize) # parTraverse \n -> do
117 let folder = mkFolder n
118 port = 14100 + n
119 log $ "Copying to folder " <> (un Folder folder)
120 copy srcFolder (un Folder folder)
121 mkConnection folder port
123 let pool = ResourcePool connections
124 q <-
125 Q.mkQueue
126 { maxSize: 50
127 , timeout: 10.0 # Seconds # fromDuration
128 }
129 pool
130 serverSetup (makeApp q)
132makeApp ∷ Queue PscIdeConnection -> App
133makeApp q = do
134 use $ static "assets"
135 useExternal jsonBodyParser
136 E.post "/compileAndRun" (compileAndRunHandler q)
138data CertificatesToUse
139 = UseLocalCertificates
140 | DoNotUseLocalCertificates
142parseCertificatesToUse ∷ String -> CertificatesToUse
143parseCertificatesToUse = case _ of
144 "LOCAL" -> UseLocalCertificates
145 _ -> DoNotUseLocalCertificates
147serverSetup ∷ App -> Aff Server
148serverSetup app = do
149 maybePortString <- lookupEnv "PORT" # liftEffect
150 let
151 port = maybePortString >>= fromString # fromMaybe 14188
152 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
153 listen <- case useLocalCertificates of
154 UseLocalCertificates -> do
155 httpsOptions <- makeHttpsOptions
156 pure $ listenHttps app (port ∷ Int) httpsOptions
157 DoNotUseLocalCertificates -> pure $ listenHttp app port
158 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
159 where
160 makeHttpsOptions = do
161 key <- readTextFile UTF8 "server.key"
162 cert <- readTextFile UTF8 "server.cert"
163 pure { key, cert }