From 598d063b2f009637c0c14bfc8025a597832a1652 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 21 Nov 2016 23:46:59 -0400 Subject: Relicense 5 source files that are not part of the webapp from AGPL to GPL. Building w/o the webapp is not supposed to pull in any AGPLed files. I appear to have written all the code in these files; the only commit by anyone else is 0d555aa363482ed041db2d9c63da271ba7f4ced8 and is a spelling fix that is not copyrightable. --- Assistant/Fsck.hs | 50 +++++++ Assistant/Gpg.hs | 36 +++++ Assistant/Repair.hs | 159 +++++++++++++++++++++++ Assistant/Restart.hs | 117 +++++++++++++++++ Assistant/Upgrade.hs | 361 +++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 723 insertions(+) create mode 100644 Assistant/Fsck.hs create mode 100644 Assistant/Gpg.hs create mode 100644 Assistant/Repair.hs create mode 100644 Assistant/Restart.hs create mode 100644 Assistant/Upgrade.hs (limited to 'Assistant') diff --git a/Assistant/Fsck.hs b/Assistant/Fsck.hs new file mode 100644 index 000000000..9d8848ba9 --- /dev/null +++ b/Assistant/Fsck.hs @@ -0,0 +1,50 @@ +{- git-annex assistant fscking + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Fsck where + +import Assistant.Common +import Types.ScheduledActivity +import qualified Types.Remote as Remote +import Annex.UUID +import Assistant.Alert +import Assistant.Types.UrlRenderer +import Logs.Schedule +import qualified Annex + +import qualified Data.Set as S + +{- Displays a nudge in the webapp if a fsck is not configured for + - the specified remote, or for the local repository. -} +fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant () +fsckNudge urlrenderer mr + | maybe True fsckableRemote mr = + whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $ + unlessM (liftAnnex $ checkFscked mr) $ + notFsckedNudge urlrenderer mr + | otherwise = noop + +fsckableRemote :: Remote -> Bool +fsckableRemote = isJust . Remote.remoteFsck + +{- Checks if the remote, or the local repository, has a fsck scheduled. + - Only looks at fscks configured to run via the local repository, not + - other repositories. -} +checkFscked :: Maybe Remote -> Annex Bool +checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID) + where + wanted = case mr of + Nothing -> isSelfFsck + Just r -> flip isFsckOf (Remote.uuid r) + +isSelfFsck :: ScheduledActivity -> Bool +isSelfFsck (ScheduledSelfFsck _ _) = True +isSelfFsck _ = False + +isFsckOf :: ScheduledActivity -> UUID -> Bool +isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u' +isFsckOf _ _ = False diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs new file mode 100644 index 000000000..34d00a384 --- /dev/null +++ b/Assistant/Gpg.hs @@ -0,0 +1,36 @@ +{- git-annex assistant gpg stuff + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Gpg where + +import Utility.Gpg +import Utility.UserInfo +import Types.Remote (RemoteConfigKey) + +import qualified Data.Map as M +import Control.Applicative +import Prelude + +{- Generates a gpg user id that is not used by any existing secret key -} +newUserId :: GpgCmd -> IO UserId +newUserId cmd = do + oldkeys <- secretKeys cmd + username <- either (const "unknown") id <$> myUserName + let basekeyname = username ++ "'s git-annex encryption key" + return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys) + ( basekeyname + : map (\n -> basekeyname ++ show n) ([2..] :: [Int]) + ) + +data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption + deriving (Eq) + +{- Generates Remote configuration for encryption. -} +configureEncryption :: EnableEncryption -> (RemoteConfigKey, String) +configureEncryption SharedEncryption = ("encryption", "shared") +configureEncryption NoEncryption = ("encryption", "none") +configureEncryption HybridEncryption = ("encryption", "hybrid") diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs new file mode 100644 index 000000000..29bdc44f1 --- /dev/null +++ b/Assistant/Repair.hs @@ -0,0 +1,159 @@ +{- git-annex assistant repository repair + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Repair where + +import Assistant.Common +import Command.Repair (repairAnnexBranch, trackingOrSyncBranch) +import Git.Fsck (FsckResults, foundBroken) +import Git.Repair (runRepairOf) +import qualified Git +import qualified Remote +import qualified Types.Remote as Remote +import Logs.FsckResults +import Annex.UUID +import Utility.Batch +import Annex.Path +import Assistant.Sync +import Assistant.Alert +import Assistant.DaemonStatus +import Assistant.Types.UrlRenderer +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import qualified Data.Text as T +#endif +import qualified Utility.Lsof as Lsof +import Utility.ThreadScheduler + +import Control.Concurrent.Async + +{- When the FsckResults require a repair, tries to do a non-destructive + - repair. If that fails, pops up an alert. -} +repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant Bool +repairWhenNecessary urlrenderer u mrmt fsckresults + | foundBroken fsckresults = do + liftAnnex $ writeFsckResults u fsckresults + repodesc <- liftAnnex $ Remote.prettyUUID u + ok <- alertWhile (repairingAlert repodesc) + (runRepair u mrmt False) +#ifdef WITH_WEBAPP + unless ok $ do + button <- mkAlertButton True (T.pack "Click Here") urlrenderer $ + RepairRepositoryR u + void $ addAlert $ brokenRepositoryAlert [button] +#endif + return ok + | otherwise = return False + +runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool +runRepair u mrmt destructiverepair = do + fsckresults <- liftAnnex $ readFsckResults u + myu <- liftAnnex getUUID + ok <- if u == myu + then localrepair fsckresults + else remoterepair fsckresults + liftAnnex $ clearFsckResults u + debug [ "Repaired", show u, show ok ] + + return ok + where + localrepair fsckresults = do + -- Stop the watcher from running while running repairs. + changeSyncable Nothing False + + -- This intentionally runs the repair inside the Annex + -- monad, which is not strictly necessary, but keeps + -- other threads that might be trying to use the Annex + -- from running until it completes. + ok <- liftAnnex $ repair fsckresults Nothing + + -- Run a background fast fsck if a destructive repair had + -- to be done, to ensure that the git-annex branch + -- reflects the current state of the repo. + when destructiverepair $ + backgroundfsck [ Param "--fast" ] + + -- Start the watcher running again. This also triggers it to + -- do a startup scan, which is especially important if the + -- git repo repair removed files from the index file. Those + -- files will be seen as new, and re-added to the repository. + when (ok || destructiverepair) $ + changeSyncable Nothing True + + return ok + + remoterepair fsckresults = case Remote.repairRepo =<< mrmt of + Nothing -> return False + Just mkrepair -> do + thisrepopath <- liftIO . absPath + =<< liftAnnex (fromRepo Git.repoPath) + a <- liftAnnex $ mkrepair $ + repair fsckresults (Just thisrepopath) + liftIO $ catchBoolIO a + + repair fsckresults referencerepo = do + (ok, modifiedbranches) <- inRepo $ + runRepairOf fsckresults trackingOrSyncBranch destructiverepair referencerepo + when destructiverepair $ + repairAnnexBranch modifiedbranches + return ok + + backgroundfsck params = liftIO $ void $ async $ do + program <- programPath + batchCommand program (Param "fsck" : params) + +{- Detect when a git lock file exists and has no git process currently + - writing to it. This strongly suggests it is a stale lock file. + - + - However, this could be on a network filesystem. Which is not very safe + - anyway (the assistant relies on being able to check when files have + - no writers to know when to commit them). Also, a few lock-file-ish + - things used by git are not kept open, particularly MERGE_HEAD. + - + - So, just in case, when the lock file appears stale, we delay for one + - minute, and check its size. If the size changed, delay for another + - minute, and so on. This will at work to detect when another machine + - is writing out a new index file, since git does so by writing the + - new content to index.lock. + - + - Returns true if locks were cleaned up. + -} +repairStaleGitLocks :: Git.Repo -> Assistant Bool +repairStaleGitLocks r = do + lockfiles <- liftIO $ filter islock <$> findgitfiles r + repairStaleLocks lockfiles + return $ not $ null lockfiles + where + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir + islock f + | "gc.pid" `isInfixOf` f = False + | ".lock" `isSuffixOf` f = True + | takeFileName f == "MERGE_HEAD" = True + | otherwise = False + +repairStaleLocks :: [FilePath] -> Assistant () +repairStaleLocks lockfiles = go =<< getsizes + where + getsize lf = catchMaybeIO $ (\s -> (lf, s)) <$> getFileSize lf + getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles + go [] = return () + go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l)) + ( do + waitforit "to check stale git lock file" + l' <- getsizes + if l' == l + then liftIO $ mapM_ nukeFile (map fst l) + else go l' + , do + waitforit "for git lock file writer" + go =<< getsizes + ) + waitforit why = do + notice ["Waiting for 60 seconds", why] + liftIO $ threadDelaySeconds $ Seconds 60 diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs new file mode 100644 index 000000000..be1b21392 --- /dev/null +++ b/Assistant/Restart.hs @@ -0,0 +1,117 @@ +{- git-annex assistant restarting + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Restart where + +import Assistant.Common +import Assistant.Threads.Watcher +import Assistant.DaemonStatus +import Assistant.NamedThread +import Utility.ThreadScheduler +import Utility.NotificationBroadcaster +import Utility.Url +import Utility.PID +import qualified Git.Construct +import qualified Git.Config +import qualified Annex +import qualified Git +import Annex.Path + +import Control.Concurrent +#ifndef mingw32_HOST_OS +import System.Posix (signalProcess, sigTERM) +#else +import Utility.WinProcess +#endif +import Network.URI + +{- Before the assistant can be restarted, have to remove our + - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also + - a good idea, to avoid fighting when two assistants are running in the + - same repo. + -} +prepRestart :: Assistant () +prepRestart = do + liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread + liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) + +{- To finish a restart, send a global redirect to the new url + - to any web browsers that are displaying the webapp. + - + - Wait for browser to update before terminating this process. -} +postRestart :: URLString -> Assistant () +postRestart url = do + modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } + liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus + void $ liftIO $ forkIO $ do + threadDelaySeconds (Seconds 120) + terminateSelf + +terminateSelf :: IO () +terminateSelf = +#ifndef mingw32_HOST_OS + signalProcess sigTERM =<< getPID +#else + terminatePID =<< getPID +#endif + +runRestart :: Assistant URLString +runRestart = liftIO . newAssistantUrl + =<< liftAnnex (Git.repoLocation <$> Annex.gitRepo) + +{- Starts up the assistant in the repository, and waits for it to create + - a gitAnnexUrlFile. Waits for the assistant to be up and listening for + - connections by testing the url. -} +newAssistantUrl :: FilePath -> IO URLString +newAssistantUrl repo = do + startAssistant repo + geturl + where + geturl = do + r <- Git.Config.read =<< Git.Construct.fromPath repo + waiturl $ gitAnnexUrlFile r + waiturl urlfile = do + v <- tryIO $ readFile urlfile + case v of + Left _ -> delayed $ waiturl urlfile + Right url -> ifM (assistantListening url) + ( return url + , delayed $ waiturl urlfile + ) + delayed a = do + threadDelay 100000 -- 1/10th of a second + a + +{- Checks if the assistant is listening on an url. + - + - Always checks http, because https with self-signed cert is problematic. + - warp-tls listens to http, in order to show an error page, so this works. + -} +assistantListening :: URLString -> IO Bool +assistantListening url = catchBoolIO $ exists url' def + where + url' = case parseURI url of + Nothing -> url + Just uri -> show $ uri + { uriScheme = "http:" + } + +{- Does not wait for assistant to be listening for web connections. + - + - On windows, the assistant does not daemonize, which is why the forkIO is + - done. + -} +startAssistant :: FilePath -> IO () +startAssistant repo = void $ forkIO $ do + program <- programPath + (_, _, _, pid) <- + createProcess $ + (proc program ["assistant"]) { cwd = Just repo } + void $ checkSuccessProcess pid diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs new file mode 100644 index 000000000..afbb61924 --- /dev/null +++ b/Assistant/Upgrade.hs @@ -0,0 +1,361 @@ +{- git-annex assistant upgrading + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Upgrade where + +import Assistant.Common +import Assistant.Restart +import qualified Annex +import Assistant.Alert +import Assistant.DaemonStatus +import Utility.Env +import Types.Distribution +import Types.Transfer +import Logs.Web +import Logs.Presence +import Logs.Location +import Annex.Content +import Annex.UUID +import qualified Backend +import qualified Types.Backend +import qualified Types.Key +import Assistant.TransferQueue +import Assistant.TransferSlots +import Remote (remoteFromUUID) +import Annex.Path +import Config.Files +import Utility.ThreadScheduler +import Utility.Tmp +import Utility.UserInfo +import Utility.Gpg +import Utility.FileMode +import qualified Utility.Lsof as Lsof +import qualified Build.SysConfig +import qualified Utility.Url as Url +import qualified Annex.Url as Url + +import qualified Data.Map as M +import Data.Tuple.Utils + +{- Upgrade without interaction in the webapp. -} +unattendedUpgrade :: Assistant () +unattendedUpgrade = do + prepUpgrade + url <- runRestart + postUpgrade url + +prepUpgrade :: Assistant () +prepUpgrade = do + void $ addAlert upgradingAlert + liftIO $ setEnv upgradedEnv "1" True + prepRestart + +postUpgrade :: URLString -> Assistant () +postUpgrade = postRestart + +autoUpgradeEnabled :: Assistant Bool +autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig + +checkSuccessfulUpgrade :: IO Bool +checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv + +upgradedEnv :: String +upgradedEnv = "GIT_ANNEX_UPGRADED" + +{- Start downloading the distribution key from the web. + - Install a hook that will be run once the download is complete, + - and finishes the upgrade. + - + - Creates the destination directory where the upgrade will be installed + - early, in order to check if another upgrade has happened (or is + - happending). On failure, the directory is removed. + -} +startDistributionDownload :: GitAnnexDistribution -> Assistant () +startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation + where + go Nothing = debug ["Skipping redundant upgrade"] + go (Just dest) = do + liftAnnex $ setUrlPresent webUUID k u + hook <- asIO1 $ distributionDownloadComplete d dest cleanup + modifyDaemonStatus_ $ \s -> s + { transferHook = M.insert k hook (transferHook s) } + maybe noop (queueTransfer "upgrade" Next (Just f) t) + =<< liftAnnex (remoteFromUUID webUUID) + startTransfer t + k = distributionKey d + u = distributionUrl d + f = takeFileName u ++ " (for upgrade)" + t = Transfer + { transferDirection = Download + , transferUUID = webUUID + , transferKey = k + } + cleanup = liftAnnex $ do + lockContentForRemoval k removeAnnex + setUrlMissing webUUID k u + logStatus k InfoMissing + +{- Called once the download is done. + - Passed an action that can be used to clean up the downloaded file. + - + - Verifies the content of the downloaded key. + -} +distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant () +distributionDownloadComplete d dest cleanup t + | transferDirection t == Download = do + debug ["finished downloading git-annex distribution"] + maybe (failedupgrade "bad download") go + =<< liftAnnex (withObjectLoc k fsckit (getM fsckit)) + | otherwise = cleanup + where + k = distributionKey d + fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of + Nothing -> return $ Just f + Just b -> case Types.Backend.verifyKeyContent b of + Nothing -> return $ Just f + Just verifier -> ifM (verifier k f) + ( return $ Just f + , return Nothing + ) + go f = do + ua <- asIO $ upgradeToDistribution dest cleanup f + fa <- asIO1 failedupgrade + liftIO $ ua `catchNonAsync` (fa . show) + failedupgrade msg = do + void $ addAlert $ upgradeFailedAlert msg + cleanup + liftIO $ void $ tryIO $ removeDirectoryRecursive dest + +{- The upgrade method varies by OS. + - + - In general, find where the distribution was installed before, + - and unpack the new distribution next to it (in a versioned directory). + - Then update the programFile to point to the new version. + -} +upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant () +upgradeToDistribution newdir cleanup distributionfile = do + liftIO $ createDirectoryIfMissing True newdir + (program, deleteold) <- unpack + changeprogram program + cleanup + prepUpgrade + url <- runRestart + {- At this point, the new assistant is fully running, so + - it's safe to delete the old version. -} + liftIO $ void $ tryIO deleteold + postUpgrade url + where + changeprogram program = liftIO $ do + unlessM (boolSystem program [Param "version"]) $ + giveup "New git-annex program failed to run! Not using." + pf <- programFile + liftIO $ writeFile pf program + +#ifdef darwin_HOST_OS + {- OS X uses a dmg, so mount it, and copy the contents into place. -} + unpack = liftIO $ do + olddir <- oldVersionLocation + withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do + void $ boolSystem "hdiutil" + [ Param "attach", File distributionfile + , Param "-mountpoint", File tmpdir + ] + void $ boolSystem "cp" + [ Param "-R" + , File $ tmpdir installBase "Contents" + , File $ newdir + ] + void $ boolSystem "hdiutil" + [ Param "eject" + , File tmpdir + ] + sanitycheck newdir + let deleteold = do + deleteFromManifest $ olddir "Contents" "MacOS" + makeorigsymlink olddir + return (newdir "Contents" "MacOS" "git-annex", deleteold) +#else + {- Linux uses a tarball (so could other POSIX systems), so + - untar it (into a temp directory) and move the directory + - into place. -} + unpack = liftIO $ do + olddir <- oldVersionLocation + withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do + let tarball = tmpdir "tar" + -- Cannot rely on filename extension, and this also + -- avoids problems if tar doesn't support transparent + -- decompression. + void $ boolSystem "sh" + [ Param "-c" + , Param $ "zcat < " ++ shellEscape distributionfile ++ + " > " ++ shellEscape tarball + ] + tarok <- boolSystem "tar" + [ Param "xf" + , Param tarball + , Param "--directory", File tmpdir + ] + unless tarok $ + error $ "failed to untar " ++ distributionfile + sanitycheck $ tmpdir installBase + installby rename newdir (tmpdir installBase) + let deleteold = do + deleteFromManifest olddir + makeorigsymlink olddir + return (newdir "git-annex", deleteold) + installby a dstdir srcdir = + mapM_ (\x -> a x (dstdir takeFileName x)) + =<< dirContents srcdir +#endif + sanitycheck dir = + unlessM (doesDirectoryExist dir) $ + error $ "did not find " ++ dir ++ " in " ++ distributionfile + makeorigsymlink olddir = do + let origdir = parentDir olddir installBase + nukeFile origdir + createSymbolicLink newdir origdir + +{- Finds where the old version was installed. -} +oldVersionLocation :: IO FilePath +oldVersionLocation = do + pdir <- parentDir <$> readProgramFile +#ifdef darwin_HOST_OS + let dirs = splitDirectories pdir + {- It will probably be deep inside a git-annex.app directory. -} + let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of + Nothing -> pdir + Just i -> joinPath (take (i + 1) dirs) +#else + let olddir = pdir +#endif + when (null olddir) $ + error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" + return olddir + +{- Finds a place to install the new version. + - Generally, put it in the parent directory of where the old version was + - installed, and use a version number in the directory name. + - If unable to write to there, instead put it in the home directory. + - + - The directory is created. If it already exists, returns Nothing. + -} +newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath) +newVersionLocation d olddir = + trymkdir newloc $ do + home <- myHomeDir + trymkdir (home s) $ + return Nothing + where + s = installBase ++ "." ++ distributionVersion d + topdir = parentDir olddir + newloc = topdir s + trymkdir dir fallback = + (createDirectory dir >> return (Just dir)) + `catchIO` const fallback + +installBase :: String +installBase = "git-annex." ++ +#ifdef linux_HOST_OS + "linux" +#else +#ifdef darwin_HOST_OS + "app" +#else + "dir" +#endif +#endif + +deleteFromManifest :: FilePath -> IO () +deleteFromManifest dir = do + fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) + mapM_ nukeFile fs + nukeFile manifest + removeEmptyRecursive dir + where + manifest = dir "git-annex.MANIFEST" + +removeEmptyRecursive :: FilePath -> IO () +removeEmptyRecursive dir = do + mapM_ removeEmptyRecursive =<< dirContents dir + void $ tryIO $ removeDirectory dir + +{- This is a file that the UpgradeWatcher can watch for modifications to + - detect when git-annex has been upgraded. + -} +upgradeFlagFile :: IO FilePath +upgradeFlagFile = programPath + +{- Sanity check to see if an upgrade is complete and the program is ready + - to be run. -} +upgradeSanityCheck :: IO Bool +upgradeSanityCheck = ifM usingDistribution + ( doesFileExist =<< programFile + , do + -- Ensure that the program is present, and has no writers, + -- and can be run. This should handle distribution + -- upgrades, manual upgrades, etc. + program <- programPath + untilM (doesFileExist program <&&> nowriter program) $ + threadDelaySeconds (Seconds 60) + boolSystem program [Param "version"] + ) + where + nowriter f = null + . filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly]) + . map snd3 + <$> Lsof.query [f] + +usingDistribution :: IO Bool +usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" + +downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) +downloadDistributionInfo = do + uo <- liftAnnex Url.getUrlOptions + gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig + liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do + let infof = tmpdir "info" + let sigf = infof ++ ".sig" + ifM (Url.downloadQuiet distributionInfoUrl infof uo + <&&> Url.downloadQuiet distributionInfoSigUrl sigf uo + <&&> verifyDistributionSig gpgcmd sigf) + ( readish <$> readFileStrict infof + , return Nothing + ) + +distributionInfoUrl :: String +distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info" + +distributionInfoSigUrl :: String +distributionInfoSigUrl = distributionInfoUrl ++ ".sig" + +{- Verifies that a file from the git-annex distribution has a valid + - signature. Pass the detached .sig file; the file to be verified should + - be located next to it. + - + - The gpg keyring used to verify the signature is located in + - trustedkeys.gpg, next to the git-annex program. + -} +verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool +verifyDistributionSig gpgcmd sig = do + p <- readProgramFile + if isAbsolute p + then withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do + let trustedkeys = takeDirectory p "trustedkeys.gpg" + boolGpgCmd gpgcmd + [ Param "--no-default-keyring" + , Param "--no-auto-check-trustdb" + , Param "--no-options" + , Param "--homedir" + , File gpgtmp + , Param "--keyring" + , File trustedkeys + , Param "--verify" + , File sig + ] + else return False -- cgit v1.2.3