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

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

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

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

gonito.cabal

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

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: