git.iko.soy/rowtype-yoga/psfp
on 2003541 help sign in
rowtype-yoga/psfp/server/src/Main.purs
226 lines 8.5 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 (any, elem, (..))
19import Data.Bifunctor (lmap)
20import Data.Either (Either(..), note)
21import Data.Either (hush)
22import Data.Int (fromString)
23import Data.Maybe (Maybe(..), fromMaybe, maybe)
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)
61import Foreign.Object (lookup) as Object
62import Control.Alt ((<|>))
63import Data.Array (elem) as Array
64import HTTPurple.Response (notFound, unauthorized)
65import Control.Monad.Error.Class (throwError)
66import Data.Monoid (guard)
67import HTTPurple.Headers (RequestHeaders)
68import Data.Map (lookup) as Mapl
69import Data.String.CaseInsensitive (CaseInsensitiveString(CaseInsensitiveString))
70import Data.Map (lookup) as Map
71import HTTPurple.Validation (fromValidated, fromValidatedE)
72import HTTPurple.Status (forbidden, unauthorized) as Status
74toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
75toBody result =
76 liftEffect
77 $ ado
78 stdout <- Buffer.toString UTF8 result.stdout
79 stderr <- Buffer.toString UTF8 result.stderr
80 let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
81 in { code, stdout, stderr } ∷ RunResult
83type ErrorWithCode =
84 { code ∷ Maybe Int }
86asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
87asErrorWithCode = unsafeCoerce >>> decodeJson >>> hush
89runCode ∷ ∀ d. Duration d => d -> Folder -> Aff (Maybe ExecResult)
90runCode timeout folder =
91 parOneOf
92 [ Just <$> execCommand folder "exec node run.mjs"
93 , Nothing <$ delay (timeout # fromDuration)
94 ]
96srcFolder ∷ String
97srcFolder = "../playground"
99destFolder ∷ String
100destFolder = "../playgrounds/"
102main ∷ Effect Unit
103main = do
104 launchAff_ do
105 tokens <- readAllowedTokens
106 cpus <- numCpus # liftEffect
107 let
108 -- poolSize = max 2 (cpus / 2) -- use at least 2
109 poolSize = 2
110 mkFolder = Folder <<< (destFolder <> _) <<< show
111 connections <-
112 (1 .. poolSize)
113 # parTraverse \n -> do
114 let
115 folder = mkFolder n
116 port = 14100 + n
117 log $ "Copying to folder " <> (un Folder folder)
118 copy srcFolder (un Folder folder)
119 mkConnection folder port
120 let pool = ResourcePool connections
121 q <-
122 Q.mkQueue
123 { maxSize: 50
124 , timeout: 10.0 # Seconds # fromDuration
125 }
126 pool
127 void $ liftEffect (serverSetup tokens q)
129-- makeApp ∷ Array Token -> Queue PscIdeConnection -> App
130-- makeApp tokens q = do
131-- use $ static "assets"
132-- useExternal jsonBodyParser
133-- use (authHandler tokens)
134-- E.post "/compileAndRun" (compileAndRunHandler q)
136-- serverSetup ∷ App -> Aff Server
137-- serverSetup app = do
138-- maybePortString <- lookupEnv "PORT" # liftEffect
139-- let port = maybePortString >>= fromString # fromMaybe 14188
140-- liftEffect $ (listenHttp app port) \_ -> info $ "psfp server started on port " <> show port
141-- where
142-- makeHttpsOptions = do
143-- key <- readTextFile UTF8 "server.key"
144-- cert <- readTextFile UTF8 "server.cert"
145-- pure { key, cert }
147data Route = CompileAndRun
149derive instance Generic Route _
151route :: RouteDuplex' Route
152route = mkRoute
153 { "CompileAndRun": "compileAndRun" / noArgs
154 }
156serverSetup :: Array Token -> Queue _ -> Effect Unit
157serverSetup tokens queue = do
158 maybePortString <- lookupEnv "PORT" # liftEffect
159 let port = maybePortString >>= fromString # fromMaybe 14188
160 --liftEffect $ (listenHttp app port) \_ ->
161 info $ "psfp server started on port " <> show port
163 void $ serve { port } { route, router }
164 where
165 getToken' headers = do
166 lookup headers "Token" # maybe
167 (Left $ "Missing Token Header")
168 (Right <<< Token)
170 validateToken' :: Token -> Either String Unit
171 validateToken' token = do
172 if Array.elem token tokens then Right unit else Left "Invalid Token"
174 router { route: CompileAndRun, headers, method: Post, body } = usingCont do
175 token <- fromValidatedE getToken' (response' Status.forbidden empty) headers
176 fromValidatedE validateToken' (response' Status.unauthorized empty) token
177 { code } :: { code :: String } <- fromJson YogaJson.jsonDecoder body -- parse the json input
178 -- jobId <- compileAndRunJob code
179 compileAndRunJobCont queue { code } -- do your business logic
180 --notFound
181 router _ = notFound
182 makeHttpsOptions = do
183 key <- readTextFile UTF8 "server.key"
184 cert <- readTextFile UTF8 "server.cert"
185 pure { key, cert }
187compileAndRunJobCont :: Queue _ -> CompileRequest -> ContT Response Aff Response
188compileAndRunJobCont queue { code } = do
189 resultVar <- lift AVar.empty
190 let
191 job :: NewJob _
192 job = NewJob \jobId conn -> do
193 stringOrErr ∷ Either Error String <- attempt $ compileCode code conn
194 jsonOrErr ∷ Either Error (Either Error CompileResult) <- attempt $ readJsonAff `traverse` stringOrErr
195 let folder = getFolder conn
196 AVar.put { jsonOrErr, stringOrErr, folder } resultVar
197 enqueueResult <- lift $ liftEffect $ Q.enqueue job queue
198 case enqueueResult of
199 QueueFull -> notFound
200 _ -> do
201 { jsonOrErr, stringOrErr, folder } <- AVar.take resultVar # lift
202 case jsonOrErr ∷ Either Error (Either Error CompileResult) of
203 Left e -> do
204 lift $ log $ "Aff failed with " <> message e
205 internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show e }
206 Right (Right res)
207 | res.resultType == "error" -> do
208 unprocessableEntity
209 Right (Right res) -> do
210 runResult <- runCode timeout folder # lift
211 case runResult of
212 Nothing -> do
213 requestTimeout' jsonHeaders -- $ toJson YogaJson.jsonEncoder { error: "Timed out after running for " <> show timeout }
214 Just rr -> do
215 resultBody <- toBody rr # lift
216 ok' jsonHeaders $ toJson YogaJson.jsonEncoder { resultBody }
217 Right (Left errs) -> do
218 log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
219 internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show errs }
220 -- case r of
221 -- Left err -> internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show err }
222 -- Right result -> ok' jsonHeaders $ toJson YogaJson.jsonEncoder result
224 where
225 jsonBody = toJson
226 timeout = 1.0 # Seconds