@@ -15,12 +15,12 @@ import Data.Argonaut.Decode (class DecodeJson, decodeJson, printJsonDecodeError)
1515import Data.Argonaut.Decode.Class (class DecodeJson)
1616import Data.Argonaut.Decode.Decoders (decodeString)
1717import Data.Argonaut.Encode (encodeJson)
18−import Data.Array (any, elem, (..))
18+import Data.Array (elem, (..))
1919import Data.Bifunctor (lmap)
20−import Data.Either (Either(..), note)
20+import Data.Either (Either(..))
2121import Data.Either (hush)
2222import Data.Int (fromString)
23−import Data.Maybe (Maybe(..), fromMaybe, maybe)
23+import Data.Maybe (Maybe(..), fromMaybe)
2424import Data.Newtype (un)
2525import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
2626import Data.Traversable (traverse)
@@ -58,18 +58,6 @@ import Shared.Json (readAff, readJsonAff)
5858import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
5959import Shared.Models.Body as Body
6060import Unsafe.Coerce (unsafeCoerce)
61−import Foreign.Object (lookup) as Object
62−import Control.Alt ((<|>))
63−import Data.Array (elem) as Array
64−import HTTPurple.Response (notFound, unauthorized, unprocessableEntity')
65−import Control.Monad.Error.Class (throwError)
66−import Data.Monoid (guard)
67−import HTTPurple.Headers (RequestHeaders)
68−import Data.Map (lookup) as Mapl
69−import Data.String.CaseInsensitive (CaseInsensitiveString(CaseInsensitiveString))
70−import Data.Map (lookup) as Map
71−import HTTPurple.Validation (fromValidated, fromValidatedE)
72−import HTTPurple.Status (forbidden, unauthorized, unprocessableEntity) as Status
7361
7462toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
7563toBody result =
@@ -93,6 +81,7 @@ runCode timeout folder =
9381 , Nothing <$ delay (timeout # fromDuration)
9482 ]
9583
84+
9685srcFolder ∷ String
9786srcFolder = "../playground"
9887
@@ -124,7 +113,7 @@ main = do
124113 , timeout: 10.0 # Seconds # fromDuration
125114 }
126115 pool
127− void $ liftEffect (serverSetup tokens q)
116+ void $ liftEffect (serverSetup q)
128117
129118-- makeApp ∷ Array Token -> Queue PscIdeConnection -> App
130119-- makeApp tokens q = do
@@ -145,7 +134,6 @@ main = do
145134-- pure { key, cert }
146135
147136data Route = CompileAndRun
148−
149137derive instance Generic Route _
150138
151139route :: RouteDuplex' Route
@@ -153,31 +141,21 @@ route = mkRoute
153141 { "CompileAndRun": "compileAndRun" / noArgs
154142 }
155143
156−serverSetup :: Array Token -> Queue _ -> Effect Unit
157−serverSetup tokens queue = do
144+serverSetup :: Queue _ -> Effect Unit
145+serverSetup queue = do
158146 maybePortString <- lookupEnv "PORT" # liftEffect
159147 let port = maybePortString >>= fromString # fromMaybe 14188
160− --liftEffect $ (listenHttp app port) \_ ->
148+ --liftEffect $ (listenHttp app port) \_ ->
161149 info $ "psfp server started on port " <> show port
162150
163151 void $ serve { port } { route, router }
164152 where
165− getToken' headers = do
166− lookup headers "Token" # maybe
167− (Left $ "Missing Token Header")
168− (Right <<< Token)
169−
170− validateToken' :: Token -> Either String Unit
171− validateToken' token = do
172− if Array.elem token tokens then Right unit else Left "Invalid Token"
173−
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
153+ router { route: CompileAndRun, method: Post, body } = usingCont do
177154 { code } :: { code :: String } <- fromJson YogaJson.jsonDecoder body -- parse the json input
178155 -- jobId <- compileAndRunJob code
179156 compileAndRunJobCont queue { code } -- do your business logic
180− --notFound
157+ -- whatever queue body
158+ --notFound
181159 router _ = notFound
182160 makeHttpsOptions = do
183161 key <- readTextFile UTF8 "server.key"
@@ -186,41 +164,40 @@ serverSetup tokens queue = do
186164
187165compileAndRunJobCont :: Queue _ -> CompileRequest -> ContT Response Aff Response
188166compileAndRunJobCont 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− let body = toJson YogaJson.jsonEncoder { result: res.result }
209− response' Status.unprocessableEntity empty body
210− Right (Right res) -> do
211− runResult <- runCode timeout folder # lift
212− case runResult of
213− Nothing -> do
214− requestTimeout' jsonHeaders -- $ toJson YogaJson.jsonEncoder { error: "Timed out after running for " <> show timeout }
215− Just rr -> do
216− resultBody <- toBody rr # lift
217− ok' jsonHeaders $ toJson YogaJson.jsonEncoder { resultBody }
218− Right (Left errs) -> do
219− log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
220− internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show errs }
221− -- case r of
222− -- Left err -> internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show err }
223− -- Right result -> ok' jsonHeaders $ toJson YogaJson.jsonEncoder result
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
224201
225202 where
226203 jsonBody = toJson