diff --git a/Foundation.hs b/Foundation.hs index ba6b196..825d478 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -169,10 +169,11 @@ instance Yesod App where isAuthorized (ChallengeReadmeR _) _ = regularAuthorization isAuthorized (ChallengeAllSubmissionsR _) _ = regularAuthorization - isAuthorized (ChallengeMySubmissionsJsonR _) _ = regularAuthorization + isAuthorized (ChallengeMySubmissionsJsonR _) _ = return Authorized isAuthorized (ChallengeAllSubmissionsJsonR _) _ = return Authorized - isAuthorized AddUserR _ = regularAuthorization - isAuthorized UserInfoR _ = regularAuthorization + isAuthorized AddUserR _ = return Authorized + isAuthorized UserInfoR _ = return Authorized + isAuthorized (ChallengeSubmissionJsonR _) _ = return Authorized isAuthorized (ChallengeGraphDataR _) _ = regularAuthorization isAuthorized (ChallengeDiscussionR _) _ = regularAuthorization diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 51ca1b7..bf6a0b7 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -15,6 +15,8 @@ import qualified Data.Text.Encoding as DTE import Database.Persist.Sql (fromSqlKey) +import Data.Scientific + import Control.Concurrent.Lifted (threadDelay) import Control.Concurrent (forkIO) @@ -99,8 +101,17 @@ runViewProgress = runViewProgress' ViewProgressR runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent runOpenViewProgress = runViewProgress' OpenViewProgressR +runViewProgressAsynchronously :: (Channel -> Handler ()) -> Handler Value +runViewProgressAsynchronously action = runViewProgressGeneralized getJobIdAsJson action +-- where getJobIdAsJson jobId = return $ Number (scientific (toInteger jobId) 0) + where getJobIdAsJson jobId = return $ String $ pack $ show jobId + runViewProgress' :: (Int -> Route App) -> (Channel -> Handler ()) -> Handler TypedContent -runViewProgress' route action = do +runViewProgress' route action = runViewProgressGeneralized doRedirection action + where doRedirection jobId = redirect $ route jobId + +runViewProgressGeneralized :: (Int -> Handler v) -> (Channel -> Handler ()) -> Handler v +runViewProgressGeneralized handler action = do App {..} <- getYesod jobId <- randomInt chan <- liftIO $ atom $ do @@ -117,7 +128,7 @@ runViewProgress' route action = do writeTChan chan Nothing m <- readTVar jobs writeTVar jobs $ IntMap.delete jobId m - redirect $ route jobId + handler jobId data RepoCloningSpec = RepoCloningSpec { cloningSpecRepo :: RepoSpec, diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 1448666..8f9df81 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -279,8 +279,10 @@ getChallengeSubmissionR name = do (formWidget, formEnctype) <- generateFormPost $ submissionForm (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge -postChallengeSubmissionR :: Text -> Handler TypedContent -postChallengeSubmissionR name = do +postChallengeSubmissionJsonR :: Text -> Handler Value +postChallengeSubmissionJsonR name = do + Entity userId _ <- requireAuthPossiblyByToken + (Entity challengeId _) <- runDB $ getBy404 $ UniqueName name ((result, _), _) <- runFormPost $ submissionForm Nothing Nothing Nothing let submissionData' = case result of @@ -288,7 +290,19 @@ postChallengeSubmissionR name = do _ -> Nothing Just submissionData = submissionData' + runViewProgressAsynchronously $ doCreateSubmission userId challengeId submissionData + +postChallengeSubmissionR :: Text -> Handler TypedContent +postChallengeSubmissionR name = do userId <- requireAuthId + + (Entity challengeId _) <- runDB $ getBy404 $ UniqueName name + ((result, _), _) <- runFormPost $ submissionForm Nothing Nothing Nothing + let submissionData' = case result of + FormSuccess res -> Just res + _ -> Nothing + Just submissionData = submissionData' + runViewProgress $ doCreateSubmission userId challengeId submissionData postTriggerLocallyR :: Handler TypedContent @@ -763,7 +777,7 @@ fetchAllSubmissionsView name = do fetchMySubmissionsView :: Text -> Handler SubmissionsView fetchMySubmissionsView name = do - userId <- requireAuthId + Entity userId _ <- requireAuthPossiblyByToken fetchChallengeSubmissionsView (\(Entity _ submission) -> (submissionSubmitter submission == userId)) name convertTagInfoToView :: (Entity Import.Tag, Entity SubmissionTag) -> TagView diff --git a/config/routes b/config/routes index e22eded..438b3d6 100644 --- a/config/routes +++ b/config/routes @@ -10,12 +10,14 @@ /view-progress/#Int ViewProgressR GET /open-view-progress/#Int OpenViewProgressR GET /list-challenges ListChallengesR GET + /api/list-challenges ListChallengesJsonR GET /api/leaderboard/#Text LeaderboardJsonR GET /api/challenge-my-submissions/#Text ChallengeMySubmissionsJsonR GET /api/challenge-all-submissions/#Text ChallengeAllSubmissionsJsonR GET /api/user-info UserInfoR GET /api/add-user AddUserR GET +/api/challenge-submission/#Text ChallengeSubmissionJsonR POST /list-archived-challenges ListArchivedChallengesR GET /challenge-image/#ChallengeId ChallengeImageR GET diff --git a/gonito.cabal b/gonito.cabal index 06c5f79..2822556 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -154,6 +154,7 @@ library , wai-cors , word8 , jose-jwt + , scientific executable gonito if flag(library-only)