git.iko.soy/rowtype-yoga/psfp
on 39a8a5d help sign in
rowtype-yoga/psfp/server/src/Main.purs
177 lines 6.4 kB history raw
1module Main where
3import Prelude
5import Auth.Handler (authHandler, readAllowedTokens)
6import Auth.Types (Token(..))
7import Control.Parallel (parOneOf, parTraverse)
8import Data.Argonaut (jsonParser)
9import Data.Argonaut.Core (Json)
10import Data.Argonaut.Core as Json
11import Data.Argonaut.Core as Json
12import Data.Argonaut.Decode (class DecodeJson, decodeJson, printJsonDecodeError)
13import Data.Argonaut.Decode.Class (class DecodeJson)
14import Data.Argonaut.Decode.Decoders (decodeString)
15import Data.Argonaut.Encode (encodeJson)
16import Data.Array (elem, (..))
17import Data.Bifunctor (lmap)
18import Data.Either (Either(..))
19import Data.Either (hush)
20import Data.Int (fromString)
21import Data.Maybe (Maybe(..), fromMaybe)
22import Data.Newtype (un)
23import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
24import Data.Traversable (traverse)
25import Effect (Effect)
26import Effect.Aff (Aff, attempt, delay, launchAff_, message)
27import Effect.Aff.Class (liftAff)
28import Effect.Class (class MonadEffect, liftEffect)
29import Effect.Class.Console (info, log)
30import Effect.Exception (Error)
31import Foreign (unsafeToForeign)
32import JobQueue (EnqueueResult(..), NewJob(..), Queue, ResourcePool(..))
33import JobQueue as Q
34import Middleware.JsonBodyParser (jsonBodyParser)
35import Node.Buffer (Buffer)
36import Node.Buffer as Buffer
37import Node.ChildProcess (ExecResult)
38import Node.Encoding (Encoding(..))
39import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
40import Node.Express.App as E
41import Node.Express.Handler (Handler, HandlerM(..), next)
42import Node.Express.Middleware.Static (static)
43import Node.Express.Request (getBody', getRequestHeader)
44import Node.Express.Response (end, setStatus)
45import Node.Express.Response as Response
46import Node.Express.Types (Request, Response)
47import Node.FS.Aff (readTextFile)
48import Node.HTTP (Server)
49import Node.OS (numCpus)
50import Node.Process (lookupEnv)
51import Playground.Playground (Folder(..), copy)
52import PscIdeClient (PscIdeConnection, compileCode, getFolder, mkConnection, execCommand)
53import Shared.Json (readAff, readJsonAff)
54import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
55import Shared.Models.Body as Body
56import Unsafe.Coerce (unsafeCoerce)
58toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
59toBody result =
60 liftEffect
61 $ ado
62 stdout <- Buffer.toString UTF8 result.stdout
63 stderr <- Buffer.toString UTF8 result.stderr
64 let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
65 in { code, stdout, stderr } ∷ RunResult
67type ErrorWithCode =
68 { code ∷ Maybe Int }
70asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
71asErrorWithCode = unsafeCoerce >>> decodeJson >>> hush
73runCode ∷ ∀ d. Duration d => d -> Folder -> Aff (Maybe ExecResult)
74runCode timeout folder =
75 parOneOf
76 [ Just <$> execCommand folder "exec node run.js"
77 , Nothing <$ delay (timeout # fromDuration)
78 ]
80compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
81compileAndRunJob json handle =
82 NewJob \jobId conn -> do
83 stringOrErr ∷ Either Error String <- attempt $ compileCode json.code conn
84 jsonOrErr ∷ Either Error (Either Error CompileResult) <- attempt $ readJsonAff `traverse` stringOrErr
85 case jsonOrErr of
86 Left e -> do
87 handle $ setStatus 500
88 log $ "Aff failed with " <> message e
89 handle $ Response.send $ encodeJson {}
90 Right (Right res)
91 | res.resultType == "error" -> do
92 handle $ setStatus 422
93 handle $ Response.send $ encodeJson res
94 Right (Right res) -> do
95 runResult <- runCode timeout (getFolder conn)
96 case runResult of
97 Nothing -> do
98 handle $ setStatus 408
99 handle $ Response.send $ encodeJson { error: "Timed out after running for " <> show timeout }
100 Just rr -> do
101 resultBody <- toBody rr
102 handle $ Response.send $ encodeJson (resultBody ∷ Body.RunResult)
103 Right (Left errs) -> do
104 handle $ setStatus 500
105 log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
106 handle $ Response.send $ encodeJson {}
107 where
108 timeout = 1.0 # Seconds
110compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
111compileAndRunHandler queue = do
112 body <- getBody'
113 json <- readAff (unsafeCoerce body) # liftAff
114 HandlerM \req res next -> do
115 let
116 handle = unHandler req res next
117 runJob = compileAndRunJob json handle
118 queueRes <- Q.enqueue runJob queue # liftEffect
119 case queueRes of
120 Enqueued _ -> pure unit
121 QueueFull ->
122 handle do
123 setStatus 500
124 Response.send $ encodeJson { error: "Queue full" }
126unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
127unHandler req res next (HandlerM h) = h req res next
129srcFolder ∷ String
130srcFolder = "../playground"
132destFolder ∷ String
133destFolder = "../playgrounds/"
135main ∷ Effect Unit
136main = do
137 launchAff_ do
138 tokens <- readAllowedTokens
139 cpus <- numCpus # liftEffect
140 let
141 poolSize = max 2 (cpus / 2) -- use at least 2
142 mkFolder = Folder <<< (destFolder <> _) <<< show
143 connections <-
144 (1 .. poolSize)
145 # parTraverse \n -> do
146 let
147 folder = mkFolder n
148 port = 14100 + n
149 log $ "Copying to folder " <> (un Folder folder)
150 copy srcFolder (un Folder folder)
151 mkConnection folder port
152 let pool = ResourcePool connections
153 q <-
154 Q.mkQueue
155 { maxSize: 50
156 , timeout: 10.0 # Seconds # fromDuration
157 }
158 pool
159 serverSetup (makeApp tokens q)
161makeApp ∷ Array Token -> Queue PscIdeConnection -> App
162makeApp tokens q = do
163 use $ static "assets"
164 useExternal jsonBodyParser
165 use (authHandler tokens)
166 E.post "/compileAndRun" (compileAndRunHandler q)
168serverSetup ∷ App -> Aff Server
169serverSetup app = do
170 maybePortString <- lookupEnv "PORT" # liftEffect
171 let port = maybePortString >>= fromString # fromMaybe 14188
172 liftEffect $ (listenHttp app port) \_ -> info $ "psfp server started on port " <> show port
173 where
174 makeHttpsOptions = do
175 key <- readTextFile UTF8 "server.key"
176 cert <- readTextFile UTF8 "server.cert"
177 pure { key, cert }