fix problem with git-annex remote when updating a repo, get rid of some warnings

This commit is contained in:
Filip Gralinski 2018-06-14 20:35:48 +02:00
parent 047cc74014
commit 252da6316a
5 changed files with 28 additions and 14 deletions

View File

@ -7,6 +7,7 @@ import System.Exit
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.Lifted (threadDelay) import Control.Concurrent.Lifted (threadDelay)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Control.Monad.IO.Class
type Channel = TChan (Maybe Text) type Channel = TChan (Maybe Text)
@ -57,6 +58,13 @@ instance Monad Runner where
RunnerOK w -> RunnerOK w 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 :: Channel -> Runner () -> Handler ExitCode
runWithChannel chan runner = do runWithChannel chan runner = do
s <- (runRunner runner) chan s <- (runRunner runner) chan

View File

@ -4,18 +4,16 @@ module Handler.Shared where
import Import import Import
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import Handler.Runner import Handler.Runner
import System.Exit import System.Exit
import Network.URI
import qualified Data.Text as T 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 Control.Concurrent (forkIO)
import qualified Crypto.Hash.SHA1 as CHS import qualified Crypto.Hash.SHA1 as CHS
@ -28,13 +26,12 @@ import System.Directory (doesFileExist, renameDirectory)
import PersistSHA1 import PersistSHA1
import qualified Data.ByteString as BS
import Text.Printf import Text.Printf
import Database.Persist.Sql
import Yesod.Form.Bootstrap3 (bfs) import Yesod.Form.Bootstrap3 (bfs)
import qualified Test.RandomStrings as RS
import qualified Crypto.Nonce as Nonce import qualified Crypto.Nonce as Nonce
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
@ -74,6 +71,7 @@ browsableGitRepoBranch :: RepoScheme -> Repo -> Text -> Text -> Text
browsableGitRepoBranch SelfHosted _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/" browsableGitRepoBranch SelfHosted _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
browsableGitRepoBranch Branches repo _ branch = sshToHttps (repoUrl repo) 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 sshToHttps url branch = "https://" ++ (T.replace ".git" "" $ T.replace ":" "/" $ T.replace "ssh://" "" $ T.replace "git@" "" url) ++ "/tree/" ++ branch
browsableGitRepo :: Text -> Text browsableGitRepo :: Text -> Text
@ -98,7 +96,7 @@ runViewProgress' route action = do
writeTVar jobs $ IntMap.insert jobId chan m writeTVar jobs $ IntMap.insert jobId chan m
return chan return chan
runInnerHandler <- handlerToIO runInnerHandler <- handlerToIO
liftIO $ forkIO $ runInnerHandler $ do _ <- liftIO $ forkIO $ runInnerHandler $ do
liftIO $ threadDelay 1000000 liftIO $ threadDelay 1000000
action chan action chan
liftIO $ atom $ do liftIO $ atom $ do
@ -240,10 +238,11 @@ rawClone tmpRepoDir repoCloningSpec chan = runWithChannel chan $ do
getStuffUsingGitAnnex :: FilePath -> Maybe Text -> Runner () getStuffUsingGitAnnex :: FilePath -> Maybe Text -> Runner ()
getStuffUsingGitAnnex _ Nothing = return () getStuffUsingGitAnnex _ Nothing = return ()
getStuffUsingGitAnnex tmpRepoDir (Just gitAnnexRemote) = do getStuffUsingGitAnnex tmpRepoDir (Just gitAnnexRemote) = do
let randomRemoteNameLen = 10
remoteName <- liftIO $ RS.randomString (RS.onlyAlpha RS.randomASCII) randomRemoteNameLen
runGitAnnex tmpRepoDir ["init"] runGitAnnex tmpRepoDir ["init"]
runGitAnnex tmpRepoDir (["initremote", remoteName] ++ (words $ T.unpack gitAnnexRemote)) runGitAnnex tmpRepoDir (["initremote", remoteName] ++ (words $ T.unpack gitAnnexRemote))
runGitAnnex tmpRepoDir ["get", "--from", remoteName] runGitAnnex tmpRepoDir ["get", "--from", remoteName]
where remoteName = "storage"
runGitAnnex :: FilePath -> [String] -> Runner () runGitAnnex :: FilePath -> [String] -> Runner ()
runGitAnnex tmpRepoDir args = runProg (Just tmpRepoDir) gitPath ("annex":args) runGitAnnex tmpRepoDir args = runProg (Just tmpRepoDir) gitPath ("annex":args)
@ -307,6 +306,7 @@ nonceGen = unsafePerformIO Nonce.new
newToken :: MonadIO m => m Text newToken :: MonadIO m => m Text
newToken = Nonce.nonce128urlT nonceGen newToken = Nonce.nonce128urlT nonceGen
enableTriggerToken :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, YesodPersist site, PersistStoreWrite (YesodPersistBackend site)) => Key User -> Maybe a -> HandlerFor site ()
enableTriggerToken _ (Just _) = return () enableTriggerToken _ (Just _) = return ()
enableTriggerToken userId Nothing = do enableTriggerToken userId Nothing = do
token <- newToken token <- newToken

View File

@ -352,14 +352,18 @@ getSubmissionRepo :: Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key
getSubmissionRepo challengeId repoSpec chan = do getSubmissionRepo challengeId repoSpec chan = do
let url = repoSpecUrl repoSpec let url = repoSpecUrl repoSpec
let branch = repoSpecBranch repoSpec let branch = repoSpecBranch repoSpec
let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
case maybeRepo of case maybeRepo of
Just (Entity repoId repo) -> do Just (Entity repoId _) -> do
msg chan "Repo already there" msg chan "Repo already there"
available <- checkRepoAvailibility challengeId repoId chan available <- checkRepoAvailibility challengeId repoId chan
if available if available
then then
do 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 updateStatus <- updateRepo repoId chan
if updateStatus if updateStatus
then then
@ -377,7 +381,8 @@ getSubmissionRepo challengeId repoSpec chan = do
cloningSpecRepo = repoSpec, cloningSpecRepo = repoSpec,
cloningSpecReferenceRepo = RepoSpec { cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl = (T.pack repoDir), repoSpecUrl = (T.pack repoDir),
repoSpecBranch = (repoBranch repo) repoSpecBranch = (repoBranch repo),
repoSpecGitAnnexRemote = Nothing
} }
} }
cloneRepo' repoCloningSpec chan cloneRepo' repoCloningSpec chan
@ -403,11 +408,11 @@ checkRepoAvailibility challengeId repoId chan = do
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission") challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text, Maybe Text) 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 (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing <*> aopt textField (tagsfs MsgSubmissionTags) Nothing
<*> areq textField (bfs MsgSubmissionUrl) defaultUrl <*> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) defaultBranch <*> areq textField (bfs MsgSubmissionBranch) defBranch
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote) <*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote)
getChallengeMySubmissionsR :: Text -> Handler Html getChallengeMySubmissionsR :: Text -> Handler Html

View File

@ -138,6 +138,7 @@ library
, esqueleto , esqueleto
, extra , extra
, attoparsec , attoparsec
, random-strings
executable gonito executable gonito
if flag(library-only) if flag(library-only)

View File

@ -8,7 +8,7 @@ packages:
git: https://github.com/bitemyapp/esqueleto git: https://github.com/bitemyapp/esqueleto
commit: b81e0d951e510ebffca03c5a58658ad884cc6fbd commit: b81e0d951e510ebffca03c5a58658ad884cc6fbd
extra-dep: true 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 resolver: lts-11.9
image: image:
container: container: