git.iko.soy/rowtype-yoga/psfp
on f8046d6 help sign in
rowtype-yoga/psfp/server/src/Main.purs
164 lines 5.8 kB history raw
1module Main where
3import Prelude
4import Auth.Handler (authHandler, readAllowedTokens)
5import Auth.Types (Token(..))
6import Control.Parallel (parOneOf, parTraverse)
7import Data.Array (elem, (..))
8import Data.Bifunctor (lmap)
9import Data.Either (Either(..))
10import Data.Int (fromString)
11import Data.Maybe (Maybe(..), fromMaybe)
12import Data.Newtype (un)
13import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
14import Effect (Effect)
15import Effect.Aff (Aff, attempt, delay, launchAff_, message)
16import Effect.Aff.Class (liftAff)
17import Effect.Class (class MonadEffect, liftEffect)
18import Effect.Class.Console (info, log)
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)
26import Node.Encoding (Encoding(..))
27import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
28import Node.Express.App as E
29import Node.Express.Handler (Handler, HandlerM(..), next)
30import Node.Express.Middleware.Static (static)
31import Node.Express.Request (getBody', getRequestHeader)
32import Node.Express.Response (end, setStatus)
33import Node.Express.Response as Response
34import Node.Express.Types (Request, Response)
35import Node.FS.Aff (readTextFile)
36import Node.HTTP (Server)
37import Node.OS (numCpus)
38import Node.Process (lookupEnv)
39import Playground.Playground (Folder(..), copy)
40import PscIdeClient (PscIdeConnection, compileCode, getFolder, mkConnection, execCommand)
41import Shared.Json (readAff)
42import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
43import Shared.Models.Body as Body
44import Simple.JSON (readJSON, read_, write)
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 (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
61runCode ∷ ∀ d. Duration d => d -> Folder -> Aff (Maybe ExecResult)
62runCode timeout folder =
63 parOneOf
64 [ Just <$> execCommand folder "exec node run.js"
65 , Nothing <$ delay (timeout # fromDuration)
66 ]
68compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
69compileAndRunJob json handle =
70 NewJob \jobId conn -> do
71 stringOrErr <- attempt $ compileCode json.code conn
72 case ((readJSON <$> stringOrErr) ∷ _ _ (_ _ CompileResult)) of
73 Left e -> do
74 handle $ setStatus 500
75 log $ "Aff failed with " <> message e
76 handle $ Response.send $ write {}
77 Right (Right res)
78 | res.resultType == "error" -> do
79 handle $ setStatus 422
80 handle $ Response.send $ write res
81 Right (Right res) -> do
82 runResult <- runCode timeout (getFolder conn)
83 case runResult of
84 Nothing -> do
85 handle $ setStatus 408
86 handle $ Response.send $ write { error: "Timed out after running for " <> show timeout }
87 Just rr -> do
88 resultBody <- toBody rr
89 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
90 Right (Left errs) -> do
91 handle $ setStatus 500
92 log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
93 handle $ Response.send $ write {}
94 where
95 timeout = 1.0 # Seconds
97compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
98compileAndRunHandler queue = do
99 body <- getBody'
100 json <- readAff body # liftAff
101 HandlerM \req res next -> do
102 let
103 handle = unHandler req res next
104 runJob = compileAndRunJob json handle
105 queueRes <- Q.enqueue runJob queue # liftEffect
106 case queueRes of
107 Enqueued _ -> pure unit
108 QueueFull ->
109 handle do
110 setStatus 500
111 Response.send $ write { error: "Queue full" }
113unHandler ∷ ∀ a. Request -> Response -> Effect Unit -> HandlerM a -> Aff a
114unHandler req res next (HandlerM h) = h req res next
116srcFolder ∷ String
117srcFolder = "../playground"
119destFolder ∷ String
120destFolder = "../playgrounds/"
122main ∷ Effect Unit
123main = do
124 launchAff_ do
125 tokens <- readAllowedTokens
126 cpus <- numCpus # liftEffect
127 let
128 poolSize = max 2 (cpus / 2) -- use at least 2
129 mkFolder = Folder <<< (destFolder <> _) <<< show
130 connections <-
131 (1 .. poolSize)
132 # parTraverse \n -> do
133 let
134 folder = mkFolder n
135 port = 14100 + n
136 log $ "Copying to folder " <> (un Folder folder)
137 copy srcFolder (un Folder folder)
138 mkConnection folder port
139 let pool = ResourcePool connections
140 q <-
141 Q.mkQueue
142 { maxSize: 50
143 , timeout: 10.0 # Seconds # fromDuration
144 }
145 pool
146 serverSetup (makeApp tokens q)
148makeApp ∷ Array Token -> Queue PscIdeConnection -> App
149makeApp tokens q = do
150 use $ static "assets"
151 useExternal jsonBodyParser
152 use (authHandler tokens)
153 E.post "/compileAndRun" (compileAndRunHandler q)
155serverSetup ∷ App -> Aff Server
156serverSetup app = do
157 maybePortString <- lookupEnv "PORT" # liftEffect
158 let port = maybePortString >>= fromString # fromMaybe 14188
159 liftEffect $ (listenHttp app port) \_ -> info $ "psfp server started on port " <> show port
160 where
161 makeHttpsOptions = do
162 key <- readTextFile UTF8 "server.key"
163 cert <- readTextFile UTF8 "server.cert"
164 pure { key, cert }