trigger evaluation remotely

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

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

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

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 ()
+postTriggerRemotelyR :: Handler TypedContent
-doCreateSubmission challengeId mDescription mTags url branch chan = do
+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 :: UserId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
-getSubmission repoId commit challengeId description chan = do
+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"

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

config/models

@@ -9,6 +9,7 @@ User
     avatar ByteString Maybe
     verificationKey Text Maybe
     keyExpirationDate UTCTime Maybe
+    triggerToken Text Maybe
     deriving Typeable
 PublicKey
     user UserId

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