@@ -15,12 +15,12 @@ import Data.Argonaut.Decode (class DecodeJson, decodeJson, printJsonDecodeError)
15import Data.Argonaut.Decode.Class (class DecodeJson)
15import Data.Argonaut.Decode.Class (class DecodeJson)
16import Data.Argonaut.Decode.Decoders (decodeString)
16import Data.Argonaut.Decode.Decoders (decodeString)
17import Data.Argonaut.Encode (encodeJson)
17import Data.Argonaut.Encode (encodeJson)
18−import Data.Array (elem, (..))
18+import Data.Array (any, elem, (..))
19import Data.Bifunctor (lmap)
19import Data.Bifunctor (lmap)
20−import Data.Either (Either(..))
20+import Data.Either (Either(..), note)
21import Data.Either (hush)
21import Data.Either (hush)
22import Data.Int (fromString)
22import Data.Int (fromString)
23−import Data.Maybe (Maybe(..), fromMaybe)
23+import Data.Maybe (Maybe(..), fromMaybe, maybe)
24import Data.Newtype (un)
24import Data.Newtype (un)
25import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
25import Data.Time.Duration (class Duration, Seconds(..), fromDuration)
26import Data.Traversable (traverse)
26import Data.Traversable (traverse)
@@ -58,6 +58,18 @@ import Shared.Json (readAff, readJsonAff)
58import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
58import Shared.Models.Body (CompileRequest, RunResult, CompileResult)
59import Shared.Models.Body as Body
59import Shared.Models.Body as Body
60import Unsafe.Coerce (unsafeCoerce)
60import 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)
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) as Status
62toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
74toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
63toBody result =
75toBody result =
@@ -81,7 +93,6 @@ runCode timeout folder =
81 , Nothing <$ delay (timeout # fromDuration)
93 , Nothing <$ delay (timeout # fromDuration)
85srcFolder ∷ String
96srcFolder ∷ String
86srcFolder = "../playground"
97srcFolder = "../playground"
@@ -113,7 +124,7 @@ main = do
113 , timeout: 10.0 # Seconds # fromDuration
124 , timeout: 10.0 # Seconds # fromDuration
116− void $ liftEffect (serverSetup q)
127+ void $ liftEffect (serverSetup tokens q)
118-- makeApp ∷ Array Token -> Queue PscIdeConnection -> App
129-- makeApp ∷ Array Token -> Queue PscIdeConnection -> App
119-- makeApp tokens q = do
130-- makeApp tokens q = do
@@ -134,6 +145,7 @@ main = do
134-- pure { key, cert }
145-- pure { key, cert }
136data Route = CompileAndRun
147data Route = CompileAndRun
137derive instance Generic Route _
149derive instance Generic Route _
139route :: RouteDuplex' Route
151route :: RouteDuplex' Route
@@ -141,21 +153,31 @@ route = mkRoute
141 { "CompileAndRun": "compileAndRun" / noArgs
153 { "CompileAndRun": "compileAndRun" / noArgs
144−serverSetup :: Queue _ -> Effect Unit
156+serverSetup :: Array Token -> Queue _ -> Effect Unit
145−serverSetup queue = do
157+serverSetup tokens queue = do
146 maybePortString <- lookupEnv "PORT" # liftEffect
158 maybePortString <- lookupEnv "PORT" # liftEffect
147 let port = maybePortString >>= fromString # fromMaybe 14188
159 let port = maybePortString >>= fromString # fromMaybe 14188
148− --liftEffect $ (listenHttp app port) \_ ->
160+ --liftEffect $ (listenHttp app port) \_ ->
149 info $ "psfp server started on port " <> show port
161 info $ "psfp server started on port " <> show port
151 void $ serve { port } { route, router }
163 void $ serve { port } { route, router }
165+ getToken' headers = do
166+ lookup headers "Token" # maybe
167+ (Left $ "Missing Token Header")
170+ validateToken' :: Token -> Either String Unit
171+ validateToken' token = do
172+ if Array.elem token tokens then Right unit else Left "Invalid Token"
153− router { route: CompileAndRun, method: Post, body } = usingCont do
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
154 { code } :: { code :: String } <- fromJson YogaJson.jsonDecoder body -- parse the json input
177 { code } :: { code :: String } <- fromJson YogaJson.jsonDecoder body -- parse the json input
155 -- jobId <- compileAndRunJob code
178 -- jobId <- compileAndRunJob code
156 compileAndRunJobCont queue { code } -- do your business logic
179 compileAndRunJobCont queue { code } -- do your business logic
157− -- whatever queue body
158− --notFound
180+ --notFound
159 router _ = notFound
181 router _ = notFound
160 makeHttpsOptions = do
182 makeHttpsOptions = do
161 key <- readTextFile UTF8 "server.key"
183 key <- readTextFile UTF8 "server.key"
@@ -164,40 +186,40 @@ serverSetup queue = do
165compileAndRunJobCont :: Queue _ -> CompileRequest -> ContT Response Aff Response
187compileAndRunJobCont :: Queue _ -> CompileRequest -> ContT Response Aff Response
166compileAndRunJobCont queue { code } = do
188compileAndRunJobCont queue { code } = do
167− resultVar <- lift AVar.empty
189+ resultVar <- lift AVar.empty
169− job :: NewJob _
191+ job :: NewJob _
170− job = NewJob \jobId conn -> do
192+ job = NewJob \jobId conn -> do
171− stringOrErr ∷ Either Error String <- attempt $ compileCode code conn
193+ stringOrErr ∷ Either Error String <- attempt $ compileCode code conn
172− jsonOrErr ∷ Either Error (Either Error CompileResult) <- attempt $ readJsonAff `traverse` stringOrErr
194+ jsonOrErr ∷ Either Error (Either Error CompileResult) <- attempt $ readJsonAff `traverse` stringOrErr
173− let folder = getFolder conn
195+ let folder = getFolder conn
174− AVar.put { jsonOrErr, stringOrErr, folder } resultVar
196+ AVar.put { jsonOrErr, stringOrErr, folder } resultVar
175− enqueueResult <- lift $ liftEffect $ Q.enqueue job queue
197+ enqueueResult <- lift $ liftEffect $ Q.enqueue job queue
176− case enqueueResult of
198+ case enqueueResult of
177− QueueFull -> notFound
199+ QueueFull -> notFound
179− { jsonOrErr, stringOrErr, folder } <- AVar.take resultVar # lift
201+ { jsonOrErr, stringOrErr, folder } <- AVar.take resultVar # lift
180− case jsonOrErr ∷ Either Error (Either Error CompileResult) of
202+ case jsonOrErr ∷ Either Error (Either Error CompileResult) of
181− Left e -> do
203+ Left e -> do
182− lift $ log $ "Aff failed with " <> message e
204+ lift $ log $ "Aff failed with " <> message e
183− internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show e }
205+ internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show e }
184− Right (Right res)
206+ Right (Right res)
185− | res.resultType == "error" -> do
207+ | res.resultType == "error" -> do
186− unprocessableEntity
208+ unprocessableEntity
187− Right (Right res) -> do
209+ Right (Right res) -> do
188− runResult <- runCode timeout folder # lift
210+ runResult <- runCode timeout folder # lift
189− case runResult of
211+ case runResult of
190− Nothing -> do
212+ Nothing -> do
191− requestTimeout' jsonHeaders -- $ toJson YogaJson.jsonEncoder { error: "Timed out after running for " <> show timeout }
213+ requestTimeout' jsonHeaders -- $ toJson YogaJson.jsonEncoder { error: "Timed out after running for " <> show timeout }
192− Just rr -> do
214+ Just rr -> do
193− resultBody <- toBody rr # lift
215+ resultBody <- toBody rr # lift
194− ok' jsonHeaders $ toJson YogaJson.jsonEncoder{ resultBody }
216+ ok' jsonHeaders $ toJson YogaJson.jsonEncoder { resultBody }
195− Right (Left errs) -> do
217+ Right (Left errs) -> do
196− log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
218+ log $ "Could not decode: " <> show (lmap (const "no way") stringOrErr) <> "\nErrors: " <> show errs
197− internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show errs }
219+ internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show errs }
198− -- case r of
220+ -- case r of
199− -- Left err -> internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show err }
221+ -- Left err -> internalServerError' jsonHeaders $ toJson YogaJson.jsonEncoder { error: show err }
200− -- Right result -> ok' jsonHeaders $ toJson YogaJson.jsonEncoder result
222+ -- Right result -> ok' jsonHeaders $ toJson YogaJson.jsonEncoder result
203 jsonBody = toJson
225 jsonBody = toJson