@@ -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 (elem, (..))
18+import Data.Array (any, elem, (..))
1919import Data.Bifunctor (lmap)
20−import Data.Either (Either(..))
20+import Data.Either (Either(..), note)
2121import Data.Either (hush)
2222import Data.Int (fromString)
23−import Data.Maybe (Maybe(..), fromMaybe)
23+import Data.Maybe (Maybe(..), fromMaybe, maybe)
2424import Data.Newtype (un)
2525import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
2626import Data.Traversable (traverse)
@@ -58,6 +58,18 @@ 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
6173
6274toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
6375toBody result =
@@ -81,7 +93,6 @@ runCode timeout folder =
8193 , Nothing <$ delay (timeout # fromDuration)
8294 ]
8395
84−
8596srcFolder ∷ String
8697srcFolder = "../playground"
8798
@@ -113,7 +124,7 @@ main = do
113124 , timeout: 10.0 # Seconds # fromDuration
114125 }
115126 pool
116− void $ liftEffect (serverSetup q)
127+ void $ liftEffect (serverSetup tokens q)
117128
118129-- makeApp ∷ Array Token -> Queue PscIdeConnection -> App
119130-- makeApp tokens q = do
@@ -134,6 +145,7 @@ main = do
134145-- pure { key, cert }
135146
136147data Route = CompileAndRun
148+
137149derive instance Generic Route _
138150
139151route :: RouteDuplex' Route
@@ -141,21 +153,31 @@ route = mkRoute
141153 { "CompileAndRun": "compileAndRun" / noArgs
142154 }
143155
144−serverSetup :: Queue _ -> Effect Unit
145−serverSetup queue = do
156+serverSetup :: Array Token -> Queue _ -> Effect Unit
157+serverSetup tokens queue = do
146158 maybePortString <- lookupEnv "PORT" # liftEffect
147159 let port = maybePortString >>= fromString # fromMaybe 14188
148− --liftEffect $ (listenHttp app port) \_ ->
160+ --liftEffect $ (listenHttp app port) \_ ->
149161 info $ "psfp server started on port " <> show port
150162
151163 void $ serve { port } { route, router }
152164 where
153− router { route: CompileAndRun, method: Post, body } = usingCont do
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
154177 { code } :: { code :: String } <- fromJson YogaJson.jsonDecoder body -- parse the json input
155178 -- jobId <- compileAndRunJob code
156179 compileAndRunJobCont queue { code } -- do your business logic
157− -- whatever queue body
158− --notFound
180+ --notFound
159181 router _ = notFound
160182 makeHttpsOptions = do
161183 key <- readTextFile UTF8 "server.key"
@@ -164,40 +186,41 @@ serverSetup queue = do
164186
165187compileAndRunJobCont :: Queue _ -> CompileRequest -> ContT Response Aff Response
166188compileAndRunJobCont queue { code } = do
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
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
201224
202225 where
203226 jsonBody = toJson