@@ -1,120 +1,178 @@
11module Main where
22
33import Prelude
4−
5−import Data.Array (unsafeIndex)
4+import Data.Array (fromFoldable, head, (..))
65import Data.Either (Either(..))
76import Data.Int (fromString)
87import Data.Maybe (Maybe(..), fromMaybe)
8+import Data.Newtype (class Newtype, un)
99import Data.Posix.Signal (Signal(..))
1010import Data.String.Utils (lines)
11+import Data.Time.Duration (Seconds(..), fromDuration)
1112import Effect (Effect)
12−import Effect.Aff (Aff, effectCanceler, launchAff_, makeAff)
13+import Effect.AVar as AVar
14+import Effect.Aff (Aff, Milliseconds(..), bracket, delay, effectCanceler, launchAff_, makeAff)
1315import Effect.Aff.Class (liftAff)
1416import Effect.Class (class MonadEffect, liftEffect)
15−import Effect.Class.Console (info)
17+import Effect.Class.Console (info, log)
18+import Effect.Exception (throw)
1619import Foreign (unsafeToForeign)
20+import JobQueue (EnqueueResult(..), NewJob(..), Queue, ResourcePool(..))
21+import JobQueue as Q
1722import Middleware.JsonBodyParser (jsonBodyParser)
1823import Node.Buffer (Buffer)
1924import Node.Buffer as Buffer
20−import Node.ChildProcess (ExecResult, defaultExecOptions, exec, kill)
25+import Node.ChildProcess (ExecResult, defaultExecOptions, exec, kill, pid)
2126import Node.Encoding (Encoding(..))
2227import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
2328import Node.Express.App as E
24−import Node.Express.Handler (HandlerM)
29+import Node.Express.Handler (HandlerM(..), Handler)
2530import Node.Express.Middleware.Static (static)
2631import Node.Express.Request (getBody')
32+import Node.Express.Response (setStatus)
2733import Node.Express.Response as Response
34+import Node.Express.Types (Request, Response)
2835import Node.FS.Aff (readTextFile, writeTextFile)
2936import Node.HTTP (Server)
37+import Node.OS (numCpus)
3038import Node.Process (lookupEnv)
31−import Partial.Unsafe (unsafePartial)
3239import Shared.Json (readAff)
33−import Shared.Models.Body (RunResult)
40+import Shared.Models.Body (RunResult, PursResult)
3441import Shared.Models.Body as Body
3542import Simple.JSON (read_, write)
43+import Simple.JSON as JSON
3644
3745toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
38−toBody result = liftEffect $ ado
39− stdout <- Buffer.toString UTF8 result.stdout
40− stderr <- Buffer.toString UTF8 result.stderr
41− let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
42− in { code, stdout, stderr } ∷ RunResult
43−
44−type ErrorWithCode = { code ∷ Maybe Int }
46+toBody result =
47+ liftEffect
48+ $ ado
49+ stdout <- Buffer.toString UTF8 result.stdout
50+ stderr <- Buffer.toString UTF8 result.stderr
51+ let
52+ (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
53+ in { code, stdout, stderr } ∷ RunResult
54+
55+type ErrorWithCode
56+ = { code ∷ Maybe Int }
4557
4658asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
4759asErrorWithCode = read_ <<< unsafeToForeign
4860
49−compileCode ∷ String -> Aff String
50−compileCode code = do
51− saveMainFile code
52− { stderr } <- execCommand "spago build -- --json-errors"
53− errorString <- liftEffect $ Buffer.toString UTF8 stderr
54− pure $ unsafePartial (unsafeIndex (lines errorString) 0)
55−
56−runCode ∷ Aff ExecResult
57−runCode = execCommand "node run.js"
61+compileCode ∷ Folder -> String -> Aff PursResult
62+compileCode folder code = do
63+ saveMainFile folder code
64+ { stderr } <- execCommand folder "spago build --purs-args \"--json-errors\""
65+ strResult <- liftEffect $ Buffer.toString UTF8 stderr
66+ case checkOutput strResult of
67+ Just r -> pure r
68+ Nothing -> liftEffect $ throw $ "No result in " <> strResult
69+ where
70+ checkOutput output =
71+ head do
72+ line <- lines output
73+ let
74+ (parseable :: Maybe PursResult) = JSON.readJSON_ line
75+ fromFoldable parseable
5876
59−playground ∷ String
60−playground = "../playground"
77+runCode ∷ Folder -> Aff ExecResult
78+runCode folder = execCommand folder "node run.js"
6179
62−saveMainFile ∷ String -> Aff Unit
63−saveMainFile code =
64− writeTextFile UTF8 (playground <> "/src/Main.purs") code
80+saveMainFile ∷ Folder -> String -> Aff Unit
81+saveMainFile folder code = writeTextFile UTF8 (un Folder folder <> "/src/Main.purs") code
6582
66−execCommand ∷ String -> Aff ExecResult
67−execCommand command =
83+execCommand ∷ Folder -> String -> Aff ExecResult
84+execCommand folder command =
6885 makeAff \callback -> do
69− let options = defaultExecOptions { cwd = Just playground }
86+ let
87+ options = defaultExecOptions { cwd = Just (un Folder folder) }
7088 childProcess <- exec command options (callback <<< Right)
71− pure $ effectCanceler (kill SIGKILL childProcess)
89+ pure $ effectCanceler ((log $ "Killing " <> show (pid childProcess)) *> kill SIGKILL childProcess)
7290
73−compileHandler ∷ HandlerM Unit
74−compileHandler = do
91+newtype Folder
92+ = Folder String
93+
94+derive instance ntFolder :: Newtype Folder _
95+derive newtype instance eqFolder :: Eq Folder
96+compileHandler ∷ Queue Folder -> HandlerM Unit
97+compileHandler queue = do
7598 body <- getBody'
7699 json <- readAff body # liftAff
77− result <- compileCode (json ∷ Body.CompileRequest).code # liftAff
78− Response.send $ write ({ result } ∷ Body.CompileResult)
79−
80−runHandler ∷ HandlerM Unit
81−runHandler = do
82− result <- liftAff do
83− result <- runCode
84− toBody result
85− Response.send $ write (result ∷ Body.RunResult)
100+ resultVar <- AVar.empty # liftEffect
101+ let
102+ cleanup ∷ Aff Unit
103+ cleanup = AVar.tryPut Nothing resultVar # liftEffect # void
104+
105+ compileJob =
106+ NewJob \folder ->
107+ bracket (pure unit) (const cleanup) \_ -> do
108+ result <- compileCode folder (json ∷ Body.CompileRequest).code
109+ AVar.tryPut (Just result) resultVar # liftEffect # void
110+ queueRes <- Q.enqueue compileJob queue # liftEffect
111+ let
112+ getResult ∷ Handler
113+ getResult = do
114+ maybeResult <- AVar.tryRead resultVar # liftEffect
115+ case maybeResult of
116+ Just (Just result) -> Response.send $ write ({ result } ∷ Body.CompileResult)
117+ Just Nothing -> do
118+ setStatus 500
119+ Response.send $ write { error: "Timeout" }
120+ Nothing -> do
121+ delay (100.0 # Milliseconds) # liftAff
122+ getResult
123+ case queueRes of
124+ Enqueued _ -> getResult
125+ QueueFull -> do
126+ setStatus 500
127+ Response.send $ write { error: "Queue full" }
128+
129+unHandler ∷ ∀ t6. Request -> Response -> Effect Unit -> HandlerM t6 -> Aff t6
130+unHandler req res next (HandlerM h) = h req res next
131+
132+runHandler ∷ Queue Folder -> HandlerM Unit
133+runHandler queue =
134+ HandlerM \req res next -> do
135+ let
136+ handle = unHandler req res next
137+
138+ runJob =
139+ NewJob \folder ->
140+ bracket (pure unit) (const (pure unit)) \_ -> do
141+ result <- runCode folder
142+ resultBody <- toBody result
143+ handle $ Response.send $ write (resultBody ∷ Body.RunResult)
144+ queueRes <- Q.enqueue runJob queue # liftEffect
145+ case queueRes of
146+ Enqueued _ -> pure unit
147+ QueueFull ->
148+ handle do
149+ setStatus 500
150+ Response.send $ write { error: "Queue full" }
86151
87152main ∷ Effect Unit
88−main = launchAff_ do
89− serverSetup makeApp
90−
91−makeApp ∷ App
92−makeApp = do
153+main =
154+ launchAff_ do
155+ cpus <- numCpus # liftEffect
156+ let
157+ foldersToUse = min 2 (max 15 (cpus - 1))
158+
159+ mkFolder = Folder <<< ("../playground" <> _) <<< show
160+
161+ folderPool = ResourcePool $ mkFolder <$> (0 .. foldersToUse)
162+ q <-
163+ Q.mkQueue
164+ { maxSize: 50
165+ , timeout: 60.0 # Seconds # fromDuration
166+ }
167+ folderPool
168+ serverSetup (makeApp q)
169+
170+makeApp ∷ Queue Folder -> App
171+makeApp q = do
93172 use $ static "assets"
94173 useExternal jsonBodyParser
95− E.post "/compile" compileHandler
96− E.post "/run" runHandler
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
101−
102− -- { method: HTTPure.Post, path: ["_run"] } -> do
103− -- result <- runCode
104− -- response <- toBody result
105− -- okJson response
106−
107− -- { method: HTTPure.Get, path } | elem path [[], [""], ["/"]] -> do
108− -- content <- readTextFile UTF8 "index.html"
109− -- HTTPure.ok' (HTTPure.header "Content-Type" "text/html") content
110−
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
116−
117− -- _ -> HTTPure.notFound
174+ E.post "/compile" (compileHandler q)
175+ E.post "/run" (runHandler q)
118176
119177data CertificatesToUse
120178 = UseLocalCertificates
@@ -128,14 +186,14 @@ parseCertificatesToUse = case _ of
128186serverSetup ∷ App -> Aff Server
129187serverSetup app = do
130188 maybePortString <- lookupEnv "PORT" # liftEffect
131− let port = maybePortString >>= fromString # fromMaybe 14188
189+ let
190+ port = maybePortString >>= fromString # fromMaybe 14188
132191 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
133192 listen <- case useLocalCertificates of
134193 UseLocalCertificates -> do
135194 httpsOptions <- makeHttpsOptions
136195 pure $ listenHttps app (port ∷ Int) httpsOptions
137− DoNotUseLocalCertificates ->
138− pure $ listenHttp app port
196+ DoNotUseLocalCertificates -> pure $ listenHttp app port
139197 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
140198 where
141199 makeHttpsOptions = do