From 252da6316ae5c8dca9c07fe8de0acd2e19eebce8 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Thu, 14 Jun 2018 20:35:48 +0200 Subject: [PATCH] fix problem with git-annex remote when updating a repo, get rid of some warnings --- Handler/Runner.hs | 8 ++++++++ Handler/Shared.hs | 18 +++++++++--------- Handler/ShowChallenge.hs | 13 +++++++++---- gonito.cabal | 1 + stack.yaml | 2 +- 5 files changed, 28 insertions(+), 14 deletions(-) diff --git a/Handler/Runner.hs b/Handler/Runner.hs index 37ade31..def5802 100644 --- a/Handler/Runner.hs +++ b/Handler/Runner.hs @@ -7,6 +7,7 @@ import System.Exit import Control.Concurrent.STM import Control.Concurrent.Lifted (threadDelay) import qualified Data.ByteString as BS +import Control.Monad.IO.Class type Channel = TChan (Maybe Text) @@ -57,6 +58,13 @@ instance Monad Runner where RunnerOK w -> RunnerOK w } +instance MonadIO Runner where + liftIO action = Runner { + runRunner = \_ -> do + r <- liftIO action + return $ RunnerOK r + } + runWithChannel :: Channel -> Runner () -> Handler ExitCode runWithChannel chan runner = do s <- (runRunner runner) chan diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 1b3cfd1..20d63b0 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -4,18 +4,16 @@ module Handler.Shared where import Import -import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Handler.Runner import System.Exit -import Network.URI import qualified Data.Text as T -import Database.Persist.Sql (ConnectionPool, runSqlPool, fromSqlKey) +import Database.Persist.Sql (fromSqlKey) -import Control.Concurrent.Lifted (fork, threadDelay) +import Control.Concurrent.Lifted (threadDelay) import Control.Concurrent (forkIO) import qualified Crypto.Hash.SHA1 as CHS @@ -28,13 +26,12 @@ import System.Directory (doesFileExist, renameDirectory) import PersistSHA1 -import qualified Data.ByteString as BS - import Text.Printf -import Database.Persist.Sql import Yesod.Form.Bootstrap3 (bfs) +import qualified Test.RandomStrings as RS + import qualified Crypto.Nonce as Nonce import System.IO.Unsafe (unsafePerformIO) @@ -74,6 +71,7 @@ browsableGitRepoBranch :: RepoScheme -> Repo -> Text -> Text -> Text browsableGitRepoBranch SelfHosted _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/" browsableGitRepoBranch Branches repo _ branch = sshToHttps (repoUrl repo) branch +sshToHttps :: Text -> Text -> Text sshToHttps url branch = "https://" ++ (T.replace ".git" "" $ T.replace ":" "/" $ T.replace "ssh://" "" $ T.replace "git@" "" url) ++ "/tree/" ++ branch browsableGitRepo :: Text -> Text @@ -98,7 +96,7 @@ runViewProgress' route action = do writeTVar jobs $ IntMap.insert jobId chan m return chan runInnerHandler <- handlerToIO - liftIO $ forkIO $ runInnerHandler $ do + _ <- liftIO $ forkIO $ runInnerHandler $ do liftIO $ threadDelay 1000000 action chan liftIO $ atom $ do @@ -240,10 +238,11 @@ rawClone tmpRepoDir repoCloningSpec chan = runWithChannel chan $ do getStuffUsingGitAnnex :: FilePath -> Maybe Text -> Runner () getStuffUsingGitAnnex _ Nothing = return () getStuffUsingGitAnnex tmpRepoDir (Just gitAnnexRemote) = do + let randomRemoteNameLen = 10 + remoteName <- liftIO $ RS.randomString (RS.onlyAlpha RS.randomASCII) randomRemoteNameLen runGitAnnex tmpRepoDir ["init"] runGitAnnex tmpRepoDir (["initremote", remoteName] ++ (words $ T.unpack gitAnnexRemote)) runGitAnnex tmpRepoDir ["get", "--from", remoteName] - where remoteName = "storage" runGitAnnex :: FilePath -> [String] -> Runner () runGitAnnex tmpRepoDir args = runProg (Just tmpRepoDir) gitPath ("annex":args) @@ -307,6 +306,7 @@ nonceGen = unsafePerformIO Nonce.new newToken :: MonadIO m => m Text newToken = Nonce.nonce128urlT nonceGen +enableTriggerToken :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, YesodPersist site, PersistStoreWrite (YesodPersistBackend site)) => Key User -> Maybe a -> HandlerFor site () enableTriggerToken _ (Just _) = return () enableTriggerToken userId Nothing = do token <- newToken diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 35b1bfe..2e1c939 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -352,14 +352,18 @@ getSubmissionRepo :: Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key getSubmissionRepo challengeId repoSpec chan = do let url = repoSpecUrl repoSpec let branch = repoSpecBranch repoSpec + let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch case maybeRepo of - Just (Entity repoId repo) -> do + Just (Entity repoId _) -> do msg chan "Repo already there" available <- checkRepoAvailibility challengeId repoId chan if available then do + -- this is not completely right... some other thread + -- might update this to a different value + runDB $ update repoId [RepoGitAnnexRemote =. gitAnnexRemote] updateStatus <- updateRepo repoId chan if updateStatus then @@ -377,7 +381,8 @@ getSubmissionRepo challengeId repoSpec chan = do cloningSpecRepo = repoSpec, cloningSpecReferenceRepo = RepoSpec { repoSpecUrl = (T.pack repoDir), - repoSpecBranch = (repoBranch repo) + repoSpecBranch = (repoBranch repo), + repoSpecGitAnnexRemote = Nothing } } cloneRepo' repoCloningSpec chan @@ -403,11 +408,11 @@ checkRepoAvailibility challengeId repoId chan = do challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission") submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text, Maybe Text) -submissionForm defaultUrl defaultBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ (,,,,) +submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ (,,,,) <$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing <*> aopt textField (tagsfs MsgSubmissionTags) Nothing <*> areq textField (bfs MsgSubmissionUrl) defaultUrl - <*> areq textField (bfs MsgSubmissionBranch) defaultBranch + <*> areq textField (bfs MsgSubmissionBranch) defBranch <*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote) getChallengeMySubmissionsR :: Text -> Handler Html diff --git a/gonito.cabal b/gonito.cabal index 9a9a19a..cf81981 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -138,6 +138,7 @@ library , esqueleto , extra , attoparsec + , random-strings executable gonito if flag(library-only) diff --git a/stack.yaml b/stack.yaml index aaad00d..2027359 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,7 +8,7 @@ packages: git: https://github.com/bitemyapp/esqueleto commit: b81e0d951e510ebffca03c5a58658ad884cc6fbd extra-dep: true -extra-deps: [../geval,wai-handler-fastcgi-3.0.0.2,murmur3-1.0.3] +extra-deps: [../geval,wai-handler-fastcgi-3.0.0.2,murmur3-1.0.3,random-strings-0.1.1.0] resolver: lts-11.9 image: container: