git.iko.soy/rowtype-yoga/psfp
on b360dae help sign in
rowtype-yoga/psfp/server/src/Main.purs
182 lines 6.2 kB history raw
1module Main where
3import Prelude
4import Data.Array (fromFoldable, head, (..))
5import Data.Either (Either(..))
6import Data.Foldable (for_)
7import Data.Int (fromString)
8import Data.Maybe (Maybe(..), fromMaybe)
9import Data.Newtype (un)
10import Data.Posix.Signal (Signal(..))
11import Data.String.Utils (lines)
12import Data.Time.Duration (Seconds(..), fromDuration)
13import Effect (Effect)
14import Effect.Aff (Aff, effectCanceler, launchAff_, makeAff)
15import Effect.Aff.Class (liftAff)
16import Effect.Class (class MonadEffect, liftEffect)
17import Effect.Class.Console (info, log)
18import Effect.Exception (throw)
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, defaultExecOptions, exec, kill, pid)
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, writeTextFile)
36import Node.HTTP (Server)
37import Node.OS (numCpus)
38import Node.Process (lookupEnv)
39import Playground.Playground (Folder(..), copy)
40import Shared.Json (readAff)
41import Shared.Models.Body (PursResult, RunResult, CompileRequest)
42import Shared.Models.Body as Body
43import Simple.JSON (read_, write)
44import Simple.JSON as JSON
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
62compileCode ∷ Folder -> String -> Aff PursResult
63compileCode folder code = do
64 saveMainFile folder code
65 { stderr } <- execCommand folder "spago build --purs-args \"--json-errors\""
66 strResult <- liftEffect $ Buffer.toString UTF8 stderr
67 case checkOutput strResult of
68 Just r -> pure r
69 Nothing -> liftEffect $ throw $ "No result in " <> strResult
70 where
71 checkOutput output =
72 head do
73 line <- lines output
74 let
75 (parseable :: Maybe PursResult) = JSON.readJSON_ line
76 fromFoldable parseable
78runCode ∷ Folder -> Aff ExecResult
79runCode folder = execCommand folder "node run.js"
81saveMainFile ∷ Folder -> String -> Aff Unit
82saveMainFile folder code = writeTextFile UTF8 (un Folder folder <> "/src/Main.purs") code
84execCommand ∷ Folder -> String -> Aff ExecResult
85execCommand folder command =
86 makeAff \callback -> do
87 let
88 options = defaultExecOptions { cwd = Just (un Folder folder) }
89 childProcess <- exec command options (callback <<< Right)
90 pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
92compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob Folder
93compileAndRunJob json handle =
94 NewJob \folder -> do
95 compileResult <- compileCode folder (json ∷ Body.CompileRequest).code
96 if compileResult.errors /= [] then do
97 handle $ setStatus 422
98 handle $ Response.send $ write ({ result: compileResult } ∷ Body.CompileResult)
99 else do
100 runResult <- runCode folder
101 resultBody <- toBody runResult
102 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
104compileAndRunHandler ∷ Queue Folder -> Handler
105compileAndRunHandler queue = do
106 body <- getBody'
107 json <- readAff body # liftAff
108 HandlerM \req res next -> do
109 let
110 handle = unHandler req res next
112 runJob = compileAndRunJob json handle
113 queueRes <- Q.enqueue runJob queue # liftEffect
114 case queueRes of
115 Enqueued _ -> pure unit
116 QueueFull ->
117 handle do
118 setStatus 500
119 Response.send $ write { error: "Queue full" }
121unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
122unHandler req res next (HandlerM h) = h req res next
124srcFolder ∷ String
125srcFolder = "../playground"
127destFolder ∷ String
128destFolder = "../playgrounds/"
130main ∷ Effect Unit
131main =
132 launchAff_ do
133 cpus <- numCpus # liftEffect
134 let
135 foldersToUse = max 2 (cpus - 1) -- use at least 2
137 mkFolder = Folder <<< (destFolder <> _) <<< show
139 folders = mkFolder <$> (0 .. foldersToUse)
141 folderPool = ResourcePool folders
142 for_ folders \(Folder f) -> copy srcFolder f
143 q <-
144 Q.mkQueue
145 { maxSize: 50
146 , timeout: 60.0 # Seconds # fromDuration
147 }
148 folderPool
149 serverSetup (makeApp q)
151makeApp ∷ Queue Folder -> App
152makeApp q = do
153 use $ static "assets"
154 useExternal jsonBodyParser
155 E.post "/compileAndRun" (compileAndRunHandler q)
157data CertificatesToUse
158 = UseLocalCertificates
159 | DoNotUseLocalCertificates
161parseCertificatesToUse ∷ String -> CertificatesToUse
162parseCertificatesToUse = case _ of
163 "LOCAL" -> UseLocalCertificates
164 _ -> DoNotUseLocalCertificates
166serverSetup ∷ App -> Aff Server
167serverSetup app = do
168 maybePortString <- lookupEnv "PORT" # liftEffect
169 let
170 port = maybePortString >>= fromString # fromMaybe 14188
171 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
172 listen <- case useLocalCertificates of
173 UseLocalCertificates -> do
174 httpsOptions <- makeHttpsOptions
175 pure $ listenHttps app (port ∷ Int) httpsOptions
176 DoNotUseLocalCertificates -> pure $ listenHttp app port
177 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
178 where
179 makeHttpsOptions = do
180 key <- readTextFile UTF8 "server.key"
181 cert <- readTextFile UTF8 "server.cert"
182 pure { key, cert }