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