git.iko.soy/rowtype-yoga/psfp
on 4e7334b help sign in
rowtype-yoga/psfp/server/src/Main.purs
202 lines 6.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)
42import Shared.Models.Body as Body
43import Simple.JSON (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
61-- compileCode ∷ JobId -> Folder -> Int -> String -> Aff PursResult
62-- compileCode jobId folder port code = do
63-- saveMainFile folder code
64-- { stderr } <- execCommand folder "node_modules/spago/spago build --purs-args \"--json-errors\""
65-- strResult <- liftEffect $ Buffer.toString UTF8 stderr
67-- case checkOutput strResult of
68-- Just r -> do
69-- pure r
70-- Nothing -> do
71-- liftEffect $ throw $ "No result in " <> strResult
72-- where
73-- checkOutput output =
74-- head do
75-- line <- lines output
76-- let
77-- (parseable :: Maybe PursResult) = JSON.readJSON_ line
78-- fromFoldable parseable
80-- compileCodeOld ∷ JobId -> Folder -> String -> Aff PursResult
81-- compileCodeOld jobId folder code = do
82-- saveMainFile folder code
83-- { stderr } <- execCommand folder "node_modules/spago/spago build --purs-args \"--json-errors\""
84-- strResult <- liftEffect $ Buffer.toString UTF8 stderr
85-- case checkOutput strResult of
86-- Just r -> do
87-- pure r
88-- Nothing -> do
89-- liftEffect $ throw $ "No result in " <> strResult
90-- where
91-- checkOutput output =
92-- head do
93-- line <- lines output
94-- let
95-- (parseable :: Maybe PursResult) = JSON.readJSON_ line
96-- fromFoldable parseable
98runCode ∷ Folder -> Aff ExecResult
99runCode folder = execCommand folder "node run.js"
101execCommand ∷ Folder -> String -> Aff ExecResult
102execCommand folder command =
103 makeAff \callback -> do
104 let
105 options = defaultExecOptions { cwd = Just (un Folder folder) }
106 childProcess <- exec command options (callback <<< Right)
107 pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
109compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
110compileAndRunJob json handle =
111 NewJob \jobId conn -> do
112 compileResult <- compileCode json.code conn
113 if compileResult.resultType == "error" then do
114 handle $ setStatus 422
115 handle $ Response.send $ write compileResult
116 else do
117 runResult <- runCode (getFolder conn)
118 resultBody <- toBody runResult
119 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
121compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
122compileAndRunHandler queue = do
123 body <- getBody'
124 json <- readAff body # liftAff
125 HandlerM \req res next -> do
126 let
127 handle = unHandler req res next
129 runJob = compileAndRunJob json handle
130 queueRes <- Q.enqueue runJob queue # liftEffect
131 case queueRes of
132 Enqueued _ -> pure unit
133 QueueFull ->
134 handle do
135 setStatus 500
136 Response.send $ write { error: "Queue full" }
138unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
139unHandler req res next (HandlerM h) = h req res next
141srcFolder ∷ String
142srcFolder = "../playground"
144destFolder ∷ String
145destFolder = "../playgrounds/"
147main ∷ Effect Unit
148main = do
149 launchAff_ do
150 cpus <- numCpus # liftEffect
151 let
152 poolSize = max 2 (cpus - 1) -- use at least 2
154 mkFolder = Folder <<< (destFolder <> _) <<< show
156 connections <- sequential $ for (0 .. poolSize) \n -> parallel do
157 let folder = mkFolder n
158 port = 14100 + n
159 copy srcFolder (un Folder folder)
160 mkConnection folder port
162 let pool = ResourcePool connections
163 q <-
164 Q.mkQueue
165 { maxSize: 50
166 , timeout: 60.0 # Seconds # fromDuration
167 }
168 pool
169 serverSetup (makeApp q)
171makeApp ∷ Queue PscIdeConnection -> App
172makeApp q = do
173 use $ static "assets"
174 useExternal jsonBodyParser
175 E.post "/compileAndRun" (compileAndRunHandler q)
177data CertificatesToUse
178 = UseLocalCertificates
179 | DoNotUseLocalCertificates
181parseCertificatesToUse ∷ String -> CertificatesToUse
182parseCertificatesToUse = case _ of
183 "LOCAL" -> UseLocalCertificates
184 _ -> DoNotUseLocalCertificates
186serverSetup ∷ App -> Aff Server
187serverSetup app = do
188 maybePortString <- lookupEnv "PORT" # liftEffect
189 let
190 port = maybePortString >>= fromString # fromMaybe 14188
191 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
192 listen <- case useLocalCertificates of
193 UseLocalCertificates -> do
194 httpsOptions <- makeHttpsOptions
195 pure $ listenHttps app (port ∷ Int) httpsOptions
196 DoNotUseLocalCertificates -> pure $ listenHttp app port
197 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
198 where
199 makeHttpsOptions = do
200 key <- readTextFile UTF8 "server.key"
201 cert <- readTextFile UTF8 "server.cert"
202 pure { key, cert }