git.iko.soy/rowtype-yoga/psfp
on 84c60dc help sign in
rowtype-yoga/psfp/server/src/Main.purs
208 lines 7.0 kB history raw
1module Main where
3import Prelude
5import Data.Array (fromFoldable, head, (..))
6import Data.Either (Either(..))
7import Data.Foldable (for_)
8import Data.Int (fromString)
9import Data.Maybe (Maybe(..), fromMaybe)
10import Data.Newtype (un)
11import Data.Posix.Signal (Signal(..))
12import Data.String.Utils (lines)
13import Data.Time.Duration (Seconds(..), fromDuration)
14import Effect (Effect)
15import Effect.AVar as AVar
16import Effect.Aff (Aff, Milliseconds(..), bracket, delay, effectCanceler, launchAff_, makeAff)
17import Effect.Aff.Class (liftAff)
18import Effect.Class (class MonadEffect, liftEffect)
19import Effect.Class.Console (info, log)
20import Effect.Exception (throw)
21import Foreign (unsafeToForeign)
22import JobQueue (EnqueueResult(..), NewJob(..), Queue, ResourcePool(..))
23import JobQueue as Q
24import Middleware.JsonBodyParser (jsonBodyParser)
25import Node.Buffer (Buffer)
26import Node.Buffer as Buffer
27import Node.ChildProcess (ExecResult, defaultExecOptions, exec, kill, pid)
28import Node.Encoding (Encoding(..))
29import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
30import Node.Express.App as E
31import Node.Express.Handler (HandlerM(..), Handler)
32import Node.Express.Middleware.Static (static)
33import Node.Express.Request (getBody')
34import Node.Express.Response (setStatus)
35import Node.Express.Response as Response
36import Node.Express.Types (Request, Response)
37import Node.FS.Aff (readTextFile, writeTextFile)
38import Node.HTTP (Server)
39import Node.OS (numCpus)
40import Node.Process (lookupEnv)
41import Playground.Playground (Folder(..), copy)
42import Shared.Json (readAff)
43import Shared.Models.Body (RunResult, PursResult)
44import Shared.Models.Body as Body
45import Simple.JSON (read_, write)
46import Simple.JSON as JSON
48toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
49toBody result =
50 liftEffect
51 $ ado
52 stdout <- Buffer.toString UTF8 result.stdout
53 stderr <- Buffer.toString UTF8 result.stderr
54 let
55 (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
56 in { code, stdout, stderr } ∷ RunResult
58type ErrorWithCode
59 = { code ∷ Maybe Int }
61asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
62asErrorWithCode = read_ <<< unsafeToForeign
64compileCode ∷ Folder -> String -> Aff PursResult
65compileCode folder code = do
66 saveMainFile folder code
67 { stderr } <- execCommand folder "spago build --purs-args \"--json-errors\""
68 strResult <- liftEffect $ Buffer.toString UTF8 stderr
69 case checkOutput strResult of
70 Just r -> pure r
71 Nothing -> 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
80runCode ∷ Folder -> Aff ExecResult
81runCode folder = execCommand folder "node run.js"
83saveMainFile ∷ Folder -> String -> Aff Unit
84saveMainFile folder code = writeTextFile UTF8 (un Folder folder <> "/src/Main.purs") code
86execCommand ∷ Folder -> String -> Aff ExecResult
87execCommand folder command =
88 makeAff \callback -> do
89 let
90 options = defaultExecOptions { cwd = Just (un Folder folder) }
91 childProcess <- exec command options (callback <<< Right)
92 pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
94compileHandler ∷ Queue Folder -> HandlerM Unit
95compileHandler queue = do
96 body <- getBody'
97 json <- readAff body # liftAff
98 resultVar <- AVar.empty # liftEffect
99 let
100 cleanup ∷ Aff Unit
101 cleanup = AVar.tryPut Nothing resultVar # liftEffect # void
103 compileJob =
104 NewJob \folder ->
105 bracket (pure unit) (const cleanup) \_ -> do
106 result <- compileCode folder (json ∷ Body.CompileRequest).code
107 AVar.tryPut (Just result) resultVar # liftEffect # void
108 queueRes <- Q.enqueue compileJob queue # liftEffect
109 let
110 getResult ∷ Handler
111 getResult = do
112 maybeResult <- AVar.tryRead resultVar # liftEffect
113 case maybeResult of
114 Just (Just result) -> Response.send $ write ({ result } ∷ Body.CompileResult)
115 Just Nothing -> do
116 setStatus 500
117 Response.send $ write { error: "Timeout" }
118 Nothing -> do
119 delay (100.0 # Milliseconds) # liftAff
120 getResult
121 case queueRes of
122 Enqueued _ -> getResult
123 QueueFull -> do
124 setStatus 500
125 Response.send $ write { error: "Queue full" }
127unHandler ∷ ∀ t6. Request -> Response -> Effect Unit -> HandlerM t6 -> Aff t6
128unHandler req res next (HandlerM h) = h req res next
130runHandler ∷ Queue Folder -> HandlerM Unit
131runHandler queue =
132 HandlerM \req res next -> do
133 let
134 handle = unHandler req res next
136 runJob =
137 NewJob \folder ->
138 bracket (pure unit) (const (pure unit)) \_ -> do
139 result <- runCode folder
140 resultBody <- toBody result
141 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
142 queueRes <- Q.enqueue runJob queue # liftEffect
143 case queueRes of
144 Enqueued _ -> pure unit
145 QueueFull ->
146 handle do
147 setStatus 500
148 Response.send $ write { error: "Queue full" }
150srcFolder :: String
151srcFolder = "../playground"
153destFolder :: String
154destFolder = "../playgrounds/"
156main ∷ Effect Unit
157main =
158 launchAff_ do
159 cpus <- numCpus # liftEffect
160 let
161 foldersToUse = max 2 (cpus - 1) -- use at least 2
163 mkFolder = Folder <<< (destFolder <> _) <<< show
165 folders = mkFolder <$> (0 .. foldersToUse)
166 folderPool = ResourcePool folders
167 for_ folders \(Folder f) -> copy srcFolder f
168 q <-
169 Q.mkQueue
170 { maxSize: 50
171 , timeout: 60.0 # Seconds # fromDuration
172 }
173 folderPool
174 serverSetup (makeApp q)
176makeApp ∷ Queue Folder -> App
177makeApp q = do
178 use $ static "assets"
179 useExternal jsonBodyParser
180 E.post "/compile" (compileHandler q)
181 E.post "/run" (runHandler q)
183data CertificatesToUse
184 = UseLocalCertificates
185 | DoNotUseLocalCertificates
187parseCertificatesToUse ∷ String -> CertificatesToUse
188parseCertificatesToUse = case _ of
189 "LOCAL" -> UseLocalCertificates
190 _ -> DoNotUseLocalCertificates
192serverSetup ∷ App -> Aff Server
193serverSetup app = do
194 maybePortString <- lookupEnv "PORT" # liftEffect
195 let
196 port = maybePortString >>= fromString # fromMaybe 14188
197 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
198 listen <- case useLocalCertificates of
199 UseLocalCertificates -> do
200 httpsOptions <- makeHttpsOptions
201 pure $ listenHttps app (port ∷ Int) httpsOptions
202 DoNotUseLocalCertificates -> pure $ listenHttp app port
203 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
204 where
205 makeHttpsOptions = do
206 key <- readTextFile UTF8 "server.key"
207 cert <- readTextFile UTF8 "server.cert"
208 pure { key, cert }