git-annex 7.20191230 → 7.20200202.7
raw patch · 98 files changed
+1828/−681 lines, 98 filesdep ~filepath-bytestringdep ~unix-compat
Dependency ranges changed: filepath-bytestring, unix-compat
Files
- Annex/AdjustedBranch.hs +2/−2
- Annex/Branch/Transitions.hs +2/−1
- Annex/Content.hs +3/−4
- Annex/Content/PointerFile.hs +2/−0
- Annex/Drop.hs +1/−1
- Annex/FileMatcher.hs +4/−2
- Annex/Import.hs +0/−2
- Annex/SpecialRemote.hs +12/−6
- Annex/SpecialRemote/Config.hs +159/−15
- Annex/Ssh.hs +40/−5
- Annex/Url.hs +22/−1
- Annex/View.hs +2/−2
- Assistant/DaemonStatus.hs +1/−1
- Assistant/Gpg.hs +5/−4
- Assistant/MakeRemote.hs +8/−7
- Assistant/WebApp/Configurators/AWS.hs +15/−8
- Assistant/WebApp/Configurators/Edit.hs +27/−12
- Assistant/WebApp/Configurators/IA.hs +17/−15
- Assistant/WebApp/Configurators/Local.hs +2/−1
- Assistant/WebApp/Configurators/Ssh.hs +10/−9
- Assistant/WebApp/Configurators/WebDAV.hs +6/−3
- Assistant/WebApp/RepoList.hs +4/−3
- CHANGELOG +28/−0
- COPYRIGHT +1/−1
- CmdLine/Usage.hs +2/−2
- Command/Add.hs +48/−7
- Command/AddUrl.hs +1/−1
- Command/EnableRemote.hs +3/−2
- Command/Export.hs +3/−3
- Command/InitRemote.hs +47/−9
- Command/Log.hs +1/−1
- Command/Reinject.hs +8/−2
- Command/RenameRemote.hs +2/−1
- Command/Sync.hs +1/−0
- Command/TestRemote.hs +15/−9
- Command/Undo.hs +1/−1
- Command/Unused.hs +1/−1
- Config.hs +0/−11
- Creds.hs +37/−18
- Crypto.hs +10/−6
- Database/Export.hs +1/−1
- Database/Keys.hs +1/−1
- Git/CatFile.hs +6/−7
- Git/Config.hs +11/−7
- Git/Credential.hs +18/−1
- Git/DiffTree.hs +4/−7
- Git/DiffTreeItem.hs +2/−2
- Git/LsFiles.hs +11/−8
- Git/LsTree.hs +2/−2
- Git/Remote.hs +1/−1
- Git/Sha.hs +26/−9
- Git/UnionMerge.hs +1/−1
- Git/UpdateIndex.hs +1/−1
- Key.hs +8/−3
- Logs/Remote/Pure.hs +10/−9
- Messages.hs +16/−7
- Messages/Concurrent.hs +7/−5
- Remote/Adb.hs +23/−7
- Remote/BitTorrent.hs +2/−1
- Remote/Bup.hs +14/−5
- Remote/Ddar.hs +13/−4
- Remote/Directory.hs +15/−6
- Remote/External.hs +138/−43
- Remote/External/Types.hs +18/−7
- Remote/GCrypt.hs +27/−11
- Remote/Git.hs +27/−14
- Remote/GitLFS.hs +27/−15
- Remote/Glacier.hs +37/−14
- Remote/Helper/AWS.hs +6/−1
- Remote/Helper/Chunked.hs +19/−10
- Remote/Helper/Encryptable.hs +165/−61
- Remote/Helper/ExportImport.hs +47/−36
- Remote/Helper/Special.hs +16/−4
- Remote/Hook.hs +14/−5
- Remote/List.hs +4/−2
- Remote/P2P.hs +2/−1
- Remote/Rsync.hs +27/−7
- Remote/Rsync/RsyncUrl.hs +3/−3
- Remote/S3.hs +171/−77
- Remote/Tahoe.hs +24/−10
- Remote/Web.hs +3/−2
- Remote/WebDAV.hs +26/−12
- Test.hs +4/−2
- Types/Crypto.hs +24/−7
- Types/ProposedAccepted.hs +38/−0
- Types/Remote.hs +9/−12
- Types/RemoteConfig.hs +69/−0
- Types/RemoteState.hs +1/−1
- Types/StandardGroups.hs +4/−2
- Utility/Daemon.hs +2/−0
- Utility/FileSystemEncoding.hs +3/−12
- Utility/RawFilePath.hs +1/−0
- Utility/Url.hs +84/−24
- doc/git-annex-add.mdwn +10/−0
- doc/git-annex-enableremote.mdwn +2/−1
- doc/git-annex-initremote.mdwn +16/−3
- doc/git-annex-reinject.mdwn +7/−2
- git-annex.cabal +7/−6
Annex/AdjustedBranch.hs view
@@ -558,8 +558,8 @@ reverseAdjustedTree :: Sha -> Adjustment -> Sha -> Annex Sha reverseAdjustedTree basis adj csha = do (diff, cleanup) <- inRepo (Git.DiffTree.commitDiff csha)- let (adds, others) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff- let (removes, changes) = partition (\dti -> Git.DiffTree.dstsha dti == nullSha) others+ let (adds, others) = partition (\dti -> Git.DiffTree.srcsha dti `elem` nullShas) diff+ let (removes, changes) = partition (\dti -> Git.DiffTree.dstsha dti `elem` nullShas) others adds' <- catMaybes <$> mapM (adjustTreeItem reverseadj) (map diffTreeToTreeItem adds) treesha <- Git.Tree.adjustTree
Annex/Branch/Transitions.hs view
@@ -22,6 +22,7 @@ import Types.UUID import Types.MetaData import Types.Remote+import Types.ProposedAccepted import Annex.SpecialRemote.Config import qualified Data.Map as M@@ -85,7 +86,7 @@ trustmap' = trustmap `M.union` M.map (const DeadTrusted) (M.filter sameasdead remoteconfigmap) sameasdead cm =- case toUUID <$> M.lookup sameasUUIDField cm of+ case toUUID . fromProposedAccepted <$> M.lookup sameasUUIDField cm of Nothing -> False Just u' -> M.lookup u' trustmap == Just DeadTrusted minimizesameasdead u l
Annex/Content.hs view
@@ -780,13 +780,12 @@ {- Downloads content from any of a list of urls, displaying a progress - meter. -}-downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool-downloadUrl k p urls file = +downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool+downloadUrl k p urls file uo = -- Poll the file to handle configurations where an external -- download command is used. meteredFile file (Just p) k $- Url.withUrlOptions $ \uo -> - anyM (\u -> Url.download p u file uo) urls+ anyM (\u -> Url.download p u file uo) urls {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -}
Annex/Content/PointerFile.hs view
@@ -22,7 +22,9 @@ import Annex.InodeSentinal import Annex.Content.LowLevel import Utility.InodeCache+#if ! defined(mingw32_HOST_OS) import Utility.Touch+#endif {- Populates a pointer file with the content of a key. -
Annex/Drop.hs view
@@ -16,7 +16,7 @@ import qualified Command.Drop import Command import Annex.Wanted-import Config+import Annex.SpecialRemote.Config import qualified Database.Keys import Git.FilePath
Annex/FileMatcher.hs view
@@ -37,8 +37,10 @@ import Types.FileMatcher import Types.GitConfig import Config.GitConfig+import Annex.SpecialRemote.Config (preferreddirField) import Git.FilePath import Types.Remote (RemoteConfig)+import Types.ProposedAccepted import Annex.CheckAttr import Git.CheckAttr (unspecifiedAttr) import qualified Git.Config@@ -155,8 +157,8 @@ , SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir) ] ++ commonKeylessTokens LimitAnnexFiles where- preferreddir = fromMaybe "public" $- M.lookup "preferreddir" =<< (`M.lookup` configMap pcd) =<< repoUUID pcd+ preferreddir = maybe "public" fromProposedAccepted $+ M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd preferredContentKeyedTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)] preferredContentKeyedTokens pcd =
Annex/Import.hs view
@@ -8,7 +8,6 @@ {-# LANGUAGE OverloadedStrings #-} module Annex.Import (- importTree, ImportTreeConfig(..), ImportCommitConfig(..), buildImportCommit,@@ -37,7 +36,6 @@ import Annex.RemoteTrackingBranch import Command import Backend-import Config import Types.Key import Types.KeySource import Messages.Progress
Annex/SpecialRemote.hs view
@@ -17,6 +17,7 @@ import Remote (remoteTypes) import Types.Remote (RemoteConfig, SetupStage(..), typename, setup) import Types.GitConfig+import Types.ProposedAccepted import Config import Remote.List import Logs.Remote@@ -49,10 +50,10 @@ -- when sameas is used -> RemoteConfig newConfig name sameas fromuser m = case sameas of- Nothing -> M.insert nameField name fromuser+ Nothing -> M.insert nameField (Proposed name) fromuser Just (Sameas u) -> addSameasInherited m $ M.fromList- [ (sameasNameField, name)- , (sameasUUIDField, fromUUID u)+ [ (sameasNameField, Proposed name)+ , (sameasUUIDField, Proposed (fromUUID u)) ] `M.union` fromuser specialRemoteMap :: Annex (M.Map UUID RemoteName)@@ -66,11 +67,15 @@ {- find the remote type -} findType :: RemoteConfig -> Either String RemoteType-findType config = maybe unspecified specified $ M.lookup typeField config+findType config = maybe unspecified (specified . fromProposedAccepted) $+ M.lookup typeField config where unspecified = Left "Specify the type of remote with type=" specified s = case filter (findtype s) remoteTypes of- [] -> Left $ "Unknown remote type " ++ s+ [] -> Left $ "Unknown remote type " ++ s + ++ " (pick from: "+ ++ intercalate " " (map typename remoteTypes)+ ++ ")" (t:_) -> Right t findtype s i = typename i == s @@ -94,7 +99,8 @@ _ -> return () where configured rc = fromMaybe False $- Git.Config.isTrueFalse =<< M.lookup autoEnableField rc+ Git.Config.isTrueFalse . fromProposedAccepted+ =<< M.lookup autoEnableField rc canenable u = (/= DeadTrusted) <$> lookupTrust u getenabledremotes = M.fromList . map (\r -> (getcu r, r))
Annex/SpecialRemote/Config.hs view
@@ -1,18 +1,27 @@ {- git-annex special remote configuration -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Annex.SpecialRemote.Config where import Common import Types.Remote (RemoteConfigField, RemoteConfig) import Types.UUID+import Types.ProposedAccepted+import Types.RemoteConfig+import Config+import qualified Git.Config import qualified Data.Map as M import qualified Data.Set as S+import Data.Typeable+import GHC.Stack newtype Sameas t = Sameas t deriving (Show)@@ -22,45 +31,85 @@ {- The name of a configured remote is stored in its config using this key. -} nameField :: RemoteConfigField-nameField = "name"+nameField = Accepted "name" {- The name of a sameas remote is stored using this key instead. - This prevents old versions of git-annex getting confused. -} sameasNameField :: RemoteConfigField-sameasNameField = "sameas-name"+sameasNameField = Accepted "sameas-name" lookupName :: RemoteConfig -> Maybe String-lookupName c = M.lookup nameField c <|> M.lookup sameasNameField c+lookupName c = fmap fromProposedAccepted $+ M.lookup nameField c <|> M.lookup sameasNameField c +instance RemoteNameable RemoteConfig where+ getRemoteName c = fromMaybe "" (lookupName c)+ {- The uuid that a sameas remote is the same as is stored in this key. -} sameasUUIDField :: RemoteConfigField-sameasUUIDField = "sameas-uuid"+sameasUUIDField = Accepted "sameas-uuid" {- The type of a remote is stored in its config using this key. -} typeField :: RemoteConfigField-typeField = "type"+typeField = Accepted "type" autoEnableField :: RemoteConfigField-autoEnableField = "autoenable"+autoEnableField = Accepted "autoenable" encryptionField :: RemoteConfigField-encryptionField = "encryption"+encryptionField = Accepted "encryption" macField :: RemoteConfigField-macField = "mac"+macField = Accepted "mac" cipherField :: RemoteConfigField-cipherField = "cipher"+cipherField = Accepted "cipher" cipherkeysField :: RemoteConfigField-cipherkeysField = "cipherkeys"+cipherkeysField = Accepted "cipherkeys" pubkeysField :: RemoteConfigField-pubkeysField = "pubkeys"+pubkeysField = Accepted "pubkeys" +chunkField :: RemoteConfigField+chunkField = Accepted "chunk"+ chunksizeField :: RemoteConfigField-chunksizeField = "chunksize"+chunksizeField = Accepted "chunksize" +embedCredsField :: RemoteConfigField+embedCredsField = Accepted "embedcreds"++preferreddirField :: RemoteConfigField+preferreddirField = Accepted "preferreddir"++exportTreeField :: RemoteConfigField+exportTreeField = Accepted "exporttree"++importTreeField :: RemoteConfigField+importTreeField = Accepted "importtree"++exportTree :: ParsedRemoteConfig -> Bool+exportTree = fromMaybe False . getRemoteConfigValue exportTreeField++importTree :: ParsedRemoteConfig -> Bool+importTree = fromMaybe False . getRemoteConfigValue importTreeField++{- Parsers for fields that are common to all special remotes. -}+commonFieldParsers :: [RemoteConfigFieldParser]+commonFieldParsers =+ [ optionalStringParser nameField+ (FieldDesc "name for the special remote")+ , optionalStringParser sameasNameField HiddenField+ , optionalStringParser sameasUUIDField HiddenField+ , optionalStringParser typeField+ (FieldDesc "type of special remote")+ , trueFalseParser autoEnableField False+ (FieldDesc "automatically enable special remote")+ , optionalStringParser preferreddirField+ (FieldDesc "directory whose content is preferred")+ ]+ {- A remote with sameas-uuid set will inherit these values from the config - of that uuid. These values cannot be overridden in the remote's config. -} sameasInherits :: S.Set RemoteConfigField@@ -92,7 +141,8 @@ M.restrictKeys parentc sameasInherits findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID)-findSameasUUID c = Sameas . toUUID <$> M.lookup sameasUUIDField c+findSameasUUID c = Sameas . toUUID . fromProposedAccepted+ <$> M.lookup sameasUUIDField c {- Remove any fields inherited from a sameas-uuid. When storing a - RemoteConfig, those fields don't get stored, since they were already@@ -108,4 +158,98 @@ where sameasuuid (u, c) = case M.lookup sameasUUIDField c of Nothing -> (u, c, Nothing)- Just u' -> (toUUID u', c, Just (ConfigFrom u))+ Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u))++{- Extracts a value from ParsedRemoteConfig. -}+getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v+getRemoteConfigValue f m = case M.lookup f m of+ Just (RemoteConfigValue v) -> case cast v of+ Just v' -> Just v'+ Nothing -> error $ unwords+ [ "getRemoteConfigValue"+ , fromProposedAccepted f+ , "found value of unexpected type"+ , show (typeOf v) ++ "."+ , "This is a bug in git-annex!"+ ]+ Nothing -> Nothing++{- Gets all fields that remoteConfigRestPassthrough matched. -}+getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String+getRemoteConfigPassedThrough = M.mapMaybe $ \(RemoteConfigValue v) ->+ case cast v of+ Just (PassedThrough s) -> Just s+ Nothing -> Nothing++newtype PassedThrough = PassedThrough String++parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig+parseRemoteConfig c rpc =+ go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers)+ where+ go l c' [] =+ let (passover, leftovers) = partition+ (maybe (const False) fst (remoteConfigRestPassthrough rpc) . fst)+ (M.toList c')+ leftovers' = filter (notaccepted . fst) leftovers+ in if not (null leftovers')+ then Left $ "Unexpected parameters: " +++ unwords (map (fromProposedAccepted . fst) leftovers')+ else Right $ M.fromList $+ l ++ map (uncurry passthrough) passover+ go l c' (p:rest) = do+ let f = parserForField p+ (valueParser p) (M.lookup f c) c >>= \case+ Just v -> go ((f,v):l) (M.delete f c') rest+ Nothing -> go l (M.delete f c') rest+ + passthrough f v = (f, RemoteConfigValue (PassedThrough (fromProposedAccepted v)))+ + notaccepted (Proposed _) = True+ notaccepted (Accepted _) = False++optionalStringParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser+optionalStringParser f fielddesc = RemoteConfigFieldParser+ { parserForField = f + , valueParser = p+ , fieldDesc = fielddesc+ , valueDesc = Nothing+ }+ where+ p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v)))+ p Nothing _c = Right Nothing++yesNoParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser+yesNoParser f v fd = genParser yesNo f v fd+ (Just (ValueDesc "yes or no"))++trueFalseParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser+trueFalseParser f v fd = genParser Git.Config.isTrueFalse f v fd+ (Just (ValueDesc "true or false"))++genParser+ :: Typeable t+ => (String -> Maybe t)+ -> RemoteConfigField+ -> t -- ^ fallback value+ -> FieldDesc+ -> Maybe ValueDesc+ -> RemoteConfigFieldParser+genParser parse f fallback fielddesc valuedesc = RemoteConfigFieldParser + { parserForField = f+ , valueParser = p+ , fieldDesc = fielddesc+ , valueDesc = valuedesc+ }+ where+ p Nothing _c = Right (Just (RemoteConfigValue fallback))+ p (Just v) _c = case parse (fromProposedAccepted v) of+ Just b -> Right (Just (RemoteConfigValue b))+ Nothing -> case v of+ Accepted _ -> Right (Just (RemoteConfigValue fallback))+ Proposed _ -> Left $+ "Bad value for " ++ fromProposedAccepted f +++ case valuedesc of+ Just (ValueDesc vd) ->+ " (expected " ++ vd ++ ")"+ Nothing -> ""
Annex/Ssh.hs view
@@ -1,6 +1,6 @@ {- git-annex ssh interface, with connection caching -- - Copyright 2012-2017 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -100,11 +100,44 @@ sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshCachingInfo (host, port) = go =<< sshCacheDir where- go Nothing = return (Nothing, []) go (Just dir) = liftIO (bestSocketPath $ dir </> hostport2socket host port) >>= return . \case Nothing -> (Nothing, []) Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile)+ -- No connection caching with concurrency is not a good+ -- combination, so warn the user.+ go Nothing = do+ Annex.getState Annex.concurrency >>= \case+ NonConcurrent -> return ()+ Concurrent {} -> warnnocaching+ ConcurrentPerCpu -> warnnocaching+ return (Nothing, [])+ + warnnocaching = do+ warning nocachingwarning+ ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)+ ( whenM crippledFileSystem $+ warning crippledfswarning+ , warning enablecachingwarning+ )+ + nocachingwarning = unwords+ [ "You have enabled concurrency, but ssh connection caching"+ , "is not enabled. This may result in multiple ssh processes"+ , "prompting for passwords at the same time."+ ]+ + crippledfswarning = unwords+ [ "This repository is on a crippled filesystem, so unix named"+ , "pipes probably don't work, and ssh connection caching"+ , "relies on those. One workaround is to set"+ , sshSocketDirEnv+ , "to point to a directory on a non-crippled filesystem."+ , "(Or, disable concurrency.)"+ ]+ + enablecachingwarning = + "Enable annex.sshcaching (or disable concurrency) to avoid this problem." {- Given an absolute path to use for a socket file, - returns whichever is shorter of that or the relative path to the same@@ -133,9 +166,11 @@ , Param "-o", Param "ControlPersist=yes" ] +sshSocketDirEnv :: String+sshSocketDirEnv = "GIT_ANNEX_SSH_SOCKET_DIR"+ {- ssh connection caching creates sockets, so will not work on a- - crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use- - a different filesystem. -}+ - crippled filesystem. -} sshCacheDir :: Annex (Maybe FilePath) sshCacheDir | BuildInfo.sshconnectioncaching = @@ -148,7 +183,7 @@ ) | otherwise = return Nothing where- gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"+ gettmpdir = liftIO $ getEnv sshSocketDirEnv usetmpdir tmpdir = liftIO $ catchMaybeIO $ do let socktmp = tmpdir </> "ssh" createDirectoryIfMissing True socktmp
Annex/Url.hs view
@@ -1,13 +1,14 @@ {- Url downloading, with git-annex user agent and configured http - headers, security restrictions, etc. -- - Copyright 2013-2019 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Url ( withUrlOptions,+ withUrlOptionsPromptingCreds, getUrlOptions, getUserAgent, ipAddressesUnlimited,@@ -34,6 +35,7 @@ import Utility.IPAddress import Utility.HttpManagerRestricted import Utility.Metered+import Git.Credential import qualified BuildInfo import Network.Socket@@ -64,6 +66,7 @@ <*> pure urldownloader <*> pure manager <*> (annexAllowedUrlSchemes <$> Annex.getGitConfig)+ <*> pure U.noBasicAuth headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])@@ -123,6 +126,24 @@ withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a withUrlOptions a = a =<< getUrlOptions++-- When downloading an url, if authentication is needed, uses+-- git-credential to prompt for username and password.+withUrlOptionsPromptingCreds :: (U.UrlOptions -> Annex a) -> Annex a+withUrlOptionsPromptingCreds a = do+ g <- Annex.gitRepo+ uo <- getUrlOptions+ prompter <- mkPrompter+ a $ uo+ { U.getBasicAuth = \u -> prompter $+ getBasicAuthFromCredential g u+ -- Can't download with curl and handle basic auth,+ -- so make sure it uses conduit.+ , U.urlDownloader = case U.urlDownloader uo of+ U.DownloadWithCurl _ -> U.DownloadWithConduit $+ U.DownloadWithCurlRestricted mempty+ v -> v+ } checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool checkBoth url expected_size uo =
Annex/View.hs view
@@ -396,12 +396,12 @@ void $ liftIO cleanup where handleremovals item- | DiffTree.srcsha item /= nullSha =+ | DiffTree.srcsha item `notElem` nullShas = handlechange item removemeta =<< catKey (DiffTree.srcsha item) | otherwise = noop handleadds item- | DiffTree.dstsha item /= nullSha = + | DiffTree.dstsha item `notElem` nullShas = handlechange item addmeta =<< catKey (DiffTree.dstsha item) | otherwise = noop
Assistant/DaemonStatus.hs view
@@ -19,8 +19,8 @@ import Utility.TimeStamp import qualified Remote import qualified Types.Remote as Remote-import Config import Config.DynamicConfig+import Annex.SpecialRemote.Config import Control.Concurrent.STM import System.Posix.Types
Assistant/Gpg.hs view
@@ -11,6 +11,7 @@ import Utility.UserInfo import Types.Remote (RemoteConfigField) import Annex.SpecialRemote.Config+import Types.ProposedAccepted import qualified Data.Map as M import Control.Applicative@@ -31,7 +32,7 @@ deriving (Eq) {- Generates Remote configuration for encryption. -}-configureEncryption :: EnableEncryption -> (RemoteConfigField, String)-configureEncryption SharedEncryption = (encryptionField, "shared")-configureEncryption NoEncryption = (encryptionField, "none")-configureEncryption HybridEncryption = (encryptionField, "hybrid")+configureEncryption :: EnableEncryption -> (RemoteConfigField, ProposedAccepted String)+configureEncryption SharedEncryption = (encryptionField, Proposed "shared")+configureEncryption NoEncryption = (encryptionField, Proposed "none")+configureEncryption HybridEncryption = (encryptionField, Proposed "hybrid")
Assistant/MakeRemote.hs view
@@ -30,6 +30,7 @@ import Utility.Gpg (KeyId) import Types.GitConfig import Config+import Types.ProposedAccepted import qualified Data.Map as M @@ -59,19 +60,19 @@ go (Just (u, c, mcu)) = setupSpecialRemote name Rsync.remote config Nothing (Just u, R.Enable c, c) mcu config = M.fromList- [ (encryptionField, "shared")- , ("rsyncurl", location)- , ("type", "rsync")+ [ (encryptionField, Proposed "shared")+ , (Proposed "rsyncurl", Proposed location)+ , (typeField, Proposed "rsync") ] {- Inits a gcrypt special remote, and returns its name. -} makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName makeGCryptRemote remotename location keyid = initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList- [ ("type", "gcrypt")- , ("gitrepo", location)+ [ (typeField, Proposed "gcrypt")+ , (Proposed "gitrepo", Proposed location) , configureEncryption HybridEncryption- , ("keyid", keyid)+ , (Proposed "keyid", Proposed keyid) ] type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName@@ -105,7 +106,7 @@ - assistant, because otherwise GnuPG may block once the entropy - 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+ let weakc = M.insert (Proposed "highRandomQuality") (Proposed "false") (M.union config c) dummycfg <- liftIO dummyRemoteGitConfig (c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg case mcu of
Assistant/WebApp/Configurators/AWS.hs view
@@ -25,6 +25,7 @@ import Assistant.Gpg import Git.Types (RemoteName) import Annex.SpecialRemote.Config+import Types.ProposedAccepted import qualified Data.Text as T import qualified Data.Map as M@@ -131,10 +132,10 @@ let name = T.unpack $ repoName input makeAWSRemote initSpecialRemote S3.remote TransferGroup (extractCreds input) name $ M.fromList [ configureEncryption $ enableEncryption input- , ("type", "S3")- , ("datacenter", T.unpack $ datacenter input)- , ("storageclass", show $ storageClass input)- , ("chunk", "1MiB")+ , (typeField, Proposed "S3")+ , (Proposed "datacenter", Proposed $ T.unpack $ datacenter input)+ , (Proposed "storageclass", Proposed $ show $ storageClass input)+ , (Proposed "chunk", Proposed "1MiB") ] _ -> $(widgetFile "configurators/adds3") #else@@ -155,8 +156,8 @@ let name = T.unpack $ repoName input makeAWSRemote initSpecialRemote Glacier.remote SmallArchiveGroup (extractCreds input) name $ M.fromList [ configureEncryption $ enableEncryption input- , ("type", "glacier")- , ("datacenter", T.unpack $ datacenter input)+ , (typeField, Proposed "glacier")+ , (Proposed "datacenter", Proposed $ T.unpack $ datacenter input) ] _ -> $(widgetFile "configurators/addglacier") #else@@ -167,7 +168,13 @@ #ifdef WITH_S3 getEnableS3R uuid = do m <- liftAnnex readRemoteLog- if maybe False S3.configIA (M.lookup uuid m)+ isia <- case M.lookup uuid m of+ Just c -> liftAnnex $ do+ pc <- either mempty id . parseRemoteConfig c+ <$> Remote.configParser S3.remote c+ return $ S3.configIA pc+ Nothing -> return False+ if isia then redirect $ EnableIAR uuid else postEnableS3R uuid #else@@ -222,7 +229,7 @@ getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|] where- bucket = fromMaybe "" $ M.lookup "bucket" c+ bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c #ifdef WITH_S3 previouslyUsedAWSCreds :: Annex (Maybe CredPair)
Assistant/WebApp/Configurators/Edit.hs view
@@ -37,7 +37,7 @@ import qualified Git.Config import qualified Annex import Git.Remote-import Remote.Helper.Encryptable (extractCipher)+import Remote.Helper.Encryptable (extractCipher, parseEncryptionConfig) import Types.Crypto import Utility.Gpg import Annex.UUID@@ -46,6 +46,8 @@ import Config.GitConfig import Config.DynamicConfig import Types.Group+import Types.ProposedAccepted+import Annex.SpecialRemote.Config import qualified Data.Text as T import qualified Data.Map as M@@ -125,7 +127,7 @@ case M.lookup uuid m of Nothing -> noop Just remoteconfig -> configSet uuid $- M.insert "preferreddir" dir remoteconfig+ M.insert (Proposed "preferreddir") (Proposed dir) remoteconfig when groupChanged $ do liftAnnex $ case repoGroup newc of RepoGroupStandard g -> setStandardGroup uuid g@@ -217,13 +219,21 @@ redirect DashboardR _ -> do let istransfer = repoGroup curr == RepoGroupStandard TransferGroup- config <- liftAnnex $ M.lookup uuid <$> readRemoteLog+ config <- liftAnnex $ fromMaybe mempty + . M.lookup uuid+ <$> readRemoteLog let repoInfo = getRepoInfo mremote config- let repoEncryption = getRepoEncryption mremote config+ let repoEncryption = getRepoEncryption mremote (Just config) $(widgetFile "configurators/edit/repository") editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do mr <- liftAnnex (repoIdRemote r)- let repoInfo = getRepoInfo mr Nothing+ let repoInfo = case mr of+ Just rmt -> do+ config <- liftAnnex $ fromMaybe mempty+ . M.lookup (Remote.uuid rmt)+ <$> readRemoteLog+ getRepoInfo mr config+ Nothing -> getRepoInfo Nothing mempty g <- liftAnnex gitRepo mrepo <- liftAnnex $ maybe (pure Nothing) (Just <$$> Remote.getRepo) mr let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation) mrepo@@ -242,17 +252,21 @@ Nothing -> noop _ -> noop -getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget-getRepoInfo (Just r) (Just c) = case M.lookup "type" c of- Just "S3"+getRepoInfo :: Maybe Remote.Remote -> Remote.RemoteConfig -> Widget+getRepoInfo (Just r) c = case fromProposedAccepted <$> M.lookup typeField c of+ Just "S3" -> do #ifdef WITH_S3- | S3.configIA c -> IA.getRepoInfo c+ pc <- liftAnnex $ either mempty id . parseRemoteConfig c+ <$> Remote.configParser S3.remote c+ if S3.configIA pc+ then IA.getRepoInfo c+ else AWS.getRepoInfo c+#else+ AWS.getRepoInfo c #endif- | otherwise -> AWS.getRepoInfo c Just t | t /= "git" -> [whamlet|#{t} remote|] _ -> getGitRepoInfo =<< liftAnnex (Remote.getRepo r)-getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r) getRepoInfo _ _ = [whamlet|git repository|] getGitRepoInfo :: Git.Repo -> Widget@@ -261,7 +275,7 @@ [whamlet|git repository located at <tt>#{loc}</tt>|] getRepoEncryption :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget-getRepoEncryption (Just _) (Just c) = case extractCipher c of+getRepoEncryption (Just _) (Just c) = case extractCipher pc of Nothing -> [whamlet|not encrypted|] (Just (SharedCipher _)) ->@@ -269,6 +283,7 @@ (Just (EncryptedCipher _ _ ks)) -> desckeys ks (Just (SharedPubKeyCipher _ ks)) -> desckeys ks where+ pc = either mempty id $ parseEncryptionConfig c desckeys (KeyIds { keyIds = ks }) = do cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig knownkeys <- liftIO (secretKeys cmd)
Assistant/WebApp/Configurators/IA.hs view
@@ -25,6 +25,7 @@ import qualified Annex.Url as Url import Creds import Annex.SpecialRemote.Config+import Types.ProposedAccepted import qualified Data.Text as T import qualified Data.Map as M@@ -131,21 +132,22 @@ case result of FormSuccess input -> liftH $ do let name = escapeBucket $ T.unpack $ itemName input+ let wrap (k, v) = (Proposed k, Proposed v)+ let c = map wrap $ catMaybes+ [ Just ("type", "S3")+ , Just ("host", S3.iaHost)+ , Just ("bucket", escapeHeader name)+ , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input)+ , if mediaType input == MediaOmitted+ then Nothing+ else Just ("x-archive-mediatype", formatMediaType $ mediaType input)+ , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input)+ -- Make item show up ASAP.+ , Just ("x-archive-interactive-priority", "1")+ , Just ("preferreddir", name)+ ] AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $- M.fromList $ catMaybes- [ Just $ configureEncryption NoEncryption- , Just ("type", "S3")- , Just ("host", S3.iaHost)- , Just ("bucket", escapeHeader name)- , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input)- , if mediaType input == MediaOmitted- then Nothing- else Just ("x-archive-mediatype", formatMediaType $ mediaType input)- , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input)- -- Make item show up ASAP.- , Just ("x-archive-interactive-priority", "1")- , Just ("preferreddir", name)- ]+ M.fromList $ configureEncryption NoEncryption : c _ -> $(widgetFile "configurators/addia") #else postAddIAR = giveup "S3 not supported by this build"@@ -202,7 +204,7 @@ have been uploaded, and the Internet Archive has processed them. |] where- bucket = fromMaybe "" $ M.lookup "bucket" c+ bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c #ifdef WITH_S3 url = S3.iaItemUrl bucket #else
Assistant/WebApp/Configurators/Local.hs view
@@ -39,6 +39,7 @@ import qualified Remote.GCrypt as GCrypt import qualified Types.Remote import Utility.Android+import Types.ProposedAccepted import qualified Data.Text as T import qualified Data.Map as M@@ -325,7 +326,7 @@ makewith $ const $ do r <- liftAnnex $ addRemote $ enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList- [("gitrepo", dir)]+ [(Proposed "gitrepo", Proposed dir)] return (u, r) {- Making a new unencrypted repo, or combining with an existing one. -} makeunencrypted = makewith $ \isnew -> (,)
Assistant/WebApp/Configurators/Ssh.hs view
@@ -20,6 +20,7 @@ import Utility.UserInfo import Utility.Gpg import Types.Remote (RemoteConfig)+import Types.ProposedAccepted import Git.Types (RemoteName, fromRef, fromConfigKey) import qualified Remote.GCrypt as GCrypt import qualified Annex@@ -177,7 +178,7 @@ where enablersync sshdata u = redirect $ ConfirmSshR (sshdata { sshCapabilities = [RsyncCapable] }) u- getsshinput = parseSshUrl <=< M.lookup "rsyncurl"+ getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "rsyncurl") {- This only handles gcrypt repositories that are located on ssh servers; - ones on local drives are handled via another part of the UI. -}@@ -191,7 +192,7 @@ sshConfigurator $ checkExistingGCrypt sshdata' $ giveup "Expected to find an encrypted git repository, but did not."- getsshinput = parseSshUrl <=< M.lookup "gitrepo"+ getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "gitrepo") getEnableSshGitRemoteR :: UUID -> Handler Html getEnableSshGitRemoteR = postEnableSshGitRemoteR@@ -200,7 +201,7 @@ where enablesshgitremote sshdata u = redirect $ ConfirmSshR sshdata u - getsshinput = parseSshUrl <=< M.lookup "location"+ getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "location") {- To enable a remote that uses ssh as its transport, - parse a config key to get its url, and display a form@@ -424,7 +425,7 @@ $(widgetFile "configurators/ssh/combine") handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do m <- liftAnnex readRemoteLog- case M.lookup "type" =<< M.lookup u m of+ case fromProposedAccepted <$> (M.lookup typeField =<< M.lookup u m) of Just "gcrypt" -> combineExistingGCrypt sshdata' u _ -> makeSshRepo ExistingRepo sshdata' @@ -474,7 +475,7 @@ enableGCrypt sshdata reponame = setupRemote postsetup Nothing Nothing mk where mk = enableSpecialRemote reponame GCrypt.remote Nothing $- M.fromList [("gitrepo", genSshUrl sshdata)]+ M.fromList [(Proposed "gitrepo", Proposed (genSshUrl sshdata))] postsetup _ = redirect DashboardR {- Combining with a gcrypt repository that may not be@@ -546,11 +547,11 @@ setup r = do m <- readRemoteLog let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m)- let c' = M.insert "location" (genSshUrl sshdata) $- M.insert "type" "git" $- case M.lookup nameField c of+ let c' = M.insert (Proposed "location") (Proposed (genSshUrl sshdata)) $+ M.insert typeField (Proposed "git") $+ case fromProposedAccepted <$> M.lookup nameField c of Just _ -> c- Nothing -> M.insert nameField (Remote.name r) c+ Nothing -> M.insert nameField (Proposed (Remote.name r)) c configSet (Remote.uuid r) c' makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -15,13 +15,14 @@ import qualified Remote.WebDAV as WebDAV import Assistant.WebApp.MakeRemote import qualified Remote-import Types.Remote (RemoteConfig)+import Types.Remote (RemoteConfig, configParser) import Types.StandardGroups import Logs.Remote import Git.Types (RemoteName) import Assistant.Gpg import Types.GitConfig import Annex.SpecialRemote.Config+import Types.ProposedAccepted import qualified Data.Map as M #endif@@ -58,10 +59,12 @@ m <- liftAnnex readRemoteLog let c = fromJust $ M.lookup uuid m let name = fromJust $ lookupName c- let url = fromJust $ M.lookup "url" c+ let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c mcreds <- liftAnnex $ do dummycfg <- liftIO dummyRemoteGitConfig- getRemoteCredPairFor "webdav" c dummycfg (WebDAV.davCreds uuid)+ pc <- either mempty id . parseRemoteConfig c+ <$> configParser WebDAV.remote c+ getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid) case mcreds of Just creds -> webDAVConfigurator $ liftH $ makeWebDavRemote enableSpecialRemote name creds M.empty
Assistant/WebApp/RepoList.hs view
@@ -26,6 +26,7 @@ import Config.Cost import Utility.NotificationBroadcaster import qualified Git+import Types.ProposedAccepted import qualified Data.Map as M import qualified Data.Set as S@@ -175,7 +176,7 @@ selectedremote (Just (iscloud, _)) | onlyCloud reposelector = iscloud | otherwise = True- findinfo m g u = case getconfig "type" of+ findinfo m g u = case fromProposedAccepted <$> getconfig (Accepted "type") of Just "rsync" -> val True EnableRsyncR Just "directory" -> val False EnableDirectoryR #ifdef WITH_S3@@ -188,12 +189,12 @@ Just "gcrypt" -> -- Skip gcrypt repos on removable drives; -- handled separately.- case getconfig "gitrepo" of+ case fromProposedAccepted <$> getconfig (Accepted "gitrepo") of Just rr | remoteLocationIsUrl (parseRemoteLocation rr g) -> val True EnableSshGCryptR _ -> Nothing Just "git" -> - case getconfig "location" of+ case fromProposedAccepted <$> getconfig (Accepted "location") of Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc g) -> val True EnableSshGitRemoteR _ -> Nothing
CHANGELOG view
@@ -1,3 +1,31 @@+git-annex (7.20200202.7) upstream; urgency=medium++ * add: --force-annex/--force-git options make it easier to override+ annex.largefiles configuration (and potentially safer as it avoids+ bugs like the smudge bug fixed in the last release).+ * reinject --known: Fix bug that prevented it from working in a bare repo.+ * Support being used in a git repository that uses sha256 rather than sha1.+ * initremote, enableremote: Be stricter about rejecting invalid+ configuration parameters for remotes, particularly things like foo=true+ when foo=yes is expected.+ * initremote, enableremote: Reject unknown configuration parameters+ provided to these commands.+ * initremote: Added --whatelse option, to show additional+ configuration parameters you might want to set. Eg:+ git annex initremote type=directory encryption=none --whatelse+ * Added LISTCONFIGS to external special remote protocol. Special remote+ programs that use GETCONFIG/SETCONFIG are recommended to implement it.+ * init: Avoid an ugly error message when http remote has no git-annex+ uuid configured.+ * Support git remotes that need http basic auth to be accessed,+ using git credential to get the password.+ * Display a warning when concurrency is enabled but ssh connection caching+ is not enabled or won't work due to a crippled filesystem.+ * Makefile: Move the fish completion to the vendor_completions.d directory.+ * Fixed a test suite failure when run in the C locale.++ -- Joey Hess <id@joeyh.name> Sun, 02 Feb 2020 00:00:00 -0400+ git-annex (7.20191230) upstream; urgency=medium * Optimised processing of many files, especially by commands like find
COPYRIGHT view
@@ -2,7 +2,7 @@ Source: native package Files: *-Copyright: © 2010-2019 Joey Hess <id@joeyh.name>+Copyright: © 2010-2020 Joey Hess <id@joeyh.name> License: AGPL-3+ Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*
CmdLine/Usage.hs view
@@ -96,8 +96,8 @@ paramItem = "ITEM" paramTreeish :: String paramTreeish = "TREEISH"-paramKeyValue :: String-paramKeyValue = "K=V"+paramParamValue :: String+paramParamValue = "PARAM=VALUE" paramNothing :: String paramNothing = "" paramRepeating :: String -> String
Command/Add.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -17,8 +17,12 @@ import Annex.FileMatcher import Annex.Link import Annex.Tmp+import Annex.HashObject import Messages.Progress+import Git.Types import Git.FilePath+import qualified Git.UpdateIndex+import Utility.FileMode import qualified Utility.RawFilePath as R cmd :: Command@@ -32,6 +36,7 @@ , includeDotFiles :: Bool , batchOption :: BatchMode , updateOnly :: Bool+ , largeFilesOverride :: Maybe Bool } optParser :: CmdParamsDesc -> Parser AddOptions@@ -47,18 +52,31 @@ <> short 'u' <> help "only update tracked files" )+ <*> (parseforcelarge <|> parseforcesmall)+ where+ parseforcelarge = flag Nothing (Just True)+ ( long "force-large"+ <> help "add all files to annex, ignoring other configuration"+ )+ parseforcesmall = flag Nothing (Just False)+ ( long "force-small"+ <> help "add all files to git, ignoring other configuration"+ ) seek :: AddOptions -> CommandSeek seek o = startConcurrency commandStages $ do largematcher <- largeFilesMatcher addunlockedmatcher <- addUnlockedMatcher- let gofile file = ifM (checkFileMatcher largematcher (fromRawFilePath file) <||> Annex.getState Annex.force)- ( start file addunlockedmatcher- , ifM (annexAddSmallFiles <$> Annex.getGitConfig)- ( startSmall file- , stop+ let gofile file = case largeFilesOverride o of+ Nothing -> ifM (checkFileMatcher largematcher (fromRawFilePath file) <||> Annex.getState Annex.force)+ ( start file addunlockedmatcher+ , ifM (annexAddSmallFiles <$> Annex.getGitConfig)+ ( startSmall file+ , stop+ ) )- )+ Just True -> start file addunlockedmatcher+ Just False -> startSmallOverridden file case batchOption o of Batch fmt | updateOnly o ->@@ -81,6 +99,29 @@ addSmall file = do showNote "non-large file; adding content to git repository" addFile file++startSmallOverridden :: RawFilePath -> CommandStart+startSmallOverridden file = starting "add" (ActionItemWorkTreeFile file) $+ next $ addSmallOverridden file++addSmallOverridden :: RawFilePath -> Annex Bool+addSmallOverridden file = do+ showNote "adding content to git repository"+ let file' = fromRawFilePath file+ s <- liftIO $ getFileStatus file'+ if isSymbolicLink s+ then addFile file + else do+ -- Can't use addFile because the clean filter will+ -- honor annex.largefiles and it has been overridden.+ -- Instead, hash the file and add to the index.+ sha <- hashFile file'+ let ty = if isExecutable (fileMode s)+ then TreeExecutable+ else TreeFile+ Annex.Queue.addUpdateIndex =<<+ inRepo (Git.UpdateIndex.stageFile sha ty file')+ return True addFile :: RawFilePath -> Annex Bool addFile file = do
Command/AddUrl.hs view
@@ -261,7 +261,7 @@ go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file))) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing- downloader f p = downloadUrl urlkey p [url] f+ downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f go Nothing = return Nothing -- If we downloaded a html file, try to use youtube-dl to -- extract embedded media.
Command/EnableRemote.hs view
@@ -24,13 +24,14 @@ import Config import Config.DynamicConfig import Types.GitConfig+import Types.ProposedAccepted import qualified Data.Map as M cmd :: Command cmd = command "enableremote" SectionSetup "enables git-annex to use a remote"- (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)+ (paramPair paramName $ paramOptional $ paramRepeating paramParamValue) (withParams seek) seek :: CmdParams -> CommandSeek@@ -41,7 +42,7 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes where matchingname r = Git.remoteName r == Just name- go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest)+ go [] = startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest) =<< SpecialRemote.findExisting name go (r:_) = do -- This could be either a normal git remote or a special
Command/Export.hs view
@@ -216,7 +216,7 @@ , (, (Nothing, Just (Git.DiffTree.file i))) <$> dstek ] getek sha- | sha == nullSha = return Nothing+ | sha `elem` nullShas = return Nothing | otherwise = Just <$> exportKey sha newtype FileUploaded = FileUploaded { fromFileUploaded :: Bool }@@ -310,7 +310,7 @@ startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart startUnexport r db f shas = do- eks <- forM (filter (/= nullSha) shas) exportKey+ eks <- forM (filter (`notElem` nullShas) shas) exportKey if null eks then stop else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $@@ -359,7 +359,7 @@ startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart startRecoverIncomplete r db sha oldf- | sha == nullSha = stop+ | sha `elem` nullShas = stop | otherwise = do ek <- exportKey sha let loc = exportTempName ek
Command/InitRemote.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -16,27 +16,35 @@ import qualified Remote import qualified Logs.Remote import qualified Types.Remote as R+import Types.RemoteConfig import Annex.UUID import Logs.UUID import Logs.Remote import Types.GitConfig+import Types.ProposedAccepted import Config cmd :: Command cmd = command "initremote" SectionSetup "creates a special (non-git) remote"- (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)+ (paramPair paramName $ paramOptional $ paramRepeating paramParamValue) (seek <$$> optParser) data InitRemoteOptions = InitRemoteOptions { cmdparams :: CmdParams , sameas :: Maybe (DeferredParse UUID)+ , whatElse :: Bool } optParser :: CmdParamsDesc -> Parser InitRemoteOptions optParser desc = InitRemoteOptions <$> cmdParams desc <*> optional parseSameasOption+ <*> switch+ ( long "whatelse"+ <> short 'w'+ <> help "describe other configuration parameters for a special remote"+ ) parseSameasOption :: Parser (DeferredParse UUID) parseSameasOption = parseUUIDOption <$> strOption@@ -63,27 +71,34 @@ (Just . Sameas <$$> getParsed) (sameas o) c <- newConfig name sameasuuid- (Logs.Remote.keyValToConfig ws)+ (Logs.Remote.keyValToConfig Proposed ws) <$> readRemoteLog t <- either giveup return (findType c)- starting "initremote" (ActionItemOther (Just name)) $- perform t name c o+ if whatElse o+ then startingCustomOutput (ActionItemOther Nothing) $+ describeOtherParamsFor c t+ else starting "initremote" (ActionItemOther (Just name)) $+ perform t name c o ) ) perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do dummycfg <- liftIO dummyRemoteGitConfig- (c', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c dummycfg- next $ cleanup u name c' o+ let c' = M.delete uuidField c+ (c'', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c' dummycfg+ next $ cleanup u name c'' o where- uuidfromuser = case M.lookup "uuid" c of+ uuidfromuser = case fromProposedAccepted <$> M.lookup uuidField c of Just s | isUUID s -> Just (toUUID s) | otherwise -> giveup "invalid uuid" Nothing -> Nothing- sameasu = toUUID <$> M.lookup sameasUUIDField c+ sameasu = toUUID . fromProposedAccepted <$> M.lookup sameasUUIDField c +uuidField :: R.RemoteConfigField+uuidField = Accepted "uuid"+ cleanup :: UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup cleanup u name c o = do case sameas o of@@ -95,3 +110,26 @@ setConfig (remoteConfig c "config-uuid") (fromUUID cu) Logs.Remote.configSet cu c return True++describeOtherParamsFor :: RemoteConfig -> RemoteType -> CommandPerform+describeOtherParamsFor c t = do+ cp <- R.configParser t c+ let l = map mk (filter notinconfig $ remoteConfigFieldParsers cp)+ ++ map mk' (maybe [] snd (remoteConfigRestPassthrough cp))+ liftIO $ forM_ l $ \(p, fd, vd) -> case fd of+ HiddenField -> return ()+ FieldDesc d -> do+ putStrLn p+ putStrLn ("\t" ++ d)+ case vd of+ Nothing -> return ()+ Just (ValueDesc d') ->+ putStrLn $ "\t(" ++ d' ++ ")"+ next $ return True+ where+ notinconfig fp = not (M.member (parserForField fp) c)+ mk fp = ( fromProposedAccepted (parserForField fp)+ , fieldDesc fp+ , valueDesc fp+ )+ mk' (k, v) = (k, v, Nothing)
Command/Log.hs view
@@ -215,7 +215,7 @@ , Param "-z" , Param "--pretty=format:%ct" , Param "--raw"- , Param "--abbrev=40"+ , Param "--no-abbrev" ] ++ os ++ [ Param $ Git.fromRef Annex.Branch.fullname , Param "--"
Command/Reinject.hs view
@@ -13,6 +13,7 @@ import Backend import Types.KeySource import Utility.Metered+import qualified Git cmd :: Command cmd = command "reinject" SectionUtility @@ -65,8 +66,13 @@ ) notAnnexed :: FilePath -> CommandStart -> CommandStart-notAnnexed src = ifAnnexed (toRawFilePath src) $- giveup $ "cannot used annexed file as src: " ++ src+notAnnexed src a = + ifM (fromRepo Git.repoIsLocalBare)+ ( a+ , ifAnnexed (toRawFilePath src)+ (giveup $ "cannot used annexed file as src: " ++ src)+ a+ ) perform :: FilePath -> Key -> CommandPerform perform src key = ifM move
Command/RenameRemote.hs view
@@ -13,6 +13,7 @@ import qualified Logs.Remote import qualified Types.Remote as R import qualified Remote+import Types.ProposedAccepted import qualified Data.Map as M @@ -50,6 +51,6 @@ let (namefield, cu) = case mcu of Nothing -> (nameField, u) Just (Annex.SpecialRemote.ConfigFrom u') -> (sameasNameField, u')- Logs.Remote.configSet cu (M.insert namefield newname cfg)+ Logs.Remote.configSet cu (M.insert namefield (Proposed newname) cfg) next $ return True
Command/Sync.hs view
@@ -43,6 +43,7 @@ import qualified Remote.Git import Config import Config.GitConfig+import Annex.SpecialRemote.Config import Config.DynamicConfig import Config.Files import Annex.Wanted
Command/TestRemote.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2014-2019 Joey Hess <id@joeyh.name>+ - Copyright 2014-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -24,8 +24,12 @@ import Utility.CopyFile import Types.Messages import Types.Export+import Types.Crypto+import Types.RemoteConfig+import Annex.SpecialRemote.Config (exportTreeField) import Remote.Helper.ExportImport import Remote.Helper.Chunked+import Remote.Helper.Encryptable (describeEncryption, encryptionField, highRandomQualityField) import Git.Types import Test.Tasty@@ -109,7 +113,7 @@ desc r' k = intercalate "; " $ map unwords [ [ "key size", show (fromKey keySize k) ] , [ show (getChunkConfig (Remote.config r')) ]- , ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]+ , ["encryption", describeEncryption (Remote.config r')] ] descexport k1 k2 = intercalate "; " $ map unwords [ [ "exporttree=yes" ]@@ -119,33 +123,35 @@ adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize r chunksize = adjustRemoteConfig r- (M.insert "chunk" (show chunksize))+ (M.insert chunkField (RemoteConfigValue (show chunksize))) -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. encryptionVariants :: Remote -> Annex [Remote] encryptionVariants r = do- noenc <- adjustRemoteConfig r (M.insert "encryption" "none")+ noenc <- adjustRemoteConfig r $+ M.insert encryptionField (RemoteConfigValue NoneEncryption) sharedenc <- adjustRemoteConfig r $- M.insert "encryption" "shared" .- M.insert "highRandomQuality" "false"+ M.insert encryptionField (RemoteConfigValue SharedEncryption) .+ M.insert highRandomQualityField (RemoteConfigValue False) return $ catMaybes [noenc, sharedenc] -- Variant of a remote with exporttree disabled. disableExportTree :: Remote -> Annex Remote disableExportTree r = maybe (error "failed disabling exportree") return - =<< adjustRemoteConfig r (M.delete "exporttree")+ =<< adjustRemoteConfig r (M.delete exportTreeField) -- Variant of a remote with exporttree enabled. exportTreeVariant :: Remote -> Annex (Maybe Remote) exportTreeVariant r = ifM (Remote.isExportSupported r) ( adjustRemoteConfig r $- M.insert "encryption" "none" . M.insert "exporttree" "yes"+ M.insert encryptionField (RemoteConfigValue NoneEncryption) . + M.insert exportTreeField (RemoteConfigValue True) , return Nothing ) -- Regenerate a remote with a modified config.-adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)+adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote) adjustRemoteConfig r adjustconfig = do repo <- Remote.getRepo r Remote.generate (Remote.remotetype r)
Command/Undo.hs view
@@ -58,7 +58,7 @@ -- Take two passes through the diff, first doing any removals, -- and then any adds. This order is necessary to handle eg, removing -- a directory and replacing it with a file.- let (removals, adds) = partition (\di -> dstsha di == nullSha) diff'+ let (removals, adds) = partition (\di -> dstsha di `elem` nullShas) diff' let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $ fromTopFilePath (file di) g
Command/Unused.hs view
@@ -267,7 +267,7 @@ where go d = do let sha = extractsha d- unless (sha == nullSha) $+ unless (sha `elem` nullShas) $ catKey sha >>= maybe noop a {- Filters out keys that have an associated file that's not modified. -}
Config.hs view
@@ -20,9 +20,7 @@ import Types.Availability import Git.Types import qualified Types.Remote as Remote-import qualified Annex.SpecialRemote.Config as SpecialRemote -import qualified Data.Map as M import qualified Data.ByteString as S type UnqualifiedConfigKey = S.ByteString@@ -64,9 +62,6 @@ instance RemoteNameable Remote where getRemoteName = Remote.name -instance RemoteNameable Remote.RemoteConfig where- getRemoteName c = fromMaybe "" (SpecialRemote.lookupName c)- {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig r key = ConfigKey $@@ -96,12 +91,6 @@ setRemoteBare :: Git.Repo -> Bool -> Annex () setRemoteBare r b = setConfig (remoteConfig r "bare") (Git.Config.boolConfig b)--exportTree :: Remote.RemoteConfig -> Bool-exportTree c = fromMaybe False $ yesNo =<< M.lookup "exporttree" c--importTree :: Remote.RemoteConfig -> Bool-importTree c = fromMaybe False $ yesNo =<< M.lookup "importtree" c isBareRepo :: Annex Bool isBareRepo = fromRepo Git.repoIsLocalBare
Creds.hs view
@@ -1,6 +1,6 @@ {- Credentials storage -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -9,6 +9,7 @@ module Types.Creds, CredPairStorage(..), setRemoteCredPair,+ setRemoteCredPair', getRemoteCredPair, getRemoteCredPairFor, missingCredPairFor,@@ -23,11 +24,14 @@ import Annex.Common import qualified Annex import Types.Creds+import Types.RemoteConfig+import Annex.SpecialRemote.Config import Annex.Perms import Utility.FileMode import Crypto import Types.Remote (RemoteConfig, RemoteConfigField)-import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher)+import Types.ProposedAccepted+import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher, parseEncryptionConfig) import Utility.Env (getEnv) import qualified Data.ByteString.Lazy.Char8 as L@@ -53,32 +57,47 @@ - cipher. The EncryptionIsSetup is witness to that being the case. -} setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig-setRemoteCredPair encsetup c gc storage mcreds = case mcreds of- Nothing -> maybe (return c) (setRemoteCredPair encsetup c gc storage . Just)- =<< getRemoteCredPair c gc storage+setRemoteCredPair = setRemoteCredPair' id+ (either (const mempty) id . parseEncryptionConfig)++setRemoteCredPair'+ :: (ProposedAccepted String -> a)+ -> (M.Map RemoteConfigField a -> ParsedRemoteConfig)+ -> EncryptionIsSetup+ -> M.Map RemoteConfigField a+ -> RemoteGitConfig+ -> CredPairStorage+ -> Maybe CredPair+ -> Annex (M.Map RemoteConfigField a)+setRemoteCredPair' mkval parseconfig encsetup c gc storage mcreds = case mcreds of+ Nothing -> maybe (return c) (setRemoteCredPair' mkval parseconfig encsetup c gc storage . Just)+ =<< getRemoteCredPair pc gc storage Just creds- | embedCreds c ->+ | embedCreds pc -> do let key = credPairRemoteField storage- in storeconfig creds key =<< flip remoteCipher gc =<< localcache creds- | otherwise -> localcache creds+ localcache creds+ storeconfig creds key =<< remoteCipher pc gc+ | otherwise -> do+ localcache creds+ return c where- localcache creds = do- writeCacheCredPair creds storage- return c+ localcache creds = writeCacheCredPair creds storage storeconfig creds key (Just cipher) = do cmd <- gpgCmd <$> Annex.getGitConfig- s <- liftIO $ encrypt cmd (c, gc) cipher+ s <- liftIO $ encrypt cmd (pc, gc) cipher (feedBytes $ L.pack $ encodeCredPair creds) (readBytes $ return . L.unpack)- return $ M.insert key (toB64 s) c+ return $ M.insert key (mkval (Accepted (toB64 s))) c storeconfig creds key Nothing =- return $ M.insert key (toB64 $ encodeCredPair creds) c+ return $ M.insert key (mkval (Accepted (toB64 $ encodeCredPair creds))) c+ + pc = parseconfig c {- Gets a remote's credpair, from the environment if set, otherwise - from the cache in gitAnnexCredsDir, or failing that, from the - value in RemoteConfig. -}-getRemoteCredPair :: RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)+getRemoteCredPair :: ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair) getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv where fromenv = liftIO $ getEnvCredPair storage@@ -86,7 +105,7 @@ fromconfig = do let key = credPairRemoteField storage mcipher <- remoteCipher' c gc- case (M.lookup key c, mcipher) of+ case (fromProposedAccepted <$> getRemoteConfigValue key c, mcipher) of (Nothing, _) -> return Nothing (Just enccreds, Just (cipher, storablecipher)) -> fromenccreds enccreds cipher storablecipher@@ -114,7 +133,7 @@ return $ Just credpair _ -> error "bad creds" -getRemoteCredPairFor :: String -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)+getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair) getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage where go Nothing = do@@ -183,7 +202,7 @@ let f = d </> file liftIO $ nukeFile f -includeCredsInfo :: RemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]+includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo c storage info = do v <- liftIO $ getEnvCredPair storage case v of
Crypto.hs view
@@ -3,7 +3,7 @@ - Currently using gpg; could later be modified to support different - crypto backends if neccessary. -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -13,6 +13,7 @@ {-# LANGUAGE Rank2Types #-} module Crypto (+ EncryptionMethod(..), Cipher, KeyIds(..), EncKey,@@ -37,7 +38,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.UTF8 (fromString)-import qualified Data.Map as M import Control.Monad.IO.Class import Annex.Common@@ -232,14 +232,18 @@ {- Extract the GnuPG options from a pair of a Remote Config and a Remote - Git Config. -}-instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where+instance LensGpgEncParams (ParsedRemoteConfig, RemoteGitConfig) where getGpgEncParamsBase (_c,gc) = map Param (remoteAnnexGnupgOptions gc) getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++ {- When the remote is configured to use public-key encryption, - look up the recipient keys and add them to the option list. -}- case M.lookup encryptionField c of- Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup cipherkeysField c- Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup pubkeysField c+ case getRemoteConfigValue encryptionField c of+ Just PubKeyEncryption -> + Gpg.pkEncTo $ maybe [] (splitc ',') $+ getRemoteConfigValue cipherkeysField c+ Just SharedPubKeyEncryption ->+ Gpg.pkEncTo $ maybe [] (splitc ',') $+ getRemoteConfigValue pubkeysField c _ -> [] getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)
Database/Export.hs view
@@ -233,7 +233,7 @@ void $ liftIO cleanup where getek sha- | sha == nullSha = return Nothing+ | sha `elem` nullShas = return Nothing | otherwise = Just <$> exportKey sha {- Diff from the old to the new tree and update the ExportTree table. -}
Database/Keys.hs view
@@ -260,7 +260,7 @@ , Param "--cached" , Param "--raw" , Param "-z"- , Param "--abbrev=40"+ , Param "--no-abbrev" -- Optimization: Only find pointer files. This is not -- perfect. A file could start with this and not be a -- pointer file. And a pointer file that is replaced with
Git/CatFile.hs view
@@ -148,13 +148,12 @@ | " missing" `isSuffixOf` l -- less expensive than full check && l == fromRef object ++ " missing" = Just DNE | otherwise = case words l of- [sha, objtype, size]- | length sha == shaSize ->- case (readObjectType (encodeBS objtype), reads size) of- (Just t, [(bytes, "")]) -> - Just $ ParsedResp (Ref sha) bytes t- _ -> Nothing- | otherwise -> Nothing+ [sha, objtype, size] -> case extractSha sha of+ Just sha' -> case (readObjectType (encodeBS objtype), reads size) of+ (Just t, [(bytes, "")]) -> + Just $ ParsedResp sha' bytes t+ _ -> Nothing+ Nothing -> Nothing _ -> Nothing querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a)
Git/Config.hs view
@@ -1,6 +1,6 @@ {- git repository configuration handling -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as S8 import Data.Char import qualified System.FilePath.ByteString as P+import Control.Concurrent.Async import Common import Git@@ -184,19 +185,22 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw- - output of the command. -}-fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString))+ - output and any standard output of the command. -}+fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) fromPipe r cmd params = try $- withHandle StdoutHandle createProcessSuccess p $ \h -> do- val <- S.hGetContents h+ withOEHandles createProcessSuccess p $ \(hout, herr) -> do+ geterr <- async $ S.hGetContents herr+ getval <- async $ S.hGetContents hout+ val <- wait getval+ err <- wait geterr r' <- store val r- return (r', val)+ return (r', val, err) where p = proc cmd $ toCommand params {- Reads git config from a specified file and returns the repo populated - with the configuration. -}-fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString))+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file"
Git/Credential.hs view
@@ -1,6 +1,6 @@ {- git credential interface -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -21,6 +21,23 @@ credentialPassword :: Credential -> Maybe String credentialPassword = M.lookup "password" . fromCredential++credentialBasicAuth :: Credential -> Maybe BasicAuth+credentialBasicAuth cred = BasicAuth+ <$> credentialUsername cred+ <*> credentialPassword cred++getBasicAuthFromCredential :: Repo -> GetBasicAuth+getBasicAuthFromCredential r u = do+ c <- getUrlCredential u r+ case credentialBasicAuth c of+ Just ba -> return $ Just (ba, signalsuccess c)+ Nothing -> do+ signalsuccess c False+ return Nothing+ where+ signalsuccess c True = approveUrlCredential c r+ signalsuccess c False = rejectUrlCredential c r -- | This may prompt the user for login information, or get cached login -- information.
Git/DiffTree.hs view
@@ -77,14 +77,14 @@ - is adjusted to be the same as diff-tree --raw._-} diffLog :: [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) diffLog params = getdiff (Param "log")- (Param "-n1" : Param "--abbrev=40" : Param "--pretty=format:" : params)+ (Param "-n1" : Param "--no-abbrev" : Param "--pretty=format:" : params) {- Uses git show to get the changes made by a commit. - - Does not support merge commits, and will fail on them. -} commitDiff :: Sha -> Repo -> IO ([DiffTreeItem], IO Bool) commitDiff ref = getdiff (Param "show")- [ Param "--abbrev=40", Param "--pretty=", Param "--raw", Param (fromRef ref) ]+ [ Param "--no-abbrev", Param "--pretty=", Param "--raw", Param (fromRef ref) ] getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) getdiff command params repo = do@@ -119,10 +119,7 @@ readmode = fst . Prelude.head . readOct -- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>- -- All fields are fixed, so we can pull them out of- -- specific positions in the line. (srcm, past_srcm) = splitAt 7 $ drop 1 info (dstm, past_dstm) = splitAt 7 past_srcm- (ssha, past_ssha) = splitAt shaSize past_dstm- (dsha, past_dsha) = splitAt shaSize $ drop 1 past_ssha- s = drop 1 past_dsha+ (ssha, past_ssha) = separate (== ' ') past_dstm+ (dsha, s) = separate (== ' ') past_ssha
Git/DiffTreeItem.hs view
@@ -17,8 +17,8 @@ data DiffTreeItem = DiffTreeItem { srcmode :: FileMode , dstmode :: FileMode- , srcsha :: Sha -- nullSha if file was added- , dstsha :: Sha -- nullSha if file was deleted+ , srcsha :: Sha -- null sha if file was added+ , dstsha :: Sha -- null sha if file was deleted , status :: String , file :: TopFilePath } deriving Show
Git/LsFiles.hs view
@@ -158,17 +158,20 @@ stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo- return (map parse ls, cleanup)+ return (map parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l- parse s- | null file = (L.toStrict s, Nothing, Nothing)- | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode)- where- (metadata, file) = separate (== '\t') (decodeBL' s)- (mode, rest) = separate (== ' ') metadata- readmode = fst <$$> headMaybe . readOct++parseStagedDetails :: L.ByteString -> StagedDetails+parseStagedDetails s+ | null file = (L.toStrict s, Nothing, Nothing)+ | otherwise = (toRawFilePath file, extractSha sha, readmode mode)+ where+ (metadata, file) = separate (== '\t') (decodeBL' s)+ (mode, metadata') = separate (== ' ') metadata+ (sha, _) = separate (== ' ') metadata'+ readmode = fst <$$> headMaybe . readOct {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -}
Git/LsTree.hs view
@@ -94,10 +94,10 @@ <$> octal <* A8.char ' ' -- type- <*> A.takeTill (== 32)+ <*> A8.takeTill (== ' ') <* A8.char ' ' -- sha- <*> (Ref . decodeBS' <$> A.take shaSize)+ <*> (Ref . decodeBS' <$> A8.takeTill (== '\t')) <* A8.char '\t' -- file <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
Git/Remote.hs view
@@ -117,5 +117,5 @@ -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" dosstyle = hasDrive- dospath = fromInternalGitPath+ dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath #endif
Git/Sha.hs view
@@ -1,6 +1,6 @@ {- git SHA stuff -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011,2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -21,8 +21,8 @@ - it, but nothing else. -} extractSha :: String -> Maybe Sha extractSha s- | len == shaSize = val s- | len == shaSize + 1 && length s' == shaSize = val s'+ | len `elem` shaSizes = val s+ | len - 1 `elem` shaSizes && length s' == len - 1 = val s' | otherwise = Nothing where len = length s@@ -31,13 +31,30 @@ | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v | otherwise = Nothing -{- Size of a git sha. -}-shaSize :: Int-shaSize = 40+{- Sizes of git shas. -}+shaSizes :: [Int]+shaSizes = + [ 40 -- sha1 (must come first)+ , 64 -- sha256+ ] -nullSha :: Ref -nullSha = Ref $ replicate shaSize '0'+{- Git plumbing often uses a all 0 sha to represent things like a+ - deleted file. -}+nullShas :: [Sha]+nullShas = map (\n -> Ref (replicate n '0')) shaSizes -{- Git's magic empty tree. -}+{- Sha to provide to git plumbing when deleting a file.+ -+ - It's ok to provide a sha1; git versions that use sha256 will map the+ - sha1 to the sha256, or probably just treat all null sha1 specially+ - the same as all null sha256. -}+deleteSha :: Sha+deleteSha = Prelude.head nullShas++{- Git's magic empty tree.+ -+ - It's ok to provide the sha1 of this to git to refer to an empty tree;+ - git versions that use sha256 will map the sha1 to the sha256.+ -} emptyTree :: Ref emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
Git/UnionMerge.hs view
@@ -82,7 +82,7 @@ - a line suitable for update-index that union merges the two sides of the - diff. -} mergeFile :: String -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)-mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of+mergeFile info file hashhandle h = case filter (`notElem` nullShas) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha shas -> use
Git/UpdateIndex.hs view
@@ -108,7 +108,7 @@ unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ "0 "- <> encodeBS' (fromRef nullSha)+ <> encodeBS' (fromRef deleteSha) <> "\t" <> indexPath p
Key.hs view
@@ -1,6 +1,6 @@ {- git-annex Keys -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -28,6 +28,7 @@ prop_isomorphic_key_encode ) where +import Data.Char import qualified Data.Text as T import qualified Data.ByteString as S import qualified Data.Attoparsec.ByteString as A@@ -79,11 +80,15 @@ <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative -- AssociatedFile cannot be empty, and cannot contain a NUL--- (but can be Nothing)+-- (but can be Nothing). instance Arbitrary AssociatedFile where- arbitrary = (AssociatedFile . fmap toRawFilePath <$> arbitrary)+ arbitrary = (AssociatedFile . fmap conv <$> arbitrary) `suchThat` (/= AssociatedFile (Just S.empty)) `suchThat` (\(AssociatedFile f) -> maybe True (S.notElem 0) f)+ where+ -- Generating arbitrary unicode leads to encoding errors+ -- when LANG=C, so limit to ascii.+ conv = toRawFilePath . filter isAscii instance Arbitrary Key where arbitrary = mkKey . const <$> arbitrary
Logs/Remote/Pure.hs view
@@ -19,6 +19,7 @@ import Annex.Common import Types.Remote+import Types.ProposedAccepted import Logs.UUIDBased import Annex.SpecialRemote.Config @@ -40,24 +41,24 @@ buildRemoteConfigLog = buildLogOld (byteString . encodeBS . showConfig) remoteConfigParser :: A.Parser RemoteConfig-remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString+remoteConfigParser = keyValToConfig Accepted . words . decodeBS <$> A.takeByteString showConfig :: RemoteConfig -> String showConfig = unwords . configToKeyVal {- Given Strings like "key=value", generates a RemoteConfig. -}-keyValToConfig :: [String] -> RemoteConfig-keyValToConfig ws = M.fromList $ map (/=/) ws+keyValToConfig :: (String -> ProposedAccepted String) -> [String] -> RemoteConfig+keyValToConfig mk ws = M.fromList $ map (/=/) ws where- (/=/) s = (k, v)+ (/=/) s = (mk k, mk v) where k = takeWhile (/= '=') s v = configUnEscape $ drop (1 + length k) s -configToKeyVal :: M.Map String String -> [String]+configToKeyVal :: RemoteConfig -> [String] configToKeyVal m = map toword $ sort $ M.toList m where- toword (k, v) = k ++ "=" ++ configEscape v+ toword (k, v) = fromProposedAccepted k ++ "=" ++ configEscape (fromProposedAccepted v) configEscape :: String -> String configEscape = concatMap escape@@ -90,9 +91,9 @@ prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c -- whitespace and '=' are not supported in config keys- | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True- | any (any excluded) (M.keys c) = True- | any (any excluded) (M.elems c) = True+ | any (\k -> any isSpace k || elem '=' k) (map fromProposedAccepted $ M.keys c) = True+ | any (any excluded) (map fromProposedAccepted $ M.keys c) = True+ | any (any excluded) (map fromProposedAccepted $ M.elems c) = True | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c where normalize v = sort . M.toList <$> v
Messages.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -48,6 +48,7 @@ outputMessage, withMessageState, prompt,+ mkPrompter, ) where import System.Log.Logger@@ -55,6 +56,7 @@ import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import Control.Concurrent+import Control.Monad.IO.Class import qualified Data.ByteString as S import Common@@ -290,14 +292,21 @@ - the user. -} prompt :: Annex a -> Annex a-prompt a = debugLocks $ Annex.getState Annex.concurrency >>= \case- NonConcurrent -> a+prompt a = do+ p <- mkPrompter+ p a++{- Like prompt, but for a non-annex action that prompts. -}+mkPrompter :: (MonadMask m, MonadIO m) => Annex (m a -> m a)+mkPrompter = Annex.getState Annex.concurrency >>= \case+ NonConcurrent -> return id (Concurrent _) -> goconcurrent ConcurrentPerCpu -> goconcurrent where goconcurrent = withMessageState $ \s -> do let l = promptLock s- bracketIO- (takeMVar l)- (putMVar l)- (const $ hideRegionsWhile s a)+ return $ \a ->+ debugLocks $ bracketIO+ (takeMVar l)+ (putMVar l)+ (const $ hideRegionsWhile s a)
Messages/Concurrent.hs view
@@ -18,6 +18,7 @@ import qualified System.Console.Concurrent as Console import qualified System.Console.Regions as Regions import Control.Concurrent.STM+import Control.Monad.IO.Class import qualified Data.Text as T #ifndef mingw32_HOST_OS import GHC.IO.Encoding@@ -120,13 +121,14 @@ {- Hide any currently displayed console regions while running the action, - so that the action can use the console itself. -}-hideRegionsWhile :: MessageState -> Annex a -> Annex a-hideRegionsWhile s a - | concurrentOutputEnabled s = bracketIO setup cleanup go+hideRegionsWhile :: (MonadIO m, Monad m, MonadMask m) => MessageState -> m a -> m a+hideRegionsWhile s a+ | concurrentOutputEnabled s = bracket setup cleanup go | otherwise = a where- setup = Regions.waitDisplayChange $ swapTMVar Regions.regionList []- cleanup = void . atomically . swapTMVar Regions.regionList+ setup = liftIO $ + Regions.waitDisplayChange $ swapTMVar Regions.regionList []+ cleanup = liftIO . void . atomically . swapTMVar Regions.regionList go _ = do liftIO $ hFlush stdout a
Remote/Adb.hs view
@@ -1,6 +1,6 @@ {- Remote on Android device accessed using adb. -- - Copyright 2018-2019 Joey Hess <id@joeyh.name>+ - Copyright 2018-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -19,6 +19,8 @@ import Remote.Helper.ExportImport import Annex.UUID import Utility.Metered+import Types.ProposedAccepted+import Annex.SpecialRemote.Config import qualified Data.Map as M import qualified System.FilePath.Posix as Posix@@ -31,16 +33,28 @@ newtype AndroidPath = AndroidPath { fromAndroidPath :: FilePath } remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "adb" , enumerate = const (findSpecialRemotes "adb") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser androiddirectoryField+ (FieldDesc "location on the Android device where the files are stored")+ , optionalStringParser androidserialField+ (FieldDesc "sometimes needed to specify which Android device to use")+ ] , setup = adbSetup , exportSupported = exportIsSupported , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+androiddirectoryField :: RemoteConfigField+androiddirectoryField = Accepted "androiddirectory"++androidserialField :: RemoteConfigField+androidserialField = Accepted "androidserial"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do let this = Remote { uuid = u@@ -109,10 +123,12 @@ u <- maybe (liftIO genUUID) return mu -- verify configuration- adir <- maybe (giveup "Specify androiddirectory=") (pure . AndroidPath)- (M.lookup "androiddirectory" c)+ adir <- maybe+ (giveup "Specify androiddirectory=")+ (pure . AndroidPath . fromProposedAccepted)+ (M.lookup androiddirectoryField c) serial <- getserial =<< liftIO enumerateAdbConnected- let c' = M.insert "androidserial" (fromAndroidSerial serial) c+ let c' = M.insert androidserialField (Proposed (fromAndroidSerial serial)) c (c'', _encsetup) <- encryptionSetup c' gc @@ -130,7 +146,7 @@ return (c'', u) where getserial [] = giveup "adb does not list any connected android devices. Plug in an Android device, or configure adb, and try again.."- getserial l = case M.lookup "androidserial" c of+ getserial l = case fromProposedAccepted <$> M.lookup androidserialField c of Nothing -> case l of (s:[]) -> return s _ -> giveup $ unlines $
Remote/BitTorrent.hs view
@@ -41,6 +41,7 @@ { typename = "bittorrent" , enumerate = list , generate = gen+ , configParser = mkRemoteConfigParser [] , setup = error "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported@@ -52,7 +53,7 @@ r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r _ c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just Remote
Remote/Bup.hs view
@@ -1,6 +1,6 @@ {- Using bup as a remote. -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -25,6 +25,7 @@ import Config import Config.Cost import qualified Remote.Helper.Ssh as Ssh+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport@@ -33,20 +34,28 @@ import Annex.UUID import Annex.Ssh import Utility.Metered+import Types.ProposedAccepted type BupRepo = String remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "bup" , enumerate = const (findSpecialRemotes "buprepo") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser buprepoField+ (FieldDesc "(required) bup repository to use")+ ] , setup = bupSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+buprepoField :: RemoteConfigField+buprepoField = Accepted "buprepo"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do bupr <- liftIO $ bup2GitRemote buprepo cst <- remoteCost gc $@@ -108,8 +117,8 @@ u <- maybe (liftIO genUUID) return mu -- verify configuration is sane- let buprepo = fromMaybe (giveup "Specify buprepo=") $- M.lookup "buprepo" c+ let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $+ M.lookup buprepoField c (c', _encsetup) <- encryptionSetup c gc -- bup init will create the repository.
Remote/Ddar.hs view
@@ -18,11 +18,13 @@ import qualified Git import Config import Config.Cost+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Annex.Ssh import Annex.UUID import Utility.SshHost+import Types.ProposedAccepted data DdarRepo = DdarRepo { ddarRepoConfig :: RemoteGitConfig@@ -30,16 +32,23 @@ } remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "ddar" , enumerate = const (findSpecialRemotes "ddarrepo") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser ddarrepoField+ (FieldDesc "(required) location of ddar archive to use")+ ] , setup = ddarSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+ddarrepoField :: RemoteConfigField+ddarrepoField = Accepted "ddarrepo"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc $ if ddarLocal ddarrepo@@ -98,8 +107,8 @@ u <- maybe (liftIO genUUID) return mu -- verify configuration is sane- let ddarrepo = fromMaybe (giveup "Specify ddarrepo=") $- M.lookup "ddarrepo" c+ let ddarrepo = maybe (giveup "Specify ddarrepo=") fromProposedAccepted $+ M.lookup ddarrepoField c (c', _encsetup) <- encryptionSetup c gc -- The ddarrepo is stored in git config, as well as this repo's
Remote/Directory.hs view
@@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory. -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -24,6 +24,7 @@ import qualified Git import Config.Cost import Config+import Annex.SpecialRemote.Config import Utility.FileMode import Remote.Helper.Special import Remote.Helper.ExportImport@@ -34,18 +35,26 @@ import Utility.Metered import Utility.Tmp import Utility.InodeCache+import Types.ProposedAccepted remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "directory" , enumerate = const (findSpecialRemotes "directory") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser directoryField+ (FieldDesc "(required) where the special remote stores data")+ ] , setup = directorySetup , exportSupported = exportIsSupported , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+directoryField :: RemoteConfigField+directoryField = Accepted "directory"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c@@ -111,8 +120,8 @@ directorySetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane- let dir = fromMaybe (giveup "Specify directory=") $- M.lookup "directory" c+ let dir = maybe (giveup "Specify directory=") fromProposedAccepted $+ M.lookup directoryField c absdir <- liftIO $ absPath dir liftIO $ unlessM (doesDirectoryExist absdir) $ giveup $ "Directory does not exist: " ++ absdir@@ -121,7 +130,7 @@ -- The directory is stored in git config, not in this remote's -- persistant state, so it can vary between hosts. gitConfigSpecialRemote u c' [("directory", absdir)]- return (M.delete "directory" c', u)+ return (M.delete directoryField c', u) {- Locations to try to access a given Key in the directory. - We try more than one since we used to write to different hash
Remote/External.hs view
@@ -1,6 +1,6 @@ {- External special remote interface. -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -16,10 +16,12 @@ import Types.Export import Types.CleanupActions import Types.UrlContents+import Types.ProposedAccepted import qualified Git import Config-import Git.Config (isTrueFalse, boolConfig)+import Git.Config (boolConfig) import Git.Env+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Remote.Helper.ReadOnly@@ -41,18 +43,26 @@ import Control.Concurrent.Async import System.Log.Logger (debugM) import qualified Data.Map as M+import qualified Data.Set as S remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "external" , enumerate = const (findSpecialRemotes "externaltype") , generate = gen+ , configParser = remoteConfigParser , setup = externalSetup , exportSupported = checkExportSupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+externaltypeField :: RemoteConfigField+externaltypeField = Accepted "externaltype"++readonlyField :: RemoteConfigField+readonlyField = Accepted "readonly"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs -- readonly mode only downloads urls; does not use external program | remoteAnnexReadOnly gc = do@@ -69,7 +79,7 @@ exportUnsupported exportUnsupported | otherwise = do- external <- newExternal externaltype u c gc (Just rs)+ external <- newExternal externaltype (Just u) c (Just gc) (Just rs) Annex.addCleanup (RemoteCleanup u) $ stopExternal external cst <- getCost external r gc avail <- getAvailability external r gc@@ -152,32 +162,43 @@ externalSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) externalSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu+ pc <- either giveup return $ parseRemoteConfig c lenientRemoteConfigParser let externaltype = fromMaybe (giveup "Specify externaltype=") $- M.lookup "externaltype" c+ getRemoteConfigValue externaltypeField pc (c', _encsetup) <- encryptionSetup c gc - c'' <- case M.lookup "readonly" c of- Just v | isTrueFalse v == Just True -> do+ c'' <- case getRemoteConfigValue readonlyField pc of+ Just True -> do setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True) return c' _ -> do- external <- newExternal externaltype u c' gc Nothing+ pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser+ external <- newExternal externaltype (Just u) pc' (Just gc) Nothing+ -- Now that we have an external, ask it to LISTCONFIGS, + -- and re-parse the RemoteConfig strictly, so we can+ -- error out if the user provided an unexpected config.+ _ <- either giveup return . parseRemoteConfig c' + =<< strictRemoteConfigParser external handleRequest external INITREMOTE Nothing $ \resp -> case resp of INITREMOTE_SUCCESS -> result () INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg _ -> Nothing- withExternalState external $- liftIO . atomically . readTVar . externalConfig+ -- Any config changes the external made before+ -- responding to INITREMOTE need to be applied to+ -- the RemoteConfig.+ changes <- withExternalState external $+ liftIO . atomically . readTVar . externalConfigChanges+ return (changes c') gitConfigSpecialRemote u c'' [("externaltype", externaltype)] return (c'', u) -checkExportSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool+checkExportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool checkExportSupported c gc = do let externaltype = fromMaybe (giveup "Specify externaltype=") $- remoteAnnexExternalType gc <|> M.lookup "externaltype" c+ remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c checkExportSupported' - =<< newExternal externaltype NoUUID c gc Nothing+ =<< newExternal externaltype Nothing c (Just gc) Nothing checkExportSupported' :: External -> Annex Bool checkExportSupported' external = go `catchNonAsync` (const (return False))@@ -387,36 +408,48 @@ handleRemoteRequest (DIRHASH_LOWER k) = send $ VALUE $ fromRawFilePath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) =- liftIO $ atomically $ modifyTVar' (externalConfig st) $- M.insert setting value+ liftIO $ atomically $ do+ modifyTVar' (externalConfig st) $+ M.insert (Accepted setting) $+ RemoteConfigValue (PassedThrough value)+ modifyTVar' (externalConfigChanges st) $ \f ->+ f . M.insert (Accepted setting) (Accepted value) handleRemoteRequest (GETCONFIG setting) = do- value <- fromMaybe "" . M.lookup setting+ value <- fromMaybe ""+ . M.lookup (Accepted setting)+ . getRemoteConfigPassedThrough <$> liftIO (atomically $ readTVar $ externalConfig st) send $ VALUE value- handleRemoteRequest (SETCREDS setting login password) = do- let v = externalConfig st- c <- liftIO $ atomically $ readTVar v- let gc = externalGitConfig external- c' <- setRemoteCredPair encryptionAlreadySetup c gc- (credstorage setting)- (Just (login, password))- void $ liftIO $ atomically $ swapTVar v c'- handleRemoteRequest (GETCREDS setting) = do- c <- liftIO $ atomically $ readTVar $ externalConfig st- let gc = externalGitConfig external- creds <- fromMaybe ("", "") <$> - getRemoteCredPair c gc (credstorage setting)- send $ CREDS (fst creds) (snd creds)- handleRemoteRequest GETUUID = send $- VALUE $ fromUUID $ externalUUID external+ handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of+ (Just u, Just gc) -> do+ let v = externalConfig st+ c <- liftIO $ atomically $ readTVar v+ c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc+ (credstorage setting u)+ (Just (login, password))+ void $ liftIO $ atomically $ swapTVar v c'+ _ -> senderror "cannot send SETCREDS here"+ handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of+ (Just u, Just gc) -> do+ c <- liftIO $ atomically $ readTVar $ externalConfig st+ creds <- fromMaybe ("", "") <$> + getRemoteCredPair c gc (credstorage setting u)+ send $ CREDS (fst creds) (snd creds)+ _ -> senderror "cannot send GETCREDS here"+ handleRemoteRequest GETUUID = case externalUUID external of+ Just u -> send $ VALUE $ fromUUID u+ Nothing -> senderror "cannot send GETUUID here" handleRemoteRequest GETGITDIR = send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir- handleRemoteRequest (SETWANTED expr) =- preferredContentSet (externalUUID external) expr- handleRemoteRequest GETWANTED = do- expr <- fromMaybe "" . M.lookup (externalUUID external)- <$> preferredContentMapRaw- send $ VALUE expr+ handleRemoteRequest (SETWANTED expr) = case externalUUID external of+ Just u -> preferredContentSet u expr+ Nothing -> senderror "cannot send SETWANTED here"+ handleRemoteRequest GETWANTED = case externalUUID external of+ Just u -> do+ expr <- fromMaybe "" . M.lookup u+ <$> preferredContentMapRaw+ send $ VALUE expr+ Nothing -> senderror "cannot send GETWANTED here" handleRemoteRequest (SETSTATE key state) = case externalRemoteStateHandle external of Just h -> setRemoteState h key state@@ -448,13 +481,13 @@ send = sendMessage st external senderror = sendMessage st external . ERROR - credstorage setting = CredPairStorage+ credstorage setting u = CredPairStorage { credPairFile = base , credPairEnvironment = (base ++ "login", base ++ "password")- , credPairRemoteField = setting+ , credPairRemoteField = Accepted setting } where- base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting+ base = replace "/" "_" $ fromUUID u ++ "-" ++ setting withurl mk uri = handleRemoteRequest $ mk $ setDownloader (show uri) OtherDownloader@@ -579,6 +612,7 @@ createProcess p `catchIO` runerr cmdpath stderrelay <- async $ errrelayer herr cv <- newTVarIO $ externalDefaultConfig external+ ccv <- newTVarIO id pv <- newTVarIO Unprepared pid <- atomically $ do n <- succ <$> readTVar (externalLastPid external)@@ -593,6 +627,7 @@ void $ waitForProcess ph , externalPrepared = pv , externalConfig = cv+ , externalConfigChanges = ccv } basecmd = externalRemoteProgram $ externalType external@@ -712,7 +747,7 @@ retrieveUrl :: Retriever retrieveUrl = fileRetriever $ \f k p -> do us <- getWebUrls k- unlessM (downloadUrl k p us f) $+ unlessM (withUrlOptions $ downloadUrl k p us f) $ giveup "failed to download content" checkKeyUrl :: Git.Repo -> CheckPresent@@ -745,3 +780,63 @@ INFOVALUE v -> Just $ return $ GetNextMessage $ collect ((f, v) : l) _ -> Nothing++{- All unknown configs are passed through in case the external program+ - uses them. -}+lenientRemoteConfigParser :: RemoteConfigParser+lenientRemoteConfigParser =+ addRemoteConfigParser specialRemoteConfigParsers baseRemoteConfigParser++baseRemoteConfigParser :: RemoteConfigParser+baseRemoteConfigParser = RemoteConfigParser+ { remoteConfigFieldParsers =+ [ optionalStringParser externaltypeField+ (FieldDesc "type of external special remote to use")+ , trueFalseParser readonlyField False+ (FieldDesc "enable readonly mode")+ ]+ , remoteConfigRestPassthrough = Just+ ( const True+ , [("*", FieldDesc "all other parameters are passed to external special remote program")]+ )+ }++{- When the remote supports LISTCONFIGS, only accept the ones it listed.+ - When it does not, accept all configs. -}+strictRemoteConfigParser :: External -> Annex RemoteConfigParser+strictRemoteConfigParser external = listConfigs external >>= \case+ Nothing -> return lenientRemoteConfigParser+ Just l -> do+ let s = S.fromList (map fst l)+ let listed f = S.member (fromProposedAccepted f) s+ return $ lenientRemoteConfigParser+ { remoteConfigRestPassthrough = Just (listed, l) }++listConfigs :: External -> Annex (Maybe [(Setting, FieldDesc)])+listConfigs external = handleRequest external LISTCONFIGS Nothing (collect [])+ where+ collect l req = case req of+ CONFIG s d -> Just $ return $+ GetNextMessage $ collect ((s, FieldDesc d) : l)+ CONFIGEND -> result (Just (reverse l))+ UNSUPPORTED_REQUEST -> result Nothing+ _ -> Nothing++remoteConfigParser :: RemoteConfig -> Annex RemoteConfigParser+remoteConfigParser c+ -- No need to start the external when there is no config to parse,+ -- or when everything in the config was already accepted; in those+ -- cases the lenient parser will do the same thing as the strict+ -- parser.+ | M.null (M.filter isproposed c) = return lenientRemoteConfigParser+ | otherwise = case parseRemoteConfig c baseRemoteConfigParser of+ Left _ -> return lenientRemoteConfigParser+ Right pc -> case (getRemoteConfigValue externaltypeField pc, getRemoteConfigValue readonlyField pc) of+ (Nothing, _) -> return lenientRemoteConfigParser+ (_, Just True) -> return lenientRemoteConfigParser+ (Just externaltype, _) -> do+ external <- newExternal externaltype Nothing pc Nothing Nothing+ strictRemoteConfigParser external+ where+ isproposed (Accepted _) = False+ isproposed (Proposed _) = True
Remote/External/Types.hs view
@@ -1,6 +1,6 @@ {- External special remote data types. -- - Copyright 2013-2018 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -28,6 +28,7 @@ AsyncMessage(..), ErrorMsg, Setting,+ Description, ProtocolVersion, supportedProtocolVersions, ) where@@ -37,7 +38,8 @@ import Utility.Metered (BytesProcessed(..)) import Types.Transfer (Direction(..)) import Config.Cost (Cost)-import Types.Remote (RemoteConfig, RemoteStateHandle)+import Types.RemoteState+import Types.RemoteConfig import Types.Export import Types.Availability (Availability(..)) import Types.Key@@ -50,17 +52,17 @@ data External = External { externalType :: ExternalType- , externalUUID :: UUID+ , externalUUID :: Maybe UUID , externalState :: TVar [ExternalState] -- ^ Contains states for external special remote processes -- that are not currently in use. , externalLastPid :: TVar PID- , externalDefaultConfig :: RemoteConfig- , externalGitConfig :: RemoteGitConfig+ , externalDefaultConfig :: ParsedRemoteConfig+ , externalGitConfig :: Maybe RemoteGitConfig , externalRemoteStateHandle :: Maybe RemoteStateHandle } -newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External+newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External newExternal externaltype u c gc rs = liftIO $ External <$> pure externaltype <*> pure u@@ -78,7 +80,8 @@ , externalShutdown :: IO () , externalPid :: PID , externalPrepared :: TVar PrepareStatus- , externalConfig :: TVar RemoteConfig+ , externalConfig :: TVar ParsedRemoteConfig+ , externalConfigChanges :: TVar (RemoteConfig -> RemoteConfig) } type PID = Int@@ -129,6 +132,7 @@ | CHECKPRESENT SafeKey | REMOVE SafeKey | WHEREIS SafeKey+ | LISTCONFIGS | GETINFO | EXPORTSUPPORTED | EXPORT ExportLocation@@ -145,6 +149,7 @@ needsPREPARE (EXTENSIONS _) = False needsPREPARE INITREMOTE = False needsPREPARE EXPORTSUPPORTED = False+needsPREPARE LISTCONFIGS = False needsPREPARE _ = True instance Proto.Sendable Request where@@ -165,6 +170,7 @@ [ "CHECKPRESENT", Proto.serialize key ] formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ] formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]+ formatMessage LISTCONFIGS = [ "LISTCONFIGS" ] formatMessage GETINFO = [ "GETINFO" ] formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"] formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]@@ -209,6 +215,8 @@ | CHECKURL_FAILURE ErrorMsg | WHEREIS_SUCCESS String | WHEREIS_FAILURE+ | CONFIG Setting Description+ | CONFIGEND | INFOFIELD String | INFOVALUE String | INFOEND@@ -243,6 +251,8 @@ parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE+ parseCommand "CONFIG" = Proto.parse2 CONFIG+ parseCommand "CONFIGEND" = Proto.parse0 CONFIGEND parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE parseCommand "INFOEND" = Proto.parse0 INFOEND@@ -330,6 +340,7 @@ -- All are serializable. type ErrorMsg = String type Setting = String+type Description = String type ProtocolVersion = Int type Size = Maybe Integer
Remote/GCrypt.hs view
@@ -39,6 +39,7 @@ import qualified Annex.Branch import Config import Config.Cost+import Annex.SpecialRemote.Config import Remote.Helper.Git import Remote.Helper.Encryptable import Remote.Helper.Special@@ -55,21 +56,31 @@ import Logs.Remote import Utility.Gpg import Utility.SshHost+import Utility.Tuple import Messages.Progress+import Types.ProposedAccepted remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "gcrypt" -- Remote.Git takes care of enumerating gcrypt remotes too, -- and will call our gen on them. , enumerate = const (return []) , generate = gen+ , configParser = mkRemoteConfigParser $+ Remote.Rsync.rsyncRemoteConfigs +++ [ optionalStringParser gitRepoField+ (FieldDesc "(required) path or url to gcrypt repository")+ ] , setup = gCryptSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gitRepoField :: RemoteConfigField+gitRepoField = Accepted "gitrepo"++chainGen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) chainGen gcryptr u c gc rs = do g <- gitRepo -- get underlying git repo with real path, not gcrypt path@@ -77,7 +88,7 @@ let r' = r { Git.remoteName = Git.remoteName gcryptr } gen r' u c gc rs -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen baser u c gc rs = do -- doublecheck that cache matches underlying repo's gcrypt-id -- (which might not be set), only for local repos@@ -98,15 +109,18 @@ v <- M.lookup u' <$> readRemoteLog case (Git.remoteName baser, v) of (Just remotename, Just c') -> do- setGcryptEncryption c' remotename+ pc <- either giveup return+ . parseRemoteConfig c'+ =<< configParser remote c'+ setGcryptEncryption pc remotename storeUUIDIn (remoteConfig baser "uuid") u' setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid- gen' r u' c' gc rs+ gen' r u' pc gc rs _ -> do warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r return Nothing -gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen' r u c gc rs = do cst <- remoteCost gc $ if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost@@ -187,7 +201,7 @@ unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported" gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c+gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c where remotename = fromJust (lookupName c) go Nothing = giveup "Specify gitrepo="@@ -206,7 +220,9 @@ | Git.repoLocation r == url -> noop | otherwise -> error "Another remote with the same name already exists." - setGcryptEncryption c' remotename+ pc <- either giveup return . parseRemoteConfig c'+ =<< configParser remote c'+ setGcryptEncryption pc remotename {- Run a git fetch and a push to the git repo in order to get - its gcrypt-id set up, so that later git annex commands@@ -322,7 +338,7 @@ - Also, sets gcrypt-publish-participants to avoid unncessary gpg - passphrase prompts. -}-setGcryptEncryption :: RemoteConfig -> String -> Annex ()+setGcryptEncryption :: ParsedRemoteConfig -> String -> Annex () setGcryptEncryption c remotename = do let participants = remoteconfig Git.GCrypt.remoteParticipantConfigKey case extractCipher c of@@ -456,7 +472,7 @@ getGCryptId fast r gc | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> liftIO (catchMaybeIO $ Git.Config.read r)- | not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)+ | not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>) [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p), return (Left $ error "configlist failed")) "configlist" [] [] , getConfigViaRsync r gc ]@@ -465,7 +481,7 @@ extract Nothing = (Nothing, r) extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r') -getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString))+getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, S.ByteString)) getConfigViaRsync r gc = do (rsynctransport, rsyncurl, _) <- rsyncTransport r gc opts <- rsynctransport
Remote/Git.hs view
@@ -37,6 +37,7 @@ import Utility.Tmp import Config import Config.Cost+import Annex.SpecialRemote.Config import Config.DynamicConfig import Annex.Init import Types.CleanupActions@@ -59,11 +60,12 @@ import Annex.Path import Creds import Types.NumCopies+import Types.ProposedAccepted import Annex.Action import Messages.Progress-import qualified Utility.RawFilePath as R #ifndef mingw32_HOST_OS+import qualified Utility.RawFilePath as R import Utility.FileMode #endif @@ -78,11 +80,18 @@ { typename = "git" , enumerate = list , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser locationField+ (FieldDesc "url of git remote to remember with special remote")+ ] , setup = gitSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } +locationField :: RemoteConfigField+locationField = Accepted "location"+ list :: Bool -> Annex [Git.Repo] list autoinit = do c <- fromRepo Git.config@@ -111,7 +120,8 @@ gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) gitSetup Init mu _ c _ = do let location = fromMaybe (giveup "Specify location=url") $- Url.parseURIRelaxed =<< M.lookup "location" c+ Url.parseURIRelaxed . fromProposedAccepted+ =<< M.lookup locationField c rs <- Annex.getGitRemotes u <- case filter (\r -> Git.location r == Git.Url location) rs of [r] -> getRepoUUID r@@ -125,7 +135,7 @@ [ Param "remote" , Param "add" , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c)- , Param $ fromMaybe (giveup "no location") (M.lookup "location" c)+ , Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c) ] return (c, u) gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid"@@ -151,7 +161,7 @@ Just r' -> return r' _ -> return r -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs -- Remote.GitLFS may be used with a repo that is also encrypted -- with gcrypt so is checked first.@@ -202,7 +212,7 @@ , remoteStateHandle = rs } -unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+unavailable :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable r = gen r' where r' = case Git.location r of@@ -238,7 +248,7 @@ | haveconfig r = return r -- already read | Git.repoIsSsh r = storeUpdatedRemote $ do v <- Ssh.onRemote NoConsumeStdin r- (pipedconfig, return (Left $ giveup "configlist failed"))+ (pipedconfig autoinit (Git.repoDescribe r), return (Left $ giveup "configlist failed")) "configlist" [] configlistfields case v of Right r'@@ -253,23 +263,25 @@ where haveconfig = not . M.null . Git.config - pipedconfig cmd params = do+ pipedconfig mustincludeuuuid configloc cmd params = do v <- liftIO $ Git.Config.fromPipe r cmd params case v of- Right (r', val) -> do- unless (isUUIDConfigured r' || S.null val) $ do+ Right (r', val, _err) -> do+ unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ "Instead, got: " ++ show val warning $ "This is unexpected; please check the network transport!" return $ Right r'- Left l -> return $ Left l+ Left l -> do+ warning $ "Unable to parse git config from " ++ configloc+ return $ Left l - geturlconfig = Url.withUrlOptions $ \uo -> do+ geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do liftIO $ hClose h let url = Git.repoLocation r ++ "/config" ifM (liftIO $ Url.downloadQuiet nullMeterUpdate url tmpfile uo)- ( Just <$> pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]+ ( Just <$> pipedconfig False url "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] , return Nothing ) case v of@@ -370,7 +382,7 @@ checkhttp = do showChecking repo gc <- Annex.getGitConfig- ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key))+ ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key)) ( return True , giveup "not found" )@@ -502,7 +514,8 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meterupdate | Git.repoIsHttp repo = unVerified $ do gc <- Annex.getGitConfig- Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest+ Url.withUrlOptionsPromptingCreds $+ Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest | not $ Git.repoIsUrl repo = guardUsable repo (unVerified (return False)) $ do params <- Ssh.rsyncParams r Download u <- getUUID
Remote/GitLFS.hs view
@@ -1,6 +1,6 @@ {- Using git-lfs as a remote. -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -14,6 +14,7 @@ import Annex.Url import Types.Key import Types.Creds+import Types.ProposedAccepted import qualified Annex import qualified Annex.SpecialRemote.Config import qualified Git@@ -24,6 +25,7 @@ import qualified Git.Credential as Git import Config import Config.Cost+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Remote.Helper.Git@@ -35,6 +37,7 @@ import Backend.Hash import Utility.Hash import Utility.SshHost+import Utility.Url import Logs.Remote import Logs.RemoteState import qualified Utility.GitLFS as LFS@@ -52,18 +55,25 @@ import qualified Control.Concurrent.MSemN as MSemN remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "git-lfs" -- Remote.Git takes care of enumerating git-lfs remotes too, -- and will call our gen on them. , enumerate = const (return []) , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser urlField+ (FieldDesc "url of git-lfs repository")+ ] , setup = mySetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+urlField :: RemoteConfigField+urlField = Accepted "url"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do -- If the repo uses gcrypt, get the underlaying repo without the -- gcrypt url, to do LFS endpoint discovery on.@@ -127,9 +137,10 @@ u <- maybe (liftIO genUUID) return mu (c', _encsetup) <- encryptionSetup c gc- case (isEncrypted c', Git.GCrypt.urlPrefix `isPrefixOf` url) of+ pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c'+ case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of (False, False) -> noop- (True, True) -> Remote.GCrypt.setGcryptEncryption c' remotename+ (True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename (True, False) -> unlessM (Annex.getState Annex.force) $ giveup $ unwords $ [ "Encryption is enabled for this remote,"@@ -158,7 +169,8 @@ setConfig (Git.ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url return (c', u) where- url = fromMaybe (giveup "Specify url=") (M.lookup "url" c)+ url = maybe (giveup "Specify url=") fromProposedAccepted + (M.lookup urlField c) remotename = fromJust (lookupName c) {- Check if a remote's url is one known to belong to a git-lfs repository.@@ -175,8 +187,10 @@ | otherwise = return Nothing where match g c = fromMaybe False $ do- t <- M.lookup Annex.SpecialRemote.Config.typeField c- u <- M.lookup "url" c+ t <- fromProposedAccepted+ <$> M.lookup Annex.SpecialRemote.Config.typeField c+ u <- fromProposedAccepted+ <$> M.lookup urlField c let u' = Git.Remote.parseRemoteLocation u g return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u' && t == typename remote@@ -270,7 +284,7 @@ if needauth (responseStatus resp) then do cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri)- let endpoint' = addbasicauth cred endpoint+ let endpoint' = addbasicauth (Git.credentialBasicAuth cred) endpoint let testreq' = LFS.startTransferRequest endpoint' transfernothing flip catchNonAsync (const (returnendpoint endpoint')) $ do resp' <- makeSmallAPIRequest testreq'@@ -290,12 +304,10 @@ needauth status = status == unauthorized401 - addbasicauth cred endpoint =- case (Git.credentialUsername cred, Git.credentialPassword cred) of- (Just u, Just p) ->- LFS.modifyEndpointRequest endpoint $- applyBasicAuth (encodeBS u) (encodeBS p)- _ -> endpoint+ addbasicauth (Just ba) endpoint =+ LFS.modifyEndpointRequest endpoint $+ applyBasicAuth' ba+ addbasicauth Nothing endpoint = endpoint -- The endpoint is cached for later use. getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)
Remote/Glacier.hs view
@@ -1,6 +1,6 @@ {- Amazon Glacier remotes. -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -16,6 +16,7 @@ import qualified Git import Config import Config.Cost+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport@@ -25,21 +26,40 @@ import qualified Annex import Annex.UUID import Utility.Env+import Types.ProposedAccepted type Vault = String type Archive = FilePath remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "glacier" , enumerate = const (findSpecialRemotes "glacier") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser datacenterField+ (FieldDesc "S3 datacenter to use")+ , optionalStringParser vaultField+ (FieldDesc "name to use for vault")+ , optionalStringParser fileprefixField+ (FieldDesc "prefix to add to filenames in the vault")+ , optionalStringParser AWS.s3credsField HiddenField+ ] , setup = glacierSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+datacenterField :: RemoteConfigField+datacenterField = Accepted "datacenter"+ +vaultField :: RemoteConfigField+vaultField = Accepted "vault"++fileprefixField :: RemoteConfigField+fileprefixField = Accepted "fileprefix"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost where new cst = Just $ specialRemote' specialcfg c@@ -99,8 +119,10 @@ (c', encsetup) <- encryptionSetup c gc c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults+ pc <- either giveup return . parseRemoteConfig fullconfig+ =<< configParser remote fullconfig case ss of- Init -> genVault fullconfig gc u+ Init -> genVault pc gc u _ -> return () gitConfigSpecialRemote u fullconfig [("glacier", "true")] return (fullconfig, u)@@ -108,8 +130,8 @@ remotename = fromJust (lookupName c) defvault = remotename ++ "-" ++ fromUUID u defaults = M.fromList- [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.Glacier)- , ("vault", defvault)+ [ (datacenterField, Proposed $ T.unpack $ AWS.defaultRegion AWS.Glacier)+ , (vaultField, Proposed defvault) ] prepareStore :: Remote -> Preparer Storer@@ -224,21 +246,21 @@ glacierAction :: Remote -> [CommandParam] -> Annex Bool glacierAction r = runGlacier (config r) (gitconfig r) (uuid r) -runGlacier :: RemoteConfig -> RemoteGitConfig -> UUID -> [CommandParam] -> Annex Bool+runGlacier :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> [CommandParam] -> Annex Bool runGlacier c gc u params = go =<< glacierEnv c gc u where go Nothing = return False go (Just e) = liftIO $ boolSystemEnv "glacier" (glacierParams c params) (Just e) -glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam]+glacierParams :: ParsedRemoteConfig -> [CommandParam] -> [CommandParam] glacierParams c params = datacenter:params where datacenter = Param $ "--region=" ++ fromMaybe (giveup "Missing datacenter configuration")- (M.lookup "datacenter" c)+ (getRemoteConfigValue datacenterField c) -glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])+glacierEnv :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)]) glacierEnv c gc u = do liftIO checkSaneGlacierCommand go =<< getRemoteCredPairFor "glacier" c gc creds@@ -251,16 +273,17 @@ creds = AWS.creds u (uk, pk) = credPairEnvironment creds -getVault :: RemoteConfig -> Vault+getVault :: ParsedRemoteConfig -> Vault getVault = fromMaybe (giveup "Missing vault configuration") - . M.lookup "vault"+ . getRemoteConfigValue vaultField archive :: Remote -> Key -> Archive archive r k = fileprefix ++ serializeKey k where- fileprefix = M.findWithDefault "" "fileprefix" $ config r+ fileprefix = fromMaybe "" $+ getRemoteConfigValue fileprefixField $ config r -genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()+genVault :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex () genVault c gc u = unlessM (runGlacier c gc u params) $ giveup "Failed creating glacier vault." where
Remote/Helper/AWS.hs view
@@ -12,6 +12,8 @@ import Annex.Common import Creds+import Types.ProposedAccepted+import Types.RemoteConfig import qualified Data.Map as M import qualified Data.ByteString as B@@ -23,8 +25,11 @@ creds u = CredPairStorage { credPairFile = fromUUID u , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY")- , credPairRemoteField = "s3creds"+ , credPairRemoteField = s3credsField }++s3credsField :: RemoteConfigField+s3credsField = Accepted "s3creds" data Service = S3 | Glacier deriving (Eq)
Remote/Helper/Chunked.hs view
@@ -1,6 +1,6 @@ {- git-annex chunked remotes -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -10,17 +10,20 @@ ChunkConfig(..), noChunks, describeChunkConfig,+ chunkConfigParsers, getChunkConfig, storeChunks, removeChunks, retrieveChunks, checkPresentChunks,+ chunkField, ) where import Annex.Common import Utility.DataUnits import Types.StoreRetrieve import Types.Remote+import Types.ProposedAccepted import Logs.Chunk import Utility.Metered import Crypto (EncKey)@@ -28,7 +31,6 @@ import Annex.SpecialRemote.Config import qualified Data.ByteString.Lazy as L-import qualified Data.Map as M data ChunkConfig = NoChunks@@ -48,19 +50,26 @@ noChunks NoChunks = True noChunks _ = False -getChunkConfig :: RemoteConfig -> ChunkConfig-getChunkConfig m =- case M.lookup chunksizeField m of- Nothing -> case M.lookup "chunk" m of+chunkConfigParsers :: [RemoteConfigFieldParser]+chunkConfigParsers =+ [ optionalStringParser chunksizeField HiddenField -- deprecated+ , optionalStringParser chunkField+ (FieldDesc "size of chunks (eg, 1MiB)")+ ]++getChunkConfig :: ParsedRemoteConfig -> ChunkConfig+getChunkConfig c =+ case getRemoteConfigValue chunksizeField c of+ Nothing -> case getRemoteConfigValue chunkField c of Nothing -> NoChunks- Just v -> readsz UnpaddedChunks v "chunk"+ Just v -> readsz UnpaddedChunks v chunkField Just v -> readsz LegacyChunks v chunksizeField where- readsz c v f = case readSize dataUnits v of+ readsz mk v f = case readSize dataUnits v of Just size | size == 0 -> NoChunks- | size > 0 -> c (fromInteger size)- _ -> giveup $ "bad configuration " ++ f ++ "=" ++ v+ | size > 0 -> mk (fromInteger size)+ _ -> giveup $ "bad configuration " ++ fromProposedAccepted f ++ "=" ++ v -- An infinite stream of chunk keys, starting from chunk 1. newtype ChunkKeyStream = ChunkKeyStream [Key]
Remote/Helper/Encryptable.hs view
@@ -1,15 +1,19 @@ {- common functions for encryptable remotes -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+ module Remote.Helper.Encryptable ( EncryptionIsSetup, encryptionSetup, noEncryptionUsed, encryptionAlreadySetup,+ encryptionConfigParsers,+ parseEncryptionConfig, remoteCipher, remoteCipher', embedCreds,@@ -17,17 +21,20 @@ extractCipher, isEncrypted, describeEncryption,+ encryptionField,+ highRandomQualityField ) where import qualified Data.Map as M+import qualified Data.Set as S import qualified "sandi" Codec.Binary.Base64 as B64 import qualified Data.ByteString as B import Annex.Common import Types.Remote-import Config import Crypto import Types.Crypto+import Types.ProposedAccepted import qualified Annex import Annex.SpecialRemote.Config @@ -46,67 +53,170 @@ encryptionAlreadySetup :: EncryptionIsSetup encryptionAlreadySetup = EncryptionIsSetup +encryptionConfigParsers :: [RemoteConfigFieldParser]+encryptionConfigParsers =+ [ encryptionFieldParser+ , optionalStringParser cipherField HiddenField+ , optionalStringParser cipherkeysField HiddenField+ , optionalStringParser pubkeysField HiddenField+ , yesNoParser embedCredsField False+ (FieldDesc "embed credentials into git repository")+ , macFieldParser+ , optionalStringParser (Accepted "keyid")+ (FieldDesc "gpg key id")+ , optionalStringParser (Accepted "keyid+")+ (FieldDesc "add additional gpg key")+ , optionalStringParser (Accepted "keyid-")+ (FieldDesc "remove gpg key")+ , highRandomQualityFieldParser+ ]++encryptionConfigs :: S.Set RemoteConfigField+encryptionConfigs = S.fromList (map parserForField encryptionConfigParsers)++-- Parse only encryption fields, ignoring all others.+parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig+parseEncryptionConfig c = parseRemoteConfig+ (M.restrictKeys c encryptionConfigs)+ (RemoteConfigParser encryptionConfigParsers Nothing)++encryptionFieldParser :: RemoteConfigFieldParser+encryptionFieldParser = RemoteConfigFieldParser+ { parserForField = encryptionField+ , valueParser = \v c -> Just . RemoteConfigValue+ <$> parseEncryptionMethod (fmap fromProposedAccepted v) c+ , fieldDesc = FieldDesc "how to encrypt data stored in the special remote"+ , valueDesc = Just $ ValueDesc $+ intercalate " or " (M.keys encryptionMethods)+ }++encryptionMethods :: M.Map String EncryptionMethod+encryptionMethods = M.fromList+ [ ("none", NoneEncryption)+ , ("shared", SharedEncryption)+ , ("hybrid", HybridEncryption)+ , ("pubkey", PubKeyEncryption)+ , ("sharedpubkey", SharedPubKeyEncryption)+ ]++parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod+parseEncryptionMethod (Just s) _ = case M.lookup s encryptionMethods of+ Just em -> Right em+ Nothing -> Left badEncryptionMethod+-- Hybrid encryption is the default when a keyid is specified without+-- an encryption field, or when there's a cipher already but no encryption+-- field.+parseEncryptionMethod Nothing c+ | M.member (Accepted "keyid") c || M.member cipherField c = Right HybridEncryption+ | otherwise = Left badEncryptionMethod++badEncryptionMethod :: String+badEncryptionMethod = "Specify " ++ intercalate " or "+ (map ((fromProposedAccepted encryptionField ++ "=") ++)+ (M.keys encryptionMethods))+ ++ "."++highRandomQualityField :: RemoteConfigField+highRandomQualityField = Accepted "highRandomQuality"++highRandomQualityFieldParser :: RemoteConfigFieldParser+highRandomQualityFieldParser = RemoteConfigFieldParser+ { parserForField = highRandomQualityField+ , valueParser = \v _c -> Just . RemoteConfigValue+ <$> parseHighRandomQuality (fmap fromProposedAccepted v)+ , fieldDesc = HiddenField+ , valueDesc = Nothing+ }+ +parseHighRandomQuality :: Maybe String -> Either String Bool+parseHighRandomQuality Nothing = Right True+parseHighRandomQuality (Just "false") = Right False+parseHighRandomQuality (Just "true") = Right True+parseHighRandomQuality _ = Left "expected highRandomQuality=true/false"+ +macFieldParser :: RemoteConfigFieldParser+macFieldParser = RemoteConfigFieldParser+ { parserForField = macField+ , valueParser = \v _c -> Just . RemoteConfigValue <$> parseMac v+ , fieldDesc = FieldDesc "how to encrypt filenames used on the remote"+ , valueDesc = Just $ ValueDesc $+ intercalate " or " (M.keys macMap)+ }++parseMac :: Maybe (ProposedAccepted String) -> Either String Mac+parseMac Nothing = Right defaultMac+parseMac (Just (Accepted s)) = Right $ fromMaybe defaultMac (readMac s)+parseMac (Just (Proposed s)) = case readMac s of+ Just mac -> Right mac+ Nothing -> Left "bad mac value"+ {- Encryption setup for a remote. The user must specify whether to use - an encryption key, or not encrypt. An encrypted cipher is created, or is - updated to be accessible to an additional encryption key. Or the user - could opt to use a shared cipher, which is stored unencrypted. -} encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup) encryptionSetup c gc = do+ pc <- either giveup return $ parseEncryptionConfig c cmd <- gpgCmd <$> Annex.getGitConfig- maybe (genCipher cmd) (updateCipher cmd) (extractCipher c)+ maybe (genCipher pc cmd) (updateCipher pc cmd) (extractCipher pc) where -- The type of encryption- encryption = M.lookup encryptionField c+ encryption = parseEncryptionMethod (fromProposedAccepted <$> M.lookup encryptionField c) c -- Generate a new cipher, depending on the chosen encryption scheme- genCipher cmd = case encryption of- _ | hasEncryptionConfig c -> cannotchange- Just "none" -> return (c, NoEncryption)- Just "shared" -> encsetup $ genSharedCipher cmd- -- hybrid encryption is the default when a keyid is- -- specified but no encryption- _ | maybe (M.member "keyid" c) (== "hybrid") encryption ->- encsetup $ genEncryptedCipher cmd (c, gc) key Hybrid- Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey- Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key- _ -> giveup $ "Specify " ++ intercalate " or "- (map ((encryptionField ++ "=") ++)- ["none","shared","hybrid","pubkey", "sharedpubkey"])- ++ "."- key = fromMaybe (giveup "Specify keyid=...") $ M.lookup "keyid" c- newkeys = maybe [] (\k -> [(True,k)]) (M.lookup "keyid+" c) ++- maybe [] (\k -> [(False,k)]) (M.lookup "keyid-" c)+ genCipher pc cmd = case encryption of+ Right NoneEncryption -> return (c, NoEncryption)+ Right SharedEncryption -> encsetup $ genSharedCipher cmd+ Right HybridEncryption -> encsetup $ genEncryptedCipher cmd (pc, gc) key Hybrid+ Right PubKeyEncryption -> encsetup $ genEncryptedCipher cmd (pc, gc) key PubKey+ Right SharedPubKeyEncryption -> encsetup $ genSharedPubKeyCipher cmd key+ Left err -> giveup err+ key = maybe (giveup "Specify keyid=...") fromProposedAccepted $+ M.lookup (Accepted "keyid") c+ newkeys = maybe [] (\k -> [(True,fromProposedAccepted k)]) (M.lookup (Accepted "keyid+") c) +++ maybe [] (\k -> [(False,fromProposedAccepted k)]) (M.lookup (Accepted "keyid-") c) cannotchange = giveup "Cannot set encryption type of existing remotes." -- Update an existing cipher if possible.- updateCipher cmd v = case v of- SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)- EncryptedCipher _ variant _- | maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption -> do- use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v+ updateCipher pc cmd v = case v of+ SharedCipher _ | encryption == Right SharedEncryption ->+ return (c', EncryptionIsSetup)+ EncryptedCipher _ variant _ | sameasencryption variant ->+ use "encryption update" $ updateCipherKeyIds cmd (pc, gc) newkeys v SharedPubKeyCipher _ _ ->- use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v+ use "encryption update" $ updateCipherKeyIds cmd (pc, gc) newkeys v _ -> cannotchange+ sameasencryption variant = case encryption of+ Right HybridEncryption -> variant == Hybrid+ Right PubKeyEncryption -> variant == PubKey+ Right _ -> False+ Left _ -> True encsetup a = use "encryption setup" . a =<< highRandomQuality use m a = do showNote m cipher <- liftIO a showNote (describeCipher cipher) return (storeCipher cipher c', EncryptionIsSetup)- highRandomQuality = - (&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c)- <$> fmap not (Annex.getState Annex.fast)+ highRandomQuality = ifM (Annex.getState Annex.fast)+ ( return False+ , case parseHighRandomQuality (fromProposedAccepted <$> M.lookup highRandomQualityField c) of+ Left err -> giveup err+ Right v -> return v+ ) c' = foldr M.delete c- -- git-annex used to remove 'encryption' as well, since+ -- Remove configs that are only used in here to generate+ -- the encryption keys, and should not be stored in+ -- remote.log.+ -- Older versions used to remove 'encryption' as well, since -- it was redundant; we now need to keep it for -- public-key encryption, hence we leave it on newer -- remotes (while being backward-compatible).- [ "keyid", "keyid+", "keyid-", "highRandomQuality" ]+ (map Accepted ["keyid", "keyid+", "keyid-", "highRandomQuality"]) -remoteCipher :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher)+remoteCipher :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher) remoteCipher c gc = fmap fst <$> remoteCipher' c gc {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex - state. -}-remoteCipher' :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))+remoteCipher' :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher)) remoteCipher' c gc = go $ extractCipher c where go Nothing = return Nothing@@ -128,17 +238,19 @@ - When gpg encryption is used and the creds are encrypted using it. - Not when a shared cipher is used. -}-embedCreds :: RemoteConfig -> Bool-embedCreds c = case yesNo =<< M.lookup "embedcreds" c of+embedCreds :: ParsedRemoteConfig -> Bool+embedCreds c = case getRemoteConfigValue embedCredsField c of Just v -> v- Nothing -> isJust (M.lookup cipherkeysField c) && isJust (M.lookup cipherField c)+ Nothing -> case (getRemoteConfigValue cipherkeysField c, getRemoteConfigValue cipherField c) of+ (Just (_ :: ProposedAccepted String), Just (_ :: ProposedAccepted String)) -> True+ _ -> False {- Gets encryption Cipher, and key encryptor. -}-cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))+cipherKey :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey)) cipherKey c gc = fmap make <$> remoteCipher c gc where make ciphertext = (ciphertext, encryptKey mac ciphertext)- mac = fromMaybe defaultMac $ M.lookup macField c >>= readMac+ mac = fromMaybe defaultMac $ getRemoteConfigValue macField c {- Stores an StorableCipher in a remote's configuration. -} storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig@@ -147,40 +259,32 @@ (EncryptedCipher t _ ks) -> addcipher t . storekeys ks cipherkeysField (SharedPubKeyCipher t ks) -> addcipher t . storekeys ks pubkeysField where- addcipher t = M.insert cipherField (toB64bs t)- storekeys (KeyIds l) n = M.insert n (intercalate "," l)+ addcipher t = M.insert cipherField (Accepted (toB64bs t))+ storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l)) {- Extracts an StorableCipher from a remote's configuration. -}-extractCipher :: RemoteConfig -> Maybe StorableCipher-extractCipher c = case (M.lookup cipherField c,- M.lookup cipherkeysField c <|> M.lookup pubkeysField c,- M.lookup encryptionField c) of- (Just t, Just ks, encryption) | maybe True (== "hybrid") encryption ->+extractCipher :: ParsedRemoteConfig -> Maybe StorableCipher+extractCipher c = case (getRemoteConfigValue cipherField c,+ (getRemoteConfigValue cipherkeysField c <|> getRemoteConfigValue pubkeysField c),+ getRemoteConfigValue encryptionField c) of+ (Just t, Just ks, Just HybridEncryption) -> Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks)- (Just t, Just ks, Just "pubkey") ->+ (Just t, Just ks, Just PubKeyEncryption) -> Just $ EncryptedCipher (fromB64bs t) PubKey (readkeys ks)- (Just t, Just ks, Just "sharedpubkey") ->+ (Just t, Just ks, Just SharedPubKeyEncryption) -> Just $ SharedPubKeyCipher (fromB64bs t) (readkeys ks)- (Just t, Nothing, encryption) | maybe True (== "shared") encryption ->+ (Just t, Nothing, Just SharedEncryption) -> Just $ SharedCipher (fromB64bs t) _ -> Nothing where readkeys = KeyIds . splitc ',' -isEncrypted :: RemoteConfig -> Bool-isEncrypted c = case M.lookup encryptionField c of- Just "none" -> False- Just _ -> True- Nothing -> hasEncryptionConfig c--hasEncryptionConfig :: RemoteConfig -> Bool-hasEncryptionConfig c = M.member cipherField c- || M.member cipherkeysField c- || M.member pubkeysField c+isEncrypted :: ParsedRemoteConfig -> Bool+isEncrypted = isJust . extractCipher -describeEncryption :: RemoteConfig -> String+describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of- Nothing -> "none"+ Nothing -> "none" ++ show (getRemoteConfigValue cipherField c :: Maybe String) ++ show (M.keys c) Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")" nameCipher :: StorableCipher -> String
Remote/Helper/ExportImport.hs view
@@ -13,25 +13,25 @@ import Types.Remote import Types.Backend import Types.Key+import Types.ProposedAccepted import Backend import Remote.Helper.Encryptable (isEncrypted) import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export import Annex.LockFile-import Config+import Annex.SpecialRemote.Config import Git.Types (fromRef) import Logs.Export import Logs.ContentIdentifier (recordContentIdentifier) -import qualified Data.Map as M import Control.Concurrent.STM -- | Use for remotes that do not support exports. class HasExportUnsupported a where exportUnsupported :: a -instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where+instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where exportUnsupported = \_ _ -> return False instance HasExportUnsupported (ExportActions Annex) where@@ -50,7 +50,7 @@ class HasImportUnsupported a where importUnsupported :: a -instance HasImportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where+instance HasImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where importUnsupported = \_ _ -> return False instance HasImportUnsupported (ImportActions Annex) where@@ -63,59 +63,70 @@ , checkPresentExportWithContentIdentifier = \_ _ _ -> return False } -exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool+exportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool exportIsSupported = \_ _ -> return True -importIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool+importIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool importIsSupported = \_ _ -> return True -- | Prevent or allow exporttree=yes and importtree=yes when -- setting up a new remote, depending on exportSupported and importSupported. adjustExportImportRemoteType :: RemoteType -> RemoteType-adjustExportImportRemoteType rt = rt { setup = setup' }+adjustExportImportRemoteType rt = rt+ { setup = setup'+ , configParser = configparser+ } where- setup' st mu cp c gc =- let checkconfig supported configured setting cont =- ifM (supported rt c gc)+ configparser c = addRemoteConfigParser exportImportConfigParsers + <$> configParser rt c+ setup' st mu cp c gc = do+ pc <- either giveup return . parseRemoteConfig c =<< configparser c+ let checkconfig supported configured configfield cont =+ ifM (supported rt pc gc) ( case st of Init- | configured c && isEncrypted c ->- giveup $ "cannot enable both encryption and " ++ setting- | otherwise -> cont- Enable oldc- | configured c /= configured oldc ->- giveup $ "cannot change " ++ setting ++ " of existing special remote"+ | configured pc && isEncrypted pc ->+ giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield | otherwise -> cont- , if configured c- then giveup $ setting ++ " is not supported by this special remote"+ Enable oldc -> do+ oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser oldc+ if configured pc /= configured oldpc+ then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"+ else cont+ , if configured pc+ then giveup $ fromProposedAccepted configfield ++ " is not supported by this special remote" else cont )- in checkconfig exportSupported exportTree "exporttree" $- checkconfig importSupported importTree "importtree" $- if importTree c && not (exportTree c)+ checkconfig exportSupported exportTree exportTreeField $+ checkconfig importSupported importTree importTreeField $+ if importTree pc && not (exportTree pc) then giveup "cannot enable importtree=yes without also enabling exporttree=yes" else setup rt st mu cp c gc +exportImportConfigParsers :: [RemoteConfigFieldParser]+exportImportConfigParsers =+ [ yesNoParser exportTreeField False+ (FieldDesc "export trees of files to this remote")+ , yesNoParser importTreeField False+ (FieldDesc "import trees of files from this remote")+ ]+ -- | Adjust a remote to support exporttree=yes and importree=yes. -- -- Note that all remotes with importree=yes also have exporttree=yes. adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote-adjustExportImport r rs = case M.lookup "exporttree" (config r) of+adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) of Nothing -> return $ notexport r- Just c -> case yesNo c of- Just True -> ifM (isExportSupported r)- ( do- exportdbv <- prepexportdb- r' <- isexport exportdbv- if importTree (config r)- then isimport r' exportdbv- else return r'- , return $ notexport r- )- Just False -> return $ notexport r- Nothing -> do- warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"- return $ notexport r+ Just True -> ifM (isExportSupported r)+ ( do+ exportdbv <- prepexportdb+ r' <- isexport exportdbv+ if importTree (config r)+ then isimport r' exportdbv+ else return r'+ , return $ notexport r+ )+ Just False -> return $ notexport r where notexport r' = notimport r' { exportActions = exportUnsupported
Remote/Helper/Special.hs view
@@ -1,6 +1,6 @@ {- helpers for special remotes -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -30,6 +30,8 @@ checkPresentDummy, SpecialRemoteCfg(..), specialRemoteCfg,+ specialRemoteConfigParsers,+ specialRemoteType, specialRemote, specialRemote', lookupName,@@ -149,7 +151,7 @@ checkPresentDummy _ = error "missing checkPresent implementation" type RemoteModifier- = RemoteConfig+ = ParsedRemoteConfig -> Preparer Storer -> Preparer Retriever -> Preparer Remover@@ -162,9 +164,19 @@ , displayProgress :: Bool } -specialRemoteCfg :: RemoteConfig -> SpecialRemoteCfg+specialRemoteCfg :: ParsedRemoteConfig -> SpecialRemoteCfg specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True +-- Modifies a base RemoteType to support chunking and encryption configs.+specialRemoteType :: RemoteType -> RemoteType+specialRemoteType r = r + { configParser = \c -> addRemoteConfigParser specialRemoteConfigParsers+ <$> configParser r c+ }++specialRemoteConfigParsers :: [RemoteConfigFieldParser]+specialRemoteConfigParsers = chunkConfigParsers ++ encryptionConfigParsers+ -- Modifies a base Remote to support both chunking and encryption, -- which special remotes typically should support. -- @@ -212,7 +224,7 @@ } } cip = cipherKey c (gitconfig baser)- isencrypted = isJust (extractCipher c)+ isencrypted = isEncrypted c safely a = catchNonAsync a (\e -> warning (show e) >> return False)
Remote/Hook.hs view
@@ -1,6 +1,6 @@ {- A remote that provides hooks to run shell commands. -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -15,11 +15,13 @@ import Config import Config.Cost import Annex.UUID+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport import Utility.Env import Messages.Progress+import Types.ProposedAccepted import qualified Data.Map as M @@ -27,16 +29,23 @@ type HookName = String remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "hook" , enumerate = const (findSpecialRemotes "hooktype") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser hooktypeField+ (FieldDesc "(required) specify collection of hooks to use")+ ] , setup = hookSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+hooktypeField :: RemoteConfigField+hooktypeField = Accepted "hooktype"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just $ specialRemote c@@ -85,8 +94,8 @@ hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) hookSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu- let hooktype = fromMaybe (giveup "Specify hooktype=") $- M.lookup "hooktype" c+ let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $+ M.lookup hooktypeField c (c', _encsetup) <- encryptionSetup c gc gitConfigSpecialRemote u c' [("hooktype", hooktype)] return (c', u)
Remote/List.hs view
@@ -1,6 +1,6 @@ {- git-annex remote list -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -20,6 +20,7 @@ import Remote.Helper.Hooks import Remote.Helper.ReadOnly import Remote.Helper.ExportImport+import Annex.SpecialRemote.Config import qualified Git import qualified Git.Config @@ -109,7 +110,8 @@ let cu = fromMaybe u $ remoteAnnexConfigUUID gc let rs = RemoteStateHandle cu let c = fromMaybe M.empty $ M.lookup cu m- generate t g u c gc rs >>= \case+ pc <- either (const mempty) id . parseRemoteConfig c <$> configParser t c+ generate t g u pc gc rs >>= \case Nothing -> return Nothing Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
Remote/P2P.hs view
@@ -36,12 +36,13 @@ -- and will call chainGen on them. , enumerate = const (return []) , generate = \_ _ _ _ _ -> return Nothing+ , configParser = mkRemoteConfigParser [] , setup = error "P2P remotes are set up using git-annex p2p" , exportSupported = exportUnsupported , importSupported = importUnsupported } -chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+chainGen :: P2PAddress -> Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) chainGen addr r u c gc rs = do connpool <- mkConnectionPool cst <- remoteCost gc veryExpensiveRemoteCost
Remote/Rsync.hs view
@@ -1,6 +1,6 @@ {- A remote that is only accessible by rsync. -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -14,6 +14,7 @@ remove, checkKey, withRsyncScratchDir,+ rsyncRemoteConfigs, genRsyncOpts, RsyncOpts ) where@@ -30,6 +31,7 @@ import Remote.Helper.Messages import Remote.Helper.ExportImport import Types.Export+import Types.ProposedAccepted import Remote.Rsync.RsyncUrl import Crypto import Utility.Rsync@@ -41,20 +43,31 @@ import Annex.DirHashes import Utility.Tmp.Dir import Utility.SshHost+import Annex.SpecialRemote.Config import qualified Data.Map as M remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "rsync" , enumerate = const (findSpecialRemotes "rsyncurl") , generate = gen+ , configParser = mkRemoteConfigParser $ rsyncRemoteConfigs +++ [ optionalStringParser rsyncUrlField+ (FieldDesc "(required) url or hostname:/directory for rsync to use")+ ] , setup = rsyncSetup , exportSupported = exportIsSupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+shellEscapeField :: RemoteConfigField+shellEscapeField = Accepted "shellescape"++rsyncUrlField :: RemoteConfigField+rsyncUrlField = Accepted "rsyncurl"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost (transport, url) <- rsyncTransport gc $@@ -111,7 +124,14 @@ -- Rsync displays its own progress. { displayProgress = False } -genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts+-- Things used by genRsyncOpts+rsyncRemoteConfigs :: [RemoteConfigFieldParser]+rsyncRemoteConfigs = + [ yesNoParser shellEscapeField True+ (FieldDesc "avoid usual shell escaping (not recommended)")+ ]++genRsyncOpts :: ParsedRemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts genRsyncOpts c gc transport url = RsyncOpts { rsyncUrl = url , rsyncOptions = appendtransport $ opts []@@ -119,7 +139,7 @@ opts (remoteAnnexRsyncUploadOptions gc) , rsyncDownloadOptions = appendtransport $ opts (remoteAnnexRsyncDownloadOptions gc)- , rsyncShellEscape = (yesNo =<< M.lookup "shellescape" c) /= Just False+ , rsyncShellEscape = fromMaybe True (getRemoteConfigValue shellEscapeField c) } where appendtransport l = (++ l) <$> transport@@ -161,8 +181,8 @@ rsyncSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane- let url = fromMaybe (giveup "Specify rsyncurl=") $- M.lookup "rsyncurl" c+ let url = maybe (giveup "Specify rsyncurl=") fromProposedAccepted $+ M.lookup rsyncUrlField c (c', _encsetup) <- encryptionSetup c gc -- The rsyncurl is stored in git config, not only in this remote's
Remote/Rsync/RsyncUrl.hs view
@@ -43,10 +43,10 @@ rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl] rsyncUrls o k = map use dirHashes where- use h = rsyncUrl o </> fromRawFilePath (hash h) </> rsyncEscape o (f </> f)+ use h = rsyncUrl o </> hash h </> rsyncEscape o (f </> f) f = fromRawFilePath (keyFile k) #ifndef mingw32_HOST_OS- hash h = h def k+ hash h = fromRawFilePath $ h def k #else- hash h = replace "\\" "/" (h def k)+ hash h = replace "\\" "/" $ fromRawFilePath $ h def k #endif
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -57,6 +57,7 @@ import Logs.Web import Logs.MetaData import Types.MetaData+import Types.ProposedAccepted import Utility.Metered import Utility.DataUnits import Annex.Content@@ -68,16 +69,92 @@ type BucketObject = String remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "S3" , enumerate = const (findSpecialRemotes "s3") , generate = gen+ , configParser = const $ pure $ RemoteConfigParser+ { remoteConfigFieldParsers = + [ optionalStringParser bucketField+ (FieldDesc "name of bucket to store content in")+ , optionalStringParser hostField+ (FieldDesc "S3 server hostname (default is Amazon S3)")+ , optionalStringParser datacenterField+ (FieldDesc "S3 datacenter to use (US, EU, us-west-1, ..)")+ , optionalStringParser partsizeField+ (FieldDesc "part size for multipart upload (eg 1GiB)")+ , optionalStringParser storageclassField+ (FieldDesc "storage class, eg STANDARD or REDUCED_REDUNDANCY")+ , optionalStringParser fileprefixField+ (FieldDesc "prefix to add to filenames in the bucket")+ , yesNoParser versioningField False+ (FieldDesc "enable versioning of bucket content")+ , yesNoParser publicField False+ (FieldDesc "allow public read access to the buckey")+ , optionalStringParser publicurlField+ (FieldDesc "url that can be used by public to download files")+ , optionalStringParser protocolField+ (FieldDesc "http or https")+ , optionalStringParser portField+ (FieldDesc "port to connect to")+ , optionalStringParser requeststyleField+ (FieldDesc "for path-style requests, set to \"path\"")+ , optionalStringParser mungekeysField HiddenField+ , optionalStringParser AWS.s3credsField HiddenField+ ]+ , remoteConfigRestPassthrough = Just+ ( \f -> isMetaHeader f || isArchiveMetaHeader f+ ,+ [ ("x-amz-meta-*", FieldDesc "http headers to add when storing on S3")+ , ("x-archive-meta-*", FieldDesc "http headers to add when storing on Internet Archive")+ ]+ )+ } , setup = s3Setup , exportSupported = exportIsSupported , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+bucketField :: RemoteConfigField+bucketField = Accepted "bucket"++hostField :: RemoteConfigField+hostField = Accepted "host"++datacenterField :: RemoteConfigField+datacenterField = Accepted "datacenter"++partsizeField :: RemoteConfigField+partsizeField = Accepted "partsize"++storageclassField :: RemoteConfigField+storageclassField = Accepted "storageclass"++fileprefixField :: RemoteConfigField+fileprefixField = Accepted "fileprefix"++versioningField :: RemoteConfigField+versioningField = Accepted "versioning"++publicField :: RemoteConfigField+publicField = Accepted "public"++publicurlField :: RemoteConfigField+publicurlField = Accepted "publicurl"++protocolField :: RemoteConfigField+protocolField = Accepted "protocol"++requeststyleField :: RemoteConfigField+requeststyleField = Accepted "requeststyle"++portField :: RemoteConfigField+portField = Accepted "port"++mungekeysField :: RemoteConfigField+mungekeysField = Accepted "mungekeys"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost info <- extractS3Info c@@ -134,7 +211,7 @@ , appendonly = versioning info , availability = GloballyAvailable , remotetype = remote- , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc rs+ , mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue ("!dne!" :: String)) c) gc rs , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) , claimUrl = Nothing , checkUrl = Nothing@@ -148,21 +225,21 @@ s3Setup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) s3Setup' ss u mcreds c gc- | configIA c = archiveorg+ | maybe False (isIAHost . fromProposedAccepted) (M.lookup hostField c) = archiveorg | otherwise = defaulthost where remotename = fromJust (lookupName c) defbucket = remotename ++ "-" ++ fromUUID u defaults = M.fromList- [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.S3)- , ("storageclass", "STANDARD")- , ("host", AWS.s3DefaultHost)- , ("port", "80")- , ("bucket", defbucket)+ [ (datacenterField, Proposed $ T.unpack $ AWS.defaultRegion AWS.S3)+ , (storageclassField, Proposed "STANDARD")+ , (hostField, Proposed AWS.s3DefaultHost)+ , (portField, Proposed "80")+ , (bucketField, Proposed defbucket) ]- - use fullconfig info = do- enableBucketVersioning ss info fullconfig gc u++ use fullconfig pc info = do+ enableBucketVersioning ss info pc gc u gitConfigSpecialRemote u fullconfig [("s3", "true")] return (fullconfig, u) @@ -170,36 +247,40 @@ (c', encsetup) <- encryptionSetup c gc c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults- info <- extractS3Info fullconfig- checkexportimportsafe fullconfig info+ pc <- either giveup return . parseRemoteConfig fullconfig+ =<< configParser remote fullconfig+ info <- extractS3Info pc+ checkexportimportsafe pc info case ss of- Init -> genBucket fullconfig gc u+ Init -> genBucket pc gc u _ -> return ()- use fullconfig info+ use fullconfig pc info archiveorg = do showNote "Internet Archive mode" c' <- setRemoteCredPair noEncryptionUsed c gc (AWS.creds u) mcreds -- Ensure user enters a valid bucket name, since -- this determines the name of the archive.org item.- let validbucket = replace " " "-" $- fromMaybe (giveup "specify bucket=") $- getBucketName c'+ let validbucket = replace " " "-" $ map toLower $+ maybe (giveup "specify bucket=") fromProposedAccepted+ (M.lookup bucketField c') let archiveconfig = -- IA acdepts x-amz-* as an alias for x-archive-*- M.mapKeys (replace "x-archive-" "x-amz-") $+ M.mapKeys (Proposed . replace "x-archive-" "x-amz-" . fromProposedAccepted) $ -- encryption does not make sense here- M.insert encryptionField "none" $- M.insert "bucket" validbucket $+ M.insert encryptionField (Proposed "none") $+ M.insert bucketField (Proposed validbucket) $ M.union c' $ -- special constraints on key names- M.insert "mungekeys" "ia" defaults- info <- extractS3Info archiveconfig- checkexportimportsafe archiveconfig info- hdl <- mkS3HandleVar archiveconfig gc u+ M.insert mungekeysField (Proposed "ia") defaults+ pc <- either giveup return . parseRemoteConfig archiveconfig+ =<< configParser remote archiveconfig+ info <- extractS3Info pc+ checkexportimportsafe pc info+ hdl <- mkS3HandleVar pc gc u withS3HandleOrFail u hdl $- writeUUIDFile archiveconfig u info- use archiveconfig info+ writeUUIDFile pc u info+ use archiveconfig pc info checkexportimportsafe c' info = unlessM (Annex.getState Annex.force) $@@ -293,7 +374,7 @@ {- Implemented as a fileRetriever, that uses conduit to stream the chunks - out to the file. Would be better to implement a byteRetriever, but - that is difficult. -}-retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> Retriever+retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case (Just h) -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case@@ -306,7 +387,7 @@ Left failreason -> do warning failreason giveup "cannot download content"- Right us -> unlessM (downloadUrl k p us f) $+ Right us -> unlessM (withUrlOptions $ downloadUrl k p us f) $ giveup "failed to download content" retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex ()@@ -330,7 +411,7 @@ S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) return $ either (const False) (const True) res -checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> CheckPresent+checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey hv r rs c info k = withS3Handle hv $ \case Just h -> do showChecking r@@ -627,7 +708,7 @@ - so first check if the UUID file already exists and we can skip creating - it. -}-genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()+genBucket :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex () genBucket c gc u = do showAction "checking bucket" info <- extractS3Info c@@ -652,7 +733,7 @@ writeUUIDFile c u info h locconstraint = mkLocationConstraint $ T.pack datacenter- datacenter = fromJust $ M.lookup "datacenter" c+ datacenter = fromJust $ getRemoteConfigValue datacenterField c -- "NEARLINE" as a storage class when creating a bucket is a -- nonstandard extension of Google Cloud Storage. storageclass = case getStorageClass c of@@ -667,7 +748,7 @@ - Note that IA buckets can only created by having a file - stored in them. So this also takes care of that. -}-writeUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex ()+writeUUIDFile :: ParsedRemoteConfig -> UUID -> S3Info -> S3Handle -> Annex () writeUUIDFile c u info h = do v <- checkUUIDFile c u info h case v of@@ -684,7 +765,7 @@ {- Checks if the UUID file exists in the bucket - and has the specified UUID already. -}-checkUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool)+checkUUIDFile :: ParsedRemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool) checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file) case resp of@@ -700,7 +781,7 @@ file = T.pack $ uuidFile c uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] -uuidFile :: RemoteConfig -> FilePath+uuidFile :: ParsedRemoteConfig -> FilePath uuidFile c = getFilePrefix c ++ "annex-uuid" tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a)@@ -724,7 +805,7 @@ {- Prepares a S3Handle for later use. Does not connect to S3 or do anything - else expensive. -}-mkS3HandleVar :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar+mkS3HandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do mcreds <- getRemoteCredPair c gc (AWS.creds u) case mcreds of@@ -755,24 +836,24 @@ needS3Creds :: UUID -> String needS3Creds u = missingCredPairFor "S3" (AWS.creds u) -s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery+s3Configuration :: ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration c = cfg { S3.s3Port = port- , S3.s3RequestStyle = case M.lookup "requeststyle" c of+ , S3.s3RequestStyle = case getRemoteConfigValue requeststyleField c of Just "path" -> S3.PathStyle Just s -> giveup $ "bad S3 requeststyle value: " ++ s Nothing -> S3.s3RequestStyle cfg } where- h = fromJust $ M.lookup "host" c- datacenter = fromJust $ M.lookup "datacenter" c+ h = fromJust $ getRemoteConfigValue hostField c+ datacenter = fromJust $ getRemoteConfigValue datacenterField c -- When the default S3 host is configured, connect directly to -- the S3 endpoint for the configured datacenter. -- When another host is configured, it's used as-is. endpoint | h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter | otherwise = T.encodeUtf8 $ T.pack h- port = case M.lookup "port" c of+ port = case getRemoteConfigValue portField c of Just s -> case reads s of [(p, _)]@@ -787,7 +868,7 @@ Just AWS.HTTPS -> 443 Just AWS.HTTP -> 80 Nothing -> 80- cfgproto = case M.lookup "protocol" c of+ cfgproto = case getRemoteConfigValue protocolField c of Just "https" -> Just AWS.HTTPS Just "http" -> Just AWS.HTTP Just s -> giveup $ "bad S3 protocol value: " ++ s@@ -814,7 +895,7 @@ , host :: Maybe String } -extractS3Info :: RemoteConfig -> Annex S3Info+extractS3Info :: ParsedRemoteConfig -> Annex S3Info extractS3Info c = do b <- maybe (giveup "S3 bucket not configured")@@ -829,13 +910,13 @@ , metaHeaders = getMetaHeaders c , partSize = getPartSize c , isIA = configIA c- , versioning = boolcfg "versioning"- , public = boolcfg "public"- , publicurl = M.lookup "publicurl" c- , host = M.lookup "host" c+ , versioning = fromMaybe False $+ getRemoteConfigValue versioningField c+ , public = fromMaybe False $+ getRemoteConfigValue publicField c+ , publicurl = getRemoteConfigValue publicurlField c+ , host = getRemoteConfigValue hostField c }- where- boolcfg k = fromMaybe False $ yesNo =<< M.lookup k c putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject putObject info file rbody = (S3.putObject (bucket info) file rbody)@@ -850,41 +931,51 @@ | public info = Just S3.AclPublicRead | otherwise = Nothing -getBucketName :: RemoteConfig -> Maybe BucketName-getBucketName = map toLower <$$> M.lookup "bucket"+getBucketName :: ParsedRemoteConfig -> Maybe BucketName+getBucketName = map toLower <$$> getRemoteConfigValue bucketField -getStorageClass :: RemoteConfig -> S3.StorageClass-getStorageClass c = case M.lookup "storageclass" c of+getStorageClass :: ParsedRemoteConfig -> S3.StorageClass+getStorageClass c = case getRemoteConfigValue storageclassField c of Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy Just s -> S3.OtherStorageClass (T.pack s) _ -> S3.Standard -getPartSize :: RemoteConfig -> Maybe Integer-getPartSize c = readSize dataUnits =<< M.lookup "partsize" c+getPartSize :: ParsedRemoteConfig -> Maybe Integer+getPartSize c = readSize dataUnits =<< getRemoteConfigValue partsizeField c -getMetaHeaders :: RemoteConfig -> [(T.Text, T.Text)]-getMetaHeaders = map munge . filter ismetaheader . M.assocs+getMetaHeaders :: ParsedRemoteConfig -> [(T.Text, T.Text)]+getMetaHeaders = map munge+ . filter (isMetaHeader . fst)+ . M.assocs+ . getRemoteConfigPassedThrough where- ismetaheader (h, _) = metaprefix `isPrefixOf` h- metaprefix = "x-amz-meta-"- metaprefixlen = length metaprefix- munge (k, v) = (T.pack $ drop metaprefixlen k, T.pack v)+ metaprefixlen = length metaPrefix+ munge (k, v) = (T.pack $ drop metaprefixlen (fromProposedAccepted k), T.pack v) -getFilePrefix :: RemoteConfig -> String-getFilePrefix = M.findWithDefault "" "fileprefix"+isMetaHeader :: RemoteConfigField -> Bool+isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h -getBucketObject :: RemoteConfig -> Key -> BucketObject+isArchiveMetaHeader :: RemoteConfigField -> Bool+isArchiveMetaHeader h = "x-archive-" `isPrefixOf` fromProposedAccepted h++metaPrefix :: String+metaPrefix = "x-amz-meta-"++getFilePrefix :: ParsedRemoteConfig -> String+getFilePrefix = fromMaybe "" . getRemoteConfigValue fileprefixField++getBucketObject :: ParsedRemoteConfig -> Key -> BucketObject getBucketObject c = munge . serializeKey where- munge s = case M.lookup "mungekeys" c of+ munge s = case getRemoteConfigValue mungekeysField c :: Maybe String of Just "ia" -> iaMunge $ getFilePrefix c ++ s _ -> getFilePrefix c ++ s -getBucketExportLocation :: RemoteConfig -> ExportLocation -> BucketObject+getBucketExportLocation :: ParsedRemoteConfig -> ExportLocation -> BucketObject getBucketExportLocation c loc = getFilePrefix c ++ fromRawFilePath (fromExportLocation loc) -getBucketImportLocation :: RemoteConfig -> BucketObject -> Maybe ImportLocation+getBucketImportLocation :: ParsedRemoteConfig -> BucketObject -> Maybe ImportLocation getBucketImportLocation c obj -- The uuidFile should not be imported. | obj == uuidfile = Nothing@@ -910,8 +1001,8 @@ | isSpace c = [] | otherwise = "&" ++ show (ord c) ++ ";" -configIA :: RemoteConfig -> Bool-configIA = maybe False isIAHost . M.lookup "host"+configIA :: ParsedRemoteConfig -> Bool+configIA = maybe False isIAHost . getRemoteConfigValue hostField {- Hostname to use for archive.org S3. -} iaHost :: HostName@@ -963,7 +1054,7 @@ AWS.Warning -> warningM AWS.Error -> errorM -s3Info :: RemoteConfig -> S3Info -> [(String, String)]+s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)] s3Info c info = catMaybes [ Just ("bucket", fromMaybe "unknown" (getBucketName c)) , Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c)))@@ -982,10 +1073,10 @@ showstorageclass (S3.OtherStorageClass t) = T.unpack t showstorageclass sc = show sc -getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex [URLString]+getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex [URLString] getPublicWebUrls u rs info c k = either (const []) id <$> getPublicWebUrls' u rs info c k -getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex (Either String [URLString])+getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex (Either String [URLString]) getPublicWebUrls' u rs info c k | not (public info) = return $ Left $ "S3 bucket does not allow public access; " ++ needS3Creds u@@ -1125,7 +1216,7 @@ s3VersionField :: MetaField s3VersionField = mkMetaFieldUnchecked "V" -eitherS3VersionID :: S3Info -> RemoteStateHandle -> RemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID))+eitherS3VersionID :: S3Info -> RemoteStateHandle -> ParsedRemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID)) eitherS3VersionID info rs c k fallback | versioning info = getS3VersionID rs k >>= return . \case [] -> if exportTree c@@ -1150,7 +1241,7 @@ -- Enable versioning on the bucket can only be done at init time; -- setting versioning in a bucket that git-annex has already exported -- files to risks losing the content of those un-versioned files.-enableBucketVersioning :: SetupStage -> S3Info -> RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()+enableBucketVersioning :: SetupStage -> S3Info -> ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex () #if MIN_VERSION_aws(0,21,1) enableBucketVersioning ss info c gc u = do #else@@ -1160,7 +1251,10 @@ Init -> when (versioning info) $ enableversioning (bucket info) Enable oldc -> do- oldinfo <- extractS3Info oldc+ oldpc <- either (const mempty) id+ . parseRemoteConfig oldc + <$> configParser remote oldc+ oldinfo <- extractS3Info oldpc when (versioning info /= versioning oldinfo) $ giveup "Cannot change versioning= of existing S3 remote." where
Remote/Tahoe.hs view
@@ -13,7 +13,7 @@ - - Tahoe has its own encryption, so git-annex's encryption is not used. -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2019 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -30,9 +30,11 @@ import Annex.Common import Types.Remote import Types.Creds+import Types.ProposedAccepted import qualified Git import Config import Config.Cost+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Annex.UUID@@ -52,16 +54,27 @@ type Capability = String remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "tahoe" , enumerate = const (findSpecialRemotes "tahoe") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser scsField+ (FieldDesc "optional, normally a unique one is generated")+ , optionalStringParser furlField HiddenField+ ] , setup = tahoeSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+scsField :: RemoteConfigField+scsField = Accepted "shared-convergence-secret"++furlField :: RemoteConfigField+furlField = Accepted "introducer-furl"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost hdl <- liftIO $ TahoeHandle@@ -102,22 +115,23 @@ tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) tahoeSetup _ mu _ c _ = do- furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)+ furl <- maybe (fromMaybe missingfurl $ M.lookup furlField c) Proposed <$> liftIO (getEnv "TAHOE_FURL") u <- maybe (liftIO genUUID) return mu configdir <- liftIO $ defaultTahoeConfigDir u- scs <- liftIO $ tahoeConfigure configdir furl (M.lookup scsk c)- let c' = if (yesNo =<< M.lookup "embedcreds" c) == Just True+ scs <- liftIO $ tahoeConfigure configdir+ (fromProposedAccepted furl)+ (fromProposedAccepted <$> (M.lookup scsField c))+ pc <- either giveup return . parseRemoteConfig c =<< configParser remote c+ let c' = if embedCreds pc then flip M.union c $ M.fromList- [ (furlk, furl)- , (scsk, scs)+ [ (furlField, furl)+ , (scsField, Proposed scs) ] else c gitConfigSpecialRemote u c' [("tahoe", configdir)] return (c', u) where- scsk = "shared-convergence-secret"- furlk = "introducer-furl" missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
Remote/Web.hs view
@@ -27,6 +27,7 @@ { typename = "web" , enumerate = list , generate = gen+ , configParser = mkRemoteConfigParser [] , setup = error "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported@@ -40,7 +41,7 @@ r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r _ c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just Remote@@ -89,7 +90,7 @@ YoutubeDownloader -> do showOutput youtubeDlTo key u' dest- _ -> downloadUrl key p [u'] dest+ _ -> Url.withUrlOptions $ downloadUrl key p [u'] dest downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool downloadKeyCheap _ _ _ = return False
Remote/WebDAV.hs view
@@ -1,6 +1,6 @@ {- WebDAV remotes. -- - Copyright 2012-2017 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -29,6 +29,7 @@ import qualified Git import Config import Config.Cost+import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.Http@@ -39,18 +40,30 @@ import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionContent) import Annex.UUID import Remote.WebDAV.DavLocation+import Types.ProposedAccepted remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType { typename = "webdav" , enumerate = const (findSpecialRemotes "webdav") , generate = gen+ , configParser = mkRemoteConfigParser+ [ optionalStringParser urlField+ (FieldDesc "(required) url to the WebDAV directory")+ , optionalStringParser davcredsField HiddenField+ ] , setup = webdavSetup , exportSupported = exportIsSupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+urlField :: RemoteConfigField+urlField = Accepted "url"++davcredsField :: RemoteConfigField+davcredsField = Accepted "davcreds"++gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost where new cst = Just $ specialRemote c@@ -95,9 +108,9 @@ , appendonly = False , availability = GloballyAvailable , remotetype = remote- , mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc rs+ , mkUnavailable = gen r u (M.insert urlField (RemoteConfigValue "http://!dne!/") c) gc rs , getInfo = includeCredsInfo c (davCreds u) $- [("url", fromMaybe "unknown" (M.lookup "url" c))]+ [("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)] , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs@@ -107,11 +120,12 @@ webdavSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) webdavSetup _ mu mcreds c gc = do u <- maybe (liftIO genUUID) return mu- url <- case M.lookup "url" c of- Nothing -> giveup "Specify url="- Just url -> return url+ url <- maybe (giveup "Specify url=")+ (return . fromProposedAccepted)+ (M.lookup urlField c) (c', encsetup) <- encryptionSetup c gc- creds <- maybe (getCreds c' gc u) (return . Just) mcreds+ pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c'+ creds <- maybe (getCreds pc gc u) (return . Just) mcreds testDav url creds gitConfigSpecialRemote u c' [("webdav", "true")] c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds@@ -255,7 +269,7 @@ runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h)) configUrl :: Remote -> Maybe URLString-configUrl r = fixup <$> M.lookup "url" (config r)+configUrl r = fixup <$> getRemoteConfigValue urlField (config r) where -- box.com DAV url changed fixup = replace "https://www.box.com/dav/" boxComUrl@@ -335,14 +349,14 @@ inLocation d mkCol ) -getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)+getCreds :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair) getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u) davCreds :: UUID -> CredPairStorage davCreds u = CredPairStorage { credPairFile = fromUUID u , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")- , credPairRemoteField = "davcreds"+ , credPairRemoteField = davcredsField } {- Content-Type to use for files uploaded to WebDAV. -}
Test.hs view
@@ -1614,7 +1614,7 @@ annexed_present annexedfile {- Ensure the configuration complies with the encryption scheme, and - that all keys are encrypted properly for the given directory remote. -}- testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher c of+ testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks -> checkKeys cip Nothing Just cip@(Crypto.EncryptedCipher encipher v ks')@@ -1622,6 +1622,8 @@ checkKeys cip (Just v) <&&> checkCipher encipher ks' _ -> return False where+ pc =either mempty id $+ Remote.Helper.Encryptable.parseEncryptionConfig c keysMatch (Utility.Gpg.KeyIds ks') = maybe False (\(Utility.Gpg.KeyIds ks2) -> sort (nub ks2) == sort (nub ks')) ks@@ -1630,7 +1632,7 @@ checkScheme Types.Crypto.PubKey = scheme == "pubkey" checkKeys cip mvariant = do dummycfg <- Types.GitConfig.dummyRemoteGitConfig- let encparams = (mempty :: Types.Remote.RemoteConfig, dummycfg)+ let encparams = (mempty :: Types.Remote.ParsedRemoteConfig, dummycfg) cipher <- Crypto.decryptCipher gpgcmd encparams cip files <- filterM doesFileExist $ map ("dir" </>) $ concatMap (serializeKeys cipher) keys
Types/Crypto.hs view
@@ -1,11 +1,12 @@ {- git-annex crypto types -- - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} module Types.Crypto (+ EncryptionMethod(..), Cipher(..), StorableCipher(..), EncryptedCipherVariant(..),@@ -14,6 +15,7 @@ Mac(..), readMac, showMac,+ macMap, defaultMac, calcMac, ) where@@ -21,6 +23,17 @@ import Utility.Hash import Utility.Gpg (KeyIds(..)) +import Data.Typeable+import qualified Data.Map as M++data EncryptionMethod+ = NoneEncryption+ | SharedEncryption+ | PubKeyEncryption+ | SharedPubKeyEncryption+ | HybridEncryption+ deriving (Typeable, Eq)+ -- XXX ideally, this would be a locked memory region data Cipher = Cipher String | MacOnlyCipher String @@ -50,9 +63,13 @@ -- Read the MAC algorithm from the remote config. readMac :: String -> Maybe Mac-readMac "HMACSHA1" = Just HmacSha1-readMac "HMACSHA224" = Just HmacSha224-readMac "HMACSHA256" = Just HmacSha256-readMac "HMACSHA384" = Just HmacSha384-readMac "HMACSHA512" = Just HmacSha512-readMac _ = Nothing+readMac n = M.lookup n macMap++macMap :: M.Map String Mac+macMap = M.fromList+ [ ("HMACSHA1", HmacSha1)+ , ("HMACSHA224", HmacSha224)+ , ("HMACSHA256", HmacSha256)+ , ("HMACSHA384", HmacSha384)+ , ("HMACSHA512", HmacSha512)+ ]
+ Types/ProposedAccepted.hs view
@@ -0,0 +1,38 @@+{- proposed and accepted values+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.ProposedAccepted where++import Test.QuickCheck++-- | A value that may be proposed, or accepted.+--+-- When parsing/validating the value, may want to error out on invalid+-- input. But if a previous version of git-annex accepted an invalid value,+-- it's too late to error out, and instead the bad value may be ignored.+data ProposedAccepted t = Proposed t | Accepted t+ deriving (Show)++fromProposedAccepted :: ProposedAccepted t -> t+fromProposedAccepted (Proposed t) = t+fromProposedAccepted (Accepted t) = t++-- | Whether a value is proposed or accepted does not matter when checking+-- equality.+instance Eq t => Eq (ProposedAccepted t) where+ a == b = fromProposedAccepted a == fromProposedAccepted b++-- | Order by the contained value, not by whether it's proposed or+-- accepted.+instance Ord t => Ord (ProposedAccepted t) where+ compare a b = compare (fromProposedAccepted a) (fromProposedAccepted b)++instance Arbitrary t => Arbitrary (ProposedAccepted t) where+ arbitrary = oneof+ [ Proposed <$> arbitrary+ , Accepted <$> arbitrary+ ]
Types/Remote.hs view
@@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -10,8 +10,7 @@ {-# LANGUAGE RankNTypes #-} module Types.Remote- ( RemoteConfigField- , RemoteConfig+ ( module Types.RemoteConfig , RemoteTypeA(..) , RemoteA(..) , RemoteStateHandle@@ -28,7 +27,6 @@ ) where -import qualified Data.Map as M import Data.Ord import qualified Git@@ -42,6 +40,7 @@ import Types.NumCopies import Types.Export import Types.Import+import Types.RemoteConfig import Config.Cost import Utility.Metered import Git.Types (RemoteName)@@ -49,10 +48,6 @@ import Utility.Url import Utility.DataUnits -type RemoteConfigField = String--type RemoteConfig = M.Map RemoteConfigField String- data SetupStage = Init | Enable RemoteConfig {- There are different types of remotes. -}@@ -63,13 +58,15 @@ -- The Bool is True if automatic initialization of remotes is desired , enumerate :: Bool -> a [Git.Repo] -- generates a remote of this type- , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))+ , generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))+ -- parse configs of remotes of this type+ , configParser :: RemoteConfig -> a RemoteConfigParser -- initializes or enables a remote , setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) -- check if a remote of this type is able to support export- , exportSupported :: RemoteConfig -> RemoteGitConfig -> a Bool+ , exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool -- check if a remote of this type is able to support import- , importSupported :: RemoteConfig -> RemoteGitConfig -> a Bool+ , importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool } instance Eq (RemoteTypeA a) where@@ -124,7 +121,7 @@ -- Runs an action to repair the remote's git repository. , repairRepo :: Maybe (a Bool -> a (IO Bool)) -- a Remote has a persistent configuration store- , config :: RemoteConfig+ , config :: ParsedRemoteConfig -- Get the git repo for the Remote. , getRepo :: a Git.Repo -- a Remote's configuration from git
+ Types/RemoteConfig.hs view
@@ -0,0 +1,69 @@+{- git-annex remote config types+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE GADTs #-}++module Types.RemoteConfig where++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Typeable++import Types.ProposedAccepted++type RemoteConfigField = ProposedAccepted String++{- What the user provides to configure the remote, and what is stored for+ - later; a bunch of fields and values. -}+type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String)++{- Before being used a RemoteConfig has to be parsed. -}+type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue++{- Remotes can have configuration values of many types, so use Typeable+ - to let them all be stored in here. -}+data RemoteConfigValue where+ RemoteConfigValue :: Typeable v => v -> RemoteConfigValue++{- Parse a field's value provided by the user into a RemoteConfigValue.+ -+ - The RemoteConfig is provided to the parser function for cases+ - where multiple fields need to be looked at. However, it's important+ - that, when a parser looks at an additional field in that way, the+ - parser list contains a dedicated parser for that field as well.+ - Presence of fields that are not included in this list will cause+ - a parse failure.+ -}+data RemoteConfigFieldParser = RemoteConfigFieldParser+ { parserForField :: RemoteConfigField+ , valueParser :: Maybe (ProposedAccepted String) -> RemoteConfig -> Either String (Maybe RemoteConfigValue)+ , fieldDesc :: FieldDesc+ , valueDesc :: Maybe ValueDesc+ }++data FieldDesc+ = FieldDesc String+ | HiddenField++newtype ValueDesc = ValueDesc String++data RemoteConfigParser = RemoteConfigParser+ { remoteConfigFieldParsers :: [RemoteConfigFieldParser]+ , remoteConfigRestPassthrough :: Maybe (RemoteConfigField -> Bool, [(String, FieldDesc)])+ }++mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> RemoteConfig -> m RemoteConfigParser+mkRemoteConfigParser l _ = pure (RemoteConfigParser l Nothing)++addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser+addRemoteConfigParser l rpc = rpc+ { remoteConfigFieldParsers = + remoteConfigFieldParsers rpc ++ filter isnew l+ }+ where+ s = S.fromList (map parserForField (remoteConfigFieldParsers rpc))+ isnew p = not (S.member (parserForField p) s)
Types/RemoteState.hs view
@@ -9,7 +9,7 @@ import Types.UUID -{- When per-remote state, its UUID is used to identify it.+{- When there is per-remote state, remotes are identified by UUID. - - However, sameas remotes mean that two different Remote implementations - can be used for the same underlying data store. To avoid them using
Types/StandardGroups.hs view
@@ -11,9 +11,10 @@ import Types.Remote (RemoteConfig) import Types.Group+import Types.ProposedAccepted+import Annex.SpecialRemote.Config (preferreddirField) import qualified Data.Map as M-import Data.Maybe type PreferredContentExpression = String @@ -71,7 +72,8 @@ associatedDirectory _ SmallArchiveGroup = Just "archive" associatedDirectory _ FullArchiveGroup = Just "archive" associatedDirectory (Just c) PublicGroup = Just $- fromMaybe "public" $ M.lookup "preferreddir" c+ maybe "public" fromProposedAccepted $+ M.lookup preferreddirField c associatedDirectory Nothing PublicGroup = Just "public" associatedDirectory _ _ = Nothing
Utility/Daemon.hs view
@@ -8,7 +8,9 @@ {-# LANGUAGE CPP #-} module Utility.Daemon (+#ifndef mingw32_HOST_OS daemonize,+#endif foreground, checkDaemon, stopDaemon,
Utility/FileSystemEncoding.hs view
@@ -43,6 +43,7 @@ import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif+import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import Utility.Exception import Utility.Split@@ -171,21 +172,11 @@ encodeBL' = L8.fromString #endif -{- Recent versions of the unix package have this alias; defined here- - for backwards compatibility. -}-type RawFilePath = S.ByteString--{- Note that the RawFilePath is assumed to never contain NUL,- - since filename's don't. This should only be used with actual- - RawFilePaths not arbitrary ByteString that may contain NUL. -} fromRawFilePath :: RawFilePath -> FilePath-fromRawFilePath = decodeBS'+fromRawFilePath = decodeFilePath -{- Note that the FilePath is assumed to never contain NUL,- - since filename's don't. This should only be used with actual FilePaths- - not arbitrary String that may contain NUL. -} toRawFilePath :: FilePath -> RawFilePath-toRawFilePath = encodeBS'+toRawFilePath = encodeFilePath {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. -
Utility/RawFilePath.hs view
@@ -31,6 +31,7 @@ #else import qualified Data.ByteString as B+import System.PosixCompat (FileStatus) import qualified System.PosixCompat as P import qualified System.Directory as D import Utility.FileSystemEncoding
Utility/Url.hs view
@@ -1,6 +1,6 @@ {- Url downloading. -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-} module Utility.Url ( newManager,@@ -35,6 +36,10 @@ parseURIRelaxed, matchStatusCodeException, matchHttpExceptionContent,+ BasicAuth(..),+ GetBasicAuth,+ noBasicAuth,+ applyBasicAuth', ) where import Common@@ -84,6 +89,7 @@ , applyRequest :: Request -> Request , httpManager :: Manager , allowedSchemes :: S.Set Scheme+ , getBasicAuth :: GetBasicAuth } data UrlDownloader@@ -101,10 +107,11 @@ <*> pure id <*> newManager tlsManagerSettings <*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"])+ <*> pure noBasicAuth -mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> UrlOptions-mkUrlOptions defuseragent reqheaders urldownloader manager =- UrlOptions useragent reqheaders urldownloader applyrequest manager+mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> GetBasicAuth -> UrlOptions+mkUrlOptions defuseragent reqheaders urldownloader manager getbasicauth =+ UrlOptions useragent reqheaders urldownloader applyrequest manager getbasicauth where applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders } addedheaders = uaheader ++ otherheaders@@ -197,14 +204,14 @@ Nothing -> return (Right dne) where go :: URI -> IO (Either String UrlInfo)- go u = case (urlDownloader uo, parseUrlRequest (show u)) of+ go u = case (urlDownloader uo, parseRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust -- When http redirects to a protocol which -- conduit does not support, it will throw -- a StatusCodeException with found302 -- and a Response with the redir Location. (matchStatusCodeException (== found302))- (Right <$> existsconduit req)+ (Right <$> existsconduit req uo) (followredir r) `catchNonAsync` (const $ return $ Right dne) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing)@@ -243,18 +250,28 @@ extractfilename = contentDispositionFilename . B8.toString <=< lookup hContentDisposition . responseHeaders - existsconduit req = do+ existsconduit req uo' = do let req' = headRequest (applyRequest uo req) debugM "url" (show req')- runResourceT $ do+ join $ runResourceT $ do resp <- http req' (httpManager uo) -- forces processing the response while -- within the runResourceT liftIO $ if responseStatus resp == ok200- then found- (extractlen resp)- (extractfilename resp)- else return dne+ then do+ let !len = extractlen resp+ let !fn = extractfilename resp+ return $ found len fn+ else if responseStatus resp == unauthorized401+ then return $ getBasicAuth uo' (show (getUri req)) >>= \case+ Nothing -> return dne+ Just (ba, signalsuccess) -> do+ ui <- existsconduit+ (applyBasicAuth' ba req) + (uo' { getBasicAuth = noBasicAuth })+ signalsuccess (urlExists ui)+ return ui+ else return $ return dne existscurl u curlparams = do output <- catchDefaultIO "" $@@ -284,6 +301,7 @@ sz <- getFileSize' f stat found (Just sz) Nothing Nothing -> return dne+ followredir r (HttpExceptionRequest _ (StatusCodeException resp _)) = case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of Just url' -> case parseURIRelaxed url' of@@ -334,7 +352,7 @@ where go = case parseURIRelaxed url of Just u -> checkPolicy uo u $- case (urlDownloader uo, parseUrlRequest (show u)) of+ case (urlDownloader uo, parseRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (matchStatusCodeException (== found302)) (downloadConduit meterupdate req file uo >> return (Right ()))@@ -416,12 +434,18 @@ downloadConduit meterupdate req file uo = catchMaybeIO (getFileSize file) >>= \case Just sz | sz > 0 -> resumedownload sz- _ -> runResourceT $ do+ _ -> join $ runResourceT $ do liftIO $ debugM "url" (show req') resp <- http req' (httpManager uo) if responseStatus resp == ok200- then store zeroBytesProcessed WriteMode resp- else respfailure resp+ then do+ store zeroBytesProcessed WriteMode resp+ return (return ())+ else if responseStatus resp == unauthorized401+ then return $ getBasicAuth uo (show (getUri req')) >>= \case+ Nothing -> respfailure resp+ Just ba -> retryauthed ba+ else return $ respfailure resp where req' = applyRequest uo $ req -- Override http-client's default decompression of gzip@@ -440,15 +464,23 @@ dl (const noop) where- dl = runResourceT $ do+ dl = join $ runResourceT $ do let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req } liftIO $ debugM "url" (show req'') resp <- http req'' (httpManager uo) if responseStatus resp == partialContent206- then store (toBytesProcessed sz) AppendMode resp+ then do+ store (toBytesProcessed sz) AppendMode resp+ return (return ()) else if responseStatus resp == ok200- then store zeroBytesProcessed WriteMode resp- else respfailure resp+ then do+ store zeroBytesProcessed WriteMode resp+ return (return ())+ else if responseStatus resp == unauthorized401+ then return $ getBasicAuth uo (show (getUri req'')) >>= \case+ Nothing -> respfailure resp+ Just ba -> retryauthed ba+ else return $ respfailure resp alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416 && case lookup hContentRange h of@@ -469,6 +501,18 @@ respfailure = giveup . B8.toString . statusMessage . responseStatus + retryauthed (ba, signalsuccess) = do+ r <- tryNonAsync $ downloadConduit+ meterupdate+ (applyBasicAuth' ba req)+ file+ (uo { getBasicAuth = noBasicAuth })+ case r of+ Right () -> signalsuccess True+ Left e -> do+ () <- signalsuccess False+ throwM e+ {- Sinks a Response's body to a file. The file can either be opened in - WriteMode or AppendMode. Updates the meter as data is received. -@@ -502,7 +546,7 @@ Nothing -> return Nothing Just u -> go u `catchNonAsync` const (return Nothing) where- go u = case parseUrlRequest (show u) of+ go u = case parseRequest (show u) of Nothing -> return Nothing Just req -> do let req' = applyRequest uo req@@ -517,9 +561,6 @@ parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $ parseURI $ escapeURIString isAllowedInURI s -parseUrlRequest :: URLString -> Maybe Request-parseUrlRequest = parseUrlThrow- {- Some characters like '[' are allowed in eg, the address of - an uri, but cannot appear unescaped further along in the uri. - This handles that, expensively, by successively escaping each character@@ -628,3 +669,22 @@ , Param "--max-redirs", Param "0" ] bracketaddr a = "[" ++ a ++ "]"++data BasicAuth = BasicAuth+ { basicAuthUser :: String+ , basicAuthPassword :: String+ }++-- Note that this is only used when using conduit, not curl.+--+-- The returned IO action is run after trying to use the BasicAuth,+-- indicating if the password worked.+type GetBasicAuth = URLString -> IO (Maybe (BasicAuth, Bool -> IO ()))++noBasicAuth :: GetBasicAuth+noBasicAuth = const $ pure Nothing++applyBasicAuth' :: BasicAuth -> Request -> Request+applyBasicAuth' ba = applyBasicAuth+ (encodeBS (basicAuthUser ba))+ (encodeBS (basicAuthPassword ba))
doc/git-annex-add.mdwn view
@@ -39,6 +39,16 @@ Add gitignored files. +* `--force-large`++ Treat all files as large files, ignoring annex.largefiles configuration,+ and add to the annex.++* `--force-small`++ Treat all files as small files, ignoring annex.largefiles configuration,+ and add to git, also ignoring annex.addsmallfiles configuration.+ * `--backend` Specifies which key-value backend to use.
doc/git-annex-enableremote.mdwn view
@@ -27,7 +27,8 @@ Some special remotes may need parameters to be specified every time they are enabled. For example, the directory special remote requires a directory=-parameter every time.+parameter every time. The command will prompt for any required parameters+you leave out. This command can also be used to modify the configuration of an existing special remote, by specifying new values for parameters that are
doc/git-annex-initremote.mdwn view
@@ -19,8 +19,11 @@ The remote's configuration is specified by the parameters passed to this command. Different types of special remotes need different-configuration values. The command will prompt for parameters as needed. A-few parameters that are supported by all special remotes are documented in+configuration values, so consult the documentation of a special remote for+details. The command will prompt for any required parameters you leave out;+you can also pass --whatelse to see additional parameters.++A few parameters that are supported by all special remotes are documented in the next section below. Once a special remote has been initialized once with this command,@@ -35,6 +38,15 @@ # OPTIONS +* `--whatelse` / `-w`++ Describe additional configuration parameters that you could specify.++ For example, if you know you want a S3 remote, but forget how to+ configure it:++ git annex initremote mys3 type=S3 --whatelse+ * `--fast` When initializing a remote that uses encryption, a cryptographic key is@@ -66,7 +78,7 @@ * `encryption` - All special remotes support encryption. You will need to specify+ Almost all special remotes support encryption. You will need to specify what encryption, if any, to use. If you do not want any encryption, use `encryption=none`@@ -76,6 +88,7 @@ For details about this and other encrpytion settings, see <https://git-annex.branchable.com/encryption/>+ or --whatelse * `autoenable`
doc/git-annex-reinject.mdwn view
@@ -36,8 +36,13 @@ With this option, each specified src file is hashed using the default key-value backend (or the one specified with `--backend`), and if git-annex- has a record of the file having been in the annex before, the content is- reinjected.+ has a record of the resulting key having been in the annex before, the+ content is reinjected.++ Note that, when using a key-value backend that includes the filename+ extension in the key, this will only work if the src files have the same+ extensions as the files with the same content that was originally added+ to git-annex. Note that this will reinject old versions of files that have been modified or deleted from the current git branch.
git-annex.cabal view
@@ -1,11 +1,11 @@ Name: git-annex-Version: 7.20191230+Version: 7.20200202.7 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable-Copyright: 2010-2019 Joey Hess+Copyright: 2010-2020 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom@@ -296,7 +296,7 @@ custom-setup Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, process, filepath, exceptions, bytestring, directory, IfElse, data-default,- filepath-bytestring (>= 1.4.2.1.0),+ filepath-bytestring (>= 1.4.2.1.1), utf8-string, transformers, Cabal Executable git-annex@@ -315,13 +315,13 @@ case-insensitive, random, dlist,- unix-compat,+ unix-compat (>= 0.5), SafeSemaphore, async, directory (>= 1.2), disk-free-space, filepath,- filepath-bytestring (>= 1.4.2.1.0),+ filepath-bytestring (>= 1.4.2.1.1), IfElse, hslogger, monad-logger,@@ -394,7 +394,6 @@ if (os(windows)) Build-Depends: Win32 (>= 2.6.1.0),- unix-compat (>= 0.5), setenv, process (>= 1.6.2.0), silently (>= 1.2.5.1)@@ -996,8 +995,10 @@ Types.MetaData Types.Mime Types.NumCopies+ Types.ProposedAccepted Types.RefSpec Types.Remote+ Types.RemoteConfig Types.RemoteState Types.RepoVersion Types.ScheduledActivity