@@ -1,120 +1,178 @@
1module Main where
1module Main where
3import Prelude
3import Prelude
5−import Data.Array (unsafeIndex)
4+import Data.Array (fromFoldable, head, (..))
6import Data.Either (Either(..))
5import Data.Either (Either(..))
7import Data.Int (fromString)
6import Data.Int (fromString)
8import Data.Maybe (Maybe(..), fromMaybe)
7import Data.Maybe (Maybe(..), fromMaybe)
8+import Data.Newtype (class Newtype, un)
9import Data.Posix.Signal (Signal(..))
9import Data.Posix.Signal (Signal(..))
10import Data.String.Utils (lines)
10import Data.String.Utils (lines)
11+import Data.Time.Duration (Seconds(..), fromDuration)
11import Effect (Effect)
12import Effect (Effect)
13+import Effect.AVar as AVar
12−import Effect.Aff (Aff, effectCanceler, launchAff_, makeAff)
14+import Effect.Aff (Aff, Milliseconds(..), bracket, delay, effectCanceler, launchAff_, makeAff)
13import Effect.Aff.Class (liftAff)
15import Effect.Aff.Class (liftAff)
14import Effect.Class (class MonadEffect, liftEffect)
16import Effect.Class (class MonadEffect, liftEffect)
15−import Effect.Class.Console (info)
17+import Effect.Class.Console (info, log)
18+import Effect.Exception (throw)
16import Foreign (unsafeToForeign)
19import Foreign (unsafeToForeign)
20+import JobQueue (EnqueueResult(..), NewJob(..), Queue, ResourcePool(..))
17import Middleware.JsonBodyParser (jsonBodyParser)
22import Middleware.JsonBodyParser (jsonBodyParser)
18import Node.Buffer (Buffer)
23import Node.Buffer (Buffer)
19import Node.Buffer as Buffer
24import Node.Buffer as Buffer
20−import Node.ChildProcess (ExecResult, defaultExecOptions, exec, kill)
25+import Node.ChildProcess (ExecResult, defaultExecOptions, exec, kill, pid)
21import Node.Encoding (Encoding(..))
26import Node.Encoding (Encoding(..))
22import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
27import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
23import Node.Express.App as E
28import Node.Express.App as E
24−import Node.Express.Handler (HandlerM)
29+import Node.Express.Handler (HandlerM(..), Handler)
25import Node.Express.Middleware.Static (static)
30import Node.Express.Middleware.Static (static)
26import Node.Express.Request (getBody')
31import Node.Express.Request (getBody')
32+import Node.Express.Response (setStatus)
27import Node.Express.Response as Response
33import Node.Express.Response as Response
34+import Node.Express.Types (Request, Response)
28import Node.FS.Aff (readTextFile, writeTextFile)
35import Node.FS.Aff (readTextFile, writeTextFile)
29import Node.HTTP (Server)
36import Node.HTTP (Server)
37+import Node.OS (numCpus)
30import Node.Process (lookupEnv)
38import Node.Process (lookupEnv)
31−import Partial.Unsafe (unsafePartial)
32import Shared.Json (readAff)
39import Shared.Json (readAff)
33−import Shared.Models.Body (RunResult)
40+import Shared.Models.Body (RunResult, PursResult)
34import Shared.Models.Body as Body
41import Shared.Models.Body as Body
35import Simple.JSON (read_, write)
42import Simple.JSON (read_, write)
43+import Simple.JSON as JSON
37toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
45toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
38−toBody result = liftEffect $ ado
46+toBody result =
39− stdout <- Buffer.toString UTF8 result.stdout
49+ stdout <- Buffer.toString UTF8 result.stdout
40− stderr <- Buffer.toString UTF8 result.stderr
50+ stderr <- Buffer.toString UTF8 result.stderr
41− let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
52+ (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
42− in { code, stdout, stderr } ∷ RunResult
53+ in { code, stdout, stderr } ∷ RunResult
44−type ErrorWithCode = { code ∷ Maybe Int }
55+type ErrorWithCode
56+ = { code ∷ Maybe Int }
46asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
58asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
47asErrorWithCode = read_ <<< unsafeToForeign
59asErrorWithCode = read_ <<< unsafeToForeign
49−compileCode ∷ String -> Aff String
61+compileCode ∷ Folder -> String -> Aff PursResult
50−compileCode code = do
62+compileCode folder code = do
51− saveMainFile code
63+ saveMainFile folder code
52− { stderr } <- execCommand "spago build -- --json-errors"
64+ { stderr } <- execCommand folder "spago build --purs-args \"--json-errors\""
53− errorString <- liftEffect $ Buffer.toString UTF8 stderr
65+ strResult <- liftEffect $ Buffer.toString UTF8 stderr
54− pure $ unsafePartial (unsafeIndex (lines errorString) 0)
66+ case checkOutput strResult of
56−runCode ∷ Aff ExecResult
68+ Nothing -> liftEffect $ throw $ "No result in " <> strResult
57−runCode = execCommand "node run.js"
69+ where
74+ (parseable :: Maybe PursResult) = JSON.readJSON_ line
75+ fromFoldable parseable
59−playground ∷ String
77+runCode ∷ Folder -> Aff ExecResult
60−playground = "../playground"
78+runCode folder = execCommand folder "node run.js"
62−saveMainFile ∷ String -> Aff Unit
80+saveMainFile ∷ Folder -> String -> Aff Unit
64− writeTextFile UTF8 (playground <> "/src/Main.purs") code
81+saveMainFile folder code = writeTextFile UTF8 (un Folder folder <> "/src/Main.purs") code
66−execCommand ∷ String -> Aff ExecResult
83+execCommand ∷ Folder -> String -> Aff ExecResult
67−execCommand command =
84+execCommand folder command =
68 makeAff \callback -> do
85 makeAff \callback -> do
69− let options = defaultExecOptions { cwd = Just playground }
87+ options = defaultExecOptions { cwd = Just (un Folder folder) }
70 childProcess <- exec command options (callback <<< Right)
88 childProcess <- exec command options (callback <<< Right)
71− pure $ effectCanceler (kill SIGKILL childProcess)
89+ pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
94+derive instance ntFolder :: Newtype Folder _
95+derive newtype instance eqFolder :: Eq Folder
73−compileHandler ∷ HandlerM Unit
96+compileHandler ∷ Queue Folder -> HandlerM Unit
74−compileHandler = do
97+compileHandler queue = do
75 body <- getBody'
98 body <- getBody'
76 json <- readAff body # liftAff
99 json <- readAff body # liftAff
100+ resultVar <- AVar.empty # liftEffect
103+ cleanup = AVar.tryPut Nothing resultVar # liftEffect # void
107+ bracket (pure unit) (const cleanup) \_ -> do
77− result <- compileCode (json ∷ Body.CompileRequest).code # liftAff
108+ result <- compileCode folder (json ∷ Body.CompileRequest).code
109+ AVar.tryPut (Just result) resultVar # liftEffect # void
110+ queueRes <- Q.enqueue compileJob queue # liftEffect
114+ maybeResult <- AVar.tryRead resultVar # liftEffect
78− Response.send $ write ({ result } ∷ Body.CompileResult)
116+ Just (Just result) -> Response.send $ write ({ result } ∷ Body.CompileResult)
79−
117+ Just Nothing -> do
119+ Response.send $ write { error: "Timeout" }
121+ delay (100.0 # Milliseconds) # liftAff
124+ Enqueued _ -> getResult
127+ Response.send $ write { error: "Queue full" }
129+unHandler ∷ ∀ t6. Request -> Response -> Effect Unit -> HandlerM t6 -> Aff t6
130+unHandler req res next (HandlerM h) = h req res next
80−runHandler ∷ HandlerM Unit
132+runHandler ∷ Queue Folder -> HandlerM Unit
81−runHandler = do
133+runHandler queue =
82− result <- liftAff do
134+ HandlerM \req res next -> do
136+ handle = unHandler req res next
140+ bracket (pure unit) (const (pure unit)) \_ -> do
83− result <- runCode
141+ result <- runCode folder
84− toBody result
142+ resultBody <- toBody result
85− Response.send $ write (result ∷ Body.RunResult)
143+ handle $ Response.send $ write (resultBody ∷ Body.RunResult)
144+ queueRes <- Q.enqueue runJob queue # liftEffect
146+ Enqueued _ -> pure unit
150+ Response.send $ write { error: "Queue full" }
87main ∷ Effect Unit
152main ∷ Effect Unit
88−main = launchAff_ do
154+ launchAff_ do
155+ cpus <- numCpus # liftEffect
157+ foldersToUse = min 2 (max 15 (cpus - 1))
159+ mkFolder = Folder <<< ("../playground" <> _) <<< show
161+ folderPool = ResourcePool $ mkFolder <$> (0 .. foldersToUse)
165+ , timeout: 60.0 # Seconds # fromDuration
89− serverSetup makeApp
168+ serverSetup (makeApp q)
91−makeApp ∷ App
170+makeApp ∷ Queue Folder -> App
92−makeApp = do
171+makeApp q = do
93 use $ static "assets"
172 use $ static "assets"
94 useExternal jsonBodyParser
173 useExternal jsonBodyParser
95− E.post "/compile" compileHandler
174+ E.post "/compile" (compileHandler q)
96− E.post "/run" runHandler
175+ E.post "/run" (runHandler q)
97− -- useOnError (errorHandler log)
98− -- { method: HTTPure.Post, path: ["_compile"], body } -> do
99− -- result <- compileCode body
100− -- HTTPure.ok' (HTTPure.header "Content-Type" "application/json") result
102− -- { method: HTTPure.Post, path: ["_run"] } -> do
103− -- result <- runCode
104− -- response <- toBody result
107− -- { method: HTTPure.Get, path } | elem path [[], [""], ["/"]] -> do
108− -- content <- readTextFile UTF8 "index.html"
109− -- HTTPure.ok' (HTTPure.header "Content-Type" "text/html") content
111− -- { method: HTTPure.Get, path } -> do
112− -- let filePath = intercalate "/" path
113− -- let mimeType = guessMimeType filePath
114− -- content <- readTextFile UTF8 filePath
115− -- HTTPure.ok' (HTTPure.header "Content-Type" mimeType) content
117− -- _ -> HTTPure.notFound
119data CertificatesToUse
177data CertificatesToUse
120 = UseLocalCertificates
178 = UseLocalCertificates
@@ -128,14 +186,14 @@ parseCertificatesToUse = case _ of
128serverSetup ∷ App -> Aff Server
186serverSetup ∷ App -> Aff Server
129serverSetup app = do
187serverSetup app = do
130 maybePortString <- lookupEnv "PORT" # liftEffect
188 maybePortString <- lookupEnv "PORT" # liftEffect
131− let port = maybePortString >>= fromString # fromMaybe 14188
190+ port = maybePortString >>= fromString # fromMaybe 14188
132 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
191 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
133 listen <- case useLocalCertificates of
192 listen <- case useLocalCertificates of
134 UseLocalCertificates -> do
193 UseLocalCertificates -> do
135 httpsOptions <- makeHttpsOptions
194 httpsOptions <- makeHttpsOptions
136 pure $ listenHttps app (port ∷ Int) httpsOptions
195 pure $ listenHttps app (port ∷ Int) httpsOptions
137− DoNotUseLocalCertificates ->
196+ DoNotUseLocalCertificates -> pure $ listenHttp app port
138− pure $ listenHttp app port
139 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
197 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
141 makeHttpsOptions = do
199 makeHttpsOptions = do