git.iko.soy/rowtype-yoga/psfp
on 110e143 help sign in
rowtype-yoga/psfp/server/src/Main.purs
204 lines 7.8 kB history raw
1module Main where
3import HTTPurple
4import Prelude hiding ((/))
6import Auth.Handler (authHandler, readAllowedTokens)
7import Auth.Types (Token(..))
8import Control.Monad.Cont (ContT(..), callCC, lift, runContT)
9import Control.Parallel (parOneOf, parTraverse)
10import Data.Argonaut (jsonParser)
11import Data.Argonaut.Core (Json)
12import Data.Argonaut.Core as Json
13import Data.Argonaut.Core as Json
14import Data.Argonaut.Decode (class DecodeJson, decodeJson, printJsonDecodeError)
15import Data.Argonaut.Decode.Class (class DecodeJson)
16import Data.Argonaut.Decode.Decoders (decodeString)
17import Data.Argonaut.Encode (encodeJson)
18import Data.Array (elem, (..))
19import Data.Bifunctor (lmap)
20import Data.Either (Either(..))
21import Data.Either (hush)
22import Data.Int (fromString)
23import Data.Maybe (Maybe(..), fromMaybe)
24import Data.Newtype (un)
25import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
26import Data.Traversable (traverse)
27import Debug (spy)
28import Effect (Effect)
29import Effect.AVar (AVar)
30import Effect.Aff (Aff, attempt, delay, error, launchAff_, message)
31import Effect.Aff.AVar as AVar
32import Effect.Aff.Class (liftAff)
33import Effect.Class (class MonadEffect, liftEffect)
34import Effect.Class.Console (info, log)
35import Effect.Exception (Error)
36import Foreign (unsafeToForeign)
37import HTTPurple.Json.Yoga (jsonDecoder, jsonEncoder) as YogaJson
38import JobQueue (EnqueueResult(..), Job, NewJob(..), Queue, ResourcePool(..))
39import JobQueue as Q
40import Middleware.JsonBodyParser (jsonBodyParser)
41import Node.Buffer (Buffer)
42import Node.Buffer as Buffer
43import Node.ChildProcess (ExecResult)
44import Node.Encoding (Encoding(..))
45import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
46import Node.Express.App as E
47import Node.Express.Handler (Handler, HandlerM(..), next)
48import Node.Express.Middleware.Static (static)
49import Node.Express.Request (getBody', getRequestHeader)
50import Node.Express.Response (end, setStatus)
51import Node.Express.Response as Response
52import Node.FS.Aff (readTextFile)
53import Node.OS (numCpus)
54import Node.Process (lookupEnv)
55import Playground.Playground (Folder(..), copy)
56import PscIdeClient (PscIdeConnection, compileCode, getFolder, mkConnection, execCommand)
57import Shared.Json (readAff, readJsonAff)
58import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
59import Shared.Models.Body as Body
60import Unsafe.Coerce (unsafeCoerce)
62toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
63toBody result =
64 liftEffect
65 $ ado
66 stdout <- Buffer.toString UTF8 result.stdout
67 stderr <- Buffer.toString UTF8 result.stderr
68 let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
69 in { code, stdout, stderr } ∷ RunResult
71type ErrorWithCode =
72 { code ∷ Maybe Int }
74asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
75asErrorWithCode = unsafeCoerce >>> decodeJson >>> hush
77runCode ∷ ∀ d. Duration d => d -> Folder -> Aff (Maybe ExecResult)
78runCode timeout folder =
79 parOneOf
80 [ Just <$> execCommand folder "exec node run.mjs"
81 , Nothing <$ delay (timeout # fromDuration)
82 ]
85srcFolder ∷ String
86srcFolder = "../playground"
88destFolder ∷ String
89destFolder = "../playgrounds/"
91main ∷ Effect Unit
92main = do
93 launchAff_ do
94 tokens <- readAllowedTokens
95 cpus <- numCpus # liftEffect
96 let
97 -- poolSize = max 2 (cpus / 2) -- use at least 2
98 poolSize = 2
99 mkFolder = Folder <<< (destFolder <> _) <<< show
100 connections <-
101 (1 .. poolSize)
102 # parTraverse \n -> do
103 let
104 folder = mkFolder n
105 port = 14100 + n
106 log $ "Copying to folder " <> (un Folder folder)
107 copy srcFolder (un Folder folder)
108 mkConnection folder port
109 let pool = ResourcePool connections
110 q <-
111 Q.mkQueue
112 { maxSize: 50
113 , timeout: 10.0 # Seconds # fromDuration
114 }
115 pool
116 void $ liftEffect (serverSetup q)
118-- makeApp ∷ Array Token -> Queue PscIdeConnection -> App
119-- makeApp tokens q = do
120-- use $ static "assets"
121-- useExternal jsonBodyParser
122-- use (authHandler tokens)
123-- E.post "/compileAndRun" (compileAndRunHandler q)
125-- serverSetup ∷ App -> Aff Server
126-- serverSetup app = do
127-- maybePortString <- lookupEnv "PORT" # liftEffect
128-- let port = maybePortString >>= fromString # fromMaybe 14188
129-- liftEffect $ (listenHttp app port) \_ -> info $ "psfp server started on port " <> show port
130-- where
131-- makeHttpsOptions = do
132-- key <- readTextFile UTF8 "server.key"
133-- cert <- readTextFile UTF8 "server.cert"
134-- pure { key, cert }
136data Route = CompileAndRun
137derive instance Generic Route _
139route :: RouteDuplex' Route
140route = mkRoute
141 { "CompileAndRun": "compileAndRun" / noArgs
142 }
144serverSetup :: Queue _ -> Effect Unit
145serverSetup queue = do
146 maybePortString <- lookupEnv "PORT" # liftEffect
147 let port = maybePortString >>= fromString # fromMaybe 14188
148 --liftEffect $ (listenHttp app port) \_ ->
149 info $ "psfp server started on port " <> show port
151 void $ serve { port } { route, router }
152 where
153 router { route: CompileAndRun, method: Post, body } = usingCont do
154 { code } :: { code :: String } <- fromJson YogaJson.jsonDecoder body -- parse the json input
155 -- jobId <- compileAndRunJob code
156 compileAndRunJobCont queue { code } -- do your business logic
157 -- whatever queue body
158 --notFound
159 router _ = notFound
160 makeHttpsOptions = do
161 key <- readTextFile UTF8 "server.key"
162 cert <- readTextFile UTF8 "server.cert"
163 pure { key, cert }
165compileAndRunJobCont :: Queue _ -> CompileRequest -> ContT Response Aff Response
166compileAndRunJobCont queue { code } = do
167 resultVar <- lift AVar.empty
168 let
169 job :: NewJob _
170 job = NewJob \jobId conn -> do
171 stringOrErr ∷ Either Error String <- attempt $ compileCode code conn
172 jsonOrErr ∷ Either Error (Either Error CompileResult) <- attempt $ readJsonAff `traverse` stringOrErr
173 let folder = getFolder conn
174 AVar.put { jsonOrErr, stringOrErr, folder } resultVar
175 enqueueResult <- lift $ liftEffect $ Q.enqueue job queue
176 case enqueueResult of
177 QueueFull -> notFound
178 _ -> do
179 { jsonOrErr, stringOrErr, folder } <- AVar.take resultVar # lift
180 case jsonOrErr ∷ Either Error (Either Error CompileResult) of
181 Left e -> do
182 lift $ log $ "Aff failed with " <> message e
183 internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show e }
184 Right (Right res)
185 | res.resultType == "error" -> do
186 unprocessableEntity
187 Right (Right res) -> do
188 runResult <- runCode timeout folder # lift
189 case runResult of
190 Nothing -> do
191 requestTimeout' jsonHeaders -- $ toJson YogaJson.jsonEncoder { error: "Timed out after running for " <> show timeout }
192 Just rr -> do
193 resultBody <- toBody rr # lift
194 ok' jsonHeaders $ toJson YogaJson.jsonEncoder{ resultBody }
195 Right (Left errs) -> do
196 log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
197 internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show errs }
198 -- case r of
199 -- Left err -> internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show err }
200 -- Right result -> ok' jsonHeaders $ toJson YogaJson.jsonEncoder result
202 where
203 jsonBody = toJson
204 timeout = 1.0 # Seconds