diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -329,7 +329,7 @@ getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig getRemoteGitConfig r = do g <- gitRepo - return $ extractRemoteGitConfig g (Git.repoDescribe r) + liftIO $ atomically $ extractRemoteGitConfig g (Git.repoDescribe r) {- Converts an Annex action into an IO action, that runs with a copy - of the current Annex state. diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -69,6 +69,7 @@ hashDirMixed, hashDirLower, preSanitizeKeyName, + reSanitizeKeyName, prop_isomorphic_fileKey ) where @@ -413,7 +414,7 @@ gitAnnexAssistantDefaultDir = "annex" {- Sanitizes a String that will be used as part of a Key's keyName, - - dealing with characters that cause problems on substandard filesystems. + - dealing with characters that cause problems. - - This is used when a new Key is initially being generated, eg by getKey. - Unlike keyFile and fileKey, it does not need to be a reversable @@ -426,17 +427,27 @@ - same key. -} preSanitizeKeyName :: String -> String -preSanitizeKeyName = concatMap escape +preSanitizeKeyName = preSanitizeKeyName' False + +preSanitizeKeyName' :: Bool -> String -> String +preSanitizeKeyName' resanitize = concatMap escape where escape c | isAsciiUpper c || isAsciiLower c || isDigit c = [c] - | c `elem` ".-_ " = [c] -- common, assumed safe + | c `elem` ".-_" = [c] -- common, assumed safe | c `elem` "/%:" = [c] -- handled by keyFile -- , is safe and uncommon, so will be used to escape -- other characters. By itself, it is escaped to -- doubled form. - | c == ',' = ",," + | c == ',' = if not resanitize + then ",," + else "," | otherwise = ',' : show (ord c) + +{- Converts a keyName that has been santizied with an old version of + - preSanitizeKeyName to be sanitized with the new version. -} +reSanitizeKeyName :: String -> String +reSanitizeKeyName = preSanitizeKeyName' True {- Converts a key into a filename fragment without any directory. - diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -10,6 +10,7 @@ import Annex.Common import Remote (remoteTypes, remoteMap) import Types.Remote (RemoteConfig, RemoteConfigKey, SetupStage(..), typename, setup) +import Types.GitConfig import Logs.Remote import Logs.Trust import qualified Git.Config @@ -79,7 +80,8 @@ case (M.lookup nameKey c, findType c) of (Just name, Right t) -> whenM (canenable u) $ do showSideAction $ "Auto enabling special remote " ++ name - res <- tryNonAsync $ setup t Enable (Just u) Nothing c def + dummycfg <- liftIO dummyRemoteGitConfig + res <- tryNonAsync $ setup t Enable (Just u) Nothing c dummycfg case res of Left e -> warning (show e) Right _ -> return () diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -62,19 +62,18 @@ where go = do ps <- sshOptions cs (host, port) gc [] - return ("ssh", Param host:ps++[Param remotecmd]) + return ("ssh", Param (fromSshHost host):ps++[Param remotecmd]) {- Generates parameters to ssh to a given host (or user@host) on a given - port. This includes connection caching parameters, and any - ssh-options. Note that the host to ssh to and the command to run - are not included in the returned options. -} -sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] +sshOptions :: ConsumeStdin -> (SshHost, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port) where go (Nothing, params) = return $ mkparams cs params go (Just socketfile, params) = do - prepSocket socketfile gc - (Param host : mkparams NoConsumeStdin params) + prepSocket socketfile gc host (mkparams NoConsumeStdin params) return $ mkparams cs params mkparams cs' ps = concat @@ -98,7 +97,7 @@ {- Returns a filename to use for a ssh connection caching socket, and - parameters to enable ssh connection caching. -} -sshCachingInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) +sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshCachingInfo (host, port) = go =<< sshCacheDir where go Nothing = return (Nothing, []) @@ -169,8 +168,8 @@ - Locks the socket lock file to prevent other git-annex processes from - stopping the ssh multiplexer on this socket. -} -prepSocket :: FilePath -> RemoteGitConfig -> [CommandParam] -> Annex () -prepSocket socketfile gc sshparams = do +prepSocket :: FilePath -> RemoteGitConfig -> SshHost -> [CommandParam] -> Annex () +prepSocket socketfile gc sshhost sshparams = do -- There could be stale ssh connections hanging around -- from a previous git-annex run that was interrupted. -- This must run only once, before we have made any ssh connection, @@ -205,7 +204,8 @@ -- get the connection started now. makeconnection socketlock = whenM (isNothing <$> fromLockCache socketlock) $ do - let startps = sshparams ++ startSshConnection gc + let startps = Param (fromSshHost sshhost) : + sshparams ++ startSshConnection gc -- When we can start the connection in batch mode, -- ssh won't prompt to the console. (_, connected) <- liftIO $ processTranscript "ssh" @@ -298,9 +298,10 @@ - of the path to a socket file. At the same time, it needs to be unique - for each host. -} -hostport2socket :: String -> Maybe Integer -> FilePath -hostport2socket host Nothing = hostport2socket' host -hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port +hostport2socket :: SshHost -> Maybe Integer -> FilePath +hostport2socket host Nothing = hostport2socket' $ fromSshHost host +hostport2socket host (Just port) = hostport2socket' $ + fromSshHost host ++ "!" ++ show port hostport2socket' :: String -> FilePath hostport2socket' s | length s > lengthofmd5s = show $ md5 $ encodeBS s @@ -385,18 +386,18 @@ ( unchanged , do let port = Git.Url.port remote - (msockfile, cacheparams) <- sshCachingInfo (host, port) + let sshhost = either error id (mkSshHost host) + (msockfile, cacheparams) <- sshCachingInfo (sshhost, port) case msockfile of Nothing -> use [] Just sockfile -> do - prepSocket sockfile gc $ - Param host : concat - [ cacheparams - , map Param (remoteAnnexSshOptions gc) - , portParams port - , consumeStdinParams NoConsumeStdin - , [Param "-T"] - ] + prepSocket sockfile gc sshhost $ concat + [ cacheparams + , map Param (remoteAnnexSshOptions gc) + , portParams port + , consumeStdinParams NoConsumeStdin + , [Param "-T"] + ] use cacheparams ) where diff --git a/Annex/VectorClock.hs b/Annex/VectorClock.hs new file mode 100644 --- /dev/null +++ b/Annex/VectorClock.hs @@ -0,0 +1,46 @@ +{- git-annex vector clocks + - + - We don't have a way yet to keep true distributed vector clocks. + - The next best thing is a timestamp. + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.VectorClock where + +import Data.Time.Clock.POSIX +import Control.Applicative +import Prelude + +import Utility.Env +import Logs.TimeStamp +import Utility.QuickCheck + +-- | Some very old logs did not have any time stamp at all; +-- Unknown is used for those. +data VectorClock = Unknown | VectorClock POSIXTime + deriving (Eq, Ord) + +-- Unknown is oldest. +prop_VectorClock_sane :: Bool +prop_VectorClock_sane = Unknown < VectorClock 1 + +instance Arbitrary VectorClock where + arbitrary = VectorClock <$> arbitrary + +currentVectorClock :: IO VectorClock +currentVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK" + where + go Nothing = VectorClock <$> getPOSIXTime + go (Just s) = case parsePOSIXTime s of + Just t -> return (VectorClock t) + Nothing -> VectorClock <$> getPOSIXTime + +formatVectorClock :: VectorClock -> String +formatVectorClock Unknown = "0" +formatVectorClock (VectorClock t) = show t + +parseVectorClock :: String -> Maybe VectorClock +parseVectorClock t = VectorClock <$> parsePOSIXTime t diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -19,6 +19,7 @@ import Logs.TimeStamp import qualified Remote import qualified Types.Remote as Remote +import Config.DynamicConfig import Control.Concurrent.STM import System.Posix.Types @@ -47,12 +48,12 @@ - and other associated information. -} calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus) calcSyncRemotes = do - rs <- filter (remoteAnnexSync . Remote.gitconfig) . - concat . Remote.byCost <$> Remote.remoteList + rs <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) + =<< (concat . Remote.byCost <$> Remote.remoteList) alive <- trustExclude DeadTrusted (map Remote.uuid rs) let good r = Remote.uuid r `elem` alive let syncable = filter good rs - let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $ + syncdata <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $ filter (\r -> Remote.uuid r /= NoUUID) $ filter (not . Remote.isXMPPRemote) syncable diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -24,6 +24,7 @@ import Creds import Assistant.Gpg import Utility.Gpg (KeyId) +import Types.GitConfig import qualified Data.Map as M @@ -102,7 +103,8 @@ - pool is drained, and as of now there's no way to tell the user - to perform IO actions to refill the pool. -} let weakc = M.insert "highRandomQuality" "false" $ M.union config c - (c', u) <- R.setup remotetype ss mu mcreds weakc def + dummycfg <- liftIO dummyRemoteGitConfig + (c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg configSet u c' when setdesc $ whenM (isNothing . M.lookup u <$> uuidMap) $ diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -42,9 +42,9 @@ [ sshOpt "StrictHostKeyChecking" "no" , sshOpt "NumberOfPasswordPrompts" "0" , "-n" - , genSshHost (sshHostName sshdata) (sshUserName sshdata) - , "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) ] + (genSshHost (sshHostName sshdata) (sshUserName sshdata)) + ("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)) Nothing r <- liftAnnex $ addRemote $ makeSshRemote sshdata liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -14,6 +14,7 @@ import Utility.FileMode import Utility.SshConfig import Git.Remote +import Utility.SshHost import Data.Text (Text) import qualified Data.Text as T @@ -64,8 +65,9 @@ sshOpt k v = concat ["-o", k, "=", v] {- user@host or host -} -genSshHost :: Text -> Maybe Text -> String -genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host +genSshHost :: Text -> Maybe Text -> SshHost +genSshHost host user = either error id $ mkSshHost $ + maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host {- Generates a ssh or rsync url from a SshData. -} genSshUrl :: SshData -> String @@ -119,8 +121,9 @@ | otherwise = makeLegalName $ host ++ "_" ++ dir {- The output of ssh, including both stdout and stderr. -} -sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool) -sshTranscript opts input = processTranscript "ssh" opts input +sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool) +sshTranscript opts sshhost cmd input = processTranscript "ssh" + (opts ++ [fromSshHost sshhost, cmd]) input {- Ensure that the ssh public key doesn't include any ssh options, like - command=foo, or other weirdness. diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -27,6 +27,7 @@ import Annex.Ssh import qualified Config import Git.Config +import Config.DynamicConfig import Assistant.NamedThread import Assistant.Threads.Watcher (watchThread, WatcherControl(..)) import Assistant.TransferSlots @@ -77,8 +78,8 @@ go = do (failed, diverged) <- sync =<< liftAnnex (join Command.Sync.getCurrBranch) - addScanRemotes diverged $ - filter (not . remoteAnnexIgnore . Remote.gitconfig) + addScanRemotes diverged =<< + filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) nonxmppremotes return failed signal r = liftIO . mapM_ (flip tryPutMVar ()) diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -44,6 +44,7 @@ import Assistant.Ssh import Config import Config.GitConfig +import Config.DynamicConfig import qualified Data.Text as T import qualified Data.Map as M @@ -76,7 +77,7 @@ description <- fmap T.pack . M.lookup uuid <$> uuidMap syncable <- case mremote of - Just r -> return $ remoteAnnexSync $ Remote.gitconfig r + Just r -> liftIO $ getDynamicConfig $ remoteAnnexSync $ Remote.gitconfig r Nothing -> getGitConfigVal annexAutoCommit return $ RepoConfig diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -39,6 +39,7 @@ import Utility.FileMode import Utility.ThreadScheduler import Utility.Env +import Utility.SshHost import qualified Data.Text as T import qualified Data.Map as M @@ -299,12 +300,11 @@ if knownhost then "yes" else "no" , "-n" -- don't read from stdin , "-p", show (inputPort sshinput) - , genSshHost - (fromJust $ inputHostname sshinput) - (inputUsername sshinput) - , remotecommand ] - parsetranscript . fst <$> sshAuthTranscript sshinput sshopts Nothing + let sshhost = genSshHost + (fromJust $ inputHostname sshinput) + (inputUsername sshinput) + parsetranscript . fst <$> sshAuthTranscript sshinput sshopts sshhost remotecommand Nothing parsetranscript s = let cs = map snd $ filter (reported . fst) [ ("git-annex-shell", GitAnnexShellCapable) @@ -339,9 +339,9 @@ {- Runs a ssh command to set up the repository; if it fails shows - the user the transcript, and if it succeeds, runs an action. -} -sshSetup :: SshInput -> [String] -> Maybe String -> Handler Html -> Handler Html -sshSetup sshinput opts input a = do - (transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts input +sshSetup :: SshInput -> [String] -> SshHost -> String -> Maybe String -> Handler Html -> Handler Html +sshSetup sshinput opts sshhost cmd input a = do + (transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts sshhost cmd input if ok then do liftAssistant $ expireCachedCred $ getLogin sshinput @@ -367,8 +367,8 @@ - cached password. ssh is coaxed to use git-annex as SSH_ASKPASS - to get the password. -} -sshAuthTranscript :: SshInput -> [String] -> (Maybe String) -> Assistant (String, Bool) -sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of +sshAuthTranscript :: SshInput -> [String] -> SshHost -> String -> (Maybe String) -> Assistant (String, Bool) +sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinput of ExistingSshKey -> liftIO $ go [passwordprompts 0] Nothing CachedPassword -> setupAskPass Password -> do @@ -379,7 +379,7 @@ geti f = maybe "" T.unpack (f sshinput) go extraopts environ = processTranscript' - (askPass environ (proc "ssh" (extraopts ++ opts))) + (askPass environ (proc "ssh" (extraopts ++ opts ++ [fromSshHost sshhost, cmd]))) -- Always provide stdin, even when empty. (Just (fromMaybe "" input)) @@ -521,10 +521,11 @@ ] a sshdata | otherwise = sshSetup (mkSshInput origsshdata) - [ "-p", show (sshPort origsshdata) - , genSshHost (sshHostName origsshdata) (sshUserName origsshdata) - , remoteCommand - ] Nothing (a sshdata) + [ "-p", show (sshPort origsshdata) + ] + (genSshHost (sshHostName origsshdata) (sshUserName origsshdata)) + remoteCommand + Nothing (a sshdata) where remotedir = T.unpack $ sshDirectory sshdata remoteCommand = shellWrap $ intercalate "&&" $ catMaybes @@ -625,7 +626,7 @@ getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $ withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ - sshSetup (mkSshInput sshdata) [sshhost, gitinit] Nothing $ + sshSetup (mkSshInput sshdata) [] sshhost gitinit Nothing $ makeGCryptRepo NewRepo keyid sshdata where sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) @@ -661,11 +662,9 @@ , sshCapabilities = [RsyncCapable] } let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) - let torsyncnet cmd = filter (not . null) - [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no" - , sshhost - , cmd - ] + let torsyncnet + | knownhost = [] + | otherwise = [sshOpt "StrictHostKeyChecking" "no"] {- I'd prefer to separate commands with && , but - rsync.net's shell does not support that. -} let remotecommand = intercalate ";" @@ -674,7 +673,8 @@ , "dd of=.ssh/authorized_keys oflag=append conv=notrunc" , "mkdir -p " ++ T.unpack (sshDirectory sshdata) ] - sshSetup sshinput (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata) + sshSetup sshinput torsyncnet sshhost remotecommand + (Just $ sshPubKey keypair) (a sshdata) isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -19,12 +19,13 @@ import Types.StandardGroups import Logs.Remote import Git.Types (RemoteName) +import Assistant.Gpg +import Types.GitConfig import qualified Data.Map as M #endif import qualified Data.Text as T import Network.URI -import Assistant.Gpg webDAVConfigurator :: Widget -> Handler Html webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) @@ -94,8 +95,9 @@ let c = fromJust $ M.lookup uuid m let name = fromJust $ M.lookup "name" c let url = fromJust $ M.lookup "url" c - mcreds <- liftAnnex $ - getRemoteCredPairFor "webdav" c def (WebDAV.davCreds uuid) + mcreds <- liftAnnex $ do + dummycfg <- liftIO dummyRemoteGitConfig + getRemoteCredPairFor "webdav" c dummycfg (WebDAV.davCreds uuid) case mcreds of Just creds -> webDAVConfigurator $ liftH $ makeWebDavRemote enableSpecialRemote name creds M.empty diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -22,8 +22,8 @@ { backendVariety = WORMKey , getKey = keyValue , verifyKeyContent = Nothing - , canUpgradeKey = Nothing - , fastMigrate = Nothing + , canUpgradeKey = Just needsUpgrade + , fastMigrate = Just removeSpaces , isStableKey = const True } @@ -42,3 +42,17 @@ , keySize = Just sz , keyMtime = Just $ modificationTime stat } + +{- Old WORM keys could contain spaces, and can be upgraded to remove them. -} +needsUpgrade :: Key -> Bool +needsUpgrade key = ' ' `elem` keyName key + +removeSpaces :: Key -> Backend -> AssociatedFile -> Maybe Key +removeSpaces oldkey newbackend _ + | migratable = Just $ oldkey + { keyName = reSanitizeKeyName (keyName oldkey) } + | otherwise = Nothing + where + migratable = oldvariety == newvariety + oldvariety = keyVariety oldkey + newvariety = backendVariety newbackend diff --git a/Build/BuildVersion.hs b/Build/BuildVersion.hs deleted file mode 100644 --- a/Build/BuildVersion.hs +++ /dev/null @@ -1,6 +0,0 @@ -{- Outputs the version of git-annex that was built, for use by - - autobuilders. Note that this includes the git rev. -} - -import Build.Version - -main = putStr =<< getVersion diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs deleted file mode 100644 --- a/Build/DistributionUpdate.hs +++ /dev/null @@ -1,207 +0,0 @@ -{- Downloads git-annex autobuilds and installs them into the git-annex - - repository in ~/lib/downloads that is used to distribute git-annex - - releases. - - - - Generates info files, containing the version (of the corresponding file - - from the autobuild). - - - - Also gpg signs the files. - -} - -import Annex.Common -import Types.Distribution -import Build.Version (getChangelogVersion, Version) -import Utility.UserInfo -import Utility.Url -import Utility.Tmp -import Utility.FileSystemEncoding -import qualified Git.Construct -import qualified Annex -import Annex.Content -import Annex.WorkTree -import Git.Command - -import Data.Time.Clock -import Data.Char -import System.Posix.Directory - --- git-annex distribution signing key (for Joey Hess) -signingKey :: String -signingKey = "89C809CB" - --- URL to an autobuilt git-annex file, and the place to install --- it in the repository. -autobuilds :: [(URLString, FilePath)] -autobuilds = - (map linuxarch ["i386", "amd64", "armel", "i386-ancient"]) ++ - (map androidversion ["4.0", "4.3", "5.0"]) ++ - [ (autobuild "x86_64-apple-yosemite/git-annex.dmg", "git-annex/OSX/current/10.10_Yosemite/git-annex.dmg") - , (autobuild "windows/git-annex-installer.exe", "git-annex/windows/current/git-annex-installer.exe") - ] - where - linuxarch a = - ( autobuild (a ++ "/git-annex-standalone-" ++ a ++ ".tar.gz") - , "git-annex/linux/current/git-annex-standalone-" ++ a ++ ".tar.gz" - ) - androidversion v = - ( autobuild ("android/" ++ v ++ "/git-annex.apk") - , "git-annex/android/current/" ++ v ++ "/git-annex.apk" - ) - autobuild f = "https://downloads.kitenet.net/git-annex/autobuild/" ++ f - -main :: IO () -main = do - useFileSystemEncoding - version <- liftIO getChangelogVersion - repodir <- getRepoDir - changeWorkingDirectory repodir - updated <- catMaybes <$> mapM (getbuild repodir) autobuilds - state <- Annex.new =<< Git.Construct.fromPath "." - Annex.eval state (makeinfos updated version) - --- Download a build from the autobuilder, virus check it, and return its --- version. --- It's very important that the version matches the build, otherwise --- auto-upgrades can loop reatedly. So, check build-version before --- and after downloading the file. -getbuild :: FilePath -> (URLString, FilePath) -> IO (Maybe (FilePath, Version)) -getbuild repodir (url, f) = do - bv1 <- getbv - let dest = repodir f - let tmp = dest ++ ".tmp" - nukeFile tmp - createDirectoryIfMissing True (parentDir dest) - let oops s = do - nukeFile tmp - putStrLn $ "*** " ++ s - return Nothing - ifM (download url tmp def) - ( ifM (liftIO $ virusFree tmp) - ( do - bv2 <- getbv - case bv2 of - Nothing -> oops $ "no build-version file for " ++ url - (Just v) - | bv2 == bv1 -> do - nukeFile dest - renameFile tmp dest - -- remove git rev part of version - let v' = takeWhile (/= '-') v - return $ Just (f, v') - | otherwise -> oops $ "build version changed while downloading " ++ url ++ " " ++ show (bv1, bv2) - , oops $ "VIRUS detected in " ++ url - ) - , oops $ "failed to download " ++ url - ) - where - bvurl = takeDirectory url ++ "/build-version" - getbv = do - bv <- catchDefaultIO "" $ readProcess "curl" ["--silent", bvurl] - return $ if null bv || any (not . versionchar) bv then Nothing else Just bv - versionchar c = isAlphaNum c || c == '.' || c == '-' - -makeinfos :: [(FilePath, Version)] -> Version -> Annex () -makeinfos updated version = do - mapM_ (\f -> inRepo $ runBool [Param "annex", Param "add", File f]) (map fst updated) - void $ inRepo $ runBool - [ Param "commit" - , Param "-a" - , Param ("-S" ++ signingKey) - , Param "-m" - , Param $ "publishing git-annex " ++ version - ] - now <- liftIO getCurrentTime - liftIO $ putStrLn $ "building info files" - forM_ updated $ \(f, bv) -> do - v <- lookupFile f - case v of - Nothing -> noop - Just k -> whenM (inAnnex k) $ do - liftIO $ putStrLn f - let infofile = f ++ ".info" - let d = GitAnnexDistribution - { distributionUrl = mkUrl f - , distributionKey = k - , distributionVersion = bv - , distributionReleasedate = now - , distributionUrgentUpgrade = Nothing - } - liftIO $ writeFile infofile $ formatInfoFile d - void $ inRepo $ runBool [Param "add", File infofile] - signFile infofile - signFile f - void $ inRepo $ runBool - [ Param "commit" - , Param ("-S" ++ signingKey) - , Param "-m" - , Param $ "updated info files for git-annex " ++ version - ] - void $ inRepo $ runBool - [ Param "annex" - , Param "move" - , Param "--to" - , Param "website" - ] - void $ inRepo $ runBool - [ Param "annex" - , Param "sync" - ] - - -- Check for out of date info files. - infos <- liftIO $ filter (".info" `isSuffixOf`) - <$> dirContentsRecursive "git-annex" - ds <- liftIO $ forM infos (readish <$$> readFile) - let dis = zip infos ds - let ood = filter outofdate dis - unless (null ood) $ - error $ "Some info files are out of date: " ++ show (map fst ood) - where - outofdate (_, md) = case md of - Nothing -> True - Just d -> distributionVersion d /= version - -getRepoDir :: IO FilePath -getRepoDir = do - home <- liftIO myHomeDir - return $ home "lib" "downloads" - -mkUrl :: FilePath -> String -mkUrl f = "https://downloads.kitenet.net/" ++ f - -signFile :: FilePath -> Annex () -signFile f = do - void $ liftIO $ boolSystem "gpg" - [ Param "-a" - , Param $ "--default-key=" ++ signingKey - , Param "--detach-sign" - , File f - ] - liftIO $ rename (f ++ ".asc") (f ++ ".sig") - void $ inRepo $ runBool [Param "add", File (f ++ ".sig")] - --- clamscan should handle unpacking archives, but did not in my --- testing, so do it manually. -virusFree :: FilePath -> IO Bool -virusFree f - | ".tar.gz" `isSuffixOf` f = unpack $ \tmpdir -> - boolSystem "tar" [ Param "xf", File f, Param "-C", File tmpdir ] - | ".dmg" `isSuffixOf` f = unpack $ \tmpdir -> do - -- 7z can extract partitions from a dmg, and then - -- run on partitions can extract their files - unhfs tmpdir f - parts <- filter (".hfs" `isSuffixOf`) <$> getDirectoryContents tmpdir - forM_ parts $ unhfs tmpdir - return True - | otherwise = clamscan f - where - clamscan f' = boolSystem "clamscan" - [ Param "--no-summary" - , Param "-r" - , Param f' - ] - unpack unpacker = withTmpDir "clamscan" $ \tmpdir -> do - unlessM (unpacker tmpdir) $ - error $ "Failed to unpack " ++ f ++ " for virus scan" - clamscan tmpdir - unhfs dest f' = unlessM (boolSystem "7z" [ Param "x", Param ("-o" ++ dest), File f' ]) $ - error $ "Failed extracting hfs " ++ f' diff --git a/Build/EvilLinker.hs b/Build/EvilLinker.hs deleted file mode 100644 --- a/Build/EvilLinker.hs +++ /dev/null @@ -1,160 +0,0 @@ -{- Allows linking haskell programs too big for all the files to fit in a - - command line. - - - - See https://ghc.haskell.org/trac/ghc/ticket/8596 - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Main where - -import Text.Parsec -import Text.Parsec.String -import Control.Applicative ((<$>)) -import Control.Monad -import Data.Maybe -import Data.List - -import Utility.Monad -import Utility.Process hiding (env) -import qualified Utility.Process -import Utility.Env -import Utility.Directory -import Utility.Split - -data CmdParams = CmdParams - { cmd :: String - , opts :: String - , env :: Maybe [(String, String)] - } deriving (Show) - -{- Find where ghc calls gcc to link the executable. -} -parseGhcLink :: Parser CmdParams -parseGhcLink = do - void $ many prelinkline - void linkheaderline - void $ char '"' - gcccmd <- many1 (noneOf "\"") - void $ string "\" " - gccparams <- restOfLine - return $ CmdParams gcccmd (manglepaths gccparams) Nothing - where - linkheaderline = do - void $ string "*** Linker" - restOfLine - prelinkline = do - void $ notFollowedBy linkheaderline - restOfLine - manglepaths = replace "\\" "/" - -{- Find where gcc calls collect2. -} -parseGccLink :: Parser CmdParams -parseGccLink = do - cenv <- collectenv - void $ try $ char ' ' - path <- manyTill anyChar (try $ string collectcmd) - void $ char ' ' - collect2params <- restOfLine - return $ CmdParams (path ++ collectcmd) (escapeDosPaths collect2params) cenv - where - collectcmd = "collect2.exe" - collectgccenv = "COLLECT_GCC" - collectltoenv = "COLLECT_LTO_WRAPPER" - pathenv = "COMPILER_PATH" - libpathenv = "LIBRARY_PATH" - optenv = "COLLECT_GCC_OPTIONS" - collectenv = do - void $ many1 $ do - notFollowedBy $ string collectgccenv - restOfLine - void $ string collectgccenv - void $ char '=' - g <- restOfLine - void $ string collectltoenv - void $ char '=' - lt <- restOfLine - void $ many1 $ do - notFollowedBy $ string pathenv - restOfLine - void $ string pathenv - void $ char '=' - p <- restOfLine - void $ string libpathenv - void $ char '=' - lp <- restOfLine - void $ string optenv - void $ char '=' - o <- restOfLine - return $ Just [(collectgccenv, g), (collectltoenv, lt), (pathenv, p), (libpathenv, lp), (optenv, o)] - -{- Find where collect2 calls ld. -} -parseCollect2 :: Parser CmdParams -parseCollect2 = do - void $ manyTill restOfLine (try versionline) - path <- manyTill anyChar (try $ string ldcmd) - void $ char ' ' - params <- restOfLine - return $ CmdParams (path ++ ldcmd) (escapeDosPaths params) Nothing - where - ldcmd = "ld.exe" - versionline = do - void $ string "collect2 version" - restOfLine - -{- Input contains something like - - c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L... - - and the *right* spaces must be escaped with \ - - - - Argh. - -} -escapeDosPaths :: String -> String -escapeDosPaths = replace "Program Files" "Program\\ Files" - . replace "program files" "program\\ files" - . replace "Haskell Platform" "Haskell\\ Platform" - . replace "haskell platform" "haskell\\ platform" - . replace "Application Data" "Application\\ Data" - . replace "Documents and Settings" "Documents\\ and\\ Settings" - . replace "Files (x86)" "Files\\ (x86)" - . replace "files (x86)" "files\\ (x86)" - -restOfLine :: Parser String -restOfLine = newline `after` many (noneOf "\n") - -getOutput :: String -> [String] -> Maybe [(String, String)] -> IO (String, Bool) -getOutput c ps environ = do - putStrLn $ unwords [c, show ps] - systemenviron <- getEnvironment - let environ' = fromMaybe [] environ ++ systemenviron - out@(_, ok) <- processTranscript' ((proc c ps) { Utility.Process.env = Just environ' }) Nothing - putStrLn $ unwords [c, "finished", show ok] - return out - -atFile :: FilePath -> String -atFile f = '@':f - -runAtFile :: Parser CmdParams -> String -> FilePath -> [String] -> IO (String, Bool) -runAtFile p s f extraparams = do - when (null $ opts c) $ - error $ "failed to find any options for " ++ f ++ " in >>>" ++ s ++ "<<<" - writeFile f (opts c) - out <- getOutput (cmd c) (atFile f:extraparams) (env c) - removeFile f - return out - where - c = case parse p "" s of - Left e -> error $ - (show e) ++ - "\n<<<\n" ++ s ++ "\n>>>" - Right r -> r - -main :: IO () -main = do - ghcout <- fst <$> getOutput "cabal" - ["build", "--ghc-options=-v -keep-tmp-files"] Nothing - gccout <- fst <$> runAtFile parseGhcLink ghcout "gcc.opt" ["-v"] - collect2out <- fst <$> runAtFile parseGccLink gccout "collect2.opt" ["-v"] - (out, ok) <- runAtFile parseCollect2 collect2out "ld.opt" [] - unless ok $ - error $ "ld failed:\n" ++ out diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs deleted file mode 100644 --- a/Build/EvilSplicer.hs +++ /dev/null @@ -1,738 +0,0 @@ -{- Expands template haskell splices - - - - You should probably just use http://hackage.haskell.org/package/zeroth - - instead. I wish I had known about it before writing this. - - - - First, the code must be built with a ghc that supports TH, - - and the splices dumped to a log. For example: - - cabal build --ghc-options=-ddump-splices 2>&1 | tee log - - - - Along with the log, a headers file may also be provided, containing - - additional imports needed by the template haskell code. - - - - This program will parse the log, and expand all splices therein, - - writing files to the specified destdir (which can be "." to modify - - the source tree directly). They can then be built a second - - time, with a ghc that does not support TH. - - - - Note that template haskell code may refer to symbols that are not - - exported by the library that defines the TH code. In this case, - - the library has to be modifed to export those symbols. - - - - There can also be other problems with the generated code; it may - - need modifications to compile. - - - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Main where - -import Text.Parsec -import Text.Parsec.String -import Control.Applicative ((<$>)) -import Data.Either -import Data.List hiding (find) -import Data.Char -import System.Environment -import System.FilePath -import System.IO -import Control.Monad -import Prelude hiding (log) - -import Utility.Monad -import Utility.Misc -import Utility.Exception hiding (try) -import Utility.Path -import Utility.FileSystemEncoding -import Utility.Directory -import Utility.Split - -data Coord = Coord - { coordLine :: Int - , coordColumn :: Int - } - deriving (Read, Show) - -offsetCoord :: Coord -> Coord -> Coord -offsetCoord a b = Coord - (coordLine a - coordLine b) - (coordColumn a - coordColumn b) - -data SpliceType = SpliceExpression | SpliceDeclaration - deriving (Read, Show, Eq) - -data Splice = Splice - { splicedFile :: FilePath - , spliceStart :: Coord - , spliceEnd :: Coord - , splicedExpression :: String - , splicedCode :: String - , spliceType :: SpliceType - } - deriving (Read, Show) - -isExpressionSplice :: Splice -> Bool -isExpressionSplice s = spliceType s == SpliceExpression - -number :: Parser Int -number = read <$> many1 digit - -{- A pair of Coords is written in one of three ways: - - "95:21-73", "1:1", or "(92,25)-(94,2)" - -} -coordsParser :: Parser (Coord, Coord) -coordsParser = (try singleline <|> try weird <|> multiline) "Coords" - where - singleline = do - line <- number - void $ char ':' - startcol <- number - void $ char '-' - endcol <- number - return $ (Coord line startcol, Coord line endcol) - - weird = do - line <- number - void $ char ':' - col <- number - return $ (Coord line col, Coord line col) - - multiline = do - start <- fromparens - void $ char '-' - end <- fromparens - return $ (start, end) - - fromparens = between (char '(') (char ')') $ do - line <- number - void $ char ',' - col <- number - return $ Coord line col - -indent :: Parser String -indent = many1 $ char ' ' - -restOfLine :: Parser String -restOfLine = newline `after` many (noneOf "\n") - -indentedLine :: Parser String -indentedLine = indent >> restOfLine - -spliceParser :: Parser Splice -spliceParser = do - file <- many1 (noneOf ":\n") - void $ char ':' - (start, end) <- coordsParser - void $ string ": Splicing " - splicetype <- tosplicetype - <$> (string "expression" <|> string "declarations") - void newline - - getthline <- expressionextractor - expression <- unlines <$> many1 getthline - - void indent - void $ string "======>" - void newline - - getcodeline <- expressionextractor - realcoords <- try (Right <$> getrealcoords file) <|> (Left <$> getcodeline) - codelines <- many getcodeline - return $ case realcoords of - Left firstcodeline -> - Splice file start end expression - (unlines $ firstcodeline:codelines) - splicetype - Right (realstart, realend) -> - Splice file realstart realend expression - (unlines codelines) - splicetype - where - tosplicetype "declarations" = SpliceDeclaration - tosplicetype "expression" = SpliceExpression - tosplicetype s = error $ "unknown splice type: " ++ s - - {- All lines of the indented expression start with the same - - indent, which is stripped. Any other indentation is preserved. -} - expressionextractor = do - i <- lookAhead indent - return $ try $ do - void $ string i - restOfLine - - {- When splicing declarations, GHC will output a splice - - at 1:1, and then inside the splice code block, - - the first line will give the actual coordinates of the - - line that was spliced. -} - getrealcoords file = do - void indent - void $ string file - void $ char ':' - char '\n' `after` coordsParser - -{- Extracts the splices, ignoring the rest of the compiler output. -} -splicesExtractor :: Parser [Splice] -splicesExtractor = rights <$> many extract - where - extract = try (Right <$> spliceParser) <|> (Left <$> compilerJunkLine) - compilerJunkLine = restOfLine - -{- Modifies the source file, expanding the splices, which all must - - have the same splicedFile. Writes the new file to the destdir. - - - - Each splice's Coords refer to the original position in the file, - - and not to its position after any previous splices may have inserted - - or removed lines. - - - - To deal with this complication, the file is broken into logical lines - - (which can contain any String, including a multiline or empty string). - - Each splice is assumed to be on its own block of lines; two - - splices on the same line is not currently supported. - - This means that a splice can modify the logical lines within its block - - as it likes, without interfering with the Coords of other splices. - - - - As well as expanding splices, this can add a block of imports to the - - file. These are put right before the first line in the file that - - starts with "import " - -} -applySplices :: FilePath -> Maybe String -> [Splice] -> IO () -applySplices _ _ [] = noop -applySplices destdir imports splices@(first:_) = do - let f = splicedFile first - let dest = (destdir f) - lls <- map (++ "\n") . lines <$> readFileStrict f - createDirectoryIfMissing True (parentDir dest) - let newcontent = concat $ addimports $ expand lls splices - oldcontent <- catchMaybeIO $ readFileStrict dest - when (oldcontent /= Just newcontent) $ do - putStrLn $ "splicing " ++ f - withFile dest WriteMode $ \h -> do - hPutStr h newcontent - hClose h - where - expand lls [] = lls - expand lls (s:rest) - | isExpressionSplice s = expand (expandExpressionSplice s lls) rest - | otherwise = expand (expandDeclarationSplice s lls) rest - - addimports lls = case imports of - Nothing -> lls - Just v -> - let (start, end) = break ("import " `isPrefixOf`) lls - in if null end - then start - else concat - [ start - , [v] - , end - ] - -{- Declaration splices are expanded to replace their whole line. -} -expandDeclarationSplice :: Splice -> [String] -> [String] -expandDeclarationSplice s lls = concat [before, [splice], end] - where - cs = spliceStart s - ce = spliceEnd s - - (before, rest) = splitAt (coordLine cs - 1) lls - (_oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest - splice = mangleCode $ splicedCode s - -{- Expression splices are expanded within their line. -} -expandExpressionSplice :: Splice -> [String] -> [String] -expandExpressionSplice sp lls = concat [before, spliced:padding, end] - where - cs = spliceStart sp - ce = spliceEnd sp - - (before, rest) = splitAt (coordLine cs - 1) lls - (oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest - (splicestart, padding, spliceend) = case map expandtabs oldlines of - ss:r - | null r -> (ss, [], ss) - | otherwise -> (ss, take (length r) (repeat []), last r) - _ -> ([], [], []) - spliced = concat - [ joinsplice $ deqqstart $ take (coordColumn cs - 1) splicestart - , addindent (findindent splicestart) (mangleCode $ splicedCode sp) - , deqqend $ drop (coordColumn ce) spliceend - ] - - {- coordinates assume tabs are expanded to 8 spaces -} - expandtabs = replace "\t" (take 8 $ repeat ' ') - - {- splicing leaves $() quasiquote behind; remove it -} - deqqstart s = case reverse s of - ('(':'$':restq) -> reverse restq - _ -> s - deqqend (')':s) = s - deqqend s = s - - {- Prepare the code that comes just before the splice so - - the splice will combine with it appropriately. -} - joinsplice s - -- all indentation? Skip it, we'll use the splice's indentation - | all isSpace s = "" - -- function definition needs no preparation - -- ie: foo = $(splice) - | "=" `isSuffixOf` s' = s - -- nor does lambda definition or case expression - | "->" `isSuffixOf` s' = s - -- nor does a let .. in declaration - | "in" `isSuffixOf` s' = s - -- already have a $ to set off the splice - -- ie: foo $ $(splice) - | "$" `isSuffixOf` s' = s - -- need to add a $ to set off the splice - -- ie: bar $(splice) - | otherwise = s ++ " $ " - where - s' = filter (not . isSpace) s - - findindent = length . takeWhile isSpace - addindent n = unlines . map (i ++) . lines - where - i = take n $ repeat ' ' - -{- Tweaks code output by GHC in splices to actually build. Yipes. -} -mangleCode :: String -> String -mangleCode = flip_colon - . persist_dequalify_hack - . let_do - . remove_unnecessary_type_signatures - . lambdaparenhackyesod - . lambdaparenhackpersistent - . lambdaparens - . declaration_parens - . case_layout - . case_layout_multiline - . yesod_url_render_hack - . text_builder_hack - . nested_instances - . boxed_fileembed - . collapse_multiline_strings - . remove_package_version - . emptylambda - where - {- Lambdas are often output without parens around them. - - This breaks when the lambda is immediately applied to a - - parameter. - - - - For example: - - - - renderRoute (StaticR sub_a1nUH) - - = \ (a_a1nUI, b_a1nUJ) - - -> (((pack "static") : a_a1nUI), - - b_a1nUJ) - - (renderRoute sub_a1nUH) - - - - There are sometimes many lines of lambda code that need to be - - parenthesised. Approach: find the "->" and scan down the - - column to the first non-whitespace. This is assumed - - to be the expression after the lambda. - - - - Runs recursively on the body of the lambda, to handle nested - - lambdas. - -} - lambdaparens = parsecAndReplace $ do - -- skip lambdas inside tuples or parens - prefix <- noneOf "(, \n" - preindent <- many1 $ oneOf " \n" - void $ string "\\ " - lambdaparams <- restofline - continuedlambdaparams <- many $ try $ do - indent1 <- many1 $ char ' ' - p <- satisfy isLetter - aram <- many $ satisfy isAlphaNum <|> oneOf "_" - void newline - return $ indent1 ++ p:aram ++ "\n" - indent1 <- many1 $ char ' ' - void $ string "-> " - firstline <- restofline - lambdalines <- many $ try $ do - void $ string indent1 - void $ char ' ' - l <- restofline - return $ indent1 ++ " " ++ l - return $ concat - [ prefix:preindent - , "(\\ " ++ lambdaparams ++ "\n" - , concat continuedlambdaparams - , indent1 ++ "-> " - , lambdaparens $ intercalate "\n" (firstline:lambdalines) - , ")\n" - ] - - {- Hack to add missing parens in a specific case in yesod - - static route code. - - - - StaticR - - yesod_dispatch_env_a4iDV - - (\ p_a4iE2 r_a4iE3 - - -> r_a4iE3 - - {Network.Wai.pathInfo = p_a4iE2} - - xrest_a4iDT req_a4iDW)) } - - - - Need to add another paren around the lambda, and close it - - before its parameters. lambdaparens misses this one because - - there is already one paren present. - - - - Note that the { } may be on the same line, or wrapped to next. - - - - FIXME: This is a hack. lambdaparens could just always add a - - layer of parens even when a lambda seems to be in parent. - -} - lambdaparenhackyesod = parsecAndReplace $ do - indent1 <- many1 $ char ' ' - staticr <- string "StaticR" - void newline - void $ string indent1 - yesod_dispatch_env <- restofline - void $ string indent1 - lambdaprefix <- string "(\\ " - l1 <- restofline - void $ string indent1 - lambdaarrow <- string " ->" - l2 <- restofline - l3 <- if '{' `elem` l2 && '}' `elem` l2 - then return "" - else do - void $ string indent1 - restofline - return $ unlines - [ indent1 ++ staticr - , indent1 ++ yesod_dispatch_env - , indent1 ++ "(" ++ lambdaprefix ++ l1 - , indent1 ++ lambdaarrow ++ l2 ++ l3 ++ ")" - ] - - {- Hack to reorder misplaced paren in persistent code. - - - - = ((Right Fscked) - - (\ persistValue_a36iM - - -> case fromPersistValue persistValue_a36iM of { - - Right r_a36iN -> Right r_a36iN - - Left err_a36iO - - -> (Left - - $ ((("field " `Data.Monoid.mappend` (packPTH "key")) - - `Data.Monoid.mappend` ": ") - - `Data.Monoid.mappend` err_a36iO)) } - - x_a36iL)) - - - - Fixed by adding another level of params around the lambda - - (lambdaparams should be generalized to cover this case). - -} - lambdaparenhackpersistent = parsecAndReplace $ do - indent1 <- many1 $ char ' ' - start <- do - s1 <- string "(\\ " - s2 <- string "persistValue_" - s3 <- restofline - return $ s1 ++ s2 ++ s3 - void $ string indent1 - indent2 <- many1 $ char ' ' - void $ string "-> " - l1 <- restofline - lambdalines <- many $ try $ do - void $ string $ indent1 ++ indent2 ++ " " - l <- restofline - return $ indent1 ++ indent2 ++ " " ++ l - return $ concat - [ indent1 ++ "(" ++ start ++ "\n" - , indent1 ++ indent2 ++ "-> " ++ l1 ++ "\n" - , intercalate "\n" lambdalines - , ")\n" - ] - - restofline = manyTill (noneOf "\n") newline - - {- For some reason, GHC sometimes doesn't like the multiline - - strings it creates. It seems to get hung up on \{ at the - - start of a new line sometimes, wanting it to not be escaped. - - - - To work around what is likely a GHC bug, just collapse - - multiline strings. -} - collapse_multiline_strings = parsecAndReplace $ do - void $ string "\\\n" - void $ many1 $ oneOf " \t" - void $ string "\\" - return "\\n" - - {- GHC outputs splices using explicit braces rather than layout. - - For a case expression, it does something weird: - - - - case foo of { - - xxx -> blah - - yyy -> blah }; - - - - This is not legal Haskell; the statements in the case must be - - separated by ';' - - - - To fix, we could just put a semicolon at the start of every line - - containing " -> " ... Except that lambdas also contain that. - - But we can get around that: GHC outputs lambdas like this: - - - - \ foo - - -> bar - - - - Or like this: - - - - \ foo -> bar - - - - So, we can put the semicolon at the start of every line - - containing " -> " unless there's a "\ " first, or it's - - all whitespace up until it. - -} - case_layout = skipfree $ parsecAndReplace $ do - void newline - indent1 <- many1 $ char ' ' - prefix <- manyTill (noneOf "\n") (try (string "-> ")) - if length prefix > 20 - then unexpected "too long a prefix" - else if "\\ " `isInfixOf` prefix - then unexpected "lambda expression" - else if null prefix - then unexpected "second line of lambda" - else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> " - {- Sometimes cases themselves span multiple lines: - - - - Nothing - - -> foo - - - - -- This is not yet handled! - - ComplexConstructor var var - - var var - - -> foo - -} - case_layout_multiline = skipfree $ parsecAndReplace $ do - void newline - indent1 <- many1 $ char ' ' - firstline <- restofline - - void $ string indent1 - indent2 <- many1 $ char ' ' - void $ string "-> " - if "\\ " `isInfixOf` firstline - then unexpected "lambda expression" - else return $ "\n" ++ indent1 ++ "; " ++ firstline ++ "\n" - ++ indent1 ++ indent2 ++ "-> " - - {- Type definitions for free monads triggers the case_* hacks, avoid. -} - skipfree f s - | "MonadFree" `isInfixOf` s = s - | otherwise = f s - - {- (foo, \ -> bar) is not valid haskell, GHC. - - Change to (foo, bar) - - - - (Does this ever happen outside a tuple? Only saw - - it inside them.. - -} - emptylambda = replace ", \\ -> " ", " - - {- GHC may output this: - - - - instance RenderRoute WebApp where - - data instance Route WebApp - - ^^^^^^^^ - - The marked word should not be there. - - - - FIXME: This is a yesod and persistent-specific hack, - - it should look for the outer instance. - -} - nested_instances = replace " data instance Route" " data Route" - . replace " data instance Unique" " data Unique" - . replace " data instance EntityField" " data EntityField" - . replace " type instance PersistEntityBackend" " type PersistEntityBackend" - - {- GHC does not properly parenthesise generated data type - - declarations. -} - declaration_parens = replace "StaticR Route Static" "StaticR (Route Static)" - - {- A type signature is sometimes given for an entire lambda, - - which is not properly parenthesized or laid out. This is a - - hack to remove one specific case where this happens and the - - signature is easily inferred, so is just removed. - -} - remove_unnecessary_type_signatures = parsecAndReplace $ do - void $ string " ::" - void newline - void $ many1 $ char ' ' - void $ string "Text.Css.Block Text.Css.Resolved" - void newline - return "" - - {- GHC may add full package and version qualifications for - - symbols from unimported modules. We don't want these. - - - - Examples: - - "blaze-html-0.4.3.1:Text.Blaze.Internal.preEscapedText" - - "ghc-prim:GHC.Types.:" - -} - remove_package_version = parsecAndReplace $ - mangleSymbol <$> qualifiedSymbol - - mangleSymbol "GHC.Types." = "" - mangleSymbol "GHC.Tuple." = "" - mangleSymbol s = s - - qualifiedSymbol :: Parser String - qualifiedSymbol = do - s <- hstoken - void $ char ':' - if length s < 5 - then unexpected "too short to be a namespace" - else do - t <- hstoken - case t of - (c:r) | isUpper c && "." `isInfixOf` r -> return t - _ -> unexpected "not a module qualified symbol" - - hstoken :: Parser String - hstoken = do - t <- satisfy isLetter - oken <- many $ satisfy isAlphaNum <|> oneOf "-.'" - return $ t:oken - - {- This works when it's "GHC.Types.:", but we strip - - that above, so have to fix up after it here. - - The ; is added by case_layout. -} - flip_colon = replace "; : _ " "; _ : " - - {- TH for persistent has some qualified symbols in places - - that are not allowed. -} - persist_dequalify_hack = replace "Database.Persist.TH.++" "`Data.Text.append`" - . replace "Database.Persist.Sql.Class.sqlType" "sqlType" - . replace "Database.Persist.Class.PersistField.toPersistValue" "toPersistValue" - . replace "Database.Persist.Class.PersistField.fromPersistValue" "fromPersistValue" - - {- Sometimes generates invalid bracketed code with a let - - expression: - - - - foo = do { let x = foo; - - use foo } - - - - Fix by converting the "let x = " to "x <- return $" - -} - let_do = parsecAndReplace $ do - void $ string "= do { let " - x <- many $ noneOf "=\r\n" - _ <- many1 $ oneOf " \t\r\n" - void $ string "= " - return $ "= do { " ++ x ++ " <- return $ " - -{- Embedded files use unsafe packing, which is problematic - - for several reasons, including that GHC sometimes omits trailing - - newlines in the file content, which leads to the wrong byte - - count. Also, GHC sometimes outputs unicode characters, which - - are not legal in unboxed strings. - - - - Avoid problems by converting: - - GHC.IO.unsafePerformIO - - (Data.ByteString.Unsafe.unsafePackAddressLen - - lllll - - "blabblah"#)), - - to: - - Data.ByteString.Char8.pack "blabblah"), - - - - Note that the string is often multiline. This only works if - - collapse_multiline_strings has run first. - -} -boxed_fileembed :: String -> String -boxed_fileembed = parsecAndReplace $ do - i <- indent - void $ string "GHC.IO.unsafePerformIO" - void newline - void indent - void $ string "(Data.ByteString.Unsafe.unsafePackAddressLen" - void newline - void indent - void number - void newline - void indent - void $ char '"' - s <- restOfLine - let s' = take (length s - 5) s - if "\"#))," `isSuffixOf` s - then return (i ++ "Data.ByteString.Char8.pack \"" ++ s' ++ "\"),\n") - else fail "not an unboxed string" - -{- This works around a problem in the expanded template haskell for Yesod - - type-safe url rendering. - - - - It generates code like this: - - - - (toHtml - - (\ u_a2ehE -> urender_a2ehD u_a2ehE [] - - (CloseAlert aid))))); - - - - Where urender_a2ehD is the function returned by getUrlRenderParams. - - But, that function that only takes 2 params, not 3. - - And toHtml doesn't take a parameter at all! - - - - So, this modifes the code, to look like this: - - - - (toHtml - - (flip urender_a2ehD [] - - (CloseAlert aid))))); - - - - FIXME: Investigate and fix this properly. - -} -yesod_url_render_hack :: String -> String -yesod_url_render_hack = parsecAndReplace $ do - void $ string "(toHtml" - void whitespace - void $ string "(\\" - void whitespace - wtf <- hstoken - void whitespace - void $ string "->" - void whitespace - renderer <- hstoken - void whitespace - void $ string wtf - void whitespace - return $ "(toHtml (flip " ++ renderer ++ " " - where - whitespace :: Parser String - whitespace = many $ oneOf " \t\r\n" - - hstoken :: Parser String - hstoken = many1 $ satisfy isAlphaNum <|> oneOf "_" - -{- Use exported symbol. -} -text_builder_hack :: String -> String -text_builder_hack = replace "Data.Text.Lazy.Builder.Internal.fromText" "Data.Text.Lazy.Builder.fromText" - -{- Given a Parser that finds strings it wants to modify, - - and returns the modified string, does a mass - - find and replace throughout the input string. - - Rather slow, but crazy powerful. -} -parsecAndReplace :: Parser String -> String -> String -parsecAndReplace p s = case parse find "" s of - Left _e -> s - Right l -> concatMap (either return id) l - where - find :: Parser [Either Char String] - find = many $ try (Right <$> p) <|> (Left <$> anyChar) - -main :: IO () -main = do - useFileSystemEncoding - go =<< getArgs - where - go (destdir:log:header:[]) = run destdir log (Just header) - go (destdir:log:[]) = run destdir log Nothing - go _ = error "usage: EvilSplicer destdir logfile [headerfile]" - - run destdir log mheader = do - r <- parseFromFile splicesExtractor log - case r of - Left e -> error $ show e - Right splices -> do - let groups = groupBy (\a b -> splicedFile a == splicedFile b) splices - imports <- maybe (return Nothing) (catchMaybeIO . readFile) mheader - mapM_ (applySplices destdir imports) groups diff --git a/Build/InstallDesktopFile.hs b/Build/InstallDesktopFile.hs deleted file mode 100644 --- a/Build/InstallDesktopFile.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- Generating and installing a desktop menu entry file and icon, - - and a desktop autostart file. (And OSX equivilants.) - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Main where - -import Build.DesktopFile - -import System.Environment - -main :: IO () -main = getArgs >>= go - where - go [] = error "specify git-annex command" - go (command:_) = install command diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs deleted file mode 100644 --- a/Build/LinuxMkLibs.hs +++ /dev/null @@ -1,114 +0,0 @@ -{- Linux library copier and binary shimmer - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Main where - -import System.Environment -import Data.Maybe -import System.FilePath -import Control.Monad -import Data.List -import System.Posix.Files -import Control.Monad.IfElse -import Control.Applicative -import Prelude - -import Utility.LinuxMkLibs -import Utility.Directory -import Utility.Process -import Utility.Monad -import Utility.Path -import Utility.FileMode -import Utility.CopyFile - -main :: IO () -main = getArgs >>= go - where - go [] = error "specify LINUXSTANDALONE_DIST" - go (top:_) = mklibs top - -mklibs :: FilePath -> IO () -mklibs top = do - fs <- dirContentsRecursive top - exes <- filterM checkExe fs - libs <- parseLdd <$> readProcess "ldd" exes - glibclibs <- glibcLibs - let libs' = nub $ libs ++ glibclibs - libdirs <- nub . catMaybes <$> mapM (installLib installFile top) libs' - - -- Various files used by runshell to set up env vars used by the - -- linker shims. - writeFile (top "libdirs") (unlines libdirs) - writeFile (top "gconvdir") - (parentDir $ Prelude.head $ filter ("/gconv/" `isInfixOf`) glibclibs) - - let linker = Prelude.head $ filter ("ld-linux" `isInfixOf`) libs' - mapM_ (installLinkerShim top linker) exes - -{- Installs a linker shim script around a binary. - - - - Note that each binary is put into its own separate directory, - - to avoid eg git looking for binaries in its directory rather - - than in PATH. - - - - The linker is symlinked to a file with the same basename as the binary, - - since that looks better in ps than "ld-linux.so". - -} -installLinkerShim :: FilePath -> FilePath -> FilePath -> IO () -installLinkerShim top linker exe = do - createDirectoryIfMissing True (top shimdir) - createDirectoryIfMissing True (top exedir) - ifM (isSymbolicLink <$> getSymbolicLinkStatus exe) - ( do - sl <- readSymbolicLink exe - nukeFile exe - nukeFile exedest - -- Assume that for a symlink, the destination - -- will also be shimmed. - let sl' = ".." takeFileName sl takeFileName sl - createSymbolicLink sl' exedest - , renameFile exe exedest - ) - link <- relPathDirToFile (top exedir) (top ++ linker) - unlessM (doesFileExist (top exelink)) $ - createSymbolicLink link (top exelink) - writeFile exe $ unlines - [ "#!/bin/sh" - , "GIT_ANNEX_PROGRAMPATH=\"$0\"" - , "export GIT_ANNEX_PROGRAMPATH" - , "exec \"$GIT_ANNEX_DIR/" ++ exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ base ++ "/" ++ base ++ "\" \"$@\"" - ] - modifyFileMode exe $ addModes executeModes - where - base = takeFileName exe - shimdir = "shimmed" base - exedir = "exe" - exedest = top shimdir base - exelink = exedir base - -installFile :: FilePath -> FilePath -> IO () -installFile top f = do - createDirectoryIfMissing True destdir - void $ copyFileExternal CopyTimeStamps f destdir - where - destdir = inTop top $ parentDir f - -checkExe :: FilePath -> IO Bool -checkExe f - | ".so" `isSuffixOf` f = return False - | otherwise = ifM (isExecutable . fileMode <$> getFileStatus f) - ( checkFileExe <$> readProcess "file" ["-L", f] - , return False - ) - -{- Check that file(1) thinks it's a Linux ELF executable, or possibly - - a shared library (a few executables like ssh appear as shared libraries). -} -checkFileExe :: String -> Bool -checkFileExe s = and - [ "ELF" `isInfixOf` s - , "executable" `isInfixOf` s || "shared object" `isInfixOf` s - ] diff --git a/Build/MakeMans.hs b/Build/MakeMans.hs deleted file mode 100644 --- a/Build/MakeMans.hs +++ /dev/null @@ -1,15 +0,0 @@ -{- Build man pages, for use by Makefile - - - - Copyright 2016 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# OPTIONS_GHC -fno-warn-tabs #-} - -module Main where - -import Build.Mans - -main :: IO () -main = buildMansOrWarn diff --git a/Build/NullSoftInstaller.hs b/Build/NullSoftInstaller.hs deleted file mode 100644 --- a/Build/NullSoftInstaller.hs +++ /dev/null @@ -1,199 +0,0 @@ -{- Generates a NullSoft installer program for git-annex on Windows. - - - - This uses the Haskell nsis package (cabal install nsis) - - to generate a .nsi file, which is then used to produce - - git-annex-installer.exe - - - - The installer includes git-annex, and utilities it uses, with the - - exception of git and some utilities that are bundled with git. - - The user needs to install git separately, and the installer checks - - for that. - - - - To build the installer, git-annex should already be built by cabal, - - and the necessary utility programs (rsync and wget) already installed - - in PATH from msys32. - - - - Copyright 2013-2015 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} - -import Development.NSIS -import System.FilePath -import Control.Monad -import Control.Applicative -import Data.String -import Data.Maybe -import Data.Char -import Data.List (nub, isPrefixOf) - -import Utility.Tmp -import Utility.Path -import Utility.CopyFile -import Utility.SafeCommand -import Utility.Process -import Utility.Exception -import Utility.Directory -import Build.BundledPrograms - -main = do - withTmpDir "nsis-build" $ \tmpdir -> do - let gitannex = tmpdir gitannexprogram - mustSucceed "ln" [File "dist/build/git-annex/git-annex.exe", File gitannex] - let license = tmpdir licensefile - mustSucceed "sh" [Param "-c", Param $ "zcat standalone/licences.gz > '" ++ license ++ "'"] - webappscript <- vbsLauncher tmpdir "git-annex-webapp" "git annex webapp" - autostartscript <- vbsLauncher tmpdir "git-annex-autostart" "git annex assistant --autostart" - let htmlhelp = tmpdir "git-annex.html" - writeFile htmlhelp htmlHelpText - let gitannexcmd = tmpdir "git-annex.cmd" - writeFile gitannexcmd "git annex %*" - writeFile nsifile $ makeInstaller - gitannex gitannexcmd license htmlhelp winPrograms - [ webappscript, autostartscript ] - mustSucceed "makensis" [File nsifile] - removeFile nsifile -- left behind if makensis fails - where - nsifile = "git-annex.nsi" - mustSucceed cmd params = do - r <- boolSystem cmd params - case r of - True -> return () - False -> error $ cmd ++ " failed" - -{- Generates a .vbs launcher which runs a command without any visible DOS - - box. It expects to be passed the directory where git-annex is installed. -} -vbsLauncher :: FilePath -> String -> String -> IO String -vbsLauncher tmpdir basename cmd = do - let f = tmpdir basename ++ ".vbs" - writeFile f $ unlines - [ "Set objshell=CreateObject(\"Wscript.Shell\")" - , "objShell.CurrentDirectory = Wscript.Arguments.item(0)" - , "objShell.Run(\"" ++ cmd ++ "\"), 0, False" - ] - return f - -gitannexprogram :: FilePath -gitannexprogram = "git-annex.exe" - -licensefile :: FilePath -licensefile = "git-annex-licenses.txt" - -installer :: FilePath -installer = "git-annex-installer.exe" - -uninstaller :: FilePath -uninstaller = "git-annex-uninstall.exe" - -gitInstallDir :: Exp FilePath -gitInstallDir = fromString "$PROGRAMFILES\\Git" - --- This intentionally has a different name than git-annex or --- git-annex-webapp, since it is itself treated as an executable file. --- Also, on XP, the filename is displayed, not the description. -startMenuItem :: Exp FilePath -startMenuItem = "$SMPROGRAMS/Git Annex (Webapp).lnk" - -oldStartMenuItem :: Exp FilePath -oldStartMenuItem = "$SMPROGRAMS/git-annex.lnk" - -autoStartItem :: Exp FilePath -autoStartItem = "$SMSTARTUP/git-annex-autostart.lnk" - -needGit :: Exp String -needGit = strConcat - [ fromString "You need git installed to use git-annex. Looking at " - , gitInstallDir - , fromString " , it seems to not be installed, " - , fromString "or may be installed in another location. " - , fromString "You can install git from http:////git-scm.com//" - ] - -makeInstaller :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> [FilePath] -> String -makeInstaller gitannex gitannexcmd license htmlhelp extrabins launchers = nsis $ do - name "git-annex" - outFile $ str installer - {- Installing into the same directory as git avoids needing to modify - - path myself, since the git installer already does it. -} - installDir gitInstallDir - requestExecutionLevel Admin - - iff (fileExists gitInstallDir) - (return ()) - (alert needGit) - - -- Pages to display - page Directory -- Pick where to install - page (License license) - page InstFiles -- Give a progress bar while installing - -- Start menu shortcut - Development.NSIS.createDirectory "$SMPROGRAMS" - createShortcut startMenuItem - [ Target "wscript.exe" - , Parameters "\"$INSTDIR/cmd/git-annex-webapp.vbs\" \"$INSTDIR/cmd\"" - , StartOptions "SW_SHOWNORMAL" - , IconFile "$INSTDIR/usr/bin/git-annex.exe" - , IconIndex 2 - , Description "Git Annex (Webapp)" - ] - delete [RebootOK] $ oldStartMenuItem - createShortcut autoStartItem - [ Target "wscript.exe" - , Parameters "\"$INSTDIR/cmd/git-annex-autostart.vbs\" \"$INSTDIR/cmd\"" - , StartOptions "SW_SHOWNORMAL" - , IconFile "$INSTDIR/usr/bin/git-annex.exe" - , IconIndex 2 - , Description "git-annex autostart" - ] - section "cmd" [] $ do - -- Remove old files no longer installed in the cmd - -- directory. - removefilesFrom "$INSTDIR/cmd" (gitannex:extrabins) - -- Install everything to the same location git puts its - -- bins. This makes "git annex" work in the git bash - -- shell, since git expects to find the git-annex binary - -- there. - setOutPath "$INSTDIR\\usr\\bin" - mapM_ addfile (gitannex:extrabins) - -- This little wrapper is installed in the cmd directory, - -- so that "git-annex" works (as well as "git annex"), - -- when only that directory is in PATH (ie, in a ms-dos - -- prompt window). - setOutPath "$INSTDIR\\cmd" - addfile gitannexcmd - section "meta" [] $ do - -- git opens this file when git annex --help is run. - -- (Program Files/Git/mingw32/share/doc/git-doc/git-annex.html) - setOutPath "$INSTDIR\\mingw32\\share\\doc\\git-doc" - addfile htmlhelp - setOutPath "$INSTDIR" - addfile license - setOutPath "$INSTDIR\\cmd" - mapM_ addfile launchers - writeUninstaller $ str uninstaller - uninstall $ do - delete [RebootOK] $ startMenuItem - delete [RebootOK] $ autoStartItem - removefilesFrom "$INSTDIR/usr/bin" (gitannex:extrabins) - removefilesFrom "$INSTDIR/cmd" (gitannexcmd:launchers) - removefilesFrom "$INSTDIR\\mingw32\\share\\doc\\git-doc" [htmlhelp] - removefilesFrom "$INSTDIR" [license, uninstaller] - where - addfile f = file [] (str f) - removefilesFrom d = mapM_ (\f -> delete [RebootOK] $ fromString $ d ++ "/" ++ takeFileName f) - -winPrograms :: [FilePath] -winPrograms = map (\p -> p ++ ".exe") bundledPrograms - -htmlHelpText :: String -htmlHelpText = unlines - [ "" - , "git-annex help" - , "" - , "For help on git-annex, run \"git annex help\", or" - , "read the man page." - , "" - , " - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Main where - -import System.Environment (getArgs) -import Data.Maybe -import System.FilePath -import Control.Monad -import Control.Monad.IfElse -import Data.List -import Control.Applicative -import Prelude - -import Utility.PartialPrelude -import Utility.Directory -import Utility.Process -import Utility.Monad -import Utility.SafeCommand -import Utility.Path -import Utility.Exception -import Utility.Env -import Utility.Misc -import Utility.Split - -import qualified Data.Map as M -import qualified Data.Set as S - -type LibMap = M.Map FilePath String - -{- Recursively find and install libs, until nothing new to install is found. -} -mklibs :: FilePath -> [FilePath] -> [(FilePath, FilePath)] -> LibMap -> IO () -mklibs appbase libdirs replacement_libs libmap = do - (new, replacement_libs', libmap') <- installLibs appbase replacement_libs libmap - unless (null new) $ - mklibs appbase (libdirs++new) replacement_libs' libmap' - -{- Returns directories into which new libs were installed. -} -installLibs :: FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap) -installLibs appbase replacement_libs libmap = do - (needlibs, replacement_libs', libmap') <- otool appbase replacement_libs libmap - libs <- forM needlibs $ \lib -> do - pathlib <- findLibPath lib - let shortlib = fromMaybe (error "internal") (M.lookup lib libmap') - let fulllib = dropWhile (== '/') lib - let dest = appbase fulllib - let symdest = appbase shortlib - -- This is a hack; libraries need to be in the same - -- directory as the program, so also link them into the - -- extra directory. - let symdestextra = appbase "extra" shortlib - ifM (doesFileExist dest) - ( return Nothing - , do - createDirectoryIfMissing True (parentDir dest) - putStrLn $ "installing " ++ pathlib ++ " as " ++ shortlib - unlessM (boolSystem "cp" [File pathlib, File dest] - <&&> boolSystem "chmod" [Param "644", File dest] - <&&> boolSystem "ln" [Param "-s", File fulllib, File symdest] - <&&> boolSystem "ln" [Param "-s", File (".." fulllib), File symdestextra]) $ - error "library install failed" - return $ Just appbase - ) - return (catMaybes libs, replacement_libs', libmap') - -{- Returns libraries to install. - - - - Note that otool -L ignores DYLD_LIBRARY_PATH, so the - - library files returned may need to be run through findLibPath - - to find the actual libraries to install. - -} -otool :: FilePath -> [(FilePath, FilePath)] -> LibMap -> IO ([FilePath], [(FilePath, FilePath)], LibMap) -otool appbase replacement_libs libmap = do - files <- filterM doesFileExist =<< dirContentsRecursive appbase - process [] files replacement_libs libmap - where - want s = not ("@executable_path" `isInfixOf` s) - && not (".framework" `isInfixOf` s) - && not ("libSystem.B" `isInfixOf` s) - process c [] rls m = return (nub $ concat c, rls, m) - process c (file:rest) rls m = do - _ <- boolSystem "chmod" [Param "755", File file] - libs <- filter want . parseOtool - <$> readProcess "otool" ["-L", file] - expanded_libs <- expand_rpath libs replacement_libs file - let rls' = nub $ rls ++ (zip libs expanded_libs) - m' <- install_name_tool file libs expanded_libs m - process (expanded_libs:c) rest rls' m' - -findLibPath :: FilePath -> IO FilePath -findLibPath l = go =<< getEnv "DYLD_LIBRARY_PATH" - where - go Nothing = return l - go (Just p) = fromMaybe l - <$> firstM doesFileExist (map ( f) (splitc ':' p)) - f = takeFileName l - -{- Expands any @rpath in the list of libraries. - - - - This is done by the nasty method of running the command with a dummy - - option (so it doesn't do anything.. hopefully!) and asking the dynamic - - linker to print expanded rpaths. - -} -expand_rpath :: [String] -> [(FilePath, FilePath)] -> FilePath -> IO [String] -expand_rpath libs replacement_libs cmd - | any ("@rpath" `isInfixOf`) libs = do - installed <- M.fromList . Prelude.read - <$> readFile "tmp/standalone-installed" - let origcmd = case M.lookup cmd installed of - Nothing -> cmd - Just cmd' -> cmd' - s <- catchDefaultIO "" $ readProcess "sh" ["-c", probe origcmd] - let m = if (null s) - then M.fromList replacement_libs - else M.fromList $ mapMaybe parse $ lines s - return $ map (replacem m) libs - | otherwise = return libs - where - probe c = "DYLD_PRINT_RPATHS=1 " ++ c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH" - parse s = case words s of - ("RPATH":"successful":"expansion":"of":old:"to:":new:[]) -> - Just (old, new) - _ -> Nothing - replacem m l = fromMaybe l $ M.lookup l m - -parseOtool :: String -> [FilePath] -parseOtool = catMaybes . map parse . lines - where - parse l - | "\t" `isPrefixOf` l = headMaybe $ words l - | otherwise = Nothing - -{- Adjusts binaries to use libraries bundled with it, rather than the - - system libraries. -} -install_name_tool :: FilePath -> [FilePath] -> [FilePath] -> LibMap -> IO LibMap -install_name_tool _ [] _ libmap = return libmap -install_name_tool binary libs expanded_libs libmap = do - let (libnames, libmap') = getLibNames expanded_libs libmap - let params = concatMap change $ zip libs libnames - ok <- boolSystem "install_name_tool" $ params ++ [File binary] - unless ok $ - error $ "install_name_tool failed for " ++ binary - return libmap' - where - change (lib, libname) = - [ Param "-change" - , File lib - , Param $ "@executable_path/" ++ libname - ] - -getLibNames :: [FilePath] -> LibMap -> ([FilePath], LibMap) -getLibNames libs libmap = go [] libs libmap - where - go c [] m = (reverse c, m) - go c (l:rest) m = - let (f, m') = getLibName l m - in go (f:c) rest m' - -{- Uses really short names for the library files it installs, because - - binaries have arbitrarily short RPATH field limits. -} -getLibName :: FilePath -> LibMap -> (FilePath, LibMap) -getLibName lib libmap = case M.lookup lib libmap of - Just n -> (n, libmap) - Nothing -> (nextfreename, M.insert lib nextfreename libmap) - where - names = map pure ['A' .. 'Z'] ++ - [[n, l] | n <- ['0' .. '9'], l <- ['A' .. 'Z']] - used = S.fromList $ M.elems libmap - nextfreename = fromMaybe (error "ran out of short library names!") $ - headMaybe $ dropWhile (`S.member` used) names - -main :: IO () -main = getArgs >>= go - where - go [] = error "specify OSXAPP_BASE" - go (appbase:_) = mklibs appbase [] [] M.empty diff --git a/Build/Standalone.hs b/Build/Standalone.hs deleted file mode 100644 --- a/Build/Standalone.hs +++ /dev/null @@ -1,52 +0,0 @@ -{- Makes standalone bundle. - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Main where - -import Control.Monad.IfElse -import System.Environment -import System.FilePath -import Control.Monad -import Build.BundledPrograms - -import Utility.SafeCommand -import Utility.Path -import Utility.Directory - -progDir :: FilePath -> FilePath -#ifdef darwin_HOST_OS -progDir topdir = topdir -#else -progDir topdir = topdir "bin" -#endif - -extraProgDir :: FilePath -> FilePath -extraProgDir topdir = topdir "extra" - -installProg :: FilePath -> FilePath -> IO (FilePath, FilePath) -installProg dir prog = searchPath prog >>= go - where - go Nothing = error $ "cannot find " ++ prog ++ " in PATH" - go (Just f) = do - let dest = dir takeFileName f - unlessM (boolSystem "install" [File f, File dest]) $ - error $ "install failed for " ++ prog - return (dest, f) - -main :: IO () -main = getArgs >>= go - where - go [] = error "specify topdir" - go (topdir:_) = do - installed <- forM - [ (progDir topdir, preferredBundledPrograms) - , (extraProgDir topdir, extraBundledPrograms) ] $ \(dir, progs) -> do - createDirectoryIfMissing True dir - forM progs $ installProg dir - writeFile "tmp/standalone-installed" (show (concat installed)) diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,48 @@ +git-annex (6.20170818) unstable; urgency=high + + * Security fix: Disallow hostname starting with a dash, which + would get passed to ssh and be treated an option. This could + be used by an attacker who provides a crafted repository url + to cause the victim to execute arbitrary code via -oProxyCommand. + (The same class of security hole recently affected git itself.) + * git-annex.cabal: Deal with breaking changes in Cabal 2.0. + * Fix build with QuickCheck 2.10. + * fsck: Support --json. + * move, copy: Support --batch. + * Added GIT_ANNEX_VECTOR_CLOCK environment variable, which can be used to + override the default timestamps used in log files in the git-annex + branch. This is a dangerous environment variable; use with caution. + * Fix a git-annex test failure when run on NFS due to NFS lock files + preventing directory removal. + * test: Avoid most situations involving failure to delete test + directories, by forking a worker process and only deleting the test + directory once it exits. + * Disable http-client's default 30 second response timeout when HEADing + an url to check if it exists. Some web servers take quite a long time + to answer a HEAD request. + * Added remote configuration settings annex-ignore-command and + annex-sync-command, which are dynamic equivilants of the annex-ignore + and annex-sync configurations. + * Prevent spaces from being embedded in the name of new WORM keys, + as that handing spaces in keys would complicate things like the + external special remote protocol. + * migrate: WORM keys containing spaces will be migrated to not contain + spaces anymore. + * External special remotes will refuse to operate on keys with spaces in + their names. That has never worked correctly due to the design of the + external special remote protocol. Display an error message suggesting + migration. + * Fix incorrect external special remote documentation, which said that + the filename parameter to the TRANSFER command could not contain + spaces. It can in fact contain spaces. Special remotes implementors + that relied on that may need to fix bugs in their special remotes. + * Fix the external special remotes git-annex-remote-ipfs, + git-annex-remote-torrent and the example.sh template to correctly + support filenames with spaces. + * Windows: Win32 package has subsumed Win32-extras; update dependency. + + -- Joey Hess Fri, 18 Aug 2017 11:19:06 -0400 + git-annex (6.20170520) unstable; urgency=medium * move --to=here moves from all reachable remotes to the local repository. diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -35,11 +35,15 @@ <*> pure (autoMode v) seek :: CopyOptions -> CommandSeek -seek o = allowConcurrentOutput $ - withKeyOptions (Command.Move.keyOptions $ moveOptions o) (autoMode o) - (Command.Move.startKey (moveOptions o) False) - (withFilesInGit $ whenAnnexed $ start o) - (Command.Move.moveFiles $ moveOptions o) +seek o = allowConcurrentOutput $ do + let go = whenAnnexed $ start o + case Command.Move.batchOption (moveOptions o) of + Batch -> batchInput Right (batchCommandAction . go) + NoBatch -> withKeyOptions + (Command.Move.keyOptions $ moveOptions o) (autoMode o) + (Command.Move.startKey (moveOptions o) False) + (withFilesInGit go) + (Command.Move.moveFiles $ moveOptions o) {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -20,6 +20,8 @@ import Logs.UUID import Annex.UUID import Config +import Config.DynamicConfig +import Types.GitConfig import qualified Data.Map as M @@ -76,7 +78,9 @@ let fullconfig = config `M.union` c t <- either giveup return (Annex.SpecialRemote.findType fullconfig) showStart "enableremote" name - gc <- maybe def Remote.gitconfig <$> Remote.byUUID u + gc <- maybe (liftIO dummyRemoteGitConfig) + (return . Remote.gitconfig) + =<< Remote.byUUID u next $ performSpecialRemote t u fullconfig gc performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform @@ -109,5 +113,6 @@ where isdisabled r = anyM id [ (==) NoUUID <$> getRepoUUID r - , remoteAnnexIgnore <$> Annex.getRemoteGitConfig r + , liftIO . getDynamicConfig . remoteAnnexIgnore + =<< Annex.getRemoteGitConfig r ] diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -13,6 +13,7 @@ import Logs.MapLog import Logs.Trust import Annex.UUID +import Annex.VectorClock import qualified Remote import Utility.HumanTime @@ -70,15 +71,15 @@ where lastact = changed <$> M.lookup u actlog whenactive = case lastact of - Just (Date t) -> do - d <- liftIO $ durationSince $ posixSecondsToUTCTime t + Just (VectorClock c) -> do + d <- liftIO $ durationSince $ posixSecondsToUTCTime c return $ "last active: " ++ fromDuration d ++ " ago" _ -> return "no activity" desc = fromUUID u ++ " " ++ fromMaybe "" (M.lookup u descs) notexpired ent = case ent of Unknown -> False - Date t -> case lookupexpire of - Just (Just expiretime) -> t >= expiretime + VectorClock c -> case lookupexpire of + Just (Just expiretime) -> c >= expiretime _ -> True lookupexpire = headMaybe $ catMaybes $ map (`M.lookup` expire) [Just u, Nothing] diff --git a/Command/Forget.hs b/Command/Forget.hs --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -11,8 +11,7 @@ import qualified Annex.Branch as Branch import Logs.Transitions import qualified Annex - -import Data.Time.Clock.POSIX +import Annex.VectorClock cmd :: Command cmd = command "forget" SectionMaintenance @@ -36,10 +35,10 @@ start :: ForgetOptions -> CommandStart start o = do showStart "forget" "git-annex" - now <- liftIO getPOSIXTime - let basets = addTransition now ForgetGitHistory noTransitions + c <- liftIO currentVectorClock + let basets = addTransition c ForgetGitHistory noTransitions let ts = if dropDead o - then addTransition now ForgetDeadRemotes basets + then addTransition c ForgetDeadRemotes basets else basets next $ perform ts =<< Annex.getState Annex.force diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -42,7 +42,7 @@ import System.Posix.Types (EpochTime) cmd :: Command -cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ +cmd = withGlobalOptions (jobsOption : jsonOption : annexedMatchingOptions) $ command "fsck" SectionMaintenance "find and fix problems" paramPaths (seek <$$> optParser) diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -15,6 +15,7 @@ import qualified Logs.Remote import qualified Types.Remote as R import Logs.UUID +import Types.GitConfig cmd :: Command cmd = command "initremote" SectionSetup @@ -46,7 +47,8 @@ perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform perform t name c = do - (c', u) <- R.setup t R.Init cu Nothing c def + dummycfg <- liftIO dummyRemoteGitConfig + (c', u) <- R.setup t R.Init cu Nothing c dummycfg next $ cleanup u name c' where cu = case M.lookup "uuid" c of diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -9,6 +9,7 @@ import Command import Annex.MetaData +import Annex.VectorClock import Logs.MetaData import Annex.WorkTree import Messages.JSON (JSONActionItem(..)) @@ -18,7 +19,6 @@ import qualified Data.Map as M import qualified Data.Text as T import qualified Data.ByteString.Lazy.UTF8 as BU -import Data.Time.Clock.POSIX import Data.Aeson import Control.Concurrent @@ -68,28 +68,28 @@ seek :: MetaDataOptions -> CommandSeek seek o = case batchOption o of NoBatch -> do - now <- liftIO getPOSIXTime + c <- liftIO currentVectorClock let seeker = case getSet o of Get _ -> withFilesInGit GetAll -> withFilesInGit Set _ -> withFilesInGitNonRecursive "Not recursively setting metadata. Use --force to do that." withKeyOptions (keyOptions o) False - (startKeys now o) - (seeker $ whenAnnexed $ start now o) + (startKeys c o) + (seeker $ whenAnnexed $ start c o) (forFiles o) Batch -> withMessageState $ \s -> case outputType s of JSONOutput _ -> batchInput parseJSONInput $ commandAction . startBatch _ -> giveup "--batch is currently only supported in --json mode" -start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart -start now o file k = startKeys now o k (mkActionItem afile) +start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart +start c o file k = startKeys c o k (mkActionItem afile) where afile = AssociatedFile (Just file) -startKeys :: POSIXTime -> MetaDataOptions -> Key -> ActionItem -> CommandStart -startKeys now o k ai = case getSet o of +startKeys :: VectorClock -> MetaDataOptions -> Key -> ActionItem -> CommandStart +startKeys c o k ai = case getSet o of Get f -> do l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k liftIO $ forM_ l $ @@ -97,14 +97,14 @@ stop _ -> do showStart' "metadata" k ai - next $ perform now o k + next $ perform c o k -perform :: POSIXTime -> MetaDataOptions -> Key -> CommandPerform -perform now o k = case getSet o of +perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform +perform c o k = case getSet o of Set ms -> do oldm <- getCurrentMetaData k let m = combineMetaData $ map (modMeta oldm) ms - addMetaData' k m now + addMetaData' k m c next $ cleanup k _ -> next $ cleanup k @@ -169,7 +169,7 @@ , keyOptions = Nothing , batchOption = NoBatch } - now <- liftIO getPOSIXTime + t <- liftIO currentVectorClock -- It would be bad if two batch mode changes used exactly -- the same timestamp, since the order of adds and removals -- of the same metadata value would then be indeterminate. @@ -178,7 +178,7 @@ -- probably less expensive than cleaner methods, -- such as taking from a list of increasing timestamps. liftIO $ threadDelay 1 - next $ perform now o k + next $ perform t o k mkModMeta (f, s) | S.null s = DelMeta f Nothing | otherwise = SetMeta f s diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -29,6 +29,7 @@ { moveFiles :: CmdParams , fromToOptions :: Either ToHere FromToOptions , keyOptions :: Maybe KeyOptions + , batchOption :: BatchMode } data ToHere = ToHere @@ -38,6 +39,7 @@ <$> cmdParams desc <*> (parsefrom <|> parseto) <*> optional (parseKeyOptions <|> parseFailedTransfersOption) + <*> parseBatchOption where parsefrom = Right . FromRemote . parseRemoteOption <$> parseFromOption parseto = herespecialcase <$> parseToOption @@ -51,13 +53,17 @@ <$> pure (moveFiles v) <*> either (pure . Left) (Right <$$> finishParse) (fromToOptions v) <*> pure (keyOptions v) + <*> pure (batchOption v) seek :: MoveOptions -> CommandSeek -seek o = allowConcurrentOutput $ - withKeyOptions (keyOptions o) False - (startKey o True) - (withFilesInGit $ whenAnnexed $ start o True) - (moveFiles o) +seek o = allowConcurrentOutput $ do + let go = whenAnnexed $ start o True + case batchOption o of + Batch -> batchInput Right (batchCommandAction . go) + NoBatch -> withKeyOptions (keyOptions o) False + (startKey o True) + (withFilesInGit go) + (moveFiles o) start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart start o move f k = start' o move afile k (mkActionItem afile) diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -40,6 +40,7 @@ import qualified Remote.Git import Config import Config.GitConfig +import Config.DynamicConfig import Config.Files import Annex.Wanted import Annex.Content @@ -152,8 +153,8 @@ remotes <- syncRemotes (syncWith o) let gitremotes = filter Remote.gitSyncableRemote remotes - let dataremotes = filter (\r -> Remote.uuid r /= NoUUID) $ - filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes + dataremotes <- filter (\r -> Remote.uuid r /= NoUUID) + <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes -- Syncing involves many actions, any of which can independently -- fail, without preventing the others from running. @@ -247,10 +248,15 @@ -- Do automatic initialization of remotes when possible when getting remote -- list. syncRemotes :: [String] -> Annex [Remote] -syncRemotes ps = syncRemotes' ps =<< Remote.remoteList' True +syncRemotes ps = do + remotelist <- Remote.remoteList' True + available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) + (filter (not . Remote.isXMPPRemote) remotelist) + syncRemotes' ps available syncRemotes' :: [String] -> [Remote] -> Annex [Remote] -syncRemotes' ps remotelist = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) +syncRemotes' ps available = + ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) where pickfast = (++) <$> listed <*> (filterM good (fastest available)) @@ -259,9 +265,6 @@ | otherwise = listed listed = concat <$> mapM Remote.byNameOrGroup ps - - available = filter (remoteAnnexSync . Remote.gitconfig) - $ filter (not . Remote.isXMPPRemote) remotelist good r | Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -15,6 +15,7 @@ import qualified Git.Command import qualified Annex import Config.Cost +import Config.DynamicConfig import Types.Availability import Git.Types @@ -70,10 +71,7 @@ remoteCost c d = fromMaybe d <$> remoteCost' c remoteCost' :: RemoteGitConfig -> Annex (Maybe Cost) -remoteCost' c = case remoteAnnexCostCommand c of - Just cmd | not (null cmd) -> liftIO $ - readish <$> readProcess "sh" ["-c", cmd] - _ -> return $ remoteAnnexCost c +remoteCost' = liftIO . getDynamicConfig . remoteAnnexCost setRemoteCost :: Git.Repo -> Cost -> Annex () setRemoteCost r c = setConfig (remoteConfig r "cost") (show c) diff --git a/Config/DynamicConfig.hs b/Config/DynamicConfig.hs new file mode 100644 --- /dev/null +++ b/Config/DynamicConfig.hs @@ -0,0 +1,47 @@ +{- dynamic configuration + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Config.DynamicConfig where + +import Common + +import Control.Concurrent.STM + +-- | A configuration value that may only be known after performing an IO +-- action. The IO action will only be run the first time the configuration +-- is accessed; its result is then cached. +data DynamicConfig a = DynamicConfig (IO a, TMVar a) | StaticConfig a + +mkDynamicConfig :: CommandRunner a -> Maybe String -> a -> STM (DynamicConfig a) +mkDynamicConfig _ Nothing static = return $ StaticConfig static +mkDynamicConfig cmdrunner (Just cmd) _ = do + tmvar <- newEmptyTMVar + return $ DynamicConfig (cmdrunner cmd, tmvar) + +getDynamicConfig :: DynamicConfig a -> IO a +getDynamicConfig (StaticConfig v) = return v +getDynamicConfig (DynamicConfig (a, tmvar)) = + go =<< atomically (tryReadTMVar tmvar) + where + go Nothing = do + v <- a + atomically $ do + _ <- tryTakeTMVar tmvar + putTMVar tmvar v + return v + go (Just v) = return v + +type CommandRunner a = String -> IO a + +successfullCommandRunner :: CommandRunner Bool +successfullCommandRunner cmd = boolSystem "sh" [Param "-c", Param cmd] + +unsuccessfullCommandRunner :: CommandRunner Bool +unsuccessfullCommandRunner cmd = not <$> successfullCommandRunner cmd + +readCommandRunner :: Read a => CommandRunner (Maybe a) +readCommandRunner cmd = readish <$> readProcess "sh" ["-c", cmd] diff --git a/Git/Filename.hs b/Git/Filename.hs --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -8,9 +8,10 @@ module Git.Filename where +import Common import Utility.Format (decode_c, encode_c) -import Common +import Data.Char decode :: String -> FilePath decode [] = [] @@ -23,6 +24,11 @@ encode :: FilePath -> String encode s = "\"" ++ encode_c s ++ "\"" -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode (encode s) +{- For quickcheck. + - + - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for + - why this only tests chars < 256 -} +prop_encode_decode_roundtrip :: String -> Bool +prop_encode_decode_roundtrip s = s' == decode (encode s') + where + s' = filter (\c -> ord c < 256) s diff --git a/Git/Ssh.hs b/Git/Ssh.hs --- a/Git/Ssh.hs +++ b/Git/Ssh.hs @@ -5,10 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Git.Ssh where +module Git.Ssh (module Git.Ssh, module Utility.SshHost) where import Common import Utility.Env +import Utility.SshHost import Data.Char @@ -21,9 +22,6 @@ gitSshEnvSet :: IO Bool gitSshEnvSet = anyM (isJust <$$> getEnv) [gitSshEnv, gitSshCommandEnv] --- Either a hostname, or user@host -type SshHost = String - type SshPort = Integer -- Command to run on the remote host. It is run by the shell @@ -59,8 +57,8 @@ -- Git passes exactly these parameters to the ssh command. gitps = map Param $ case mp of - Nothing -> [host, cmd] - Just p -> [host, "-p", show p, cmd] + Nothing -> [fromSshHost host, cmd] + Just p -> [fromSshHost host, "-p", show p, cmd] -- Passing any extra parameters to the ssh command may -- break some commands. diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -147,7 +147,7 @@ <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t") <*> (parseKeyVariety <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND <*> ((abs <$>) <$> arbitrary) -- size cannot be negative - <*> arbitrary + <*> ((abs . fromInteger <$>) <$> arbitrary) -- mtime cannot be negative <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative diff --git a/Logs/Activity.hs b/Logs/Activity.hs --- a/Logs/Activity.hs +++ b/Logs/Activity.hs @@ -12,8 +12,6 @@ lastActivities, ) where -import Data.Time.Clock.POSIX - import Annex.Common import qualified Annex.Branch import Logs @@ -24,9 +22,9 @@ recordActivity :: Activity -> UUID -> Annex () recordActivity act uuid = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change activityLog $ - showLog show . changeLog ts uuid act . parseLog readish + showLog show . changeLog c uuid act . parseLog readish lastActivities :: Maybe Activity -> Annex (Log Activity) lastActivities wantact = parseLog onlywanted <$> Annex.Branch.get activityLog diff --git a/Logs/Chunk.hs b/Logs/Chunk.hs --- a/Logs/Chunk.hs +++ b/Logs/Chunk.hs @@ -32,14 +32,13 @@ import qualified Annex import qualified Data.Map as M -import Data.Time.Clock.POSIX chunksStored :: UUID -> Key -> ChunkMethod -> ChunkCount -> Annex () chunksStored u k chunkmethod chunkcount = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (chunkLogFile config k) $ - showLog . changeMapLog ts (u, chunkmethod) chunkcount . parseLog + showLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog chunksRemoved :: UUID -> Key -> ChunkMethod -> Annex () chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0 diff --git a/Logs/Config.hs b/Logs/Config.hs --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -19,7 +19,6 @@ import Logs.MapLog import qualified Annex.Branch -import Data.Time.Clock.POSIX import qualified Data.Map as M type ConfigName = String @@ -33,9 +32,9 @@ setGlobalConfig' :: ConfigName -> ConfigValue -> Annex () setGlobalConfig' name new = do - now <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change configLog $ - showMapLog id id . changeMapLog now name new . parseGlobalConfig + showMapLog id id . changeMapLog c name new . parseGlobalConfig unsetGlobalConfig :: ConfigName -> Annex () unsetGlobalConfig name = do diff --git a/Logs/Difference.hs b/Logs/Difference.hs --- a/Logs/Difference.hs +++ b/Logs/Difference.hs @@ -12,7 +12,6 @@ module Logs.Difference.Pure ) where -import Data.Time.Clock.POSIX import qualified Data.Map as M import Annex.Common @@ -24,9 +23,9 @@ recordDifferences :: Differences -> UUID -> Annex () recordDifferences ds@(Differences {}) uuid = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change differenceLog $ - showLog id . changeLog ts uuid (showDifferences ds) . parseLog Just + showLog id . changeLog c uuid (showDifferences ds) . parseLog Just recordDifferences UnknownDifferences _ = return () -- Map of UUIDs that have Differences recorded. diff --git a/Logs/Group.hs b/Logs/Group.hs --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -18,7 +18,6 @@ import qualified Data.Map as M import qualified Data.Set as S -import Data.Time.Clock.POSIX import Annex.Common import Logs @@ -36,10 +35,10 @@ groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex () groupChange uuid@(UUID _) modifier = do curr <- lookupGroups uuid - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change groupLog $ showLog (unwords . S.toList) . - changeLog ts uuid (modifier curr) . + changeLog c uuid (modifier curr) . parseLog (Just . S.fromList . words) -- The changed group invalidates the preferred content cache. diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -33,6 +33,7 @@ import Logs.Presence import Annex.UUID import Annex.CatFile +import Annex.VectorClock import Git.Types (RefDate, Ref) import qualified Annex @@ -107,7 +108,10 @@ setDead' :: LogLine -> LogLine setDead' l = l { status = InfoDead - , date = date l + realToFrac (picosecondsToDiffTime 1) + , date = case date l of + VectorClock c -> VectorClock $ + c + realToFrac (picosecondsToDiffTime 1) + Unknown -> Unknown } {- Finds all keys that have location log information. diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -11,30 +11,30 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Logs.MapLog where - -import qualified Data.Map as M -import Data.Time.Clock.POSIX +module Logs.MapLog ( + module Logs.MapLog, + VectorClock, + currentVectorClock, +) where import Common -import Logs.TimeStamp +import Annex.VectorClock import Logs.Line -data TimeStamp = Unknown | Date POSIXTime - deriving (Eq, Ord, Show) +import qualified Data.Map as M data LogEntry v = LogEntry - { changed :: TimeStamp + { changed :: VectorClock , value :: v - } deriving (Eq, Show) + } deriving (Eq) type MapLog f v = M.Map f (LogEntry v) showMapLog :: (f -> String) -> (v -> String) -> MapLog f v -> String showMapLog fieldshower valueshower = unlines . map showpair . M.toList where - showpair (f, LogEntry (Date p) v) = - unwords [show p, fieldshower f, valueshower v] + showpair (f, LogEntry (VectorClock c) v) = + unwords [show c, fieldshower f, valueshower v] showpair (f, LogEntry Unknown v) = unwords ["0", fieldshower f, valueshower v] @@ -42,16 +42,16 @@ parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . splitLines where parse line = do - let (ts, rest) = splitword line + let (sc, rest) = splitword line (sf, sv) = splitword rest - date <- Date <$> parsePOSIXTime ts + c <- parseVectorClock sc f <- fieldparser sf v <- valueparser sv - Just (f, LogEntry date v) + Just (f, LogEntry c v) splitword = separate (== ' ') -changeMapLog :: Ord f => POSIXTime -> f -> v -> MapLog f v -> MapLog f v -changeMapLog t f v = M.insert f $ LogEntry (Date t) v +changeMapLog :: Ord f => VectorClock -> f -> v -> MapLog f v -> MapLog f v +changeMapLog c f v = M.insert f $ LogEntry c v {- Only add an LogEntry if it's newer (or at least as new as) than any - existing LogEntry for a field. -} @@ -69,15 +69,11 @@ | changed old > changed new = old | otherwise = new --- Unknown is oldest. -prop_TimeStamp_sane :: Bool -prop_TimeStamp_sane = Unknown < Date 1 - prop_addMapLog_sane :: Bool prop_addMapLog_sane = newWins && newestWins where - newWins = addMapLog ("foo") (LogEntry (Date 1) "new") l == l2 - newestWins = addMapLog ("foo") (LogEntry (Date 1) "newest") l2 /= l2 + newWins = addMapLog ("foo") (LogEntry (VectorClock 1) "new") l == l2 + newestWins = addMapLog ("foo") (LogEntry (VectorClock 1) "newest") l2 /= l2 - l = M.fromList [("foo", LogEntry (Date 0) "old")] - l2 = M.fromList [("foo", LogEntry (Date 1) "new")] + l = M.fromList [("foo", LogEntry (VectorClock 0) "old")] + l2 = M.fromList [("foo", LogEntry (VectorClock 1) "new")] diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -36,6 +36,7 @@ import Annex.Common import Types.MetaData import Annex.MetaData.StandardFields +import Annex.VectorClock import qualified Annex.Branch import qualified Annex import Logs @@ -44,7 +45,6 @@ import qualified Data.Set as S import qualified Data.Map as M -import Data.Time.Clock.POSIX instance SingleValueSerializable MetaData where serialize = Types.MetaData.serialize @@ -83,26 +83,29 @@ let MetaData m = value l ts = lastchangedval l in M.map (const ts) m - lastchangedval l = S.singleton $ toMetaValue $ showts $ changed l + lastchangedval l = S.singleton $ toMetaValue $ showts $ + case changed l of + VectorClock t -> t + Unknown -> 0 showts = formatPOSIXTime "%F@%H-%M-%S" {- Adds in some metadata, which can override existing values, or unset - them, but otherwise leaves any existing metadata as-is. -} addMetaData :: Key -> MetaData -> Annex () -addMetaData k metadata = addMetaData' k metadata =<< liftIO getPOSIXTime +addMetaData k metadata = addMetaData' k metadata =<< liftIO currentVectorClock -{- Reusing the same timestamp when making changes to the metadata +{- Reusing the same VectorClock when making changes to the metadata - of multiple keys is a nice optimisation. The same metadata lines - will tend to be generated across the different log files, and so - git will be able to pack the data more efficiently. -} -addMetaData' :: Key -> MetaData -> POSIXTime -> Annex () -addMetaData' k d@(MetaData m) now +addMetaData' :: Key -> MetaData -> VectorClock -> Annex () +addMetaData' k d@(MetaData m) c | d == emptyMetaData = noop | otherwise = do config <- Annex.getGitConfig Annex.Branch.change (metaDataLogFile config k) $ showLog . simplifyLog - . S.insert (LogEntry now metadata) + . S.insert (LogEntry c metadata) . parseLog where metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m diff --git a/Logs/Multicast.hs b/Logs/Multicast.hs --- a/Logs/Multicast.hs +++ b/Logs/Multicast.hs @@ -11,8 +11,6 @@ knownFingerPrints, ) where -import Data.Time.Clock.POSIX - import Annex.Common import qualified Annex.Branch import Logs @@ -25,9 +23,9 @@ recordFingerprint :: Fingerprint -> UUID -> Annex () recordFingerprint fp uuid = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change multicastLog $ - showLog show . changeLog ts uuid fp . parseLog readish + showLog show . changeLog c uuid fp . parseLog readish knownFingerPrints :: Annex (M.Map UUID Fingerprint) knownFingerPrints = simpleMap . parseLog readish <$> Annex.Branch.get activityLog diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -7,9 +7,6 @@ module Logs.PreferredContent.Raw where -import qualified Data.Map as M -import Data.Time.Clock.POSIX - import Annex.Common import qualified Annex.Branch import qualified Annex @@ -19,6 +16,8 @@ import Types.StandardGroups import Types.Group +import qualified Data.Map as M + {- Changes the preferred content configuration of a remote. -} preferredContentSet :: UUID -> PreferredContentExpression -> Annex () preferredContentSet = setLog preferredContentLog @@ -28,10 +27,10 @@ setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change logfile $ showLog id - . changeLog ts uuid val + . changeLog c uuid val . parseLog Just Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing @@ -42,10 +41,10 @@ {- Changes the preferred content configuration of a group. -} groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex () groupPreferredContentSet g val = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change groupPreferredContentLog $ showMapLog id id - . changeMapLog ts g val + . changeMapLog c g val . parseMapLog Just Just Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -22,10 +22,9 @@ historicalLogInfo, ) where -import Data.Time.Clock.POSIX - import Logs.Presence.Pure as X import Annex.Common +import Annex.VectorClock import qualified Annex.Branch import Git.Types (RefDate) @@ -49,11 +48,11 @@ readLog :: FilePath -> Annex [LogLine] readLog = parseLog <$$> Annex.Branch.get -{- Generates a new LogLine with the current date. -} +{- Generates a new LogLine with the current time. -} logNow :: LogStatus -> String -> Annex LogLine logNow s i = do - now <- liftIO getPOSIXTime - return $ LogLine now s i + c <- liftIO currentVectorClock + return $ LogLine c s i {- Reads a log and returns only the info that is still in effect. -} currentLogInfo :: FilePath -> Annex [String] diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -7,20 +7,22 @@ module Logs.Presence.Pure where -import Data.Time.Clock.POSIX -import qualified Data.Map as M - import Annex.Common -import Logs.TimeStamp +import Annex.VectorClock import Logs.Line import Utility.QuickCheck -data LogLine = LogLine { - date :: POSIXTime, - status :: LogStatus, - info :: String -} deriving (Eq, Show) +import qualified Data.Map as M +data LogLine = LogLine + { date :: VectorClock + , status :: LogStatus + , info :: String + } deriving (Eq) + +instance Show LogLine where + show l = "LogLine " ++ formatVectorClock (date l) ++ show (status l) ++ " " ++ show (info l) + data LogStatus = InfoPresent | InfoMissing | InfoDead deriving (Eq, Show, Bounded, Enum) @@ -29,12 +31,12 @@ parseLog = mapMaybe parseline . splitLines where parseline l = LogLine - <$> parsePOSIXTime d + <$> parseVectorClock c <*> parseStatus s <*> pure rest where - (d, pastd) = separate (== ' ') l - (s, rest) = separate (== ' ') pastd + (c, pastc) = separate (== ' ') l + (s, rest) = separate (== ' ') pastc parseStatus :: String -> Maybe LogStatus parseStatus "1" = Just InfoPresent @@ -46,7 +48,7 @@ showLog :: [LogLine] -> String showLog = unlines . map genline where - genline (LogLine d s i) = unwords [show d, genstatus s, i] + genline (LogLine c s i) = unwords [formatVectorClock c, genstatus s, i] genstatus InfoPresent = "1" genstatus InfoMissing = "0" genstatus InfoDead = "X" diff --git a/Logs/Remote.hs b/Logs/Remote.hs --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -18,22 +18,21 @@ prop_parse_show_Config, ) where -import qualified Data.Map as M -import Data.Time.Clock.POSIX -import Data.Char - import Annex.Common import qualified Annex.Branch import Types.Remote import Logs import Logs.UUIDBased +import qualified Data.Map as M +import Data.Char + {- Adds or updates a remote's config in the log. -} configSet :: UUID -> RemoteConfig -> Annex () -configSet u c = do - ts <- liftIO getPOSIXTime +configSet u cfg = do + c <- liftIO currentVectorClock Annex.Branch.change remoteLog $ - showLog showConfig . changeLog ts u c . parseLog parseConfig + showLog showConfig . changeLog c u cfg . parseLog parseConfig {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig) diff --git a/Logs/RemoteState.hs b/Logs/RemoteState.hs --- a/Logs/RemoteState.hs +++ b/Logs/RemoteState.hs @@ -17,16 +17,15 @@ import qualified Annex import qualified Data.Map as M -import Data.Time.Clock.POSIX type RemoteState = String setRemoteState :: UUID -> Key -> RemoteState -> Annex () setRemoteState u k s = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (remoteStateLogFile config k) $ - showLogNew id . changeLog ts u s . parseLogNew Just + showLogNew id . changeLog c u s . parseLogNew Just getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState) getRemoteState u k = do diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -19,7 +19,6 @@ import qualified Data.Map as M import qualified Data.Set as S -import Data.Time.Clock.POSIX import Data.Time.LocalTime import Annex.Common @@ -31,9 +30,9 @@ scheduleSet :: UUID -> [ScheduledActivity] -> Annex () scheduleSet uuid@(UUID _) activities = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change scheduleLog $ - showLog id . changeLog ts uuid val . parseLog Just + showLog id . changeLog c uuid val . parseLog Just where val = fromScheduledActivities activities scheduleSet NoUUID _ = error "unknown UUID; cannot modify" diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -15,36 +15,35 @@ import Annex.Common import qualified Annex.Branch -import Logs.TimeStamp import Logs.Line +import Annex.VectorClock import qualified Data.Set as S -import Data.Time.Clock.POSIX class SingleValueSerializable v where serialize :: v -> String deserialize :: String -> Maybe v data LogEntry v = LogEntry - { changed :: POSIXTime + { changed :: VectorClock , value :: v - } deriving (Eq, Show, Ord) + } deriving (Eq, Ord) type Log v = S.Set (LogEntry v) showLog :: (SingleValueSerializable v) => Log v -> String showLog = unlines . map showline . S.toList where - showline (LogEntry t v) = unwords [show t, serialize v] + showline (LogEntry c v) = unwords [formatVectorClock c, serialize v] parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v parseLog = S.fromList . mapMaybe parse . splitLines where parse line = do - let (ts, s) = splitword line - date <- parsePOSIXTime ts + let (sc, s) = splitword line + c <- parseVectorClock sc v <- deserialize s - Just (LogEntry date v) + Just (LogEntry c v) splitword = separate (== ' ') newestValue :: Log v -> Maybe v @@ -60,6 +59,6 @@ setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex () setLog f v = do - now <- liftIO getPOSIXTime - let ent = LogEntry now v + c <- liftIO currentVectorClock + let ent = LogEntry c v Annex.Branch.change f $ \_old -> showLog (S.singleton ent) diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -14,13 +14,12 @@ module Logs.Transitions where -import Data.Time.Clock.POSIX -import qualified Data.Set as S - import Annex.Common -import Logs.TimeStamp +import Annex.VectorClock import Logs.Line +import qualified Data.Set as S + transitionsLog :: FilePath transitionsLog = "transitions.log" @@ -30,9 +29,9 @@ deriving (Show, Ord, Eq, Read) data TransitionLine = TransitionLine - { transitionStarted :: POSIXTime + { transitionStarted :: VectorClock , transition :: Transition - } deriving (Show, Ord, Eq) + } deriving (Ord, Eq) type Transitions = S.Set TransitionLine @@ -43,8 +42,8 @@ noTransitions :: Transitions noTransitions = S.empty -addTransition :: POSIXTime -> Transition -> Transitions -> Transitions -addTransition ts t = S.insert $ TransitionLine ts t +addTransition :: VectorClock -> Transition -> Transitions -> Transitions +addTransition c t = S.insert $ TransitionLine c t showTransitions :: Transitions -> String showTransitions = unlines . map showTransitionLine . S.elems @@ -63,16 +62,16 @@ badsource = giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!" showTransitionLine :: TransitionLine -> String -showTransitionLine (TransitionLine ts t) = unwords [show t, show ts] +showTransitionLine (TransitionLine c t) = unwords [show t, formatVectorClock c] parseTransitionLine :: String -> Maybe TransitionLine parseTransitionLine s = TransitionLine - <$> parsePOSIXTime ds + <$> parseVectorClock cs <*> readish ts where ws = words s ts = Prelude.head ws - ds = unwords $ Prelude.tail ws + cs = unwords $ Prelude.tail ws combineTransitions :: [Transitions] -> Transitions combineTransitions = S.unions diff --git a/Logs/Trust/Basic.hs b/Logs/Trust/Basic.hs --- a/Logs/Trust/Basic.hs +++ b/Logs/Trust/Basic.hs @@ -11,8 +11,6 @@ trustMapRaw, ) where -import Data.Time.Clock.POSIX - import Annex.Common import Types.TrustLevel import qualified Annex.Branch @@ -24,10 +22,10 @@ {- Changes the trust level for a uuid in the trustLog. -} trustSet :: UUID -> TrustLevel -> Annex () trustSet uuid@(UUID _) level = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change trustLog $ showLog showTrustLog . - changeLog ts uuid level . + changeLog c uuid level . parseLog (Just . parseTrustLog) Annex.changeState $ \s -> s { Annex.trustmap = Nothing } trustSet NoUUID _ = error "unknown UUID; cannot modify" diff --git a/Logs/UUID.hs b/Logs/UUID.hs --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -21,23 +21,23 @@ uuidMapLoad ) where -import qualified Data.Map as M -import Data.Time.Clock.POSIX - import Types.UUID import Annex.Common +import Annex.VectorClock import qualified Annex import qualified Annex.Branch import Logs import Logs.UUIDBased import qualified Annex.UUID +import qualified Data.Map as M + {- Records a description for a uuid in the log. -} describeUUID :: UUID -> String -> Annex () describeUUID uuid desc = do - ts <- liftIO getPOSIXTime + c <- liftIO currentVectorClock Annex.Branch.change uuidLog $ - showLog id . changeLog ts uuid desc . fixBadUUID . parseLog Just + showLog id . changeLog c uuid desc . fixBadUUID . parseLog Just {- Temporarily here to fix badly formatted uuid logs generated by - versions 3.20111105 and 3.20111025. @@ -52,7 +52,7 @@ fixBadUUID = M.fromList . map fixup . M.toList where fixup (k, v) - | isbad = (fixeduuid, LogEntry (Date $ newertime v) fixedvalue) + | isbad = (fixeduuid, LogEntry (newertime v) fixedvalue) | otherwise = (k, v) where kuuid = fromUUID k @@ -63,8 +63,8 @@ fixedvalue = unwords $ kuuid: Prelude.init ws -- For the fixed line to take precidence, it should be -- slightly newer, but only slightly. - newertime (LogEntry (Date d) _) = d + minimumPOSIXTimeSlice - newertime (LogEntry Unknown _) = minimumPOSIXTimeSlice + newertime (LogEntry (VectorClock c) _) = VectorClock (c + minimumPOSIXTimeSlice) + newertime (LogEntry Unknown _) = VectorClock minimumPOSIXTimeSlice minimumPOSIXTimeSlice = 0.000001 isuuid s = length s == 36 && length (splitc '-' s) == 5 diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -17,7 +17,8 @@ module Logs.UUIDBased ( Log, LogEntry(..), - TimeStamp(..), + VectorClock, + currentVectorClock, parseLog, parseLogNew, parseLogWithUUID, @@ -29,12 +30,11 @@ ) where import qualified Data.Map as M -import Data.Time.Clock.POSIX import Common import Types.UUID +import Annex.VectorClock import Logs.MapLog -import Logs.TimeStamp import Logs.Line type Log v = MapLog UUID v @@ -42,8 +42,8 @@ showLog :: (v -> String) -> Log v -> String showLog shower = unlines . map showpair . M.toList where - showpair (k, LogEntry (Date p) v) = - unwords [fromUUID k, shower v, tskey ++ show p] + showpair (k, LogEntry (VectorClock c) v) = + unwords [fromUUID k, shower v, tskey ++ show c] showpair (k, LogEntry Unknown v) = unwords [fromUUID k, shower v] @@ -67,15 +67,12 @@ u = toUUID $ Prelude.head ws t = Prelude.last ws ts - | tskey `isPrefixOf` t = - pdate $ drop 1 $ dropWhile (/= '=') t + | tskey `isPrefixOf` t = fromMaybe Unknown $ + parseVectorClock $ drop 1 $ dropWhile (/= '=') t | otherwise = Unknown info | ts == Unknown = drop 1 ws | otherwise = drop 1 $ beginning ws - pdate s = case parsePOSIXTime s of - Nothing -> Unknown - Just d -> Date d showLogNew :: (v -> String) -> Log v -> String showLogNew = showMapLog fromUUID @@ -83,7 +80,7 @@ parseLogNew :: (String -> Maybe v) -> String -> Log v parseLogNew = parseMapLog (Just . toUUID) -changeLog :: POSIXTime -> UUID -> v -> Log v -> Log v +changeLog :: VectorClock -> UUID -> v -> Log v -> Log v changeLog = changeMapLog addLog :: UUID -> LogEntry v -> Log v -> Log v diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -70,6 +70,7 @@ import Logs.Web import Remote.List import Config +import Config.DynamicConfig import Git.Types (RemoteName) import qualified Git @@ -120,12 +121,13 @@ where checkuuid Nothing = return Nothing checkuuid (Just r) - | uuid r == NoUUID = giveup $ - if remoteAnnexIgnore (gitconfig r) - then noRemoteUUIDMsg r ++ + | uuid r == NoUUID = + ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore (gitconfig r)) + ( giveup $ noRemoteUUIDMsg r ++ " (" ++ show (remoteConfig (repo r) "ignore") ++ " is set)" - else noRemoteUUIDMsg r + , giveup $ noRemoteUUIDMsg r + ) | otherwise = return $ Just r byName' :: RemoteName -> Annex (Either String Remote) @@ -292,8 +294,8 @@ let validtrustedlocations = nub locations `intersect` trusted -- remotes that match uuids that have the key - allremotes <- filter (not . remoteAnnexIgnore . gitconfig) - <$> remoteList + allremotes <- remoteList + >>= filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) let validremotes = remotesWithUUID allremotes locations return (sortBy (comparing cost) validremotes, validtrustedlocations) @@ -313,7 +315,8 @@ let msg = message ppuuidswanted ppuuidsskipped unless (null msg) $ showLongNote msg - ignored <- filter (remoteAnnexIgnore . gitconfig) <$> remoteList + ignored <- remoteList + >>= filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) unless (null ignored) $ showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")" where diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -21,6 +21,7 @@ import Remote.Helper.Special import Annex.Ssh import Annex.UUID +import Utility.SshHost data DdarRepo = DdarRepo { ddarRepoConfig :: RemoteGitConfig @@ -109,9 +110,8 @@ liftIO $ boolSystem "ddar" params {- Convert remote DdarRepo to host and path on remote end -} -splitRemoteDdarRepo :: DdarRepo -> (String, String) -splitRemoteDdarRepo ddarrepo = - (host, ddarrepo') +splitRemoteDdarRepo :: DdarRepo -> (SshHost, String) +splitRemoteDdarRepo ddarrepo = (either error id $ mkSshHost host, ddarrepo') where (host, remainder) = span (/= ':') (ddarRepoLocation ddarrepo) ddarrepo' = drop 1 remainder diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -134,7 +134,7 @@ store :: External -> Storer store external = fileStorer $ \k f p -> - handleRequest external (TRANSFER Upload k f) (Just p) $ \resp -> + handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Upload k' | k == k' -> Just $ return True @@ -146,7 +146,7 @@ retrieve :: External -> Retriever retrieve external = fileRetriever $ \d k p -> - handleRequest external (TRANSFER Download k d) (Just p) $ \resp -> + handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Download k' | k == k' -> Just $ return () @@ -156,7 +156,7 @@ remove :: External -> Remover remove external k = safely $ - handleRequest external (REMOVE k) Nothing $ \resp -> + handleRequestKey external REMOVE k Nothing $ \resp -> case resp of REMOVE_SUCCESS k' | k == k' -> Just $ return True @@ -169,7 +169,7 @@ checkKey :: External -> CheckPresent checkKey external k = either giveup id <$> go where - go = handleRequest external (CHECKPRESENT k) Nothing $ \resp -> + go = handleRequestKey external CHECKPRESENT k Nothing $ \resp -> case resp of CHECKPRESENT_SUCCESS k' | k' == k -> Just $ return $ Right True @@ -180,7 +180,7 @@ _ -> Nothing whereis :: External -> Key -> Annex [String] -whereis external k = handleRequest external (WHEREIS k) Nothing $ \resp -> case resp of +whereis external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of WHEREIS_SUCCESS s -> Just $ return [s] WHEREIS_FAILURE -> Just $ return [] UNSUPPORTED_REQUEST -> Just $ return [] @@ -211,6 +211,11 @@ handleRequest external req mp responsehandler = withExternalState external $ \st -> handleRequest' st external req mp responsehandler + +handleRequestKey :: External -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a +handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of + Right sk -> handleRequest external (mkreq sk) mp responsehandler + Left e -> giveup e handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a handleRequest' st external req mp responsehandler diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -18,6 +18,8 @@ Proto.Sendable(..), Proto.Receivable(..), Request(..), + SafeKey, + mkSafeKey, needsPREPARE, Response(..), RemoteRequest(..), @@ -36,11 +38,13 @@ import Config.Cost (Cost) import Types.Remote (RemoteConfig) import Types.Availability (Availability(..)) +import Types.Key import Utility.Url (URLString) import qualified Utility.SimpleProtocol as Proto import Control.Concurrent.STM import Network.URI +import Data.Char data External = External { externalType :: ExternalType @@ -77,6 +81,29 @@ data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg +-- The protocol does not support keys with spaces in their names; +-- SafeKey can only be constructed for keys that are safe to use with the +-- protocol. +newtype SafeKey = SafeKey Key + deriving (Show) + +mkSafeKey :: Key -> Either String SafeKey +mkSafeKey k + | any isSpace (keyName k) = Left $ concat + [ "Sorry, this file cannot be stored on an external special remote because its key's name contains a space. " + , "To avoid this problem, you can run: git-annex migrate --backend=" + , formatKeyVariety (keyVariety k) + , " and pass it the name of the file" + ] + | otherwise = Right (SafeKey k) + +fromSafeKey :: SafeKey -> Key +fromSafeKey (SafeKey k) = k + +instance Proto.Serializable SafeKey where + serialize = Proto.serialize . fromSafeKey + deserialize = fmap SafeKey . Proto.deserialize + -- Messages that can be sent to the external remote to request it do something. data Request = PREPARE @@ -85,10 +112,10 @@ | GETAVAILABILITY | CLAIMURL URLString | CHECKURL URLString - | TRANSFER Direction Key FilePath - | CHECKPRESENT Key - | REMOVE Key - | WHEREIS Key + | TRANSFER Direction SafeKey FilePath + | CHECKPRESENT SafeKey + | REMOVE SafeKey + | WHEREIS SafeKey deriving (Show) -- Does PREPARE need to have been sent before this request? diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -48,6 +48,7 @@ import Utility.Tmp import Logs.Remote import Utility.Gpg +import Utility.SshHost remote :: RemoteType remote = RemoteType { @@ -158,8 +159,9 @@ let rsyncpath = if "/~/" `isPrefixOf` path then drop 3 path else path - opts <- sshOptions ConsumeStdin (host, Nothing) gc [] - return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ rsyncpath, AccessShell) + let sshhost = either error id (mkSshHost host) + opts <- sshOptions ConsumeStdin (sshhost, Nothing) gc [] + return (rsyncShell $ Param "ssh" : opts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessShell) othertransport = return ([], loc, AccessDirect) noCrypto :: Annex a @@ -227,7 +229,8 @@ setupRepo :: Git.GCrypt.GCryptId -> Git.Repo -> Annex AccessMethod setupRepo gcryptid r | Git.repoIsUrl r = do - (_, _, accessmethod) <- rsyncTransport r def + dummycfg <- liftIO dummyRemoteGitConfig + (_, _, accessmethod) <- rsyncTransport r dummycfg case accessmethod of AccessDirect -> rsyncsetup AccessShell -> ifM gitannexshellsetup @@ -249,7 +252,8 @@ -} rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do liftIO $ createDirectoryIfMissing True $ tmp objectDir - (rsynctransport, rsyncurl, _) <- rsyncTransport r def + dummycfg <- liftIO dummyRemoteGitConfig + (rsynctransport, rsyncurl, _) <- rsyncTransport r dummycfg let tmpconfig = tmp "config" void $ liftIO $ rsync $ rsynctransport ++ [ Param $ rsyncurl ++ "/config" @@ -389,8 +393,10 @@ toAccessMethod _ = AccessDirect getGCryptUUID :: Bool -> Git.Repo -> Annex (Maybe UUID) -getGCryptUUID fast r = (genUUIDInNameSpace gCryptNameSpace <$>) . fst - <$> getGCryptId fast r def +getGCryptUUID fast r = do + dummycfg <- liftIO dummyRemoteGitConfig + (genUUIDInNameSpace gCryptNameSpace <$>) . fst + <$> getGCryptId fast r dummycfg coreGCryptId :: String coreGCryptId = "core.gcrypt-id" diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -35,6 +35,7 @@ import Utility.Tmp import Config import Config.Cost +import Config.DynamicConfig import Annex.Init import Annex.Version import Types.CleanupActions @@ -128,7 +129,8 @@ configRead autoinit r = do gc <- Annex.getRemoteGitConfig r u <- getRepoUUID r - case (repoCheap r, remoteAnnexIgnore gc, u) of + annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc) + case (repoCheap r, annexignore, u) of (_, True, _) -> return r (True, _, _) -> tryGitConfigRead autoinit r (False, _, NoUUID) -> tryGitConfigRead autoinit r diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -19,13 +19,17 @@ import Messages.Progress import Utility.Metered import Utility.Rsync +import Utility.SshHost import Types.Remote import Types.Transfer import Config toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam]) toRepo cs r gc remotecmd = do - let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r + let host = maybe + (giveup "bad ssh url") + (either error id . mkSshHost) + (Git.Url.hostuser r) sshCommand cs (host, Git.Url.port r) gc remotecmd {- Generates parameters to run a git-annex-shell command on a remote diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -38,6 +38,7 @@ import Types.Creds import Annex.DirHashes import Utility.Tmp +import Utility.SshHost import qualified Data.Map as M @@ -120,7 +121,8 @@ case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of "ssh":sshopts -> do let (port, sshopts') = sshReadPort sshopts - userhost = takeWhile (/=':') url + userhost = either error id $ mkSshHost $ + takeWhile (/= ':') url (Param "ssh":) <$> sshOptions ConsumeStdin (userhost, port) gc (map Param $ loginopt ++ sshopts') diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -23,7 +23,7 @@ import Data.Char import Network.Socket (HostName) import Network.HTTP.Conduit (Manager, newManager) -import Network.HTTP.Client (managerResponseTimeout, responseStatus, responseBody, RequestBody(..)) +import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..)) import Network.HTTP.Types import Control.Monad.Trans.Resource import Control.Monad.Catch @@ -50,13 +50,6 @@ import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, managerSettings, closeManager) -#if MIN_VERSION_http_client(0,5,0) -import Network.HTTP.Client (responseTimeoutNone) -#else -responseTimeoutNone :: Maybe Int -responseTimeoutNone = Nothing -#endif - type BucketName = String remote :: RemoteType @@ -441,13 +434,11 @@ Just creds -> do awscreds <- liftIO $ genCredentials creds let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper - bracketIO (newManager httpcfg) closeManager $ \mgr -> + bracketIO (newManager managerSettings) closeManager $ \mgr -> a $ Just $ S3Handle mgr awscfg s3cfg Nothing -> a Nothing where s3cfg = s3Configuration c - httpcfg = managerSettings - { managerResponseTimeout = responseTimeoutNone } s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration c = cfg diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -10,6 +10,7 @@ import qualified Annex import Common import Types.GitConfig +import Config.DynamicConfig import RemoteDaemon.Common import RemoteDaemon.Types import RemoteDaemon.Transport @@ -139,19 +140,21 @@ genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan = M.fromList . catMaybes <$> mapM gen (Git.remotes g) where - gen r = case Git.location r of - Git.Url u -> case M.lookup (uriScheme u) remoteTransports of - Just transport - | remoteAnnexSync gc -> do - ichan <- newTChanIO :: IO (TChan Consumed) - return $ Just - ( r - , (transport (RemoteRepo r gc) (RemoteURI u) h ichan ochan, ichan) - ) + gen r = do + gc <- atomically $ extractRemoteGitConfig g (Git.repoDescribe r) + case Git.location r of + Git.Url u -> case M.lookup (uriScheme u) remoteTransports of + Just transport -> ifM (getDynamicConfig (remoteAnnexSync gc)) + ( do + ichan <- newTChanIO :: IO (TChan Consumed) + return $ Just + ( r + , (transport (RemoteRepo r gc) (RemoteURI u) h ichan ochan, ichan) + ) + , return Nothing + ) + Nothing -> return Nothing _ -> return Nothing - _ -> return Nothing - where - gc = extractRemoteGitConfig g (Git.repoDescribe r) genTransportHandle :: IO TransportHandle genTransportHandle = do diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -34,6 +34,7 @@ import qualified Data.Map as M import qualified Data.Aeson import qualified Data.ByteString.Lazy.UTF8 as BU8 +import System.Environment import Common import CmdLine.GitAnnex.Options @@ -51,6 +52,7 @@ import qualified Git.LsTree import qualified Git.FilePath import qualified Annex.Locations +import qualified Types.GitConfig import qualified Types.KeySource import qualified Types.Backend import qualified Types.TrustLevel @@ -70,12 +72,14 @@ import qualified Config import qualified Config.Cost import qualified Crypto +import qualified Database.Keys import qualified Annex.WorkTree import qualified Annex.Link import qualified Annex.Init import qualified Annex.CatFile import qualified Annex.Path import qualified Annex.AdjustedBranch +import qualified Annex.VectorClock import qualified Annex.View import qualified Annex.View.ViewedFile import qualified Logs.View @@ -125,8 +129,23 @@ where go opts | fakeSsh opts = runFakeSsh (internalData opts) - | otherwise = runtests opts - runtests opts = isolateGitConfig $ do + | otherwise = runsubprocesstests opts + =<< Utility.Env.getEnv subenv + + -- Run git-annex test in a subprocess, so that any files + -- it may open will be closed before running finalCleanup. + -- This should prevent most failures to clean up after the test + -- suite. + subenv = "GIT_ANNEX_TEST_SUBPROCESS" + runsubprocesstests opts Nothing = do + pp <- Annex.Path.programPath + Utility.Env.setEnv subenv "1" True + ps <- getArgs + (Nothing, Nothing, Nothing, pid) <-createProcess (proc pp ps) + exitcode <- waitForProcess pid + unless (keepFailuresOption opts) finalCleanup + exitWith exitcode + runsubprocesstests opts (Just _) = isolateGitConfig $ do ensuretmpdir crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of @@ -134,7 +153,7 @@ Just act -> ifM act ( exitSuccess , do - putStrLn " (This could be due to a bug in git-annex, or an incompatibility" + putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility" putStrLn " with utilities, such as git, installed on this system.)" exitFailure ) @@ -161,8 +180,8 @@ properties :: TestTree properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" - [ testProperty "prop_isomorphic_deencode_git" Git.Filename.prop_isomorphic_deencode - , testProperty "prop_isomorphic_deencode" Utility.Format.prop_isomorphic_deencode + [ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip + , testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip , testProperty "prop_isomorphic_fileKey" Annex.Locations.prop_isomorphic_fileKey , testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode , testProperty "prop_isomorphic_key_decode" Key.prop_isomorphic_key_decode @@ -176,7 +195,7 @@ , testProperty "prop_cost_sane" Config.Cost.prop_cost_sane , testProperty "prop_matcher_sane" Utility.Matcher.prop_matcher_sane , testProperty "prop_HmacSha1WithCipher_sane" Crypto.prop_HmacSha1WithCipher_sane - , testProperty "prop_TimeStamp_sane" Logs.MapLog.prop_TimeStamp_sane + , testProperty "prop_VectorClock_sane" Annex.VectorClock.prop_VectorClock_sane , testProperty "prop_addMapLog_sane" Logs.MapLog.prop_addMapLog_sane , testProperty "prop_verifiable_sane" Utility.Verifiable.prop_verifiable_sane , testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest @@ -651,6 +670,7 @@ git_annex "get" [annexedfile] @? "get of file failed" git_annex "unlock" [annexedfile] @? "unlock failed in v6 mode" annexeval $ do + Database.Keys.closeDb dbdir <- Annex.fromRepo Annex.Locations.gitAnnexKeysDb liftIO $ removeDirectoryRecursive dbdir writeFile annexedfile "test_lock_v6_force content" @@ -1623,7 +1643,6 @@ testscheme "pubkey" where gpgcmd = Utility.Gpg.mkGpgCmd Nothing - encparams = (mempty :: Types.Remote.RemoteConfig, def :: Types.RemoteGitConfig) testscheme scheme = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do Utility.Gpg.testTestHarness gpgcmd @? "test harness self-test failed" @@ -1679,6 +1698,8 @@ checkScheme Types.Crypto.Hybrid = scheme == "hybrid" checkScheme Types.Crypto.PubKey = scheme == "pubkey" checkKeys cip mvariant = do + dummycfg <- Types.GitConfig.dummyRemoteGitConfig + let encparams = (mempty :: Types.Remote.RemoteConfig, dummycfg) cipher <- Crypto.decryptCipher gpgcmd encparams cip files <- filterM doesFileExist $ map ("dir" ) $ concatMap (key2files cipher) keys @@ -1912,20 +1933,24 @@ a cleanup :: FilePath -> IO () -cleanup = cleanup' False - -cleanup' :: Bool -> FilePath -> IO () -cleanup' final dir = whenM (doesDirectoryExist dir) $ do +cleanup dir = whenM (doesDirectoryExist dir) $ do Command.Uninit.prepareRemoveAnnexDir' dir - -- This sometimes fails on Windows, due to some files - -- being still opened by a subprocess. - catchIO (removeDirectoryRecursive dir) $ \e -> - when final $ do - print e - putStrLn "sleeping 10 seconds and will retry directory cleanup" - Utility.ThreadScheduler.threadDelaySeconds (Utility.ThreadScheduler.Seconds 10) - whenM (doesDirectoryExist dir) $ - removeDirectoryRecursive dir + -- This can fail if files in the directory are still open by a + -- subprocess. + void $ tryIO $ removeDirectoryRecursive dir + +finalCleanup :: IO () +finalCleanup = whenM (doesDirectoryExist tmpdir) $ do + Utility.Misc.reapZombies + Command.Uninit.prepareRemoveAnnexDir' tmpdir + catchIO (removeDirectoryRecursive tmpdir) $ \e -> do + print e + putStrLn "sleeping 10 seconds and will retry directory cleanup" + Utility.ThreadScheduler.threadDelaySeconds $ + Utility.ThreadScheduler.Seconds 10 + whenM (doesDirectoryExist tmpdir) $ do + Utility.Misc.reapZombies + removeDirectoryRecursive tmpdir checklink :: FilePath -> Assertion checklink f = @@ -2083,11 +2108,7 @@ Just act -> unlessM act $ error "init tests failed! cannot continue" return () - release _ - | keepFailures testmode = void $ tryIO $ do - cleanup' True mainrepodir - removeDirectory tmpdir - | otherwise = cleanup' True tmpdir + release _ = cleanup mainrepodir setTestMode :: TestMode -> IO () setTestMode testmode = do diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -12,6 +12,7 @@ mergeGitConfig, RemoteGitConfig(..), extractRemoteGitConfig, + dummyRemoteGitConfig, ) where import Common @@ -27,11 +28,15 @@ import Types.NumCopies import Types.Difference import Types.RefSpec +import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd) import Utility.ThreadScheduler (Seconds(..)) --- | A configurable value, that may not be fully determined yet. +import Control.Concurrent.STM + +-- | A configurable value, that may not be fully determined yet because +-- the global git config has not yet been loaded. data Configurable a = HasConfig a -- ^ Value is fully determined. @@ -187,10 +192,9 @@ - key such as .annex-foo, or if that is not set, a default from - annex.foo -} data RemoteGitConfig = RemoteGitConfig - { remoteAnnexCost :: Maybe Cost - , remoteAnnexCostCommand :: Maybe String - , remoteAnnexIgnore :: Bool - , remoteAnnexSync :: Bool + { remoteAnnexCost :: DynamicConfig (Maybe Cost) + , remoteAnnexIgnore :: DynamicConfig Bool + , remoteAnnexSync :: DynamicConfig Bool , remoteAnnexPull :: Bool , remoteAnnexPush :: Bool , remoteAnnexReadOnly :: Bool @@ -224,41 +228,50 @@ , remoteGitConfig :: GitConfig } -extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig -extractRemoteGitConfig r remotename = RemoteGitConfig - { remoteAnnexCost = getmayberead "cost" - , remoteAnnexCostCommand = notempty $ getmaybe "cost-command" - , remoteAnnexIgnore = getbool "ignore" False - , remoteAnnexSync = getbool "sync" True - , remoteAnnexPull = getbool "pull" True - , remoteAnnexPush = getbool "push" True - , remoteAnnexReadOnly = getbool "readonly" False - , remoteAnnexVerify = getbool "verify" True - , remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" - , remoteAnnexStartCommand = notempty $ getmaybe "start-command" - , remoteAnnexStopCommand = notempty $ getmaybe "stop-command" - , remoteAnnexAvailability = getmayberead "availability" - , remoteAnnexBare = getmaybebool "bare" - - , remoteAnnexShell = getmaybe "shell" - , remoteAnnexSshOptions = getoptions "ssh-options" - , remoteAnnexRsyncOptions = getoptions "rsync-options" - , remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options" - , remoteAnnexRsyncUploadOptions = getoptions "rsync-upload-options" - , remoteAnnexRsyncTransport = getoptions "rsync-transport" - , remoteAnnexGnupgOptions = getoptions "gnupg-options" - , remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options" - , remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" - , remoteAnnexBupRepo = getmaybe "buprepo" - , remoteAnnexTahoe = getmaybe "tahoe" - , remoteAnnexBupSplitOptions = getoptions "bup-split-options" - , remoteAnnexDirectory = notempty $ getmaybe "directory" - , remoteAnnexGCrypt = notempty $ getmaybe "gcrypt" - , remoteAnnexDdarRepo = getmaybe "ddarrepo" - , remoteAnnexHookType = notempty $ getmaybe "hooktype" - , remoteAnnexExternalType = notempty $ getmaybe "externaltype" - , remoteGitConfig = extractGitConfig r - } +extractRemoteGitConfig :: Git.Repo -> String -> STM RemoteGitConfig +extractRemoteGitConfig r remotename = do + annexcost <- mkDynamicConfig readCommandRunner + (notempty $ getmaybe "cost-command") + (getmayberead "cost") + annexignore <- mkDynamicConfig unsuccessfullCommandRunner + (notempty $ getmaybe "ignore-command") + (getbool "ignore" False) + annexsync <- mkDynamicConfig successfullCommandRunner + (notempty $ getmaybe "sync-command") + (getbool "sync" True) + return $ RemoteGitConfig + { remoteAnnexCost = annexcost + , remoteAnnexIgnore = annexignore + , remoteAnnexSync = annexsync + , remoteAnnexPull = getbool "pull" True + , remoteAnnexPush = getbool "push" True + , remoteAnnexReadOnly = getbool "readonly" False + , remoteAnnexVerify = getbool "verify" True + , remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" + , remoteAnnexStartCommand = notempty $ getmaybe "start-command" + , remoteAnnexStopCommand = notempty $ getmaybe "stop-command" + , remoteAnnexAvailability = getmayberead "availability" + , remoteAnnexBare = getmaybebool "bare" + + , remoteAnnexShell = getmaybe "shell" + , remoteAnnexSshOptions = getoptions "ssh-options" + , remoteAnnexRsyncOptions = getoptions "rsync-options" + , remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options" + , remoteAnnexRsyncUploadOptions = getoptions "rsync-upload-options" + , remoteAnnexRsyncTransport = getoptions "rsync-transport" + , remoteAnnexGnupgOptions = getoptions "gnupg-options" + , remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options" + , remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" + , remoteAnnexBupRepo = getmaybe "buprepo" + , remoteAnnexTahoe = getmaybe "tahoe" + , remoteAnnexBupSplitOptions = getoptions "bup-split-options" + , remoteAnnexDirectory = notempty $ getmaybe "directory" + , remoteAnnexGCrypt = notempty $ getmaybe "gcrypt" + , remoteAnnexDdarRepo = getmaybe "ddarrepo" + , remoteAnnexHookType = notempty $ getmaybe "hooktype" + , remoteAnnexExternalType = notempty $ getmaybe "externaltype" + , remoteGitConfig = extractGitConfig r + } where getbool k d = fromMaybe d $ getmaybebool k getmaybebool k = Git.Config.isTrue =<< getmaybe k @@ -275,5 +288,6 @@ notempty (Just "") = Nothing notempty (Just s) = Just s -instance Default RemoteGitConfig where - def = extractRemoteGitConfig Git.Construct.fromUnknown "dummy" +dummyRemoteGitConfig :: IO RemoteGitConfig +dummyRemoteGitConfig = atomically $ + extractRemoteGitConfig Git.Construct.fromUnknown "dummy" diff --git a/Utility/Format.hs b/Utility/Format.hs --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -11,7 +11,7 @@ format, decode_c, encode_c, - prop_isomorphic_deencode + prop_encode_c_decode_c_roundtrip ) where import Text.Printf (printf) @@ -100,8 +100,8 @@ empty (Const "") = True empty _ = False -{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal - - encoded character, and \xNN is a hex encoded character. +{- Decodes a C-style encoding, where \n is a newline (etc), + - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} decode_c :: FormatString -> String decode_c [] = [] @@ -173,6 +173,15 @@ e_asc c = showoctal $ ord c showoctal i = '\\' : printf "%03o" i -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode_c (encode_c s) +{- For quickcheck. + - + - Encoding and then decoding roundtrips only when + - the string does not contain high unicode, because eg, + - both "\12345" and "\227\128\185" are encoded to "\343\200\271". + - + - This property papers over the problem, by only testing chars < 256. + -} +prop_encode_c_decode_c_roundtrip :: String -> Bool +prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s') + where + s' = filter (\c -> ord c < 256) s diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -184,6 +184,9 @@ params = [Param "--with-colons", Param "--list-secret-keys", Param "--fixed-list-mode"] parse = extract [] Nothing . map (splitc ':') extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) = + -- If the userid contains a ":" or a few other special + -- characters, gpg will hex-escape it. Use decode_c to + -- undo. extract ((keyid, decode_c userid):c) Nothing rest extract c (Just keyid) rest@(("sec":_):_) = extract ((keyid, ""):c) Nothing rest diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -210,7 +210,8 @@ let prim = InodeCachePrim <$> arbitrary <*> arbitrary - <*> arbitrary + -- timestamp cannot be negative + <*> (abs . fromInteger <$> arbitrary) in InodeCache <$> prim #ifdef mingw32_HOST_OS diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -112,7 +112,7 @@ peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] -{- Reaps any zombie git processes. +{- Reaps any zombie processes that may be hanging around. - - Warning: Not thread safe. Anything that was expecting to wait - on a process and get back an exit status is going to be confused diff --git a/Utility/PID.hs b/Utility/PID.hs --- a/Utility/PID.hs +++ b/Utility/PID.hs @@ -13,8 +13,7 @@ import System.Posix.Types (ProcessID) import System.Posix.Process (getProcessID) #else -import System.Win32.Process (ProcessId) -import System.Win32.Process.Current (getCurrentProcessId) +import System.Win32.Process (ProcessId, getCurrentProcessId) #endif #ifndef mingw32_HOST_OS diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -35,9 +35,6 @@ instance Arbitrary POSIXTime where arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral -instance Arbitrary EpochTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) diff --git a/Utility/SshHost.hs b/Utility/SshHost.hs new file mode 100644 --- /dev/null +++ b/Utility/SshHost.hs @@ -0,0 +1,29 @@ +{- ssh hostname sanitization + - + - When constructing a ssh command with a hostname that may be controlled + - by an attacker, prevent the hostname from starting with "-", + - to prevent tricking ssh into arbitrary command execution via + - eg "-oProxyCommand=" + - + - Copyright 2017 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.SshHost (SshHost, mkSshHost, fromSshHost) where + +newtype SshHost = SshHost String + +-- | Smart constructor for a legal hostname or IP address. +-- In some cases, it may be prefixed with "user@" to specify the remote +-- user at the host. +-- +-- For now, we only filter out the problem ones, because determining an +-- actually legal hostnames is quite complicated. +mkSshHost :: String -> Either String SshHost +mkSshHost h@('-':_) = Left $ + "rejecting ssh hostname that starts with '-' : " ++ h +mkSshHost h = Right (SshHost h) + +fromSshHost :: SshHost -> String +fromSshHost (SshHost h) = h diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -50,12 +50,18 @@ closeManager _ = return () #endif +#if ! MIN_VERSION_http_client(0,5,0) +responseTimeoutNone :: Maybe Int +responseTimeoutNone = Nothing +#endif + managerSettings :: ManagerSettings #if MIN_VERSION_http_conduit(2,1,7) managerSettings = tlsManagerSettings #else managerSettings = conduitManagerSettings #endif + { managerResponseTimeout = responseTimeoutNone } type URLString = String diff --git a/doc/git-annex-copy.mdwn b/doc/git-annex-copy.mdwn --- a/doc/git-annex-copy.mdwn +++ b/doc/git-annex-copy.mdwn @@ -75,6 +75,19 @@ The [[git-annex-matching-options]](1) can be used to specify files to copy. +* `--batch` + + Enables batch mode, in which lines containing names of files to copy + are read from stdin. + + As each specified file is processed, the usual progress output is + displayed. If a file's content does not need to be copied or it + is not an annexed file, a blank line is output in response instead. + + Since the usual output while copying a file is verbose and not + machine-parseable, you may want to use --json in combination with + --batch. + * `--json` Enable JSON output. This is intended to be parsed by programs that use diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn --- a/doc/git-annex-fsck.mdwn +++ b/doc/git-annex-fsck.mdwn @@ -93,6 +93,11 @@ Runs multiple fsck jobs in parallel. For example: `-J4` +* `--json` + + Enable JSON output. This is intended to be parsed by programs that use + git-annex. Each line of output is a JSON object. + # OPTIONS # SEE ALSO diff --git a/doc/git-annex-move.mdwn b/doc/git-annex-move.mdwn --- a/doc/git-annex-move.mdwn +++ b/doc/git-annex-move.mdwn @@ -70,6 +70,19 @@ The [[git-annex-matching-options]](1) can be used to specify files to move. +* `--batch` + + Enables batch mode, in which lines containing names of files to move + are read from stdin. + + As each specified file is processed, the usual progress output is + displayed. If a file's content does not need to be moved or it + is not an annexed file, a blank line is output in response instead. + + Since the usual output while moving a file is verbose and not + machine-parseable, you may want to use --json in combination with + --batch. + * `--json` Enable JSON output. This is intended to be parsed by programs that use diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1125,8 +1125,7 @@ * `remote..annex-cost-command` If set, the command is run, and the number it outputs is used as the cost. - This allows varying the cost based on e.g., the current network. The - cost-command can be any shell command line. + This allows varying the cost based on e.g., the current network. * `remote..annex-start-command` @@ -1165,12 +1164,24 @@ This does not prevent git-annex sync (or the git-annex assistant) from syncing the git repository to the remote. +* `remote..annex-ignore-command` + + If set, the command is run, and if it exits nonzero, that's the same + as setting annex-ignore to true. This allows controlling behavior based + on e.g., the current network. + * `remote..annex-sync` If set to `false`, prevents git-annex sync (and the git-annex assistant) from syncing with this remote by default. However, `git annex sync ` can still be used to sync with the remote. +* `remote..annex-sync-command` + + If set, the command is run, and if it exits nonzero, that's the same + as setting annex-sync to false. This allows controlling behavior based + on e.g., the current network. + * `remote..annex-pull` If set to `false`, prevents git-annex sync (and the git-annex assistant @@ -1466,6 +1477,19 @@ Usually it's better to configure any desired options through your ~/.ssh/config file, or by setting `annex.ssh-options`. + +* `GIT_ANNEX_VECTOR_CLOCK` + + Normally git-annex timestamps lines in the log files committed to the + git-annex branch. Setting this environment variable to a number + will make git-annex use that rather than the current number of seconds + since the UNIX epoch. Note that decimal seconds are supported. + + This is only provided for advanced users who either have a better way to + tell which commit is current than the local clock, or who need to avoid + embedding timestamps for policy reasons. Misuse of this environment + variable can confuse git-annex's book-keeping, sometimes in ways that + `git annex fsck` is unable to repair. Some special remotes use additional environment variables for authentication etc. For example, `AWS_ACCESS_KEY_ID` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 6.20170520 +Version: 6.20170818 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -385,7 +385,7 @@ Build-Depends: network (< 2.6), network (>= 2.4) if (os(windows)) - Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3), setenv, + Build-Depends: Win32 (>= 2.5), unix-compat (>= 0.4.1.3), setenv, process (>= 1.4.2.0) else Build-Depends: unix @@ -409,30 +409,31 @@ CPP-Options: -DWITH_ASSISTANT if flag(Assistant) - if os(linux) + if os(linux) || flag(Android) Build-Depends: hinotify CPP-Options: -DWITH_INOTIFY + Other-Modules: Utility.DirWatcher.INotify else if os(darwin) Build-Depends: hfsevents CPP-Options: -DWITH_FSEVENTS + Other-Modules: Utility.DirWatcher.FSEvents else if os(windows) Build-Depends: Win32-notify CPP-Options: -DWITH_WIN32NOTIFY + Other-Modules: Utility.DirWatcher.Win32Notify else if (! os(solaris) && ! os(linux)) - if flag(Android) - Build-Depends: hinotify - CPP-Options: -DWITH_INOTIFY - else - CPP-Options: -DWITH_KQUEUE - C-Sources: Utility/libkqueue.c + CPP-Options: -DWITH_KQUEUE + C-Sources: Utility/libkqueue.c + Other-Modules: Utility.DirWatcher.Kqueue if flag(Dbus) if (os(linux)) Build-Depends: dbus (>= 0.10.7), fdo-notify (>= 0.3) CPP-Options: -DWITH_DBUS -DWITH_DESKTOP_NOTIFY -DWITH_DBUS_NOTIFICATIONS + Other-Modules: Utility.DBus if flag(Android) Build-Depends: data-endian @@ -481,6 +482,7 @@ if flag(Benchmark) Build-Depends: criterion, deepseq CPP-Options: -DWITH_BENCHMARK + Other-Modules: Command.Benchmark Other-Modules: Annex @@ -536,6 +538,7 @@ Annex.UpdateInstead Annex.UUID Annex.Url + Annex.VectorClock Annex.VariantFile Annex.Version Annex.View @@ -650,20 +653,10 @@ Backend.URL Backend.Utilities Backend.WORM - Build.BuildVersion Build.BundledPrograms Build.Configure Build.DesktopFile - Build.DistributionUpdate - Build.EvilLinker - Build.EvilSplicer - Build.InstallDesktopFile - Build.LinuxMkLibs - Build.MakeMans Build.Mans - Build.NullSoftInstaller - Build.OSXMkLibs - Build.Standalone Build.TestConfig Build.Version BuildInfo @@ -686,7 +679,6 @@ Command.AddUrl Command.Adjust Command.Assistant - Command.Benchmark Command.CalcKey Command.CheckPresentKey Command.Commit @@ -791,6 +783,7 @@ Config Config.Cost Config.Files + Config.DynamicConfig Config.GitConfig Creds Crypto @@ -982,16 +975,11 @@ Utility.Bloom Utility.CoProcess Utility.CopyFile - Utility.DBus Utility.Daemon Utility.Data Utility.DataUnits Utility.DirWatcher - Utility.DirWatcher.FSEvents - Utility.DirWatcher.INotify - Utility.DirWatcher.Kqueue Utility.DirWatcher.Types - Utility.DirWatcher.Win32Notify Utility.Directory Utility.DiskFree Utility.Dot @@ -1014,14 +1002,10 @@ Utility.LockFile Utility.LockFile.LockStatus Utility.LockFile.PidLock - Utility.LockFile.Posix - Utility.LockFile.Windows Utility.LockPool Utility.LockPool.LockHandle Utility.LockPool.PidLock - Utility.LockPool.Posix Utility.LockPool.STM - Utility.LockPool.Windows Utility.LogFile Utility.Lsof Utility.MagicWormhole @@ -1053,6 +1037,7 @@ Utility.SimpleProtocol Utility.Split Utility.SshConfig + Utility.SshHost Utility.Su Utility.SystemDirectory Utility.TList @@ -1067,5 +1052,14 @@ Utility.UserInfo Utility.Verifiable Utility.WebApp - Utility.WinProcess Utility.Yesod + + if (os(windows)) + Other-Modules: + Utility.LockFile.Windows + Utility.LockPool.Windows + Utility.WinProcess + else + Other-Modules: + Utility.LockFile.Posix + Utility.LockPool.Posix