From bed791a5c64048fd939f24c98198249a7ee6391c Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Thu, 28 Sep 2017 11:29:48 +0200 Subject: [PATCH] trigger evaluation remotely --- Foundation.hs | 4 ++++ Handler/AccountReset.hs | 19 ++++--------------- Handler/Shared.hs | 25 +++++++++++++++++++++++-- Handler/ShowChallenge.hs | 36 +++++++++++++++++++++++++++++------- Handler/YourAccount.hs | 13 ++++++++++++- config/models | 1 + config/routes | 2 ++ 7 files changed, 75 insertions(+), 25 deletions(-) diff --git a/Foundation.hs b/Foundation.hs index e7d5733..30d35d7 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -132,6 +132,9 @@ instance Yesod App where isAuthorized (AvatarR _) _ = return Authorized + isAuthorized TriggerRemotelyR _ = return Authorized + isAuthorized (OpenViewProgressR _) _ = return Authorized + isAuthorized CreateResetLinkR _ = isAdmin isAuthorized (ScoreR _) _ = isAdmin @@ -206,6 +209,7 @@ instance YesodAuth App where , userAvatar = Nothing , userVerificationKey = Nothing , userKeyExpirationDate = Nothing + , userTriggerToken = Nothing } -- You can add other plugins like BrowserID, email or OAuth here diff --git a/Handler/AccountReset.hs b/Handler/AccountReset.hs index 9d8ce14..2acd504 100644 --- a/Handler/AccountReset.hs +++ b/Handler/AccountReset.hs @@ -1,11 +1,9 @@ module Handler.AccountReset where import Import +import Handler.Shared import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) -import qualified Crypto.Nonce as Nonce -import System.IO.Unsafe (unsafePerformIO) - import Data.Time.Clock (addUTCTime) import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage) @@ -32,7 +30,7 @@ doCreateResetLink (Just email) = do mUserEnt <- runDB $ getBy $ UniqueUser email userId <- createOrUse mUserEnt email - key <- newVerifyKey + key <- newToken theNow <- liftIO getCurrentTime let expirationMoment = addUTCTime (60*60*24) theNow runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment] @@ -49,23 +47,14 @@ createOrUse :: Maybe (Entity User) -> Text -> Handler UserId createOrUse (Just userEnt) _ = return $ entityKey userEnt createOrUse Nothing email = do setMessage $ toHtml ("Created new user " ++ email) - userId <- runDB $ insert $ User email Nothing Nothing False Nothing True Nothing Nothing Nothing + triggerToken <- newToken + userId <- runDB $ insert $ User email Nothing Nothing False Nothing True Nothing Nothing Nothing (Just triggerToken) return userId createResetLinkForm :: Form Text createResetLinkForm = renderBootstrap3 BootstrapBasicForm $ areq textField (bfs MsgEMail) Nothing - -nonceGen :: Nonce.Generator -nonceGen = unsafePerformIO Nonce.new -{-# NOINLINE nonceGen #-} - --- | Randomly create a new verification key. -newVerifyKey :: MonadIO m => m Text -newVerifyKey = Nonce.nonce128urlT nonceGen - - getResetPasswordR :: Text -> Handler Html getResetPasswordR key = do mUserId <- checkVerificationKey key diff --git a/Handler/Shared.hs b/Handler/Shared.hs index e7e26cf..0ce6b5f 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -32,6 +32,9 @@ import Database.Persist.Sql import Yesod.Form.Bootstrap3 (bfs) +import qualified Crypto.Nonce as Nonce +import System.IO.Unsafe (unsafePerformIO) + atom = Control.Concurrent.STM.atomically type Channel = TChan (Maybe Text) @@ -74,8 +77,15 @@ browsableGitRepo bareRepoName | ".git" `isSuffixOf` bareRepoName = browsableGitSite ++ bareRepoName | otherwise = browsableGitSite ++ bareRepoName ++ ".git" + runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent -runViewProgress action = do +runViewProgress = runViewProgress' ViewProgressR + +runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent +runOpenViewProgress = runViewProgress' OpenViewProgressR + +runViewProgress' :: (Int -> Route App) -> (Channel -> Handler ()) -> Handler TypedContent +runViewProgress' route action = do App {..} <- getYesod jobId <- randomInt chan <- liftIO $ atom $ do @@ -91,7 +101,7 @@ runViewProgress action = do writeTChan chan Nothing m <- readTVar jobs writeTVar jobs $ IntMap.delete jobId m - redirect $ ViewProgressR jobId + redirect $ route jobId msg :: Channel -> Text -> Handler () msg chan m = liftIO $ atom $ writeTChan chan $ Just (m ++ "\n") @@ -243,6 +253,9 @@ checkRepoUrl url = case parsedURI of Nothing -> False where parsedURI = parseURI $ T.unpack url +getOpenViewProgressR :: Int -> Handler TypedContent +getOpenViewProgressR = getViewProgressR + getViewProgressR :: Int -> Handler TypedContent getViewProgressR jobId = do App {..} <- getYesod @@ -336,3 +349,11 @@ formatSubmitter user = if userIsAnonymous user fieldWithTooltip :: forall master msg msg1. (RenderMessage master msg, RenderMessage master msg1) => msg -> msg1 -> FieldSettings master fieldWithTooltip name tooltip = (bfs name) { fsTooltip = Just $ SomeMessage tooltip } + +nonceGen :: Nonce.Generator +nonceGen = unsafePerformIO Nonce.new +{-# NOINLINE nonceGen #-} + +-- | Randomly create a new verification key. +newToken :: MonadIO m => m Text +newToken = Nonce.nonce128urlT nonceGen diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 3c66e5e..827fe5f 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -113,10 +113,33 @@ postChallengeSubmissionR name = do _ -> Nothing Just (mDescription, mTags, submissionUrl, submissionBranch) = submissionData - runViewProgress $ doCreateSubmission challengeId mDescription mTags submissionUrl submissionBranch + userId <- requireAuthId + runViewProgress $ doCreateSubmission userId challengeId mDescription mTags submissionUrl submissionBranch -doCreateSubmission :: Key Challenge -> Maybe Text -> Maybe Text -> Text -> Text -> Channel -> Handler () -doCreateSubmission challengeId mDescription mTags url branch chan = do +postTriggerRemotelyR :: Handler TypedContent +postTriggerRemotelyR = do + (Just token) <- lookupPostParam "token" + (Just name) <- lookupPostParam "challenge" + (Just url) <- lookupPostParam "url" + mBranch <- lookupPostParam "branch" + let branch = fromMaybe "master" mBranch + Entity challengeId _ <- runDB $ getBy404 $ UniqueName name + [Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] [] + isPermitted <- canTrigger userId name url + if isPermitted + then + runOpenViewProgress $ doCreateSubmission userId challengeId Nothing Nothing url branch + else + return $ toTypedContent ("Cannot be triggered, must be submitted manually at Gonito.net!\n" :: String) + +canTrigger userId name url = do + user <- runDB $ get404 userId + return $ case userLocalId user of + Just localId -> (url == gitServer ++ localId ++ "/" ++ name) + Nothing -> False + +doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> Text -> Text -> Channel -> Handler () +doCreateSubmission userId challengeId mDescription mTags url branch chan = do maybeRepoKey <- getSubmissionRepo challengeId url branch chan case maybeRepoKey of Just repoId -> do @@ -126,17 +149,16 @@ doCreateSubmission challengeId mDescription mTags url branch chan = do commitMessage <- getLastCommitMessage repoDir chan let (mCommitDescription, mCommitTags) = parseCommitMessage commitMessage - submissionId <- getSubmission repoId (repoCurrentCommit repo) challengeId (fromMaybe (fromMaybe "???" mCommitDescription) mDescription) chan + submissionId <- getSubmission userId repoId (repoCurrentCommit repo) challengeId (fromMaybe (fromMaybe "???" mCommitDescription) mDescription) chan _ <- getOuts chan submissionId runDB $ addTags submissionId (if isNothing mTags then mCommitTags else mTags) [] msg chan "Done" Nothing -> return () -getSubmission :: Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission) -getSubmission repoId commit challengeId description chan = do +getSubmission :: UserId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission) +getSubmission userId repoId commit challengeId description chan = do maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId - userId <- requireAuthId case maybeSubmission of Just (Entity submissionId _) -> do msg chan "Submission already there, re-checking" diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index e3ce000..51cf333 100644 --- a/Handler/YourAccount.hs +++ b/Handler/YourAccount.hs @@ -10,13 +10,15 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage) - import Handler.Shared getYourAccountR :: Handler Html getYourAccountR = do userId <- requireAuthId user <- runDB $ get404 userId + + enableTriggerToken userId (userTriggerToken user) + keyS <- runDB $ selectFirst [PublicKeyUser ==. userId] [] let key = publicKeyPubkey <$> entityVal <$> keyS (formWidget, formEnctype) <- generateFormPost (yourAccountForm (userName user) (userLocalId user) key (userIsAnonymous user)) @@ -29,6 +31,9 @@ postYourAccountR = do ((result, formWidget), formEnctype) <- runFormPost (yourAccountForm Nothing Nothing Nothing False) userId <- requireAuthId user <- runDB $ get404 userId + + enableTriggerToken userId (userTriggerToken user) + let accountData = case result of FormSuccess res -> Just res _ -> Nothing @@ -45,6 +50,12 @@ postYourAccountR = do setTitle "Your account" $(widgetFile "your-account") + +enableTriggerToken _ (Just _) = return () +enableTriggerToken userId Nothing = do + token <- newToken + runDB $ update userId [UserTriggerToken =. Just token] + checkPassword :: Maybe Text -> Bool checkPassword Nothing = True checkPassword (Just "") = True diff --git a/config/models b/config/models index edbc8a7..273dfcf 100644 --- a/config/models +++ b/config/models @@ -9,6 +9,7 @@ User avatar ByteString Maybe verificationKey Text Maybe keyExpirationDate UTCTime Maybe + triggerToken Text Maybe deriving Typeable PublicKey user UserId diff --git a/config/routes b/config/routes index 3321b60..3585db0 100644 --- a/config/routes +++ b/config/routes @@ -8,6 +8,7 @@ /create-challenge CreateChallengeR GET POST /view-progress/#Int ViewProgressR GET +/open-view-progress/#Int OpenViewProgressR GET /list-challenges ListChallengesR GET /challenge/#Text ShowChallengeR GET @@ -19,6 +20,7 @@ /challenge-graph-data/#Text ChallengeGraphDataR GET /challenge-discussion/#Text ChallengeDiscussionR GET POST /challenge-discussion-rss/#Text ChallengeDiscussionFeedR GET +/trigger-remotely TriggerRemotelyR POST /q QueryFormR GET POST /q/#Text QueryResultsR GET