@@ -1,9 +1,10 @@
11module Main where
22
33import Prelude
4−
4+import Auth.Handler (authHandler, readAllowedTokens)
5+import Auth.Types (Token(..))
56import Control.Parallel (parOneOf, parTraverse)
6−import Data.Array ((..))
7+import Data.Array (elem, (..))
78import Data.Bifunctor (lmap)
89import Data.Either (Either(..))
910import Data.Int (fromString)
@@ -25,10 +26,10 @@ import Node.ChildProcess (ExecResult)
2526import Node.Encoding (Encoding(..))
2627import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
2728import Node.Express.App as E
28−import Node.Express.Handler (HandlerM(..), Handler)
29+import Node.Express.Handler (Handler, HandlerM(..), next)
2930import Node.Express.Middleware.Static (static)
30−import Node.Express.Request (getBody')
31−import Node.Express.Response (setStatus)
31+import Node.Express.Request (getBody', getRequestHeader)
32+import Node.Express.Response (end, setStatus)
3233import Node.Express.Response as Response
3334import Node.Express.Types (Request, Response)
3435import Node.FS.Aff (readTextFile)
@@ -48,40 +49,41 @@ toBody result =
4849 $ ado
4950 stdout <- Buffer.toString UTF8 result.stdout
5051 stderr <- Buffer.toString UTF8 result.stderr
51− let
52− (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
52+ let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
5353 in { code, stdout, stderr } ∷ RunResult
5454
55−type ErrorWithCode
56− = { code ∷ Maybe Int }
55+type ErrorWithCode =
56+ { code ∷ Maybe Int }
5757
5858asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
5959asErrorWithCode = read_ <<< unsafeToForeign
6060
6161runCode ∷ ∀ d. Duration d => d -> Folder -> Aff (Maybe ExecResult)
62−runCode timeout folder = parOneOf
63− [ Just <$> execCommand folder "exec node run.js"
64− , Nothing <$ delay (timeout # fromDuration)
65− ]
62+runCode timeout folder =
63+ parOneOf
64+ [ Just <$> execCommand folder "exec node run.js"
65+ , Nothing <$ delay (timeout # fromDuration)
66+ ]
6667
6768compileAndRunJob ∷ CompileRequest -> (Handler -> Aff Unit) -> NewJob PscIdeConnection
6869compileAndRunJob json handle =
6970 NewJob \jobId conn -> do
7071 stringOrErr <- attempt $ compileCode json.code conn
71− case ((readJSON <$> stringOrErr) ∷ _ _ (_ _ CompileResult)) of
72+ case ((readJSON <$> stringOrErr) ∷ _ _ (_ _ CompileResult)) of
7273 Left e -> do
7374 handle $ setStatus 500
7475 log $ "Aff failed with " <> message e
7576 handle $ Response.send $ write {}
76− Right (Right res) | res.resultType == "error" -> do
77− handle $ setStatus 422
78− handle $ Response.send $ write res
77+ Right (Right res)
78+ | res.resultType == "error" -> do
79+ handle $ setStatus 422
80+ handle $ Response.send $ write res
7981 Right (Right res) -> do
80− runResult <- runCode timeout (getFolder conn)
82+ runResult <- runCode timeout (getFolder conn)
8183 case runResult of
8284 Nothing -> do
8385 handle $ setStatus 408
84− handle $ Response.send $ write { error: "Timed out after running for " <> show timeout}
86+ handle $ Response.send $ write { error: "Timed out after running for " <> show timeout }
8587 Just rr -> do
8688 resultBody <- toBody rr
8789 handle $ Response.send $ write (resultBody ∷ Body.RunResult)
@@ -89,8 +91,8 @@ compileAndRunJob json handle =
8991 handle $ setStatus 500
9092 log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
9193 handle $ Response.send $ write {}
92− where
93− timeout = 1.0 # Seconds
94+ where
95+ timeout = 1.0 # Seconds
9496
9597compileAndRunHandler ∷ Queue PscIdeConnection -> Handler
9698compileAndRunHandler queue = do
@@ -99,7 +101,6 @@ compileAndRunHandler queue = do
99101 HandlerM \req res next -> do
100102 let
101103 handle = unHandler req res next
102−
103104 runJob = compileAndRunJob json handle
104105 queueRes <- Q.enqueue runJob queue # liftEffect
105106 case queueRes of
@@ -121,19 +122,20 @@ destFolder = "../playgrounds/"
121122main ∷ Effect Unit
122123main = do
123124 launchAff_ do
125+ tokens <- readAllowedTokens
124126 cpus <- numCpus # liftEffect
125127 let
126128 poolSize = max 2 (cpus / 2) -- use at least 2
127−
128129 mkFolder = Folder <<< (destFolder <> _) <<< show
129−
130− connections <- (1 .. poolSize) # parTraverse \n -> do
131− let folder = mkFolder n
132− port = 14100 + n
133− log $ "Copying to folder " <> (un Folder folder)
134− copy srcFolder (un Folder folder)
135− mkConnection folder port
136−
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
137139 let pool = ResourcePool connections
138140 q <-
139141 Q.mkQueue
@@ -141,38 +143,22 @@ main = do
141143 , timeout: 10.0 # Seconds # fromDuration
142144 }
143145 pool
144− serverSetup (makeApp q)
146+ serverSetup (makeApp tokens q)
145147
146−makeApp ∷ Queue PscIdeConnection -> App
147−makeApp q = do
148+makeApp ∷ Array Token -> Queue PscIdeConnection -> App
149+makeApp tokens q = do
148150 use $ static "assets"
149151 useExternal jsonBodyParser
152+ use (authHandler tokens)
150153 E.post "/compileAndRun" (compileAndRunHandler q)
151154
152−data CertificatesToUse
153− = UseLocalCertificates
154− | DoNotUseLocalCertificates
155−
156−parseCertificatesToUse ∷ String -> CertificatesToUse
157−parseCertificatesToUse = case _ of
158− "LOCAL" -> UseLocalCertificates
159− _ -> DoNotUseLocalCertificates
160−
161155serverSetup ∷ App -> Aff Server
162156serverSetup app = do
163157 maybePortString <- lookupEnv "PORT" # liftEffect
164− let
165− port = maybePortString >>= fromString # fromMaybe 14188
166− useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
167− listen <- case useLocalCertificates of
168− UseLocalCertificates -> do
169− httpsOptions <- makeHttpsOptions
170− pure $ listenHttps app (port ∷ Int) httpsOptions
171− DoNotUseLocalCertificates -> pure $ listenHttp app port
172− liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
158+ let port = maybePortString >>= fromString # fromMaybe 14188
159+ liftEffect $ (listenHttp app port) \_ -> info $ "psfp server started on port " <> show port
173160 where
174− makeHttpsOptions = do
175− key <- readTextFile UTF8 "server.key"
176− cert <- readTextFile UTF8 "server.cert"
177− pure { key, cert }
178−
161+ makeHttpsOptions = do
162+ key <- readTextFile UTF8 "server.key"
163+ cert <- readTextFile UTF8 "server.cert"
164+ pure { key, cert }