git.iko.soy/rowtype-yoga/psfp
on 148366a help sign in
rowtype-yoga/psfp/server/src/Main.purs
178 lines 6.1 kB history raw
1module Main where
3import Prelude
5import Control.Parallel (parOneOf, parTraverse)
6import Data.Array ((..))
7import Data.Bifunctor (lmap)
8import Data.Either (Either(..))
9import Data.Int (fromString)
10import Data.Maybe (Maybe(..), fromMaybe)
11import Data.Newtype (un)
12import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
13import Effect (Effect)
14import Effect.Aff (Aff, attempt, delay, launchAff_, message)
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 ∷ ∀ d. Duration d => d -> Folder -> Aff (Maybe ExecResult)
62runCode timeout folder = parOneOf
63 [ Just <$> execCommand folder "exec node run.js"
64 , Nothing <$ delay (timeout # fromDuration)
65 ]
67compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
68compileAndRunJob json handle =
69 NewJob \jobId conn -> do
70 stringOrErr <- attempt $ compileCode json.code conn
71 case ((readJSON <$> stringOrErr) ∷ _ _ (_ _ CompileResult)) of
72 Left e -> do
73 handle $ setStatus 500
74 log $ "Aff failed with " <> message e
75 handle $ Response.send $ write {}
76 Right (Right res) | res.resultType == "error" -> do
77 handle $ setStatus 422
78 handle $ Response.send $ write res
79 Right (Right res) -> do
80 runResult <- runCode timeout (getFolder conn)
81 case runResult of
82 Nothing -> do
83 handle $ setStatus 408
84 handle $ Response.send $ write { error: "Timed out after running for " <> show timeout}
85 Just rr -> do
86 resultBody <- toBody rr
87 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
88 Right (Left errs) -> do
89 handle $ setStatus 500
90 log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
91 handle $ Response.send $ write {}
92 where
93 timeout = 1.0 # Seconds
95compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
96compileAndRunHandler queue = do
97 body <- getBody'
98 json <- readAff body # liftAff
99 HandlerM \req res next -> do
100 let
101 handle = unHandler req res next
103 runJob = compileAndRunJob json handle
104 queueRes <- Q.enqueue runJob queue # liftEffect
105 case queueRes of
106 Enqueued _ -> pure unit
107 QueueFull ->
108 handle do
109 setStatus 500
110 Response.send $ write { error: "Queue full" }
112unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
113unHandler req res next (HandlerM h) = h req res next
115srcFolder ∷ String
116srcFolder = "../playground"
118destFolder ∷ String
119destFolder = "../playgrounds/"
121main ∷ Effect Unit
122main = do
123 launchAff_ do
124 cpus <- numCpus # liftEffect
125 let
126 poolSize = max 2 (cpus / 2) -- use at least 2
128 mkFolder = Folder <<< (destFolder <> _) <<< show
130 connections <- (1 .. poolSize) # parTraverse \n -> do
131 let folder = mkFolder n
132 port = 14100 + n
133 log $ "Copying to folder " <> (un Folder folder)
134 copy srcFolder (un Folder folder)
135 mkConnection folder port
137 let pool = ResourcePool connections
138 q <-
139 Q.mkQueue
140 { maxSize: 50
141 , timeout: 10.0 # Seconds # fromDuration
142 }
143 pool
144 serverSetup (makeApp q)
146makeApp ∷ Queue PscIdeConnection -> App
147makeApp q = do
148 use $ static "assets"
149 useExternal jsonBodyParser
150 E.post "/compileAndRun" (compileAndRunHandler q)
152data CertificatesToUse
153 = UseLocalCertificates
154 | DoNotUseLocalCertificates
156parseCertificatesToUse ∷ String -> CertificatesToUse
157parseCertificatesToUse = case _ of
158 "LOCAL" -> UseLocalCertificates
159 _ -> DoNotUseLocalCertificates
161serverSetup ∷ App -> Aff Server
162serverSetup app = do
163 maybePortString <- lookupEnv "PORT" # liftEffect
164 let
165 port = maybePortString >>= fromString # fromMaybe 14188
166 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
167 listen <- case useLocalCertificates of
168 UseLocalCertificates -> do
169 httpsOptions <- makeHttpsOptions
170 pure $ listenHttps app (port ∷ Int) httpsOptions
171 DoNotUseLocalCertificates -> pure $ listenHttp app port
172 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
173 where
174 makeHttpsOptions = do
175 key <- readTextFile UTF8 "server.key"
176 cert <- readTextFile UTF8 "server.cert"
177 pure { key, cert }