git.iko.soy/rowtype-yoga/psfp
on bbaf3fb help sign in
rowtype-yoga/psfp/server/src/Main.purs
202 lines 6.8 kB history raw
1module Main where
3import Prelude
4import Data.Array (fromFoldable, head, (..))
5import Data.Either (Either(..))
6import Data.Int (fromString)
7import Data.Maybe (Maybe(..), fromMaybe)
8import Data.Newtype (class Newtype, un)
9import Data.Posix.Signal (Signal(..))
10import Data.String.Utils (lines)
11import Data.Time.Duration (Seconds(..), fromDuration)
12import Effect (Effect)
13import Effect.AVar as AVar
14import Effect.Aff (Aff, Milliseconds(..), bracket, delay, 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 Shared.Json (readAff)
40import Shared.Models.Body (RunResult, PursResult)
41import Shared.Models.Body as Body
42import Simple.JSON (read_, write)
43import Simple.JSON as JSON
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
61compileCode ∷ Folder -> String -> Aff PursResult
62compileCode folder code = do
63 saveMainFile folder code
64 { stderr } <- execCommand folder "spago build --purs-args \"--json-errors\""
65 strResult <- liftEffect $ Buffer.toString UTF8 stderr
66 case checkOutput strResult of
67 Just r -> pure r
68 Nothing -> liftEffect $ throw $ "No result in " <> strResult
69 where
70 checkOutput output =
71 head do
72 line <- lines output
73 let
74 (parseable :: Maybe PursResult) = JSON.readJSON_ line
75 fromFoldable parseable
77runCode ∷ Folder -> Aff ExecResult
78runCode folder = execCommand folder "node run.js"
80saveMainFile ∷ Folder -> String -> Aff Unit
81saveMainFile folder code = writeTextFile UTF8 (un Folder folder <> "/src/Main.purs") code
83execCommand ∷ Folder -> String -> Aff ExecResult
84execCommand folder command =
85 makeAff \callback -> do
86 let
87 options = defaultExecOptions { cwd = Just (un Folder folder) }
88 childProcess <- exec command options (callback <<< Right)
89 pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
91newtype Folder
92 = Folder String
94derive instance ntFolder :: Newtype Folder _
95derive newtype instance eqFolder :: Eq Folder
96compileHandler ∷ Queue Folder -> HandlerM Unit
97compileHandler queue = do
98 body <- getBody'
99 json <- readAff body # liftAff
100 resultVar <- AVar.empty # liftEffect
101 let
102 cleanup ∷ Aff Unit
103 cleanup = AVar.tryPut Nothing resultVar # liftEffect # void
105 compileJob =
106 NewJob \folder ->
107 bracket (pure unit) (const cleanup) \_ -> do
108 result <- compileCode folder (json ∷ Body.CompileRequest).code
109 AVar.tryPut (Just result) resultVar # liftEffect # void
110 queueRes <- Q.enqueue compileJob queue # liftEffect
111 let
112 getResult ∷ Handler
113 getResult = do
114 maybeResult <- AVar.tryRead resultVar # liftEffect
115 case maybeResult of
116 Just (Just result) -> Response.send $ write ({ result } ∷ Body.CompileResult)
117 Just Nothing -> do
118 setStatus 500
119 Response.send $ write { error: "Timeout" }
120 Nothing -> do
121 delay (100.0 # Milliseconds) # liftAff
122 getResult
123 case queueRes of
124 Enqueued _ -> getResult
125 QueueFull -> do
126 setStatus 500
127 Response.send $ write { error: "Queue full" }
129unHandler ∷ ∀ t6. Request -> Response -> Effect Unit -> HandlerM t6 -> Aff t6
130unHandler req res next (HandlerM h) = h req res next
132runHandler ∷ Queue Folder -> HandlerM Unit
133runHandler queue =
134 HandlerM \req res next -> do
135 let
136 handle = unHandler req res next
138 runJob =
139 NewJob \folder ->
140 bracket (pure unit) (const (pure unit)) \_ -> do
141 result <- runCode folder
142 resultBody <- toBody result
143 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
144 queueRes <- Q.enqueue runJob queue # liftEffect
145 case queueRes of
146 Enqueued _ -> pure unit
147 QueueFull ->
148 handle do
149 setStatus 500
150 Response.send $ write { error: "Queue full" }
152main ∷ Effect Unit
153main =
154 launchAff_ do
155 cpus <- numCpus # liftEffect
156 let
157 foldersToUse = min 2 (max 15 (cpus - 1))
159 mkFolder = Folder <<< ("../playground" <> _) <<< show
161 folderPool = ResourcePool $ mkFolder <$> (0 .. foldersToUse)
162 q <-
163 Q.mkQueue
164 { maxSize: 50
165 , timeout: 60.0 # Seconds # fromDuration
166 }
167 folderPool
168 serverSetup (makeApp q)
170makeApp ∷ Queue Folder -> App
171makeApp q = do
172 use $ static "assets"
173 useExternal jsonBodyParser
174 E.post "/compile" (compileHandler q)
175 E.post "/run" (runHandler 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 }