git.iko.soy/rowtype-yoga/psfp
on 4a3f8f8 help sign in
rowtype-yoga/psfp/server/src/Main.purs
170 lines 5.8 kB history raw
1module Main where
3import Prelude
5import Data.Array ((..))
6import Data.Either (Either(..))
7import Data.Int (fromString)
8import Data.Maybe (Maybe(..), fromMaybe)
9import Data.Newtype (un)
10import Data.Posix.Signal (Signal(..))
11import Data.Time.Duration (Seconds(..), fromDuration)
12import Data.Traversable (for)
13import Effect (Effect)
14import Effect.Aff (Aff, effectCanceler, launchAff_, makeAff, parallel, sequential)
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, defaultExecOptions, exec, kill, pid)
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)
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"
64execCommand ∷ Folder -> String -> Aff ExecResult
65execCommand folder command =
66 makeAff \callback -> do
67 let
68 options = defaultExecOptions { cwd = Just (un Folder folder) }
69 childProcess <- exec command options (callback <<< Right)
70 pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
72compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
73compileAndRunJob json handle =
74 NewJob \jobId conn -> do
75 responseString <- compileCode json.code conn
76 case ((readJSON responseString) :: _ _ CompileResult) of
77 Right res | res.resultType == "error" -> do
78 handle $ setStatus 422
79 handle $ Response.send $ write res
80 Right res -> do
81 runResult <- runCode (getFolder conn)
82 resultBody <- toBody runResult
83 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
84 Left errs -> do
85 handle $ setStatus 500
86 log $ "Could not decode: " <> responseString <> "\nErrors: " <> show errs
87 handle $ Response.send $ write {}
89compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
90compileAndRunHandler queue = do
91 body <- getBody'
92 json <- readAff body # liftAff
93 HandlerM \req res next -> do
94 let
95 handle = unHandler req res next
97 runJob = compileAndRunJob json handle
98 queueRes <- Q.enqueue runJob queue # liftEffect
99 case queueRes of
100 Enqueued _ -> pure unit
101 QueueFull ->
102 handle do
103 setStatus 500
104 Response.send $ write { error: "Queue full" }
106unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
107unHandler req res next (HandlerM h) = h req res next
109srcFolder ∷ String
110srcFolder = "../playground"
112destFolder ∷ String
113destFolder = "../playgrounds/"
115main ∷ Effect Unit
116main = do
117 launchAff_ do
118 cpus <- numCpus # liftEffect
119 let
120 poolSize = max 2 (cpus - 1) -- use at least 2
122 mkFolder = Folder <<< (destFolder <> _) <<< show
124 connections <- for (0 .. poolSize) \n -> do
125 let folder = mkFolder n
126 port = 14100 + n
127 copy srcFolder (un Folder folder)
128 mkConnection folder port
130 let pool = ResourcePool connections
131 q <-
132 Q.mkQueue
133 { maxSize: 50
134 , timeout: 10.0 # Seconds # fromDuration
135 }
136 pool
137 serverSetup (makeApp q)
139makeApp ∷ Queue PscIdeConnection -> App
140makeApp q = do
141 use $ static "assets"
142 useExternal jsonBodyParser
143 E.post "/compileAndRun" (compileAndRunHandler q)
145data CertificatesToUse
146 = UseLocalCertificates
147 | DoNotUseLocalCertificates
149parseCertificatesToUse ∷ String -> CertificatesToUse
150parseCertificatesToUse = case _ of
151 "LOCAL" -> UseLocalCertificates
152 _ -> DoNotUseLocalCertificates
154serverSetup ∷ App -> Aff Server
155serverSetup app = do
156 maybePortString <- lookupEnv "PORT" # liftEffect
157 let
158 port = maybePortString >>= fromString # fromMaybe 14188
159 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
160 listen <- case useLocalCertificates of
161 UseLocalCertificates -> do
162 httpsOptions <- makeHttpsOptions
163 pure $ listenHttps app (port ∷ Int) httpsOptions
164 DoNotUseLocalCertificates -> pure $ listenHttp app port
165 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
166 where
167 makeHttpsOptions = do
168 key <- readTextFile UTF8 "server.key"
169 cert <- readTextFile UTF8 "server.cert"
170 pure { key, cert }