summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoeyHess <>2018-06-26 16:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-06-26 16:03:00 (GMT)
commit2cdd87347d8d7aa238de5d163e78cae1d3a12c85 (patch)
tree5f4cd7526be5ce21f5c9ab0fc4c4887f2f325496
parent9ac5de07ccf351b09ffb9ad922ee85fe22fcfea6 (diff)
version 6.201806266.20180626
-rw-r--r--Annex/Content.hs86
-rw-r--r--Annex/Ssh.hs12
-rw-r--r--Annex/Url.hs66
-rw-r--r--Annex/YoutubeDl.hs79
-rw-r--r--Assistant/DaemonStatus.hs3
-rw-r--r--Assistant/Pairing/MakeRemote.hs3
-rw-r--r--Assistant/Sync.hs37
-rw-r--r--Assistant/Threads/Cronner.hs6
-rw-r--r--Assistant/Threads/MountWatcher.hs3
-rw-r--r--Assistant/Threads/ProblemFixer.hs15
-rw-r--r--Assistant/Threads/RemoteControl.hs2
-rw-r--r--Assistant/TransferSlots.hs12
-rw-r--r--Assistant/WebApp/Configurators/Edit.hs25
-rw-r--r--Assistant/WebApp/MakeRemote.hs3
-rw-r--r--Assistant/WebApp/RepoList.hs17
-rw-r--r--CHANGELOG55
-rw-r--r--COPYRIGHT48
-rw-r--r--Command/AddUrl.hs2
-rw-r--r--Command/EnableRemote.hs4
-rw-r--r--Command/Export.hs7
-rw-r--r--Command/Get.hs2
-rw-r--r--Command/Info.hs31
-rw-r--r--Command/Move.hs2
-rw-r--r--Command/Multicast.hs2
-rw-r--r--Command/ReKey.hs2
-rw-r--r--Command/RecvKey.hs5
-rw-r--r--Command/Reinject.hs2
-rw-r--r--Command/SetKey.hs2
-rw-r--r--Command/Sync.hs49
-rw-r--r--Command/TestRemote.hs20
-rw-r--r--Command/TransferKey.hs2
-rw-r--r--Command/TransferKeys.hs2
-rw-r--r--Command/Version.hs18
-rw-r--r--Git/Fsck.hs34
-rw-r--r--Limit.hs2
-rw-r--r--NEWS26
-rw-r--r--P2P/Annex.hs6
-rw-r--r--P2P/IO.hs8
-rw-r--r--Remote.hs22
-rw-r--r--Remote/Adb.hs5
-rw-r--r--Remote/BitTorrent.hs4
-rw-r--r--Remote/Bup.hs5
-rw-r--r--Remote/Ddar.hs5
-rw-r--r--Remote/Directory.hs3
-rw-r--r--Remote/External.hs178
-rw-r--r--Remote/External/Types.hs10
-rw-r--r--Remote/GCrypt.hs75
-rw-r--r--Remote/Git.hs220
-rw-r--r--Remote/Glacier.hs7
-rw-r--r--Remote/Helper/Git.hs3
-rw-r--r--Remote/Helper/Special.hs8
-rw-r--r--Remote/Helper/Ssh.hs63
-rw-r--r--Remote/Hook.hs5
-rw-r--r--Remote/List.hs2
-rw-r--r--Remote/P2P.hs6
-rw-r--r--Remote/Rsync.hs3
-rw-r--r--Remote/S3.hs5
-rw-r--r--Remote/Tahoe.hs4
-rw-r--r--Remote/Web.hs5
-rw-r--r--Remote/WebDAV.hs5
-rw-r--r--Test.hs6
-rw-r--r--Types/DesktopNotify.hs22
-rw-r--r--Types/Difference.hs32
-rw-r--r--Types/GitConfig.hs31
-rw-r--r--Types/Key.hs19
-rw-r--r--Types/Remote.hs35
-rw-r--r--Types/Test.hs30
-rw-r--r--Utility/HttpManagerRestricted.hs232
-rw-r--r--Utility/IPAddress.hs93
-rw-r--r--Utility/Url.hs155
-rw-r--r--doc/git-annex-addurl.mdwn9
-rw-r--r--doc/git-annex-groupwanted.mdwn4
-rw-r--r--doc/git-annex-importfeed.mdwn5
-rw-r--r--doc/git-annex-preferred-content.mdwn11
-rw-r--r--doc/git-annex.mdwn80
-rw-r--r--git-annex.cabal8
76 files changed, 1573 insertions, 542 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
index d14bc06..cc0a0b3 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -1,6 +1,6 @@
{- git-annex file content managing
-
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -15,6 +15,7 @@ module Annex.Content (
lockContentShared,
lockContentForRemoval,
ContentRemovalLock,
+ RetrievalSecurityPolicy(..),
getViaTmp,
getViaTmpFromDisk,
checkDiskSpaceToGet,
@@ -78,7 +79,7 @@ import qualified Annex.Content.Direct as Direct
import Annex.ReplaceFile
import Annex.LockPool
import Messages.Progress
-import Types.Remote (unVerified, Verification(..))
+import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..))
import qualified Types.Remote
import qualified Types.Backend
import qualified Backend
@@ -293,15 +294,15 @@ lockContentUsing locker key a = do
{- Runs an action, passing it the temp file to get,
- and if the action succeeds, verifies the file matches
- the key and moves the file into the annex as a key's content. -}
-getViaTmp :: VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool
-getViaTmp v key action = checkDiskSpaceToGet key False $
- getViaTmpFromDisk v key action
+getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool
+getViaTmp rsp v key action = checkDiskSpaceToGet key False $
+ getViaTmpFromDisk rsp v key action
{- Like getViaTmp, but does not check that there is enough disk space
- for the incoming key. For use when the key content is already on disk
- and not being copied into place. -}
-getViaTmpFromDisk :: VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool
-getViaTmpFromDisk v key action = do
+getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (FilePath -> Annex (Bool, Verification)) -> Annex Bool
+getViaTmpFromDisk rsp v key action = checkallowed $ do
tmpfile <- prepTmp key
resuming <- liftIO $ doesFileExist tmpfile
(ok, verification) <- action tmpfile
@@ -315,7 +316,7 @@ getViaTmpFromDisk v key action = do
_ -> MustVerify
else verification
if ok
- then ifM (verifyKeyContent v verification' key tmpfile)
+ then ifM (verifyKeyContent rsp v verification' key tmpfile)
( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key))
( do
logStatus key InfoPresent
@@ -324,30 +325,59 @@ getViaTmpFromDisk v key action = do
)
, do
warning "verification of content failed"
+ -- The bad content is not retained, because
+ -- a retry should not try to resume from it
+ -- since it's apparently corrupted.
+ -- Also, the bad content could be any data,
+ -- including perhaps the content of another
+ -- file than the one that was requested,
+ -- and so it's best not to keep it on disk.
pruneTmpWorkDirBefore tmpfile (liftIO . nukeFile)
return False
)
-- On transfer failure, the tmp file is left behind, in case
-- caller wants to resume its transfer
else return False
+ where
+ -- Avoid running the action to get the content when the
+ -- RetrievalSecurityPolicy would cause verification to always fail.
+ checkallowed a = case rsp of
+ RetrievalAllKeysSecure -> a
+ RetrievalVerifiableKeysSecure
+ | isVerifiable (keyVariety key) -> a
+ | otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
+ ( a
+ , warnUnverifiableInsecure key >> return False
+ )
{- Verifies that a file is the expected content of a key.
+ -
- Configuration can prevent verification, for either a
- - particular remote or always.
+ - particular remote or always, unless the RetrievalSecurityPolicy
+ - requires verification.
-
- Most keys have a known size, and if so, the file size is checked.
-
- - When the key's backend allows verifying the content (eg via checksum),
+ - When the key's backend allows verifying the content (via checksum),
- it is checked.
+ -
+ - If the RetrievalSecurityPolicy requires verification and the key's
+ - backend doesn't support it, the verification will fail.
-}
-verifyKeyContent :: VerifyConfig -> Verification -> Key -> FilePath -> Annex Bool
-verifyKeyContent v verification k f = case verification of
- Verified -> return True
- UnVerified -> ifM (shouldVerify v)
+verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> FilePath -> Annex Bool
+verifyKeyContent rsp v verification k f = case (rsp, verification) of
+ (_, Verified) -> return True
+ (RetrievalVerifiableKeysSecure, _)
+ | isVerifiable (keyVariety k) -> verify
+ | otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
+ ( verify
+ , warnUnverifiableInsecure k >> return False
+ )
+ (_, UnVerified) -> ifM (shouldVerify v)
( verify
, return True
)
- MustVerify -> verify
+ (_, MustVerify) -> verify
where
verify = verifysize <&&> verifycontent
verifysize = case keySize k of
@@ -359,6 +389,16 @@ verifyKeyContent v verification k f = case verification of
Nothing -> return True
Just verifier -> verifier k f
+warnUnverifiableInsecure :: Key -> Annex ()
+warnUnverifiableInsecure k = warning $ unwords
+ [ "Getting " ++ kv ++ " keys with this remote is not secure;"
+ , "the content cannot be verified to be correct."
+ , "(Use annex.security.allow-unverified-downloads to bypass"
+ , "this safety check.)"
+ ]
+ where
+ kv = formatKeyVariety (keyVariety k)
+
data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify
shouldVerify :: VerifyConfig -> Annex Bool
@@ -827,7 +867,7 @@ isUnmodified key f = go =<< geti
go (Just fc) = cheapcheck fc <||> expensivecheck fc
cheapcheck fc = anyM (compareInodeCaches fc)
=<< Database.Keys.getInodeCaches key
- expensivecheck fc = ifM (verifyKeyContent AlwaysVerify UnVerified key f)
+ expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f)
-- The file could have been modified while it was
-- being verified. Detect that.
( geti >>= maybe (return False) (compareInodeCaches fc)
@@ -943,18 +983,8 @@ downloadUrl k p urls file =
-- Poll the file to handle configurations where an external
-- download command is used.
meteredFile file (Just p) k $
- go =<< annexWebDownloadCommand <$> Annex.getGitConfig
- where
- go Nothing = Url.withUrlOptions $ \uo ->
- liftIO $ anyM (\u -> Url.download p u file uo) urls
- go (Just basecmd) = anyM (downloadcmd basecmd) urls
- downloadcmd basecmd url =
- progressCommand "sh" [Param "-c", Param $ gencmd url basecmd]
- <&&> liftIO (doesFileExist file)
- gencmd url = massReplace
- [ ("%file", shellEscape file)
- , ("%url", shellEscape url)
- ]
+ Url.withUrlOptions $ \uo ->
+ liftIO $ 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. -}
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 7bb9ad0..b6e5a77 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -73,7 +73,7 @@ sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)
where
go (Nothing, params) = return $ mkparams cs params
go (Just socketfile, params) = do
- prepSocket socketfile gc host (mkparams NoConsumeStdin params)
+ prepSocket socketfile host (mkparams NoConsumeStdin params)
return $ mkparams cs params
mkparams cs' ps = concat
@@ -167,8 +167,8 @@ portParams (Just port) = [Param "-p", Param $ show port]
- Locks the socket lock file to prevent other git-annex processes from
- stopping the ssh multiplexer on this socket.
-}
-prepSocket :: FilePath -> RemoteGitConfig -> SshHost -> [CommandParam] -> Annex ()
-prepSocket socketfile gc sshhost sshparams = do
+prepSocket :: FilePath -> SshHost -> [CommandParam] -> Annex ()
+prepSocket socketfile sshhost sshparams = do
-- There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted.
-- This must run only once, before we have made any ssh connection,
@@ -190,9 +190,7 @@ prepSocket socketfile gc sshhost sshparams = do
let socketlock = socket2lock socketfile
Annex.getState Annex.concurrency >>= \case
- Concurrent {}
- | annexUUID (remoteGitConfig gc) /= NoUUID ->
- makeconnection socketlock
+ Concurrent {} -> makeconnection socketlock
_ -> return ()
lockFileCached socketlock
@@ -389,7 +387,7 @@ sshOptionsTo remote gc localr
case msockfile of
Nothing -> use []
Just sockfile -> do
- prepSocket sockfile gc sshhost $ concat
+ prepSocket sockfile sshhost $ concat
[ cacheparams
, map Param (remoteAnnexSshOptions gc)
, portParams port
diff --git a/Annex/Url.hs b/Annex/Url.hs
index 0d65a3e..968118b 100644
--- a/Annex/Url.hs
+++ b/Annex/Url.hs
@@ -1,5 +1,5 @@
{- Url downloading, with git-annex user agent and configured http
- - headers and curl options.
+ - headers, security restrictions, etc.
-
- Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
@@ -11,13 +11,18 @@ module Annex.Url (
withUrlOptions,
getUrlOptions,
getUserAgent,
+ httpAddressesUnlimited,
) where
import Annex.Common
import qualified Annex
import Utility.Url as U
+import Utility.IPAddress
+import Utility.HttpManagerRestricted
import qualified BuildInfo
+import Network.Socket
+
defaultUserAgent :: U.UserAgent
defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion
@@ -34,15 +39,62 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case
{ Annex.urloptions = Just uo }
return uo
where
- mk = mkUrlOptions
- <$> getUserAgent
- <*> headers
- <*> options
- <*> liftIO (U.newManager U.managerSettings)
+ mk = do
+ (urldownloader, manager) <- checkallowedaddr
+ mkUrlOptions
+ <$> getUserAgent
+ <*> headers
+ <*> pure urldownloader
+ <*> pure manager
+ <*> (annexAllowedUrlSchemes <$> Annex.getGitConfig)
+
headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case
Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
Nothing -> annexHttpHeaders <$> Annex.getGitConfig
- options = map Param . annexWebOptions <$> Annex.getGitConfig
+
+ checkallowedaddr = words . annexAllowedHttpAddresses <$> Annex.getGitConfig >>= \case
+ ["all"] -> do
+ -- Only allow curl when all are allowed,
+ -- as its interface does not allow preventing
+ -- it from accessing specific IP addresses.
+ curlopts <- map Param . annexWebOptions <$> Annex.getGitConfig
+ let urldownloader = if null curlopts
+ then U.DownloadWithCurl curlopts
+ else U.DownloadWithConduit
+ manager <- liftIO $ U.newManager U.managerSettings
+ return (urldownloader, manager)
+ allowedaddrs -> do
+ addrmatcher <- liftIO $
+ (\l v -> any (\f -> f v) l) . catMaybes
+ <$> mapM makeAddressMatcher allowedaddrs
+ -- Default to not allowing access to loopback
+ -- and private IP addresses to avoid data
+ -- leakage.
+ let isallowed addr
+ | addrmatcher addr = True
+ | isLoopbackAddress addr = False
+ | isPrivateAddress addr = False
+ | otherwise = True
+ let connectionrestricted = addrConnectionRestricted
+ ("Configuration of annex.security.allowed-http-addresses does not allow accessing address " ++)
+ let r = Restriction
+ { addressRestriction = \addr ->
+ if isallowed (addrAddress addr)
+ then Nothing
+ else Just (connectionrestricted addr)
+ }
+ (settings, pr) <- liftIO $
+ restrictManagerSettings r U.managerSettings
+ case pr of
+ Nothing -> return ()
+ Just ProxyRestricted -> toplevelWarning True
+ "http proxy settings not used due to annex.security.allowed-http-addresses configuration"
+ manager <- liftIO $ U.newManager settings
+ return (U.DownloadWithConduit, manager)
+
+httpAddressesUnlimited :: Annex Bool
+httpAddressesUnlimited =
+ ("all" == ) . annexAllowedHttpAddresses <$> Annex.getGitConfig
withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a
withUrlOptions a = a =<< getUrlOptions
diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs
index 425d06d..cb4f4e2 100644
--- a/Annex/YoutubeDl.hs
+++ b/Annex/YoutubeDl.hs
@@ -1,6 +1,6 @@
{- youtube-dl integration for git-annex
-
- - Copyright 2017 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -11,7 +11,7 @@ module Annex.YoutubeDl (
youtubeDlSupported,
youtubeDlCheck,
youtubeDlFileName,
- youtubeDlFileName',
+ youtubeDlFileNameHtmlOnly,
) where
import Annex.Common
@@ -27,6 +27,12 @@ import Logs.Transfer
import Network.URI
import Control.Concurrent.Async
+-- youtube-dl is can follow redirects to anywhere, including potentially
+-- localhost or a private address. So, it's only allowed to be used if the
+-- user has allowed access to all addresses.
+youtubeDlAllowed :: Annex Bool
+youtubeDlAllowed = httpAddressesUnlimited
+
-- Runs youtube-dl in a work directory, to download a single media file
-- from the url. Reutrns the path to the media file in the work directory.
--
@@ -41,8 +47,14 @@ import Control.Concurrent.Async
-- (Note that we can't use --output to specifiy the file to download to,
-- due to <https://github.com/rg3/youtube-dl/issues/14864>)
youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath))
-youtubeDl url workdir
- | supportedScheme url = ifM (liftIO $ inPath "youtube-dl")
+youtubeDl url workdir = ifM httpAddressesUnlimited
+ ( withUrlOptions $ youtubeDl' url workdir
+ , return (Right Nothing)
+ )
+
+youtubeDl' :: URLString -> FilePath -> UrlOptions -> Annex (Either String (Maybe FilePath))
+youtubeDl' url workdir uo
+ | supportedScheme uo url = ifM (liftIO $ inPath "youtube-dl")
( runcmd >>= \case
Right True -> workdirfiles >>= \case
(f:[]) -> return (Right (Just f))
@@ -107,7 +119,13 @@ youtubeDlMaxSize workdir = ifM (Annex.getState Annex.force)
-- Download a media file to a destination,
youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool
-youtubeDlTo key url dest = do
+youtubeDlTo key url dest = ifM youtubeDlAllowed
+ ( youtubeDlTo' key url dest
+ , return False
+ )
+
+youtubeDlTo' :: Key -> URLString -> FilePath -> Annex Bool
+youtubeDlTo' key url dest = do
res <- withTmpWorkDir key $ \workdir ->
youtubeDl url workdir >>= \case
Right (Just mediafile) -> do
@@ -134,8 +152,14 @@ youtubeDlSupported url = either (const False) id <$> youtubeDlCheck url
-- Check if youtube-dl can find media in an url.
youtubeDlCheck :: URLString -> Annex (Either String Bool)
-youtubeDlCheck url
- | supportedScheme url = catchMsgIO $ htmlOnly url False $ do
+youtubeDlCheck url = ifM youtubeDlAllowed
+ ( withUrlOptions $ youtubeDlCheck' url
+ , return (Right False)
+ )
+
+youtubeDlCheck' :: URLString -> UrlOptions -> Annex (Either String Bool)
+youtubeDlCheck' url uo
+ | supportedScheme uo url = catchMsgIO $ htmlOnly url False $ do
opts <- youtubeDlOpts [ Param url, Param "--simulate" ]
liftIO $ snd <$> processTranscript "youtube-dl" (toCommand opts) Nothing
| otherwise = return (Right False)
@@ -144,18 +168,28 @@ youtubeDlCheck url
--
-- (This is not always identical to the filename it uses when downloading.)
youtubeDlFileName :: URLString -> Annex (Either String FilePath)
-youtubeDlFileName url
- | supportedScheme url = flip catchIO (pure . Left . show) $
- htmlOnly url nomedia (youtubeDlFileName' url)
- | otherwise = return nomedia
+youtubeDlFileName url = ifM youtubeDlAllowed
+ ( withUrlOptions go
+ , return nomedia
+ )
where
+ go uo
+ | supportedScheme uo url = flip catchIO (pure . Left . show) $
+ htmlOnly url nomedia (youtubeDlFileNameHtmlOnly' url uo)
+ | otherwise = return nomedia
nomedia = Left "no media in url"
-- Does not check if the url contains htmlOnly; use when that's already
-- been verified.
-youtubeDlFileName' :: URLString -> Annex (Either String FilePath)
-youtubeDlFileName' url
- | supportedScheme url = flip catchIO (pure . Left . show) go
+youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String FilePath)
+youtubeDlFileNameHtmlOnly url = ifM youtubeDlAllowed
+ ( withUrlOptions $ youtubeDlFileNameHtmlOnly' url
+ , return (Left "no media in url")
+ )
+
+youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String FilePath)
+youtubeDlFileNameHtmlOnly' url uo
+ | supportedScheme uo url = flip catchIO (pure . Left . show) go
| otherwise = return nomedia
where
go = do
@@ -189,12 +223,13 @@ youtubeDlOpts addopts = do
opts <- map Param . annexYoutubeDlOptions <$> Annex.getGitConfig
return (opts ++ addopts)
-supportedScheme :: URLString -> Bool
-supportedScheme url = case uriScheme <$> parseURIRelaxed url of
+supportedScheme :: UrlOptions -> URLString -> Bool
+supportedScheme uo url = case parseURIRelaxed url of
Nothing -> False
- -- avoid ugly message from youtube-dl about not supporting file:
- Just "file:" -> False
- -- ftp indexes may look like html pages, and there's no point
- -- involving youtube-dl in a ftp download
- Just "ftp:" -> False
- Just _ -> True
+ Just u -> case uriScheme u of
+ -- avoid ugly message from youtube-dl about not supporting file:
+ "file:" -> False
+ -- ftp indexes may look like html pages, and there's no point
+ -- involving youtube-dl in a ftp download
+ "ftp:" -> False
+ _ -> allowedScheme uo u
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 2cb5574..2f1df57 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -55,8 +55,7 @@ calcSyncRemotes = do
let good r = Remote.uuid r `elem` alive
let syncable = filter good rs
contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $
- filter (\r -> Remote.uuid r /= NoUUID) $
- filter (not . Remote.isXMPPRemote) syncable
+ filter (\r -> Remote.uuid r /= NoUUID) syncable
let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes
return $ \dstatus -> dstatus
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index a97bb31..22baffe 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -47,7 +47,8 @@ finishedLocalPairing msg keypair = do
("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata))
Nothing
r <- liftAnnex $ addRemote $ makeSshRemote sshdata
- liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost
+ repo <- liftAnnex $ Remote.getRepo r
+ liftAnnex $ setRemoteCost repo semiExpensiveRemoteCost
syncRemote r
{- Mostly a straightforward conversion. Except:
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 5f08ec8..508b86e 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -64,26 +64,25 @@ reconnectRemotes rs = void $ do
mapM_ signal $ filter (`notElem` failedrs) rs'
recordExportCommit
where
- gitremotes = filter (notspecialremote . Remote.repo) rs
- (_xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
+ gitremotes = liftAnnex $
+ filterM (notspecialremote <$$> Remote.getRepo) rs
notspecialremote r
| Git.repoIsUrl r = True
| Git.repoIsLocal r = True
| Git.repoIsLocalUnknown r = True
| otherwise = False
sync currentbranch@(Just _, _) = do
- (failedpull, diverged) <- manualPull currentbranch gitremotes
+ (failedpull, diverged) <- manualPull currentbranch =<< gitremotes
now <- liftIO getCurrentTime
- failedpush <- pushToRemotes' now gitremotes
+ failedpush <- pushToRemotes' now =<< gitremotes
return (nub $ failedpull ++ failedpush, diverged)
{- No local branch exists yet, but we can try pulling. -}
- sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes
+ sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes
go = do
(failed, diverged) <- sync
=<< liftAnnex (join Command.Sync.getCurrBranch)
addScanRemotes diverged =<<
- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig)
- nonxmppremotes
+ filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs
return failed
signal r = liftIO . mapM_ (flip tryPutMVar ())
=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
@@ -130,8 +129,7 @@ pushToRemotes' now remotes = do
<$> gitRepo
<*> join Command.Sync.getCurrBranch
<*> getUUID
- let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
- ret <- go True branch g u normalremotes
+ ret <- go True branch g u remotes
return ret
where
go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
@@ -174,7 +172,8 @@ parallelPush g rs a = do
where
topush r = (,)
<$> pure r
- <*> sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g
+ <*> (Remote.getRepo r >>= \repo ->
+ sshOptionsTo repo (Remote.gitconfig r) g)
{- Displays an alert while running an action that syncs with some remotes,
- and returns any remotes that it failed to sync with.
@@ -187,7 +186,7 @@ syncAction rs a
| otherwise = do
i <- addAlert $ syncAlert visibleremotes
failed <- a rs
- let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed
+ failed' <- filterM (not . Git.repoIsLocalUnknown <$$> liftAnnex . Remote.getRepo) failed
let succeeded = filter (`notElem` failed) visibleremotes
if null succeeded && null failed'
then removeAlert i
@@ -195,8 +194,7 @@ syncAction rs a
syncResultAlert succeeded failed'
return failed
where
- visibleremotes = filter (not . Remote.readonly) $
- filter (not . Remote.isXMPPRemote) rs
+ visibleremotes = filter (not . Remote.readonly) rs
{- Manually pull from remotes and merge their branches. Returns any
- remotes that it failed to pull from, and a Bool indicating
@@ -206,17 +204,18 @@ syncAction rs a
manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
g <- liftAnnex gitRepo
- let (_xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
- failed <- forM normalremotes $ \r -> if wantpull $ Remote.gitconfig r
+ failed <- forM remotes $ \r -> if wantpull $ Remote.gitconfig r
then do
- g' <- liftAnnex $ sshOptionsTo (Remote.repo r) (Remote.gitconfig r) g
+ g' <- liftAnnex $ do
+ repo <- Remote.getRepo r
+ sshOptionsTo repo (Remote.gitconfig r) g
ifM (liftIO $ Git.Command.runBool [Param "fetch", Param $ Remote.name r] g')
( return Nothing
, return $ Just r
)
else return Nothing
haddiverged <- liftAnnex Annex.Branch.forceUpdate
- forM_ normalremotes $ \r ->
+ forM_ remotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r
currentbranch Command.Sync.mergeConfig def
when haddiverged $
@@ -263,10 +262,10 @@ changeSyncable (Just r) False = do
changeSyncFlag :: Remote -> Bool -> Annex ()
changeSyncFlag r enabled = do
+ repo <- Remote.getRepo r
+ let key = Config.remoteConfig repo "sync"
Config.setConfig key (boolConfig enabled)
void Remote.remoteListRefresh
- where
- key = Config.remoteConfig (Remote.repo r) "sync"
updateExportTreeFromLogAll :: Assistant ()
updateExportTreeFromLogAll = do
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 145a76e..3e21531 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/Assistant/Threads/Cronner.hs
@@ -210,11 +210,11 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (r
- Annex monad. -}
go rmt =<< liftAnnex (mkfscker (annexFsckParams d))
go rmt annexfscker = do
+ repo <- liftAnnex $ Remote.getRepo rmt
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do
void annexfscker
- let r = Remote.repo rmt
- if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r)
- then Just <$> Git.Fsck.findBroken True r
+ if Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo)
+ then Just <$> Git.Fsck.findBroken True repo
else pure Nothing
maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index bd8d0e6..c5d075f 100644
--- a/Assistant/Threads/MountWatcher.hs
+++ b/Assistant/Threads/MountWatcher.hs
@@ -144,7 +144,8 @@ handleMounts urlrenderer wasmounted nowmounted =
handleMount :: UrlRenderer -> FilePath -> Assistant ()
handleMount urlrenderer dir = do
debug ["detected mount of", dir]
- rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
+ rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo)
+ =<< remotesUnder dir
mapM_ (fsckNudge urlrenderer . Just) rs
reconnectRemotes rs
diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs
index 86ee027..19f7ccc 100644
--- a/Assistant/Threads/ProblemFixer.hs
+++ b/Assistant/Threads/ProblemFixer.hs
@@ -49,20 +49,23 @@ handleProblem urlrenderer repoproblem = do
liftIO $ afterFix repoproblem
handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool
-handleRemoteProblem urlrenderer rmt
- | Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
+handleRemoteProblem urlrenderer rmt = do
+ repo <- liftAnnex $ Remote.getRepo rmt
+ handleRemoteProblem' repo urlrenderer rmt
+
+handleRemoteProblem' :: Git.Repo -> UrlRenderer -> Remote -> Assistant Bool
+handleRemoteProblem' repo urlrenderer rmt
+ | Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo) =
ifM (liftIO $ checkAvailable True rmt)
( do
- fixedlocks <- repairStaleGitLocks r
+ fixedlocks <- repairStaleGitLocks repo
fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $
- Git.Fsck.findBroken True r
+ Git.Fsck.findBroken True repo
repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
return $ fixedlocks || repaired
, return False
)
| otherwise = return False
- where
- r = Remote.repo rmt
{- This is not yet used, and should probably do a fsck. -}
handleLocalRepoProblem :: UrlRenderer -> Assistant Bool
diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs
index 1aa8bc9..2a411ef 100644
--- a/Assistant/Threads/RemoteControl.hs
+++ b/Assistant/Threads/RemoteControl.hs
@@ -99,7 +99,7 @@ remoteResponderThread fromh urimap = go M.empty
cont
getURIMap :: Annex (M.Map URI Remote)
-getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
+getURIMap = Remote.remoteMap' id (\r -> mkk . Git.location <$> Remote.getRepo r)
where
mkk (Git.Url u) = Just u
mkk _ = Nothing
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index c0d464e..3c7a01b 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -106,13 +106,13 @@ runTransferThread' program batchmaker d run = go
- already have been updated to include the transfer. -}
genTransfer :: Transfer -> TransferInfo -> TransferGenerator
genTransfer t info = case transferRemote info of
- Just remote
- | Git.repoIsLocalUnknown (Remote.repo remote) -> do
- -- optimisation for removable drives not plugged in
+ Just remote -> ifM (unpluggedremovabledrive remote)
+ ( do
+ -- optimisation, since the transfer would fail
liftAnnex $ recordFailedTransfer t info
void $ removeTransfer t
return Nothing
- | otherwise -> ifM (liftAnnex $ shouldTransfer t info)
+ , ifM (liftAnnex $ shouldTransfer t info)
( do
debug [ "Transferring:" , describeTransfer t info ]
notifyTransfer
@@ -124,11 +124,15 @@ genTransfer t info = case transferRemote info of
finishedTransfer t (Just info)
return Nothing
)
+ )
_ -> return Nothing
where
direction = transferDirection t
isdownload = direction == Download
+ unpluggedremovabledrive remote = Git.repoIsLocalUnknown
+ <$> liftAnnex (Remote.getRepo remote)
+
{- Alerts are only shown for successful transfers.
- Transfers can temporarily fail for many reasons,
- so there's no point in bothering the user about
diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs
index 822b74a..fe30d1b 100644
--- a/Assistant/WebApp/Configurators/Edit.hs
+++ b/Assistant/WebApp/Configurators/Edit.hs
@@ -146,8 +146,8 @@ setRepoConfig uuid mremote oldc newc = do
legalName = makeLegalName . T.unpack . repoName
-editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig
-editRepositoryAForm mremote d = RepoConfig
+editRepositoryAForm :: Maybe Git.Repo -> Maybe Remote -> RepoConfig -> MkAForm RepoConfig
+editRepositoryAForm mrepo mremote d = RepoConfig
<$> areq (if ishere then readonlyTextField else textField)
(bfs "Name") (Just $ repoName d)
<*> aopt textField (bfs "Description") (Just $ repoDescription d)
@@ -156,8 +156,7 @@ editRepositoryAForm mremote d = RepoConfig
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable d)
where
ishere = isNothing mremote
- isspecial = fromMaybe False $
- (== Git.Unknown) . Git.location . Remote.repo <$> mremote
+ isspecial = maybe False ((== Git.Unknown) . Git.location) mrepo
groups = customgroups ++ standardgroups
standardgroups :: [(Text, RepoGroup)]
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) $
@@ -204,8 +203,11 @@ editForm new (RepoUUID uuid)
error "unknown remote"
curr <- liftAnnex $ getRepoConfig uuid mremote
liftAnnex $ checkAssociatedDirectory curr mremote
+ mrepo <- liftAnnex $
+ maybe (pure Nothing) (Just <$$> Remote.getRepo) mremote
((result, form), enctype) <- liftH $
- runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr
+ runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+ editRepositoryAForm mrepo mremote curr
case result of
FormSuccess input -> liftH $ do
setRepoConfig uuid mremote curr input
@@ -221,7 +223,8 @@ editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
mr <- liftAnnex (repoIdRemote r)
let repoInfo = getRepoInfo mr Nothing
g <- liftAnnex gitRepo
- let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation . Remote.repo) mr
+ mrepo <- liftAnnex $ maybe (pure Nothing) (Just <$$> Remote.getRepo) mr
+ let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation) mrepo
$(widgetFile "configurators/edit/nonannexremote")
{- Makes any directory associated with the repository. -}
@@ -246,7 +249,7 @@ getRepoInfo (Just r) (Just c) = case M.lookup "type" c of
| otherwise -> AWS.getRepoInfo c
Just t
| t /= "git" -> [whamlet|#{t} remote|]
- _ -> getGitRepoInfo $ Remote.repo r
+ _ -> getGitRepoInfo =<< liftAnnex (Remote.getRepo r)
getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
getRepoInfo _ _ = [whamlet|git repository|]
@@ -283,9 +286,11 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
go Nothing = redirect DashboardR
go (Just rmt) = do
liftIO fixSshKeyPairIdentitiesOnly
- liftAnnex $ setConfig
- (remoteConfig (Remote.repo rmt) "ignore")
- (Git.Config.boolConfig False)
+ liftAnnex $ do
+ repo <- Remote.getRepo rmt
+ setConfig
+ (remoteConfig repo "ignore")
+ (Git.Config.boolConfig False)
liftAnnex $ void Remote.remoteListRefresh
liftAssistant updateSyncRemotes
liftAssistant $ syncRemote rmt
diff --git a/Assistant/WebApp/MakeRemote.hs b/Assistant/WebApp/MakeRemote.hs
index 438691b..2575feb 100644
--- a/Assistant/WebApp/MakeRemote.hs
+++ b/Assistant/WebApp/MakeRemote.hs
@@ -38,8 +38,9 @@ setupCloudRemote = setupRemote postsetup . Just
setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupRemote postsetup mgroup mcost getname = do
r <- liftAnnex $ addRemote getname
+ repo <- liftAnnex $ Remote.getRepo r
liftAnnex $ do
maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup
- maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
+ maybe noop (Config.setRemoteCost repo) mcost
liftAssistant $ syncRemote r
postsetup r
diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs
index 49b89bb..092557d 100644
--- a/Assistant/WebApp/RepoList.hs
+++ b/Assistant/WebApp/RepoList.hs
@@ -139,10 +139,11 @@ repoList reposelector
unwanted <- S.fromList
<$> filterM inUnwantedGroup (map Remote.uuid syncremotes)
trustmap <- trustMap
+ allrs <- concat . Remote.byCost <$> Remote.remoteList
rs <- filter (\r -> M.lookup (Remote.uuid r) trustmap /= Just DeadTrusted)
- . filter selectedrepo
- . concat . Remote.byCost
- <$> Remote.remoteList
+ . map fst
+ . filter selectedrepo
+ <$> forM allrs (\r -> (,) <$> pure r <*> Remote.getRepo r)
let l = flip map (map mkRepoId rs) $ \r -> case r of
(RepoUUID u)
| u `S.member` unwanted -> (r, mkUnwantedRepoActions r)
@@ -165,11 +166,10 @@ repoList reposelector
map snd . catMaybes . filter selectedremote
. map (findinfo m g)
<$> trustExclude DeadTrusted (M.keys m)
- selectedrepo r
+ selectedrepo (r, repo)
| Remote.readonly r = False
- | onlyCloud reposelector = Git.repoIsUrl (Remote.repo r)
+ | onlyCloud reposelector = Git.repoIsUrl repo
&& Remote.uuid r /= NoUUID
- && not (Remote.isXMPPRemote r)
| otherwise = True
selectedremote Nothing = False
selectedremote (Just (iscloud, _))
@@ -238,8 +238,9 @@ getRepositoriesReorderR = do
go list (Just remote) = do
rs <- catMaybes <$> mapM repoIdRemote list
forM_ (reorderCosts remote rs) $ \(r, newcost) ->
- when (Remote.cost r /= newcost) $
- setRemoteCost (Remote.repo r) newcost
+ when (Remote.cost r /= newcost) $ do
+ repo <- Remote.getRepo r
+ setRemoteCost repo newcost
void remoteListRefresh
fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack
diff --git a/CHANGELOG b/CHANGELOG
index 5ad2191..e269691 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,58 @@
+git-annex (6.20180626) upstream; urgency=high
+
+ Security fix release for CVE-2018-10857 and CVE-2018-10859
+ https://git-annex.branchable.com/security/CVE-2018-10857_and_CVE-2018-10859/
+
+ * Refuse to download content, that cannot be verified with a hash,
+ from encrypted special remotes (for CVE-2018-10859),
+ and from all external special remotes and glacier (for CVE-2018-10857).
+ In particular, URL and WORM keys stored on such remotes won't
+ be downloaded. If this affects your files, you can run
+ `git-annex migrate` on the affected files, to convert them
+ to use a hash.
+ * Added annex.security.allow-unverified-downloads, which can override
+ the above.
+ * Added annex.security.allowed-url-schemes setting, which defaults
+ to only allowing http, https, and ftp URLs. Note especially that file:/
+ is no longer enabled by default.
+ * Removed annex.web-download-command, since its interface does not allow
+ supporting annex.security.allowed-url-schemes across redirects.
+ If you used this setting, you may want to instead use annex.web-options
+ to pass options to curl.
+ * git-annex will refuse to download content from http servers on
+ localhost, or any private IP addresses, to prevent accidental
+ exposure of internal data. This can be overridden with the
+ annex.security.allowed-http-addresses setting.
+ * Local http proxies will not be used unless allowed by the
+ annex.security.allowed-http-addresses setting.
+ * Since the interfaces to curl and youtube-dl do not have a way to
+ prevent them from accessing localhost or private IP addresses,
+ they default to not being used for url downloads.
+ Only when annex.security.allowed-http-addresses=all will curl and
+ youtube-dl be used.
+
+ Non-security fix changes:
+
+ * Fix build with ghc 8.4+, which broke due to the Semigroup Monoid change.
+ * version: Show operating system and repository version list
+ when run outside a git repo too.
+ * Fix annex-checkuuid implementation, so that remotes configured that
+ way can be used.
+ * Fix problems accessing repositories over http when annex.tune.*
+ is configured.
+ * External special remotes can now add info to `git annex info $remote`,
+ by replying to the GETINFO message.
+ * adb: Android serial numbers are not all 16 characters long, so accept
+ other lengths.
+ * Display error messages that come from git-annex-shell when the p2p
+ protocol is used, so that diskreserve messages, IO errors, etc from
+ the remote side are visible again.
+ * When content has been lost from an export remote and
+ git-annex fsck --from remote has noticed it's gone, re-running
+ git-annex export or git-annex sync --content will re-upload it.
+
+ -- Joey Hess <id@joeyh.name> Fri, 22 Jun 2018 10:36:22 -0400
+
git-annex (6.20180529) upstream; urgency=medium
* Prevent haskell http-client from decompressing gzip files, so downloads
diff --git a/COPYRIGHT b/COPYRIGHT
index 1c689da..2b19d18 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -10,7 +10,7 @@ Copyright: © 2012-2017 Joey Hess <id@joeyh.name>
© 2014 Sören Brunk
License: AGPL-3+
-Files: Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs
+Files: Remote/Git.hs Remote/Helper/Ssh.hs Remote/Adb.hs Remote/External.hs Remote/Extermal/Types.hs
Copyright: © 2011-2018 Joey Hess <id@joeyh.name>
License: AGPL-3+
@@ -24,6 +24,11 @@ Copyright: 2011 Bas van Dijk & Roel van Dijk
2012, 2013 Joey Hess <id@joeyh.name>
License: BSD-2-clause
+Files: Utility/HttpManagerRestricted.hs
+Copyright: 2018 Joey Hess <id@joeyh.name>
+ 2013 Michael Snoyman
+License: MIT
+
Files: Utility/*
Copyright: 2012-2018 Joey Hess <id@joeyh.name>
License: BSD-2-clause
@@ -51,26 +56,7 @@ Copyright: © 2005-2011 by John Resig, Branden Aaron & Jörn Zaefferer
License: MIT or GPL-2
The full text of version 2 of the GPL is distributed in
/usr/share/common-licenses/GPL-2 on Debian systems. The text of the MIT
- license follows:
- .
- Permission is hereby granted, free of charge, to any person obtaining
- a copy of this software and associated documentation files (the
- "Software"), to deal in the Software without restriction, including
- without limitation the rights to use, copy, modify, merge, publish,
- distribute, sublicense, and/or sell copies of the Software, and to
- permit persons to whom the Software is furnished to do so, subject to
- the following conditions:
- .
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
- .
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
- WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ license is in the MIT section below.
Files: static/*/bootstrap* static/*/glyphicons-halflings*
Copyright: 2012-2014 Twitter, Inc.
@@ -153,6 +139,26 @@ License: BSD-2-clause
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+
+License: MIT
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+ .
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+ .
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
License: AGPL-3+
GNU AFFERO GENERAL PUBLIC LICENSE
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 4721599..156dbaf 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -277,7 +277,7 @@ downloadWeb o url urlinfo file =
-- Ask youtube-dl what filename it will download
-- first, and check if that is already an annexed file,
-- to avoid unnecessary work in that case.
- | otherwise = youtubeDlFileName' url >>= \case
+ | otherwise = youtubeDlFileNameHtmlOnly url >>= \case
Right dest -> ifAnnexed dest
(alreadyannexed dest)
(dl dest)
diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs
index 0966614..1185296 100644
--- a/Command/EnableRemote.hs
+++ b/Command/EnableRemote.hs
@@ -92,7 +92,9 @@ cleanupSpecialRemote u c = do
Logs.Remote.configSet u c
Remote.byUUID u >>= \case
Nothing -> noop
- Just r -> setRemoteIgnore (R.repo r) False
+ Just r -> do
+ repo <- R.getRepo r
+ setRemoteIgnore repo False
return True
unknownNameError :: String -> Annex a
diff --git a/Command/Export.hs b/Command/Export.hs
index d4e2b4a..5084e4f 100644
--- a/Command/Export.hs
+++ b/Command/Export.hs
@@ -201,7 +201,7 @@ fillExport r ea db new = do
startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
startExport r ea db cvar ti = do
ek <- exportKey (Git.LsTree.sha ti)
- stopUnless (liftIO $ notElem loc <$> getExportedLocation db (asKey ek)) $ do
+ stopUnless (notpresent ek) $ do
showStart ("export " ++ name r) f
liftIO $ modifyMVar_ cvar (pure . const True)
next $ performExport r ea db ek af (Git.LsTree.sha ti) loc
@@ -209,6 +209,11 @@ startExport r ea db cvar ti = do
loc = mkExportLocation f
f = getTopFilePath (Git.LsTree.file ti)
af = AssociatedFile (Just f)
+ notpresent ek = (||)
+ <$> liftIO (notElem loc <$> getExportedLocation db (asKey ek))
+ -- If content was removed from the remote, the export db
+ -- will still list it, so also check location tracking.
+ <*> (notElem (uuid r) <$> loggedLocations (asKey ek))
performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform
performExport r ea db ek af contentsha loc = do
diff --git a/Command/Get.hs b/Command/Get.hs
index f4e3d47..eac8e88 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -109,7 +109,7 @@ getKey' key afile = dispatch
| Remote.hasKeyCheap r =
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
- docopy r witness = getViaTmp (RemoteVerify r) key $ \dest ->
+ docopy r witness = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key $ \dest ->
download (Remote.uuid r) key afile stdRetry
(\p -> do
showAction $ "from " ++ Remote.name r
diff --git a/Command/Info.hs b/Command/Info.hs
index c9a3140..9e7e527 100644
--- a/Command/Info.hs
+++ b/Command/Info.hs
@@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, CPP #-}
module Command.Info where
@@ -13,6 +13,10 @@ import "mtl" Control.Monad.State.Strict
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Data.Ord
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Semigroup as Sem
+#endif
+import Prelude
import Command
import qualified Git
@@ -55,15 +59,28 @@ data KeyData = KeyData
, unknownSizeKeys :: Integer
, backendsKeys :: M.Map KeyVariety Integer
}
+
+appendKeyData :: KeyData -> KeyData -> KeyData
+appendKeyData a b = KeyData
+ { countKeys = countKeys a + countKeys b
+ , sizeKeys = sizeKeys a + sizeKeys b
+ , unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b
+ , backendsKeys = backendsKeys a <> backendsKeys b
+ }
+
+#if MIN_VERSION_base(4,9,0)
+instance Sem.Semigroup KeyData where
+ (<>) = appendKeyData
+#endif
instance Monoid KeyData where
mempty = KeyData 0 0 0 M.empty
- mappend a b = KeyData
- { countKeys = countKeys a + countKeys b
- , sizeKeys = sizeKeys a + sizeKeys b
- , unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b
- , backendsKeys = backendsKeys a <> backendsKeys b
- }
+#if MIN_VERSION_base(4,11,0)
+#elif MIN_VERSION_base(4,9,0)
+ mappend = (Sem.<>)
+#else
+ mappend = appendKeyData
+#endif
data NumCopiesStats = NumCopiesStats
{ numCopiesVarianceMap :: M.Map Variance Integer
diff --git a/Command/Move.hs b/Command/Move.hs
index 2f30792..b50c877 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -207,7 +207,7 @@ fromPerform src removewhen key afile = do
where
go = notifyTransfer Download afile $
download (Remote.uuid src) key afile stdRetry $ \p ->
- getViaTmp (RemoteVerify src) key $ \t ->
+ getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t ->
Remote.retrieveKeyFile src key afile t p
dispatch _ _ False = stop -- failed
dispatch RemoveNever _ True = next $ return True -- copy complete
diff --git a/Command/Multicast.hs b/Command/Multicast.hs
index e2f6870..5c853dd 100644
--- a/Command/Multicast.hs
+++ b/Command/Multicast.hs
@@ -213,7 +213,7 @@ storeReceived f = do
warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file."
liftIO $ nukeFile f
Just k -> void $
- getViaTmpFromDisk AlwaysVerify k $ \dest -> unVerified $
+ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $
liftIO $ catchBoolIO $ do
rename f dest
return True
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
index be67a25..4de6e96 100644
--- a/Command/ReKey.hs
+++ b/Command/ReKey.hs
@@ -83,7 +83,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
- This avoids hard linking to content linked to an
- unlocked file, which would leave the new key unlocked
- and vulnerable to corruption. -}
- ( getViaTmpFromDisk DefaultVerify newkey $ \tmp -> unVerified $ do
+ ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do
oldobj <- calcRepo (gitAnnexLocation oldkey)
linkOrCopy' (return True) newkey oldobj tmp Nothing
, do
diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
index 103db55..84f71f8 100644
--- a/Command/RecvKey.hs
+++ b/Command/RecvKey.hs
@@ -13,6 +13,7 @@ import Annex.Action
import Annex
import Utility.Rsync
import Types.Transfer
+import Types.Remote (RetrievalSecurityPolicy(..))
import Command.SendKey (fieldTransfer)
import qualified CmdLine.GitAnnexShell.Fields as Fields
@@ -31,7 +32,9 @@ start key = fieldTransfer Download key $ \_p -> do
fromunlocked <- (isJust <$> Fields.getField Fields.unlocked)
<||> (isJust <$> Fields.getField Fields.direct)
let verify = if fromunlocked then AlwaysVerify else DefaultVerify
- ifM (getViaTmp verify key go)
+ -- This matches the retrievalSecurityPolicy of Remote.Git
+ let rsp = RetrievalAllKeysSecure
+ ifM (getViaTmp rsp verify key go)
( do
-- forcibly quit after receiving one key,
-- and shutdown cleanly
diff --git a/Command/Reinject.hs b/Command/Reinject.hs
index 48f50d3..bde4c81 100644
--- a/Command/Reinject.hs
+++ b/Command/Reinject.hs
@@ -45,7 +45,7 @@ startSrcDest (src:dest:[])
showStart "reinject" dest
next $ ifAnnexed dest go stop
where
- go key = ifM (verifyKeyContent DefaultVerify UnVerified key src)
+ go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
( perform src key
, error "failed"
)
diff --git a/Command/SetKey.hs b/Command/SetKey.hs
index 090edee..5d6a6ca 100644
--- a/Command/SetKey.hs
+++ b/Command/SetKey.hs
@@ -33,7 +33,7 @@ perform file key = do
-- the file might be on a different filesystem, so moveFile is used
-- rather than simply calling moveAnnex; disk space is also
-- checked this way.
- ok <- getViaTmp DefaultVerify key $ \dest -> unVerified $
+ ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key $ \dest -> unVerified $
if dest /= file
then liftIO $ catchBoolIO $ do
moveFile file dest
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 2c2828b..0fb3bdc 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -275,8 +275,7 @@ remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote]
syncRemotes ps = do
remotelist <- Remote.remoteList' True
- available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig)
- (filter (not . Remote.isXMPPRemote) remotelist)
+ available <- filterM (liftIO . getDynamicConfig . remoteAnnexSync . Remote.gitconfig) remotelist
syncRemotes' ps available
syncRemotes' :: [String] -> [Remote] -> Annex [Remote]
@@ -292,7 +291,8 @@ syncRemotes' ps available =
listed = concat <$> mapM Remote.byNameOrGroup ps
good r
- | Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r
+ | Remote.gitSyncableRemote r =
+ Remote.Git.repoAvail =<< Remote.getRepo r
| otherwise = return True
fastest = fromMaybe [] . headMaybe . Remote.byCost
@@ -408,9 +408,11 @@ pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && want
stopUnless fetch $
next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
where
- fetch = inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $
- Git.Command.runBool
- [Param "fetch", Param $ Remote.name remote]
+ fetch = do
+ repo <- Remote.getRepo remote
+ inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $
+ Git.Command.runBool
+ [Param "fetch", Param $ Remote.name remote]
wantpull = remoteAnnexPull (Remote.gitconfig remote)
{- The remote probably has both a master and a synced/master branch.
@@ -441,35 +443,38 @@ pushRemote _o _remote (Nothing, _) = stop
pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
showStart' "push" (Just (Remote.name remote))
next $ next $ do
+ repo <- Remote.getRepo remote
showOutput
- ok <- inRepoWithSshOptionsTo (Remote.repo remote) gc $
+ ok <- inRepoWithSshOptionsTo repo gc $
pushBranch remote branch
if ok
- then postpushupdate
+ then postpushupdate repo
else do
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
return ok
where
+ gc = Remote.gitconfig remote
needpush
| remoteAnnexReadOnly gc = return False
| not (remoteAnnexPush gc) = return False
| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
-- Do updateInstead emulation for remotes on eg removable drives
- -- formatted FAT, where the post-update hook won't run.
- postpushupdate
- | annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) =
- case Git.repoWorkTree (Remote.repo remote) of
- Nothing -> return True
- Just wt -> ifM (Remote.Git.onLocal remote needUpdateInsteadEmulation)
- ( liftIO $ do
- p <- readProgramFile
- boolSystem' p [Param "post-receive"]
- (\cp -> cp { cwd = Just wt })
- , return True
- )
- | otherwise = return True
- gc = Remote.gitconfig remote
+ -- formatted FAT, where the post-receive hook won't run.
+ postpushupdate repo = case Git.repoWorkTree repo of
+ Nothing -> return True
+ Just wt -> ifM needemulation
+ ( liftIO $ do
+ p <- readProgramFile
+ boolSystem' p [Param "post-receive"]
+ (\cp -> cp { cwd = Just wt })
+ , return True
+ )
+ where
+ needemulation = Remote.Git.onLocal repo remote $
+ (annexCrippledFileSystem <$> Annex.getGitConfig)
+ <&&>
+ needUpdateInsteadEmulation
{- Pushes a regular branch like master to a remote. Also pushes the git-annex
- branch.
diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index f83f4f6..baffbe1 100644
--- a/Command/TestRemote.hs
+++ b/Command/TestRemote.hs
@@ -123,11 +123,13 @@ exportTreeVariant r = ifM (Remote.isExportSupported r)
-- Regenerate a remote with a modified config.
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
-adjustRemoteConfig r adjustconfig = Remote.generate (Remote.remotetype r)
- (Remote.repo r)
- (Remote.uuid r)
- (adjustconfig (Remote.config r))
- (Remote.gitconfig r)
+adjustRemoteConfig r adjustconfig = do
+ repo <- Remote.getRepo r
+ Remote.generate (Remote.remotetype r)
+ repo
+ (Remote.uuid r)
+ (adjustconfig (Remote.config r))
+ (Remote.gitconfig r)
test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
test st r k =
@@ -177,7 +179,7 @@ test st r k =
Just b -> case Backend.verifyKeyContent b of
Nothing -> return True
Just verifier -> verifier k (key2file k)
- get = getViaTmp (RemoteVerify r) k $ \dest ->
+ get = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest ->
Remote.retrieveKeyFile r k (AssociatedFile Nothing)
dest nullMeterUpdate
store = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
@@ -218,7 +220,7 @@ testExportTree st (Just _) ea k1 k2 =
retrieveexport k = withTmpFile "exported" $ \tmp h -> do
liftIO $ hClose h
ifM (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate)
- ( verifyKeyContent AlwaysVerify UnVerified k tmp
+ ( verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified k tmp
, return False
)
checkpresentexport k = Remote.checkPresentExport ea k testexportlocation
@@ -236,10 +238,10 @@ testUnavailable st r k =
, check (`notElem` [Right True, Right False]) "checkPresent" $
Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $
- getViaTmp (RemoteVerify r) k $ \dest ->
+ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest ->
Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate
, check (== Right False) "retrieveKeyFileCheap" $
- getViaTmp (RemoteVerify r) k $ \dest -> unVerified $
+ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> unVerified $
Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest
]
where
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index 1aa0a72..b1f9515 100644
--- a/Command/TransferKey.hs
+++ b/Command/TransferKey.hs
@@ -60,7 +60,7 @@ toPerform key file remote = go Upload file $
fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
fromPerform key file remote = go Upload file $
download (uuid remote) key file stdRetry $ \p ->
- getViaTmp (RemoteVerify remote) key $
+ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $
\t -> Remote.retrieveKeyFile remote key file t p
go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index 94582b2..b986a32 100644
--- a/Command/TransferKeys.hs
+++ b/Command/TransferKeys.hs
@@ -42,7 +42,7 @@ start = do
return ok
| otherwise = notifyTransfer direction file $
download (Remote.uuid remote) key file stdRetry $ \p ->
- getViaTmp (RemoteVerify remote) key $ \t -> do
+ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> do
r <- Remote.retrieveKeyFile remote key file t p
-- Make sure we get the current
-- associated files data for the key,
diff --git a/Command/Version.hs b/Command/Version.hs
index ef3ef39..a7a5d50 100644
--- a/Command/Version.hs
+++ b/Command/Version.hs
@@ -48,16 +48,9 @@ seekNoRepo o
showVersion :: Annex ()
showVersion = do
- v <- getVersion
- liftIO $ do
- showPackageVersion
- vinfo "local repository version" $ fromMaybe "unknown" v
- vinfo "supported repository versions" $
- unwords supportedVersions
- vinfo "upgrade supported from repository versions" $
- unwords upgradableVersions
- vinfo "operating system" $
- unwords [os, arch]
+ liftIO showPackageVersion
+ maybe noop (liftIO . vinfo "local repository version")
+ =<< getVersion
showPackageVersion :: IO ()
showPackageVersion = do
@@ -67,6 +60,11 @@ showPackageVersion = do
vinfo "key/value backends" $ unwords $
map (formatKeyVariety . B.backendVariety) Backend.list
vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes
+ vinfo "operating system" $ unwords [os, arch]
+ vinfo "supported repository versions" $
+ unwords supportedVersions
+ vinfo "upgrade supported from repository versions" $
+ unwords upgradableVersions
showRawVersion :: IO ()
showRawVersion = do
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index a716b56..3092ff2 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns, CPP #-}
module Git.Fsck (
FsckResults(..),
@@ -26,6 +26,10 @@ import qualified Git.Version
import qualified Data.Set as S
import Control.Concurrent.Async
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Semigroup as Sem
+#endif
+import Prelude
data FsckResults
= FsckFoundMissing
@@ -44,15 +48,29 @@ type MissingObjects = S.Set Sha
type Truncated = Bool
+appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput
+appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) =
+ FsckOutput (S.union s1 s2) (t1 || t2)
+appendFsckOutput (FsckOutput s t) _ = FsckOutput s t
+appendFsckOutput _ (FsckOutput s t) = FsckOutput s t
+appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput
+appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning
+appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+
+#if MIN_VERSION_base(4,9,0)
+instance Sem.Semigroup FsckOutput where
+ (<>) = appendFsckOutput
+#endif
+
instance Monoid FsckOutput where
mempty = NoFsckOutput
- mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)
- mappend (FsckOutput s t) _ = FsckOutput s t
- mappend _ (FsckOutput s t) = FsckOutput s t
- mappend NoFsckOutput NoFsckOutput = NoFsckOutput
- mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
- mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning
- mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+#if MIN_VERSION_base(4,11,0)
+#elif MIN_VERSION_base(4,9,0)
+ mappend = (Sem.<>)
+#else
+ mappend = appendFsckOutput
+#endif
{- Runs fsck to find some of the broken objects in the repository.
- May not find all broken objects, if fsck fails on bad data in some of
diff --git a/Limit.hs b/Limit.hs
index 483336e..5d00e2e 100644
--- a/Limit.hs
+++ b/Limit.hs
@@ -163,6 +163,8 @@ addCopies = addLimit . limitCopies
limitCopies :: MkLimit Annex
limitCopies want = case splitc ':' want of
+ -- Note that in case of a group having the same name as a trust
+ -- level, it's parsed as a trust level, not as a group.
[v, n] -> case parsetrustspec v of
Just checker -> go n $ checktrust checker
Nothing -> go n $ checkgroup v
diff --git a/NEWS b/NEWS
index a127219..f757a23 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,29 @@
+git-annex (6.20180626) upstream; urgency=high
+
+ A security fix has changed git-annex to refuse to download content from
+ some special remotes when the content cannot be verified with a hash check.
+ In particular URL and WORM keys stored on such remotes won't be downloaded.
+ See the documentation of the annex.security.allow-unverified-downloads
+ configuration for how to deal with this if it affects your files.
+
+ A security fix has changed git-annex to only support http, https, and ftp
+ URL schemes by default. You can enable other URL schemes, at your own risk,
+ using annex.security.allowed-url-schemes.
+
+ A related security fix prevents git-annex from connecting to http
+ servers (and proxies) on localhost or private networks. This can
+ be overridden, at your own risk, using annex.security.allowed-http-addresses.
+
+ Setting annex.web-options no longer is enough to make curl be used,
+ and youtube-dl is also no longer used by default. See the
+ documentation of annex.security.allowed-http-addresses for
+ details and how to enable them.
+
+ The annex.web-download-command configuration has been removed,
+ use annex.web-options instead.
+
+ -- Joey Hess <id@joeyh.name> Fri, 15 Jun 2018 17:54:23 -0400
+
git-annex (6.20180309) upstream; urgency=medium
Note that, due to not using rsync to transfer files over ssh
diff --git a/P2P/Annex.hs b/P2P/Annex.hs
index 05fa9e9..008de23 100644
--- a/P2P/Annex.hs
+++ b/P2P/Annex.hs
@@ -22,6 +22,7 @@ import P2P.Protocol
import P2P.IO
import Logs.Location
import Types.NumCopies
+import Types.Remote (RetrievalSecurityPolicy(..))
import Utility.Metered
import Control.Monad.Free
@@ -63,9 +64,12 @@ runLocal runst runner a = case a of
Right Nothing -> runner (next False)
Left e -> return (Left (show e))
StoreContent k af o l getb validitycheck next -> do
+ -- This is the same as the retrievalSecurityPolicy of
+ -- Remote.P2P and Remote.Git.
+ let rsp = RetrievalAllKeysSecure
ok <- flip catchNonAsync (const $ return False) $
transfer download k af $ \p ->
- getViaTmp DefaultVerify k $ \tmp -> do
+ getViaTmp rsp DefaultVerify k $ \tmp -> do
storefile tmp o l getb validitycheck p
runner (next ok)
StoreContentTo dest o l getb validitycheck next -> do
diff --git a/P2P/IO.hs b/P2P/IO.hs
index 840980c..18971d9 100644
--- a/P2P/IO.hs
+++ b/P2P/IO.hs
@@ -164,10 +164,10 @@ runNet runst conn runner f = case f of
Left e -> return (Left (show e))
Right Nothing -> return (Left "protocol error")
Right (Just l) -> case parseMessage l of
- Just m -> do
- liftIO $ debugMessage "P2P <" m
- runner (next (Just m))
- Nothing -> runner (next Nothing)
+ Just m -> do
+ liftIO $ debugMessage "P2P <" m
+ runner (next (Just m))
+ Nothing -> runner (next Nothing)
SendBytes len b p next -> do
v <- liftIO $ tryNonAsync $ do
ok <- sendExactly len b (connOhdl conn) p
diff --git a/Remote.hs b/Remote.hs
index 29f59a7..ff89196 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -12,6 +12,7 @@ module Remote (
storeKey,
retrieveKeyFile,
retrieveKeyFileCheap,
+ retrievalSecurityPolicy,
removeKey,
hasKey,
hasKeyCheap,
@@ -51,7 +52,6 @@ module Remote (
forceTrust,
logStatus,
checkAvailable,
- isXMPPRemote,
claimingUrl,
isExportSupported,
) where
@@ -72,21 +72,20 @@ import Remote.List
import Config
import Config.DynamicConfig
import Git.Types (RemoteName)
-import qualified Git
import Utility.Aeson
{- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
-remoteMap mkv = remoteMap' mkv mkk
+remoteMap mkv = remoteMap' mkv (pure . mkk)
where
mkk r = case uuid r of
NoUUID -> Nothing
u -> Just u
-remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Maybe k) -> Annex (M.Map k v)
-remoteMap' mkv mkk = M.fromList . mapMaybe mk <$> remoteList
+remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Annex (Maybe k)) -> Annex (M.Map k v)
+remoteMap' mkv mkk = M.fromList . catMaybes <$> (mapM mk =<< remoteList)
where
- mk r = case mkk r of
+ mk r = mkk r >>= return . \case
Nothing -> Nothing
Just k -> Just (k, mkv r)
@@ -122,10 +121,11 @@ byNameWithUUID = checkuuid <=< byName
where
checkuuid Nothing = return Nothing
checkuuid (Just r)
- | uuid r == NoUUID =
+ | uuid r == NoUUID = do
+ repo <- getRepo r
ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore (gitconfig r))
( giveup $ noRemoteUUIDMsg r ++
- " (" ++ show (remoteConfig (repo r) "ignore") ++
+ " (" ++ show (remoteConfig repo "ignore") ++
" is set)"
, giveup $ noRemoteUUIDMsg r
)
@@ -357,12 +357,6 @@ checkAvailable :: Bool -> Remote -> IO Bool
checkAvailable assumenetworkavailable =
maybe (return assumenetworkavailable) doesDirectoryExist . localpath
-{- Old remotes using the XMPP transport have urls like xmpp::user@host -}
-isXMPPRemote :: Remote -> Bool
-isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
- where
- r = repo remote
-
hasKey :: Remote -> Key -> Annex (Either String Bool)
hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k)
diff --git a/Remote/Adb.hs b/Remote/Adb.hs
index 2929ee4..8e99f1f 100644
--- a/Remote/Adb.hs
+++ b/Remote/Adb.hs
@@ -48,6 +48,7 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ _ -> return False
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -64,7 +65,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = Nothing
, remotetype = remote
@@ -236,7 +237,7 @@ enumerateAdbConnected =
where
parse l =
let (serial, desc) = separate (== '\t') l
- in if null desc || length serial /= 16
+ in if null desc || length serial < 4
then Nothing
else Just (AndroidSerial serial)
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index 4177528..659cc47 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -59,6 +59,8 @@ gen r _ c gc =
, storeKey = uploadKey
, retrieveKeyFile = downloadKey
, retrieveKeyFileCheap = downloadKeyCheap
+ -- Bittorrent does its own hash checks.
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = dropKey
, lockContent = Nothing
, checkPresent = checkKey
@@ -70,7 +72,7 @@ gen r _ c gc =
, config = c
, gitconfig = gc
, localpath = Nothing
- , repo = r
+ , getRepo = return r
, readonly = True
, availability = GloballyAvailable
, remotetype = remote
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 8a94ee8..024e06a 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -59,6 +59,9 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap buprepo
+ -- Bup uses git, which cryptographically verifies content
+ -- (with SHA1, but sufficiently for this).
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -68,7 +71,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo)
then Just buprepo
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 1cca7dd..4a6af3e 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -58,6 +58,9 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
+ -- ddar communicates over ssh, not subject to http redirect
+ -- type attacks
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -67,7 +70,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = if ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo)
then Just $ ddarRepoLocation ddarrepo
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index c31b423..2fcb05d 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -58,6 +58,7 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -76,7 +77,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = Just dir
, readonly = False
diff --git a/Remote/External.hs b/Remote/External.hs
index d9e5697..1427d61 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -1,8 +1,8 @@
{- External special remote interface.
-
- - Copyright 2013-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
module Remote.External (remote) where
@@ -61,6 +61,7 @@ gen r u c gc
readonlyRemoveKey
(checkKeyUrl r)
Nothing
+ (externalInfo externaltype)
Nothing
Nothing
exportUnsupported
@@ -94,12 +95,13 @@ gen r u c gc
(removeKeyM external)
(checkPresentM external)
(Just (whereisKeyM external))
+ (getInfoM external)
(Just (claimUrlM external))
(Just (checkUrlM external))
exportactions
cheapexportsupported
where
- mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl exportactions cheapexportsupported = do
+ mk cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do
let rmt = Remote
{ uuid = u
, cost = cst
@@ -107,6 +109,11 @@ gen r u c gc
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ _ -> return False
+ -- External special remotes use many http libraries
+ -- and have no protection against redirects to
+ -- local private web servers, or in some cases
+ -- to file:// urls.
+ , retrievalSecurityPolicy = RetrievalVerifiableKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -117,7 +124,7 @@ gen r u c gc
, repairRepo = Nothing
, config = c
, localpath = Nothing
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, readonly = False
, availability = avail
@@ -125,7 +132,7 @@ gen r u c gc
{ exportSupported = cheapexportsupported }
, mkUnavailable = gen r u c $
gc { remoteAnnexExternalType = Just "!dne!" }
- , getInfo = return [("externaltype", externaltype)]
+ , getInfo = togetinfo
, claimUrl = toclaimurl
, checkUrl = tocheckurl
}
@@ -151,7 +158,7 @@ externalSetup _ mu _ c gc = do
_ -> do
external <- newExternal externaltype u c' gc
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
- INITREMOTE_SUCCESS -> Just noop
+ INITREMOTE_SUCCESS -> result ()
INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
_ -> Nothing
withExternalState external $
@@ -171,21 +178,20 @@ checkExportSupported' :: External -> Annex Bool
checkExportSupported' external = go `catchNonAsync` (const (return False))
where
go = handleRequest external EXPORTSUPPORTED Nothing $ \resp -> case resp of
- EXPORTSUPPORTED_SUCCESS -> Just $ return True
- EXPORTSUPPORTED_FAILURE -> Just $ return False
- UNSUPPORTED_REQUEST -> Just $ return False
+ EXPORTSUPPORTED_SUCCESS -> result True
+ EXPORTSUPPORTED_FAILURE -> result False
+ UNSUPPORTED_REQUEST -> result False
_ -> Nothing
storeKeyM :: External -> Storer
storeKeyM external = fileStorer $ \k f p ->
handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
case resp of
- TRANSFER_SUCCESS Upload k' | k == k' ->
- Just $ return True
+ TRANSFER_SUCCESS Upload k' | k == k' -> result True
TRANSFER_FAILURE Upload k' errmsg | k == k' ->
Just $ do
warning errmsg
- return False
+ return (Result False)
_ -> Nothing
retrieveKeyFileM :: External -> Retriever
@@ -193,7 +199,7 @@ retrieveKeyFileM external = fileRetriever $ \d k p ->
handleRequestKey external (\sk -> TRANSFER Download sk d) k (Just p) $ \resp ->
case resp of
TRANSFER_SUCCESS Download k'
- | k == k' -> Just $ return ()
+ | k == k' -> result ()
TRANSFER_FAILURE Download k' errmsg
| k == k' -> Just $ giveup errmsg
_ -> Nothing
@@ -203,11 +209,11 @@ removeKeyM external k = safely $
handleRequestKey external REMOVE k Nothing $ \resp ->
case resp of
REMOVE_SUCCESS k'
- | k == k' -> Just $ return True
+ | k == k' -> result True
REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do
warning errmsg
- return False
+ return (Result False)
_ -> Nothing
checkPresentM :: External -> CheckPresent
@@ -216,32 +222,31 @@ checkPresentM external k = either giveup id <$> go
go = handleRequestKey external CHECKPRESENT k Nothing $ \resp ->
case resp of
CHECKPRESENT_SUCCESS k'
- | k' == k -> Just $ return $ Right True
+ | k' == k -> result $ Right True
CHECKPRESENT_FAILURE k'
- | k' == k -> Just $ return $ Right False
+ | k' == k -> result $ Right False
CHECKPRESENT_UNKNOWN k' errmsg
- | k' == k -> Just $ return $ Left errmsg
+ | k' == k -> result $ Left errmsg
_ -> Nothing
whereisKeyM :: External -> Key -> Annex [String]
whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of
- WHEREIS_SUCCESS s -> Just $ return [s]
- WHEREIS_FAILURE -> Just $ return []
- UNSUPPORTED_REQUEST -> Just $ return []
+ WHEREIS_SUCCESS s -> result [s]
+ WHEREIS_FAILURE -> result []
+ UNSUPPORTED_REQUEST -> result []
_ -> Nothing
storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportM external f k loc p = safely $
handleRequestExport external loc req k (Just p) $ \resp -> case resp of
- TRANSFER_SUCCESS Upload k' | k == k' ->
- Just $ return True
+ TRANSFER_SUCCESS Upload k' | k == k' -> result True
TRANSFER_FAILURE Upload k' errmsg | k == k' ->
Just $ do
warning errmsg
- return False
+ return (Result False)
UNSUPPORTED_REQUEST -> Just $ do
warning "TRANSFEREXPORT not implemented by external special remote"
- return False
+ return (Result False)
_ -> Nothing
where
req sk = TRANSFEREXPORT Upload sk f
@@ -250,14 +255,14 @@ retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate
retrieveExportM external k loc d p = safely $
handleRequestExport external loc req k (Just p) $ \resp -> case resp of
TRANSFER_SUCCESS Download k'
- | k == k' -> Just $ return True
+ | k == k' -> result True
TRANSFER_FAILURE Download k' errmsg
| k == k' -> Just $ do
warning errmsg
- return False
+ return (Result False)
UNSUPPORTED_REQUEST -> Just $ do
warning "TRANSFEREXPORT not implemented by external special remote"
- return False
+ return (Result False)
_ -> Nothing
where
req sk = TRANSFEREXPORT Download sk d
@@ -267,12 +272,12 @@ checkPresentExportM external k loc = either giveup id <$> go
where
go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of
CHECKPRESENT_SUCCESS k'
- | k' == k -> Just $ return $ Right True
+ | k' == k -> result $ Right True
CHECKPRESENT_FAILURE k'
- | k' == k -> Just $ return $ Right False
+ | k' == k -> result $ Right False
CHECKPRESENT_UNKNOWN k' errmsg
- | k' == k -> Just $ return $ Left errmsg
- UNSUPPORTED_REQUEST -> Just $ return $
+ | k' == k -> result $ Left errmsg
+ UNSUPPORTED_REQUEST -> result $
Left "CHECKPRESENTEXPORT not implemented by external special remote"
_ -> Nothing
@@ -280,22 +285,22 @@ removeExportM :: External -> Key -> ExportLocation -> Annex Bool
removeExportM external k loc = safely $
handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of
REMOVE_SUCCESS k'
- | k == k' -> Just $ return True
+ | k == k' -> result True
REMOVE_FAILURE k' errmsg
| k == k' -> Just $ do
warning errmsg
- return False
+ return (Result False)
UNSUPPORTED_REQUEST -> Just $ do
warning "REMOVEEXPORT not implemented by external special remote"
- return False
+ return (Result False)
_ -> Nothing
removeExportDirectoryM :: External -> ExportDirectory -> Annex Bool
removeExportDirectoryM external dir = safely $
handleRequest external req Nothing $ \resp -> case resp of
- REMOVEEXPORTDIRECTORY_SUCCESS -> Just $ return True
- REMOVEEXPORTDIRECTORY_FAILURE -> Just $ return False
- UNSUPPORTED_REQUEST -> Just $ return True
+ REMOVEEXPORTDIRECTORY_SUCCESS -> result True
+ REMOVEEXPORTDIRECTORY_FAILURE -> result False
+ UNSUPPORTED_REQUEST -> result True
_ -> Nothing
where
req = REMOVEEXPORTDIRECTORY dir
@@ -304,10 +309,10 @@ renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bo
renameExportM external k src dest = safely $
handleRequestExport external src req k Nothing $ \resp -> case resp of
RENAMEEXPORT_SUCCESS k'
- | k' == k -> Just $ return True
+ | k' == k -> result True
RENAMEEXPORT_FAILURE k'
- | k' == k -> Just $ return False
- UNSUPPORTED_REQUEST -> Just $ return False
+ | k' == k -> result False
+ UNSUPPORTED_REQUEST -> result False
_ -> Nothing
where
req sk = RENAMEEXPORT sk dest
@@ -333,12 +338,12 @@ safely a = go =<< tryNonAsync a
- May throw exceptions, for example on protocol errors, or
- when the repository cannot be used.
-}
-handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
+handleRequest :: External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequest external req mp responsehandler =
withExternalState external $ \st ->
handleRequest' st external req mp responsehandler
-handleRequestKey :: External -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
+handleRequestKey :: External -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of
Right sk -> handleRequest external (mkreq sk) mp responsehandler
Left e -> giveup e
@@ -346,14 +351,14 @@ handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of
{- Export location is first sent in an EXPORT message before
- the main request. This is done because the ExportLocation can
- contain spaces etc. -}
-handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
+handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequestExport external loc mkreq k mp responsehandler = do
withExternalState external $ \st -> do
checkPrepared st external
sendMessage st external (EXPORT loc)
handleRequestKey external mkreq k mp responsehandler
-handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
+handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
handleRequest' st external req mp responsehandler
| needsPREPARE req = do
checkPrepared st external
@@ -449,6 +454,17 @@ sendMessage st external m = liftIO $ do
line = unwords $ formatMessage m
h = externalSend st
+{- A response handler can yeild a result, or it can request that another
+ - message be consumed from the external result. -}
+data ResponseHandlerResult a
+ = Result a
+ | GetNextMessage (ResponseHandler a)
+
+type ResponseHandler a = Response -> Maybe (Annex (ResponseHandlerResult a))
+
+result :: a -> Maybe (Annex (ResponseHandlerResult a))
+result = Just . return . Result
+
{- Waits for a message from the external remote, and passes it to the
- apppropriate handler.
-
@@ -456,7 +472,7 @@ sendMessage st external m = liftIO $ do
receiveMessage
:: ExternalState
-> External
- -> (Response -> Maybe (Annex a))
+ -> ResponseHandler a
-> (RemoteRequest -> Maybe (Annex a))
-> (AsyncMessage -> Maybe (Annex a))
-> Annex a
@@ -467,14 +483,21 @@ receiveMessage st external handleresponse handlerequest handleasync =
go (Just s) = do
liftIO $ protocolDebug external st False s
case parseMessage s :: Maybe Response of
- Just resp -> maybe (protocolError True s) id (handleresponse resp)
+ Just resp -> case handleresponse resp of
+ Nothing -> protocolError True s
+ Just callback -> callback >>= \case
+ Result a -> return a
+ GetNextMessage handleresponse' ->
+ receiveMessage st external handleresponse' handlerequest handleasync
Nothing -> case parseMessage s :: Maybe RemoteRequest of
Just req -> maybe (protocolError True s) id (handlerequest req)
Nothing -> case parseMessage s :: Maybe AsyncMessage of
Just msg -> maybe (protocolError True s) id (handleasync msg)
Nothing -> protocolError False s
protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
- if parsed then "(command not allowed at this time)" else "(unable to parse command)"
+ if parsed
+ then "(command not allowed at this time)"
+ else "(unable to parse command)"
protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()
protocolDebug external st sendto line = debugM "external" $ unwords
@@ -521,8 +544,8 @@ startExternal external = do
-- accepted.
receiveMessage st external
(\resp -> case resp of
- EXTENSIONS_RESPONSE _ -> Just (return ())
- UNSUPPORTED_REQUEST -> Just (return ())
+ EXTENSIONS_RESPONSE _ -> result ()
+ UNSUPPORTED_REQUEST -> result ()
_ -> Nothing
)
(const Nothing)
@@ -603,8 +626,9 @@ checkPrepared st external = do
Unprepared ->
handleRequest' st external PREPARE Nothing $ \resp ->
case resp of
- PREPARE_SUCCESS -> Just $
+ PREPARE_SUCCESS -> Just $ do
setprepared Prepared
+ return (Result ())
PREPARE_FAILURE errmsg -> Just $ do
setprepared $ FailedPrepare errmsg
giveup errmsg
@@ -617,17 +641,18 @@ checkPrepared st external = do
- external special remote every time time just to ask it what its
- cost is. -}
getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost
-getCost external r gc = catchNonAsync (go =<< remoteCost' gc) (const defcst)
+getCost external r gc =
+ (go =<< remoteCost' gc) `catchNonAsync` const (pure defcst)
where
go (Just c) = return c
go Nothing = do
c <- handleRequest external GETCOST Nothing $ \req -> case req of
- COST c -> Just $ return c
- UNSUPPORTED_REQUEST -> Just defcst
+ COST c -> result c
+ UNSUPPORTED_REQUEST -> result defcst
_ -> Nothing
setRemoteCost r c
return c
- defcst = return expensiveRemoteCost
+ defcst = expensiveRemoteCost
{- Caches the availability in the git config to avoid needing to start up an
- external special remote every time time just to ask it what its
@@ -638,35 +663,36 @@ getCost external r gc = catchNonAsync (go =<< remoteCost' gc) (const defcst)
-}
getAvailability :: External -> Git.Repo -> RemoteGitConfig -> Annex Availability
getAvailability external r gc =
- maybe (catchNonAsync query (const defavail)) return (remoteAnnexAvailability gc)
+ maybe (catchNonAsync query (const (pure defavail))) return
+ (remoteAnnexAvailability gc)
where
query = do
avail <- handleRequest external GETAVAILABILITY Nothing $ \req -> case req of
- AVAILABILITY avail -> Just $ return avail
- UNSUPPORTED_REQUEST -> Just defavail
+ AVAILABILITY avail -> result avail
+ UNSUPPORTED_REQUEST -> result defavail
_ -> Nothing
setRemoteAvailability r avail
return avail
- defavail = return GloballyAvailable
+ defavail = GloballyAvailable
claimUrlM :: External -> URLString -> Annex Bool
claimUrlM external url =
handleRequest external (CLAIMURL url) Nothing $ \req -> case req of
- CLAIMURL_SUCCESS -> Just $ return True
- CLAIMURL_FAILURE -> Just $ return False
- UNSUPPORTED_REQUEST -> Just $ return False
+ CLAIMURL_SUCCESS -> result True
+ CLAIMURL_FAILURE -> result False
+ UNSUPPORTED_REQUEST -> result False
_ -> Nothing
checkUrlM :: External -> URLString -> Annex UrlContents
checkUrlM external url =
handleRequest external (CHECKURL url) Nothing $ \req -> case req of
- CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz
- (if null f then Nothing else Just $ mkSafeFilePath f)
+ CHECKURL_CONTENTS sz f -> result $ UrlContents sz $
+ if null f then Nothing else Just $ mkSafeFilePath f
-- Treat a single item multi response specially to
-- simplify the external remote implementation.
CHECKURL_MULTI ((_, sz, f):[]) ->
- Just $ return $ UrlContents sz $ Just $ mkSafeFilePath f
- CHECKURL_MULTI l -> Just $ return $ UrlMulti $ map mkmulti l
+ result $ UrlContents sz $ Just $ mkSafeFilePath f
+ CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l
CHECKURL_FAILURE errmsg -> Just $ giveup errmsg
UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote"
_ -> Nothing
@@ -689,3 +715,23 @@ getWebUrls :: Key -> Annex [URLString]
getWebUrls key = filter supported <$> getUrls key
where
supported u = snd (getDownloader u) == WebDownloader
+
+externalInfo :: ExternalType -> Annex [(String, String)]
+externalInfo et = return [("externaltype", et)]
+
+getInfoM :: External -> Annex [(String, String)]
+getInfoM external = (++)
+ <$> externalInfo (externalType external)
+ <*> handleRequest external GETINFO Nothing (collect [])
+ where
+ collect l req = case req of
+ INFOFIELD f -> Just $ return $
+ GetNextMessage $ collectvalue l f
+ INFOEND -> result (reverse l)
+ UNSUPPORTED_REQUEST -> result []
+ _ -> Nothing
+
+ collectvalue l f req = case req of
+ INFOVALUE v -> Just $ return $
+ GetNextMessage $ collect ((f, v) : l)
+ _ -> Nothing
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 3b66027..11c314e 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -2,7 +2,7 @@
-
- Copyright 2013-2018 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
@@ -127,6 +127,7 @@ data Request
| CHECKPRESENT SafeKey
| REMOVE SafeKey
| WHEREIS SafeKey
+ | GETINFO
| EXPORTSUPPORTED
| EXPORT ExportLocation
| TRANSFEREXPORT Direction SafeKey FilePath
@@ -162,6 +163,7 @@ instance Proto.Sendable Request where
[ "CHECKPRESENT", Proto.serialize key ]
formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]
+ formatMessage GETINFO = [ "GETINFO" ]
formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]
formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]
formatMessage (TRANSFEREXPORT direction key file) =
@@ -205,6 +207,9 @@ data Response
| CHECKURL_FAILURE ErrorMsg
| WHEREIS_SUCCESS String
| WHEREIS_FAILURE
+ | INFOFIELD String
+ | INFOVALUE String
+ | INFOEND
| EXPORTSUPPORTED_SUCCESS
| EXPORTSUPPORTED_FAILURE
| REMOVEEXPORTDIRECTORY_SUCCESS
@@ -236,6 +241,9 @@ instance Proto.Receivable Response where
parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS
parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
+ parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD
+ parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE
+ parseCommand "INFOEND" = Proto.parse0 INFOEND
parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS
parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE
parseCommand "REMOVEEXPORTDIRECTORY-SUCCESS" = Proto.parse0 REMOVEEXPORTDIRECTORY_SUCCESS
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 4eda826..20c4733 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -113,6 +113,7 @@ gen' r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ _ -> return False
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -123,8 +124,8 @@ gen' r u c gc = do
, repairRepo = Nothing
, config = c
, localpath = localpathCalc r
- , repo = r
- , gitconfig = gc { remoteGitConfig = extractGitConfig r }
+ , getRepo = return r
+ , gitconfig = gc
, readonly = Git.repoIsHttp r
, availability = availabilityCalc r
, remotetype = remote
@@ -328,17 +329,22 @@ setGcryptEncryption c remotename = do
remoteconfig n = ConfigKey $ n remotename
store :: Remote -> Remote.Rsync.RsyncOpts -> Storer
-store r rsyncopts
- | not $ Git.repoIsUrl (repo r) =
- byteStorer $ \k b p -> guardUsable (repo r) (return False) $ liftIO $ do
- let tmpdir = Git.repoLocation (repo r) </> "tmp" </> keyFile k
+store r rsyncopts k s p = do
+ repo <- getRepo r
+ store' repo r rsyncopts k s p
+
+store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Storer
+store' repo r rsyncopts
+ | not $ Git.repoIsUrl repo =
+ byteStorer $ \k b p -> guardUsable repo (return False) $ liftIO $ do
+ let tmpdir = Git.repoLocation repo </> "tmp" </> keyFile k
void $ tryIO $ createDirectoryIfMissing True tmpdir
let tmpf = tmpdir </> keyFile k
meteredWriteFile p tmpf b
- let destdir = parentDir $ gCryptLocation r k
+ let destdir = parentDir $ gCryptLocation repo k
Remote.Directory.finalizeStoreGeneric tmpdir destdir
return True
- | Git.repoIsSsh (repo r) = if accessShell r
+ | Git.repoIsSsh repo = if accessShell r
then fileStorer $ \k f p -> do
oh <- mkOutputHandler
Ssh.rsyncHelper oh (Just p)
@@ -348,11 +354,16 @@ store r rsyncopts
| otherwise = unsupportedUrl
retrieve :: Remote -> Remote.Rsync.RsyncOpts -> Retriever
-retrieve r rsyncopts
- | not $ Git.repoIsUrl (repo r) = byteRetriever $ \k sink ->
- guardUsable (repo r) (return False) $
- sink =<< liftIO (L.readFile $ gCryptLocation r k)
- | Git.repoIsSsh (repo r) = if accessShell r
+retrieve r rsyncopts k p sink = do
+ repo <- getRepo r
+ retrieve' repo r rsyncopts k p sink
+
+retrieve' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Retriever
+retrieve' repo r rsyncopts
+ | not $ Git.repoIsUrl repo = byteRetriever $ \k sink ->
+ guardUsable repo (return False) $
+ sink =<< liftIO (L.readFile $ gCryptLocation repo k)
+ | Git.repoIsSsh repo = if accessShell r
then fileRetriever $ \f k p -> do
ps <- Ssh.rsyncParamsRemote False r Download k f
(AssociatedFile Nothing)
@@ -364,30 +375,40 @@ retrieve r rsyncopts
where
remove :: Remote -> Remote.Rsync.RsyncOpts -> Remover
-remove r rsyncopts k
- | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $
- liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation (repo r)) (parentDir (gCryptLocation r k))
- | Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
+remove r rsyncopts k = do
+ repo <- getRepo r
+ remove' repo r rsyncopts k
+
+remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Remover
+remove' repo r rsyncopts k
+ | not $ Git.repoIsUrl repo = guardUsable repo (return False) $
+ liftIO $ Remote.Directory.removeDirGeneric (Git.repoLocation repo) (parentDir (gCryptLocation repo k))
+ | Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| otherwise = unsupportedUrl
where
removersync = Remote.Rsync.remove rsyncopts k
- removeshell = Ssh.dropKey (repo r) k
+ removeshell = Ssh.dropKey repo k
checkKey :: Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
-checkKey r rsyncopts k
- | not $ Git.repoIsUrl (repo r) =
- guardUsable (repo r) (cantCheck $ repo r) $
- liftIO $ doesFileExist (gCryptLocation r k)
- | Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
+checkKey r rsyncopts k = do
+ repo <- getRepo r
+ checkKey' repo r rsyncopts k
+
+checkKey' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> CheckPresent
+checkKey' repo r rsyncopts k
+ | not $ Git.repoIsUrl repo =
+ guardUsable repo (cantCheck repo) $
+ liftIO $ doesFileExist (gCryptLocation repo k)
+ | Git.repoIsSsh repo = shellOrRsync r checkshell checkrsync
| otherwise = unsupportedUrl
where
- checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
- checkshell = Ssh.inAnnex (repo r) k
+ checkrsync = Remote.Rsync.checkKey repo rsyncopts k
+ checkshell = Ssh.inAnnex repo k
{- Annexed objects are hashed using lower-case directories for max
- portability. -}
-gCryptLocation :: Remote -> Key -> FilePath
-gCryptLocation r key = Git.repoLocation (repo r) </> objectDir </> keyPath key (hashDirLower def)
+gCryptLocation :: Git.Repo -> Key -> FilePath
+gCryptLocation repo key = Git.repoLocation repo </> objectDir </> keyPath key (hashDirLower def)
data AccessMethod = AccessDirect | AccessShell
diff --git a/Remote/Git.hs b/Remote/Git.hs
index adc7564..8a2ee9a 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -161,6 +161,7 @@ gen r u c gc
, storeKey = copyToRemote new st
, retrieveKeyFile = copyFromRemote new st
, retrieveKeyFileCheap = copyFromRemoteCheap new st
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = dropKey new st
, lockContent = Just (lockKey new st)
, checkPresent = inAnnex new st
@@ -175,8 +176,8 @@ gen r u c gc
else Just $ repairRemote r
, config = c
, localpath = localpathCalc r
- , repo = r
- , gitconfig = gc { remoteGitConfig = extractGitConfig r }
+ , getRepo = getRepoFromState st
+ , gitconfig = gc
, readonly = Git.repoIsHttp r
, availability = availabilityCalc r
, remotetype = remote
@@ -328,51 +329,60 @@ tryGitConfigRead autoinit r
{- Checks if a given remote has the content for a key in its annex. -}
inAnnex :: Remote -> State -> Key -> Annex Bool
-inAnnex rmt (State connpool duc) key
- | Git.repoIsHttp r = checkhttp
- | Git.repoIsUrl r = checkremote
+inAnnex rmt st key = do
+ repo <- getRepo rmt
+ inAnnex' repo rmt st key
+
+inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
+inAnnex' repo rmt (State connpool duc _) key
+ | Git.repoIsHttp repo = checkhttp
+ | Git.repoIsUrl repo = checkremote
| otherwise = checklocal
where
- r = repo rmt
checkhttp = do
- showChecking r
+ showChecking repo
+ gc <- Annex.getGitConfig
ifM (Url.withUrlOptions $ \uo -> liftIO $
- anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))
+ anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key))
( return True
, giveup "not found"
)
checkremote =
- let fallback = Ssh.inAnnex r key
+ let fallback = Ssh.inAnnex repo key
in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key
checklocal = ifM duc
- ( guardUsable r (cantCheck r) $
- maybe (cantCheck r) return
- =<< onLocalFast rmt (Annex.Content.inAnnexSafe key)
- , cantCheck r
+ ( guardUsable repo (cantCheck repo) $
+ maybe (cantCheck repo) return
+ =<< onLocalFast repo rmt (Annex.Content.inAnnexSafe key)
+ , cantCheck repo
)
-keyUrls :: Remote -> Key -> [String]
-keyUrls r key = map tourl locs'
+keyUrls :: GitConfig -> Git.Repo -> Remote -> Key -> [String]
+keyUrls gc repo r key = map tourl locs'
where
- tourl l = Git.repoLocation (repo r) ++ "/" ++ l
+ tourl l = Git.repoLocation repo ++ "/" ++ l
-- If the remote is known to not be bare, try the hash locations
-- used for non-bare repos first, as an optimisation.
locs
- | remoteAnnexBare remoteconfig == Just False = reverse (annexLocations cfg key)
- | otherwise = annexLocations cfg key
+ | remoteAnnexBare remoteconfig == Just False = reverse (annexLocations gc key)
+ | otherwise = annexLocations gc key
#ifndef mingw32_HOST_OS
locs' = locs
#else
locs' = map (replace "\\" "/") locs
#endif
remoteconfig = gitconfig r
- cfg = remoteGitConfig remoteconfig
dropKey :: Remote -> State -> Key -> Annex Bool
-dropKey r (State connpool duc) key
- | not $ Git.repoIsUrl (repo r) = ifM duc
- ( guardUsable (repo r) (return False) $
- commitOnCleanup r $ onLocalFast r $ do
+dropKey r st key = do
+ repo <- getRepo r
+ dropKey' repo r st key
+
+dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex Bool
+dropKey' repo r (State connpool duc _) key
+ | not $ Git.repoIsUrl repo = ifM duc
+ ( guardUsable repo (return False) $
+ commitOnCleanup repo r $ onLocalFast repo r $ do
ensureInitialized
whenM (Annex.Content.inAnnex key) $ do
Annex.Content.lockContentForRemoval key $ \lock -> do
@@ -382,25 +392,30 @@ dropKey r (State connpool duc) key
return True
, return False
)
- | Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported"
- | otherwise = commitOnCleanup r $ do
- let fallback = Ssh.dropKey (repo r) key
+ | Git.repoIsHttp repo = giveup "dropping from http remote not supported"
+ | otherwise = commitOnCleanup repo r $ do
+ let fallback = Ssh.dropKey repo key
P2PHelper.remove (Ssh.runProto r connpool False fallback) key
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
-lockKey r (State connpool duc) key callback
- | not $ Git.repoIsUrl (repo r) = ifM duc
- ( guardUsable (repo r) failedlock $ do
+lockKey r st key callback = do
+ repo <- getRepo r
+ lockKey' repo r st key callback
+
+lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
+lockKey' repo r (State connpool duc _) key callback
+ | not $ Git.repoIsUrl repo = ifM duc
+ ( guardUsable repo failedlock $ do
inorigrepo <- Annex.makeRunner
-- Lock content from perspective of remote,
-- and then run the callback in the original
-- annex monad, not the remote's.
- onLocalFast r $
+ onLocalFast repo r $
Annex.Content.lockContentShared key $
liftIO . inorigrepo . callback
, failedlock
)
- | Git.repoIsSsh (repo r) = do
+ | Git.repoIsSsh repo = do
showLocking r
let withconn = Ssh.withP2PSshConnection r connpool fallback
P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback
@@ -408,7 +423,7 @@ lockKey r (State connpool duc) key callback
where
fallback = do
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
- (repo r) "lockcontent"
+ repo "lockcontent"
[Param $ key2file key] []
(Just hin, Just hout, Nothing, p) <- liftIO $
withFile devNull WriteMode $ \nullh ->
@@ -451,15 +466,21 @@ copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterU
copyFromRemote = copyFromRemote' False
copyFromRemote' :: Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
-copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
- | Git.repoIsHttp (repo r) = unVerified $
- Annex.Content.downloadUrl key meterupdate (keyUrls r key) dest
- | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (unVerified (return False)) $ do
+copyFromRemote' forcersync r st key file dest meterupdate = do
+ repo <- getRepo r
+ copyFromRemote'' repo forcersync r st key file dest meterupdate
+
+copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
+copyFromRemote'' repo forcersync r (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
+ | not $ Git.repoIsUrl repo = guardUsable repo (unVerified (return False)) $ do
params <- Ssh.rsyncParams r Download
u <- getUUID
hardlink <- wantHardLink
-- run copy from perspective of remote
- onLocalFast r $ do
+ onLocalFast repo r $ do
ensureInitialized
v <- Annex.Content.prepSendAnnex key
case v of
@@ -469,7 +490,7 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
runTransfer (Transfer Download u key)
file stdRetry
(\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess)
- | Git.repoIsSsh (repo r) = if forcersync
+ | Git.repoIsSsh repo = if forcersync
then fallback meterupdate
else P2PHelper.retrieve
(\p -> Ssh.runProto r connpool (False, UnVerified) (fallback p))
@@ -505,7 +526,7 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
let fields = (Fields.remoteUUID, fromUUID u)
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
- (repo r) "transferinfo"
+ repo "transferinfo"
[Param $ key2file key] fields
v <- liftIO (newEmptySV :: IO (MSampleVar Integer))
pidv <- liftIO $ newEmptyMVar
@@ -541,12 +562,17 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
bracketIO noop (const cleanup) (const $ a feeder)
copyFromRemoteCheap :: Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool
+copyFromRemoteCheap r st key af file = do
+ repo <- getRepo r
+ copyFromRemoteCheap' repo r st key af file
+
+copyFromRemoteCheap' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> Annex Bool
#ifndef mingw32_HOST_OS
-copyFromRemoteCheap r st key af file
- | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ liftIO $ do
- loc <- gitAnnexLocation key (repo r) $
- remoteGitConfig $ gitconfig r
- ifM (doesFileExist loc)
+copyFromRemoteCheap' repo r st key af file
+ | not $ Git.repoIsUrl repo = guardUsable repo (return False) $ do
+ gc <- getGitConfigFromState st
+ loc <- liftIO $ gitAnnexLocation key repo gc
+ liftIO $ ifM (doesFileExist loc)
( do
absloc <- absPath loc
catchBoolIO $ do
@@ -554,25 +580,30 @@ copyFromRemoteCheap r st key af file
return True
, return False
)
- | Git.repoIsSsh (repo r) =
+ | Git.repoIsSsh repo =
ifM (Annex.Content.preseedTmp key file)
( fst <$> copyFromRemote' True r st key af file nullMeterUpdate
, return False
)
| otherwise = return False
#else
-copyFromRemoteCheap _ _ _ _ _ = return False
+copyFromRemoteCheap' _ _ _ _ _ _ = return False
#endif
{- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-copyToRemote r (State connpool duc) key file meterupdate
- | not $ Git.repoIsUrl (repo r) = ifM duc
- ( guardUsable (repo r) (return False) $ commitOnCleanup r $
+copyToRemote r st key file meterupdate = do
+ repo <- getRepo r
+ copyToRemote' repo r st key file meterupdate
+
+copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+copyToRemote' repo r (State connpool duc _) key file meterupdate
+ | not $ Git.repoIsUrl repo = ifM duc
+ ( guardUsable repo (return False) $ commitOnCleanup repo r $
copylocal =<< Annex.Content.prepSendAnnex key
, return False
)
- | Git.repoIsSsh (repo r) = commitOnCleanup r $
+ | Git.repoIsSsh repo = commitOnCleanup repo r $
P2PHelper.store
(\p -> Ssh.runProto r connpool False (copyremotefallback p))
key file meterupdate
@@ -589,16 +620,17 @@ copyToRemote r (State connpool duc) key file meterupdate
u <- getUUID
hardlink <- wantHardLink
-- run copy from perspective of remote
- onLocalFast r $ ifM (Annex.Content.inAnnex key)
+ onLocalFast repo r $ ifM (Annex.Content.inAnnex key)
( return True
, do
ensureInitialized
copier <- mkCopier hardlink params
let verify = Annex.Content.RemoteVerify r
+ let rsp = RetrievalAllKeysSecure
runTransfer (Transfer Download u key) file stdRetry $ \p ->
let p' = combineMeterUpdate meterupdate p
in Annex.Content.saveState True `after`
- Annex.Content.getViaTmp verify key
+ Annex.Content.getViaTmp rsp verify key
(\dest -> copier object dest p' (liftIO checksuccessio))
)
copyremotefallback p = Annex.Content.sendAnnex key noop $ \object -> do
@@ -642,11 +674,11 @@ repairRemote r a = return $ do
- However, coprocesses are stopped after each call to avoid git
- processes hanging around on removable media.
-}
-onLocal :: Remote -> Annex a -> Annex a
-onLocal r a = do
+onLocal :: Git.Repo -> Remote -> Annex a -> Annex a
+onLocal repo r a = do
m <- Annex.getState Annex.remoteannexstate
go =<< maybe
- (liftIO $ Annex.new $ repo r)
+ (liftIO $ Annex.new repo)
return
(M.lookup (uuid r) m)
where
@@ -666,8 +698,8 @@ onLocal r a = do
- it gets the most current value. Caller of onLocalFast can make changes
- to the branch, however.
-}
-onLocalFast :: Remote -> Annex a -> Annex a
-onLocalFast r a = onLocal r $ Annex.BranchState.disableUpdate >> a
+onLocalFast :: Git.Repo -> Remote -> Annex a -> Annex a
+onLocalFast repo r a = onLocal repo r $ Annex.BranchState.disableUpdate >> a
{- Copys a file with rsync unless both locations are on the same
- filesystem. Then cp could be faster. -}
@@ -689,18 +721,18 @@ rsyncOrCopyFile rsyncparams src dest p =
Ssh.rsyncHelper oh (Just p) $
rsyncparams ++ [File src, File dest]
-commitOnCleanup :: Remote -> Annex a -> Annex a
-commitOnCleanup r a = go `after` a
+commitOnCleanup :: Git.Repo -> Remote -> Annex a -> Annex a
+commitOnCleanup repo r a = go `after` a
where
go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup
cleanup
- | not $ Git.repoIsUrl (repo r) = onLocalFast r $
+ | not $ Git.repoIsUrl repo = onLocalFast repo r $
doQuietSideAction $
Annex.Branch.commit "update"
| otherwise = void $ do
Just (shellcmd, shellparams) <-
Ssh.git_annex_shell NoConsumeStdin
- (repo r) "commit" [] []
+ repo "commit" [] []
-- Throw away stderr, since the remote may not
-- have a new enough git-annex shell to
@@ -746,13 +778,6 @@ mkCopier remotewanthardlink rsyncparams = do
, return copier
)
-data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck
-
-mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State
-mkState r u gc = State
- <$> Ssh.mkP2PSshConnectionPool
- <*> mkDeferredUUIDCheck r u gc
-
{- Normally the UUID of a local repository is checked at startup,
- but annex-checkuuid config can prevent that. To avoid getting
- confused, a deferred check is done just before the repository
@@ -760,19 +785,46 @@ mkState r u gc = State
- This returns False when the repository UUID is not as expected. -}
type DeferredUUIDCheck = Annex Bool
-mkDeferredUUIDCheck :: Git.Repo -> UUID -> RemoteGitConfig -> Annex DeferredUUIDCheck
-mkDeferredUUIDCheck r u gc
- | remoteAnnexCheckUUID gc = return (return True)
- | otherwise = do
- v <- liftIO newEmptyMVar
- return $ ifM (liftIO $ isEmptyMVar v)
- ( do
- r' <- tryGitConfigRead False r
- u' <- getRepoUUID r'
- let ok = u' == u
- void $ liftIO $ tryPutMVar v ok
- unless ok $
- warning $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now."
- return ok
- , liftIO $ readMVar v
- )
+data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck (Annex (Git.Repo, GitConfig))
+
+getRepoFromState :: State -> Annex Git.Repo
+getRepoFromState (State _ _ a) = fst <$> a
+
+{- The config of the remote git repository, cached for speed. -}
+getGitConfigFromState :: State -> Annex GitConfig
+getGitConfigFromState (State _ _ a) = snd <$> a
+
+mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State
+mkState r u gc = do
+ pool <- Ssh.mkP2PSshConnectionPool
+ (duc, getrepo) <- go
+ return $ State pool duc getrepo
+ where
+ go
+ | remoteAnnexCheckUUID gc = return
+ (return True, return (r, extractGitConfig r))
+ | otherwise = do
+ rv <- liftIO newEmptyMVar
+ let getrepo = ifM (liftIO $ isEmptyMVar rv)
+ ( do
+ r' <- tryGitConfigRead False r
+ let t = (r', extractGitConfig r')
+ void $ liftIO $ tryPutMVar rv t
+ return t
+ , liftIO $ readMVar rv
+ )
+
+ cv <- liftIO newEmptyMVar
+ let duc = ifM (liftIO $ isEmptyMVar cv)
+ ( do
+ r' <- fst <$> getrepo
+ u' <- getRepoUUID r'
+ let ok = u' == u
+ void $ liftIO $ tryPutMVar cv ok
+ unless ok $
+ warning $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now."
+ return ok
+ , liftIO $ readMVar cv
+ )
+
+ return (duc, getrepo)
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 99d9523..ad5f2e2 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -55,6 +55,11 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap this
+ -- glacier-cli does not follow redirects and does
+ -- not support file://, as far as we know, but
+ -- there's no guarantee that will continue to be
+ -- the case, so require verifiable keys.
+ , retrievalSecurityPolicy = RetrievalVerifiableKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -64,7 +69,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = Nothing
, readonly = False
diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs
index 5c611e4..12348f7 100644
--- a/Remote/Helper/Git.hs
+++ b/Remote/Helper/Git.hs
@@ -42,7 +42,8 @@ gitRepoInfo r = do
let lastsynctime = case mtimes of
[] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
+ repo <- Remote.getRepo r
return
- [ ("repository location", Git.repoLocation (Remote.repo r))
+ [ ("repository location", Git.repoLocation repo)
, ("last synced", lastsynctime)
]
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 7348644..883dcc9 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -162,6 +162,14 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
(retrieveKeyFileCheap baser k f d)
-- retrieval of encrypted keys is never cheap
(\_ -> return False)
+ -- When encryption is used, the remote could provide
+ -- some other content encrypted by the user, and trick
+ -- git-annex into decrypting it, leaking the decryption
+ -- into the git-annex repository. Verifiable keys
+ -- are the main protection against this attack.
+ , retrievalSecurityPolicy = if isencrypted
+ then RetrievalVerifiableKeysSecure
+ else retrievalSecurityPolicy baser
, removeKey = \k -> cip >>= removeKeyGen k
, checkPresent = \k -> cip >>= checkPresentGen k
, cost = if isencrypted
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 3ceb41e..021e6a0 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -27,6 +27,8 @@ import qualified P2P.IO as P2P
import qualified P2P.Annex as P2P
import Control.Concurrent.STM
+import Control.Concurrent.Async
+import qualified Data.ByteString as B
toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam])
toRepo cs r gc remotecmd = do
@@ -135,7 +137,8 @@ rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
-- compatability.
: (Fields.direct, if unlocked then "1" else "")
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
- Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin (repo r)
+ repo <- getRepo r
+ Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo
(if direction == Download then "sendkey" else "recvkey")
[ Param $ key2file key ]
fields
@@ -185,12 +188,15 @@ contentLockedMarker = "OK"
-- A connection over ssh to git-annex shell speaking the P2P protocol.
type P2PSshConnection = P2P.ClosableConnection
- (P2P.RunState, P2P.P2PConnection, ProcessHandle)
+ (P2P.RunState, P2P.P2PConnection, ProcessHandle, TVar StderrHandlerState)
+
+data StderrHandlerState = DiscardStderr | DisplayStderr | EndStderrHandler
closeP2PSshConnection :: P2PSshConnection -> IO (P2PSshConnection, Maybe ExitCode)
closeP2PSshConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)
-closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid)) = do
+closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid, stderrhandlerst)) = do
P2P.closeConnection conn
+ atomically $ writeTVar stderrhandlerst EndStderrHandler
exitcode <- waitForProcess pid
return (P2P.ClosedConnection, Just exitcode)
@@ -237,35 +243,37 @@ openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshCon
openP2PSshConnection r connpool = do
u <- getUUID
let ps = [Param (fromUUID u)]
- git_annex_shell ConsumeStdin (repo r) "p2pstdio" ps [] >>= \case
+ repo <- getRepo r
+ git_annex_shell ConsumeStdin repo "p2pstdio" ps [] >>= \case
Nothing -> do
liftIO $ rememberunsupported
return Nothing
- Just (cmd, params) -> start cmd params
+ Just (cmd, params) -> start cmd params =<< getRepo r
where
- start cmd params = liftIO $ withNullHandle $ \nullh -> do
- -- stderr is discarded because old versions of git-annex
- -- shell always error
- (Just from, Just to, Nothing, pid) <- createProcess $
+ start cmd params repo = liftIO $ do
+ (Just from, Just to, Just err, pid) <- createProcess $
(proc cmd (toCommand params))
{ std_in = CreatePipe
, std_out = CreatePipe
- , std_err = UseHandle nullh
+ , std_err = CreatePipe
}
let conn = P2P.P2PConnection
- { P2P.connRepo = repo r
+ { P2P.connRepo = repo
, P2P.connCheckAuth = const False
, P2P.connIhdl = to
, P2P.connOhdl = from
}
+ stderrhandlerst <- newStderrHandler err
runst <- P2P.mkRunState P2P.Client
- let c = P2P.OpenConnection (runst, conn, pid)
+ let c = P2P.OpenConnection (runst, conn, pid, stderrhandlerst)
-- When the connection is successful, the remote
-- will send an AUTH_SUCCESS with its uuid.
let proto = P2P.postAuth $
P2P.negotiateProtocolVersion P2P.maxProtocolVersion
tryNonAsync (P2P.runNetProto runst conn proto) >>= \case
- Right (Right (Just theiruuid)) | theiruuid == uuid r ->
+ Right (Right (Just theiruuid)) | theiruuid == uuid r -> do
+ atomically $
+ writeTVar stderrhandlerst DisplayStderr
return $ Just c
_ -> do
(cclosed, exitcode) <- closeP2PSshConnection c
@@ -284,6 +292,33 @@ openP2PSshConnection r connpool = do
modifyTVar' connpool $
maybe (Just P2PSshUnsupported) Just
+newStderrHandler :: Handle -> IO (TVar StderrHandlerState)
+newStderrHandler errh = do
+ -- stderr from git-annex-shell p2pstdio is initially discarded
+ -- because old versions don't support the command. Once it's known
+ -- to be running, this is changed to DisplayStderr.
+ v <- newTVarIO DiscardStderr
+ p <- async $ go v
+ void $ async $ ender p v
+ return v
+ where
+ go v = do
+ l <- B.hGetLine errh
+ atomically (readTVar v) >>= \case
+ DiscardStderr -> go v
+ DisplayStderr -> do
+ B.hPut stderr l
+ go v
+ EndStderrHandler -> return ()
+
+ ender p v = do
+ atomically $ do
+ readTVar v >>= \case
+ EndStderrHandler -> return ()
+ _ -> retry
+ hClose errh
+ cancel p
+
-- Runs a P2P Proto action on a remote when it supports that,
-- otherwise the fallback action.
runProto :: Remote -> P2PSshConnectionPool -> a -> Annex a -> P2P.Proto a -> Annex (Maybe a)
@@ -302,7 +337,7 @@ runProto r connpool bad fallback proto = Just <$>
runProtoConn :: P2P.Proto a -> P2PSshConnection -> Annex (P2PSshConnection, Maybe a)
runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)
-runProtoConn a conn@(P2P.OpenConnection (runst, c, _pid)) = do
+runProtoConn a conn@(P2P.OpenConnection (runst, c, _, _)) = do
P2P.runFullProto runst c a >>= \case
Right r -> return (conn, Just r)
-- When runFullProto fails, the connection is no longer
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index c1fb199..a6e5339 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -49,6 +49,9 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap hooktype
+ -- A hook could use http and be vulnerable to
+ -- redirect to file:// attacks, etc.
+ , retrievalSecurityPolicy = RetrievalVerifiableKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -59,7 +62,7 @@ gen r u c gc = do
, repairRepo = Nothing
, config = c
, localpath = Nothing
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, readonly = False
, availability = GloballyAvailable
diff --git a/Remote/List.hs b/Remote/List.hs
index b76cccd..7c21aa8 100644
--- a/Remote/List.hs
+++ b/Remote/List.hs
@@ -111,7 +111,7 @@ remoteGen m t r = do
updateRemote :: Remote -> Annex (Maybe Remote)
updateRemote remote = do
m <- readRemoteLog
- remote' <- updaterepo $ repo remote
+ remote' <- updaterepo =<< getRepo remote
remoteGen m (remotetype remote) remote'
where
updaterepo r
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index 41b6b21..c47a9e6 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -18,7 +18,6 @@ import P2P.Annex
import P2P.IO
import P2P.Auth
import Types.Remote
-import Types.GitConfig
import qualified Git
import Annex.UUID
import Config
@@ -54,6 +53,7 @@ chainGen addr r u c gc = do
, storeKey = store (const protorunner)
, retrieveKeyFile = retrieve (const protorunner)
, retrieveKeyFileCheap = \_ _ _ -> return False
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = remove protorunner
, lockContent = Just $ lock withconn runProtoConn u
, checkPresent = checkpresent protorunner
@@ -64,8 +64,8 @@ chainGen addr r u c gc = do
, repairRepo = Nothing
, config = c
, localpath = Nothing
- , repo = r
- , gitconfig = gc { remoteGitConfig = extractGitConfig r }
+ , getRepo = return r
+ , gitconfig = gc
, readonly = False
, availability = GloballyAvailable
, remotetype = remote
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 2f9b353..8f4e8ac 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -72,6 +72,7 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap o
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -88,7 +89,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = if islocal
then Just $ rsyncUrl o
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 505d8f4..5665455 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -84,6 +84,9 @@ gen r u c gc = do
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
+ -- HttpManagerRestricted is used here, so this is
+ -- secure.
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -102,7 +105,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = Nothing
, readonly = False
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 6423fef..5615c48 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -73,6 +73,8 @@ gen r u c gc = do
, storeKey = store u hdl
, retrieveKeyFile = retrieve u hdl
, retrieveKeyFileCheap = \_ _ _ -> return False
+ -- Tahoe cryptographically verifies content.
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = remove
, lockContent = Nothing
, checkPresent = checkKey u hdl
@@ -82,7 +84,7 @@ gen r u c gc = do
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = Nothing
, readonly = False
diff --git a/Remote/Web.hs b/Remote/Web.hs
index f2ab3a5..eef6b69 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -48,6 +48,9 @@ gen r _ c gc =
, storeKey = uploadKey
, retrieveKeyFile = downloadKey
, retrieveKeyFileCheap = downloadKeyCheap
+ -- HttpManagerRestricted is used here, so this is
+ -- secure.
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = dropKey
, lockContent = Nothing
, checkPresent = checkKey
@@ -59,7 +62,7 @@ gen r _ c gc =
, config = c
, gitconfig = gc
, localpath = Nothing
- , repo = r
+ , getRepo = return r
, readonly = True
, availability = GloballyAvailable
, remotetype = remote
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index d8d06c9..d8fc8be 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -72,6 +72,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
+ -- HttpManagerRestricted is used here, so this is
+ -- secure.
+ , retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = removeKeyDummy
, lockContent = Nothing
, checkPresent = checkPresentDummy
@@ -89,7 +92,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
- , repo = r
+ , getRepo = return r
, gitconfig = gc
, localpath = Nothing
, readonly = False
diff --git a/Test.hs b/Test.hs
index 659ebf1..463f06e 100644
--- a/Test.hs
+++ b/Test.hs
@@ -1714,10 +1714,12 @@ test_add_subdirs = intmpclonerepo $ do
test_addurl :: Assertion
test_addurl = intmpclonerepo $ do
-- file:// only; this test suite should not hit the network
+ let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps)
f <- absPath "myurl"
let url = replace "\\" "/" ("file:///" ++ dropDrive f)
writeFile f "foo"
- git_annex "addurl" [url] @? ("addurl failed on " ++ url)
+ not <$> git_annex "addurl" [url] @? "addurl failed to fail on file url"
+ filecmd "addurl" [url] @? ("addurl failed on " ++ url)
let dest = "addurlurldest"
- git_annex "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ " with --file")
+ filecmd "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ " with --file")
doesFileExist dest @? (dest ++ " missing after addurl --file")
diff --git a/Types/DesktopNotify.hs b/Types/DesktopNotify.hs
index e6df05a..ce7e4c4 100644
--- a/Types/DesktopNotify.hs
+++ b/Types/DesktopNotify.hs
@@ -5,9 +5,14 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
+
module Types.DesktopNotify where
import Data.Monoid
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Semigroup as Sem
+#endif
import Prelude
data DesktopNotify = DesktopNotify
@@ -16,10 +21,23 @@ data DesktopNotify = DesktopNotify
}
deriving (Show)
+appendDesktopNotify :: DesktopNotify -> DesktopNotify -> DesktopNotify
+appendDesktopNotify (DesktopNotify s1 f1) (DesktopNotify s2 f2) =
+ DesktopNotify (s1 || s2) (f1 || f2)
+
+#if MIN_VERSION_base(4,9,0)
+instance Sem.Semigroup DesktopNotify where
+ (<>) = appendDesktopNotify
+#endif
+
instance Monoid DesktopNotify where
mempty = DesktopNotify False False
- mappend (DesktopNotify s1 f1) (DesktopNotify s2 f2) =
- DesktopNotify (s1 || s2) (f1 || f2)
+#if MIN_VERSION_base(4,11,0)
+#elif MIN_VERSION_base(4,9,0)
+ mappend = (Sem.<>)
+#else
+ mappend = appendDesktopNotify
+#endif
mkNotifyStart :: DesktopNotify
mkNotifyStart = DesktopNotify True False
diff --git a/Types/Difference.hs b/Types/Difference.hs
index 4abc75c..0f7100c 100644
--- a/Types/Difference.hs
+++ b/Types/Difference.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
+
module Types.Difference (
Difference(..),
Differences(..),
@@ -23,8 +25,11 @@ import qualified Git.Config
import Data.Maybe
import Data.Monoid
-import Prelude
import qualified Data.Set as S
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Semigroup as Sem
+#endif
+import Prelude
-- Describes differences from the v5 repository format.
--
@@ -67,14 +72,27 @@ instance Eq Differences where
, oneLevelBranchHash
]
+appendDifferences :: Differences -> Differences -> Differences
+appendDifferences a@(Differences {}) b@(Differences {}) = a
+ { objectHashLower = objectHashLower a || objectHashLower b
+ , oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b
+ , oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b
+ }
+appendDifferences _ _ = UnknownDifferences
+
+#if MIN_VERSION_base(4,9,0)
+instance Sem.Semigroup Differences where
+ (<>) = appendDifferences
+#endif
+
instance Monoid Differences where
mempty = Differences False False False
- mappend a@(Differences {}) b@(Differences {}) = a
- { objectHashLower = objectHashLower a || objectHashLower b
- , oneLevelObjectHash = oneLevelObjectHash a || oneLevelObjectHash b
- , oneLevelBranchHash = oneLevelBranchHash a || oneLevelBranchHash b
- }
- mappend _ _ = UnknownDifferences
+#if MIN_VERSION_base(4,11,0)
+#elif MIN_VERSION_base(4,9,0)
+ mappend = (Sem.<>)
+#else
+ mappend = appendDifferences
+#endif
readDifferences :: String -> Differences
readDifferences = maybe UnknownDifferences mkDifferences . readish
diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index 6fe635a..26ad354 100644
--- a/Types/GitConfig.hs
+++ b/Types/GitConfig.hs
@@ -19,6 +19,7 @@ import Common
import qualified Git
import qualified Git.Config
import qualified Git.Construct
+import Git.Types
import Git.ConfigTypes
import Utility.DataUnits
import Config.Cost
@@ -32,8 +33,10 @@ import Config.DynamicConfig
import Utility.HumanTime
import Utility.Gpg (GpgCmd, mkGpgCmd)
import Utility.ThreadScheduler (Seconds(..))
+import Utility.Url (Scheme, mkScheme)
import Control.Concurrent.STM
+import qualified Data.Set as S
-- | A configurable value, that may not be fully determined yet because
-- the global git config has not yet been loaded.
@@ -70,7 +73,6 @@ data GitConfig = GitConfig
, annexWebOptions :: [String]
, annexYoutubeDlOptions :: [String]
, annexAriaTorrentOptions :: [String]
- , annexWebDownloadCommand :: Maybe String
, annexCrippledFileSystem :: Bool
, annexLargeFiles :: Maybe String
, annexAddSmallFiles :: Bool
@@ -92,12 +94,14 @@ data GitConfig = GitConfig
, annexSecureHashesOnly :: Bool
, annexRetry :: Maybe Integer
, annexRetryDelay :: Maybe Seconds
+ , annexAllowedUrlSchemes :: S.Set Scheme
+ , annexAllowedHttpAddresses :: String
+ , annexAllowUnverifiedDownloads :: Bool
, coreSymlinks :: Bool
, coreSharedRepository :: SharedRepository
, receiveDenyCurrentBranch :: DenyCurrentBranch
, gcryptId :: Maybe String
, gpgCmd :: GpgCmd
- , gitConfigRepo :: Git.Repo
}
extractGitConfig :: Git.Repo -> GitConfig
@@ -133,7 +137,6 @@ extractGitConfig r = GitConfig
, annexWebOptions = getwords (annex "web-options")
, annexYoutubeDlOptions = getwords (annex "youtube-dl-options")
, annexAriaTorrentOptions = getwords (annex "aria-torrent-options")
- , annexWebDownloadCommand = getmaybe (annex "web-download-command")
, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False
, annexLargeFiles = getmaybe (annex "largefiles")
, annexAddSmallFiles = getbool (annex "addsmallfiles") True
@@ -159,12 +162,18 @@ extractGitConfig r = GitConfig
, annexRetry = getmayberead (annex "retry")
, annexRetryDelay = Seconds
<$> getmayberead (annex "retrydelay")
+ , annexAllowedUrlSchemes = S.fromList $ map mkScheme $
+ maybe ["http", "https", "ftp"] words $
+ getmaybe (annex "security.allowed-url-schemes")
+ , annexAllowedHttpAddresses = fromMaybe "" $
+ getmaybe (annex "security.allowed-http-addresses")
+ , annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
+ getmaybe (annex "security.allow-unverified-downloads")
, coreSymlinks = getbool "core.symlinks" True
, coreSharedRepository = getSharedRepository r
, receiveDenyCurrentBranch = getDenyCurrentBranch r
, gcryptId = getmaybe "core.gcrypt-id"
, gpgCmd = mkGpgCmd (getmaybe "gpg.program")
- , gitConfigRepo = r
}
where
getbool k d = fromMaybe d $ getmaybebool k
@@ -197,7 +206,12 @@ mergeGitConfig gitconfig repoglobals = gitconfig
{- Per-remote git-annex settings. Each setting corresponds to a git-config
- key such as <remote>.annex-foo, or if that is not set, a default from
- - annex.foo -}
+ - annex.foo.
+ -
+ - Note that this is from the perspective of the local repository,
+ - it is not influenced in any way by the contents of the remote
+ - repository's git config.
+ -}
data RemoteGitConfig = RemoteGitConfig
{ remoteAnnexCost :: DynamicConfig (Maybe Cost)
, remoteAnnexIgnore :: DynamicConfig Bool
@@ -237,11 +251,11 @@ data RemoteGitConfig = RemoteGitConfig
, remoteAnnexDdarRepo :: Maybe String
, remoteAnnexHookType :: Maybe String
, remoteAnnexExternalType :: Maybe String
- {- A regular git remote's git repository config. -}
- , remoteGitConfig :: GitConfig
}
-extractRemoteGitConfig :: Git.Repo -> String -> STM RemoteGitConfig
+{- The Git.Repo is the local repository, which has the remote with the
+ - given RemoteName. -}
+extractRemoteGitConfig :: Git.Repo -> RemoteName -> STM RemoteGitConfig
extractRemoteGitConfig r remotename = do
annexcost <- mkDynamicConfig readCommandRunner
(notempty $ getmaybe "cost-command")
@@ -290,7 +304,6 @@ extractRemoteGitConfig r remotename = do
, remoteAnnexDdarRepo = getmaybe "ddarrepo"
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
, remoteAnnexExternalType = notempty $ getmaybe "externaltype"
- , remoteGitConfig = extractGitConfig r
}
where
getbool k d = fromMaybe d $ getmaybebool k
diff --git a/Types/Key.hs b/Types/Key.hs
index b3efc04..4b81850 100644
--- a/Types/Key.hs
+++ b/Types/Key.hs
@@ -1,6 +1,6 @@
{- git-annex Key data type
-
- - Copyright 2011-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -88,6 +88,23 @@ cryptographicallySecure (Blake2sKey _ _) = True
cryptographicallySecure (Blake2spKey _ _) = True
cryptographicallySecure _ = False
+{- Is the Key variety backed by a hash, which allows verifying content?
+ - It does not have to be cryptographically secure against eg birthday
+ - attacks.
+ -}
+isVerifiable :: KeyVariety -> Bool
+isVerifiable (SHA2Key _ _) = True
+isVerifiable (SHA3Key _ _) = True
+isVerifiable (SKEINKey _ _) = True
+isVerifiable (Blake2bKey _ _) = True
+isVerifiable (Blake2sKey _ _) = True
+isVerifiable (Blake2spKey _ _) = True
+isVerifiable (SHA1Key _) = True
+isVerifiable (MD5Key _) = True
+isVerifiable WORMKey = False
+isVerifiable URLKey = False
+isVerifiable (OtherKey _) = False
+
formatKeyVariety :: KeyVariety -> String
formatKeyVariety v = case v of
SHA2Key sz e -> adde e (addsz sz "SHA")
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 78ec416..9f61f70 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -2,7 +2,7 @@
-
- Most things should not need this, using Types instead
-
- - Copyright 2011-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -18,6 +18,7 @@ module Types.Remote
, Availability(..)
, Verification(..)
, unVerified
+ , RetrievalSecurityPolicy(..)
, isExportSupported
, ExportActions(..)
)
@@ -85,6 +86,8 @@ data RemoteA a = Remote
-- Retrieves a key's contents to a tmp file, if it can be done cheaply.
-- It's ok to create a symlink or hardlink.
, retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool
+ -- Security policy for reteiving keys from this remote.
+ , retrievalSecurityPolicy :: RetrievalSecurityPolicy
-- Removes a key's contents (succeeds if the contents are not present)
, removeKey :: Key -> a Bool
-- Uses locking to prevent removal of a key's contents,
@@ -111,8 +114,8 @@ data RemoteA a = Remote
, repairRepo :: Maybe (a Bool -> a (IO Bool))
-- a Remote has a persistent configuration store
, config :: RemoteConfig
- -- git repo for the Remote
- , repo :: Git.Repo
+ -- Get the git repo for the Remote.
+ , getRepo :: a Git.Repo
-- a Remote's configuration from git
, gitconfig :: RemoteGitConfig
-- a Remote can be assocated with a specific local filesystem path
@@ -165,6 +168,32 @@ unVerified a = do
ok <- a
return (ok, UnVerified)
+-- Security policy indicating what keys can be safely retrieved from a
+-- remote.
+data RetrievalSecurityPolicy
+ = RetrievalVerifiableKeysSecure
+ -- ^ Transfer of keys whose content can be verified
+ -- with a hash check is secure; transfer of unverifiable keys is
+ -- not secure and should not be allowed.
+ --
+ -- This is used eg, when HTTP to a remote could be redirected to a
+ -- local private web server or even a file:// url, causing private
+ -- data from it that is not the intended content of a key to make
+ -- its way into the git-annex repository.
+ --
+ -- It's also used when content is stored encrypted on a remote,
+ -- which could replace it with a different encrypted file, and
+ -- trick git-annex into decrypting it and leaking the decryption
+ -- into the git-annex repository.
+ --
+ -- It's not (currently) used when the remote could alter the
+ -- content stored on it, because git-annex does not provide
+ -- strong guarantees about the content of keys that cannot be
+ -- verified with a hash check.
+ -- (But annex.securehashesonly does provide such guarantees.)
+ | RetrievalAllKeysSecure
+ -- ^ Any key can be securely retrieved.
+
isExportSupported :: RemoteA a -> a Bool
isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)
diff --git a/Types/Test.hs b/Types/Test.hs
index 50c460f..5a9a9e0 100644
--- a/Types/Test.hs
+++ b/Types/Test.hs
@@ -5,11 +5,17 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
+
module Types.Test where
import Test.Tasty.Options
import Data.Monoid
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Semigroup as Sem
+#endif
import Prelude
+
import Types.Command
data TestOptions = TestOptions
@@ -19,13 +25,25 @@ data TestOptions = TestOptions
, internalData :: CmdParams
}
+appendTestOptions :: TestOptions -> TestOptions -> TestOptions
+appendTestOptions a b = TestOptions
+ (tastyOptionSet a <> tastyOptionSet b)
+ (keepFailuresOption a || keepFailuresOption b)
+ (fakeSsh a || fakeSsh b)
+ (internalData a <> internalData b)
+
+#if MIN_VERSION_base(4,9,0)
+instance Sem.Semigroup TestOptions where
+ (<>) = appendTestOptions
+#endif
+
instance Monoid TestOptions where
mempty = TestOptions mempty False False mempty
- mappend a b = TestOptions
- (tastyOptionSet a <> tastyOptionSet b)
- (keepFailuresOption a || keepFailuresOption b)
- (fakeSsh a || fakeSsh b)
- (internalData a <> internalData b)
-
+#if MIN_VERSION_base(4,11,0)
+#elif MIN_VERSION_base(4,9,0)
+ mappend = (Sem.<>)
+#else
+ mappend = appendTestOptions
+#endif
type TestRunner = TestOptions -> IO ()
diff --git a/Utility/HttpManagerRestricted.hs b/Utility/HttpManagerRestricted.hs
new file mode 100644
index 0000000..00611b7
--- /dev/null
+++ b/Utility/HttpManagerRestricted.hs
@@ -0,0 +1,232 @@
+{- | Restricted Manager for http-client-tls
+ -
+ - Copyright 2018 Joey Hess <id@joeyh.name>
+ -
+ - Portions from http-client-tls Copyright (c) 2013 Michael Snoyman
+ -
+ - License: MIT
+ -}
+
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-}
+{-# LANGUAGE CPP #-}
+
+module Utility.HttpManagerRestricted (
+ restrictManagerSettings,
+ Restriction(..),
+ ConnectionRestricted(..),
+ addrConnectionRestricted,
+ ProxyRestricted(..),
+ IPAddrString,
+) where
+
+import Network.HTTP.Client
+import Network.HTTP.Client.Internal
+ (ManagerSettings(..), Connection, runProxyOverride, makeConnection)
+import Network.Socket
+import Network.BSD (getProtocolNumber)
+import Control.Exception
+import qualified Network.Connection as NC
+import qualified Data.ByteString.UTF8 as BU
+import Data.Default
+import Data.Typeable
+import Control.Applicative
+
+data Restriction = Restriction
+ { addressRestriction :: AddrInfo -> Maybe ConnectionRestricted
+ }
+
+-- | An exception used to indicate that the connection was restricted.
+data ConnectionRestricted = ConnectionRestricted String
+ deriving (Show, Typeable)
+
+instance Exception ConnectionRestricted
+
+type IPAddrString = String
+
+-- | Constructs a ConnectionRestricted, passing the function a string
+-- containing the IP address.
+addrConnectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted
+addrConnectionRestricted mkmessage =
+ ConnectionRestricted . mkmessage . showSockAddress . addrAddress
+
+data ProxyRestricted = ProxyRestricted
+ deriving (Show)
+
+-- | Adjusts a ManagerSettings to enforce a Restriction. The restriction
+-- will be checked each time a Request is made, and for each redirect
+-- followed.
+--
+-- The http proxy is also checked against the Restriction, and if
+-- access to it is blocked, the http proxy will not be used.
+restrictManagerSettings
+ :: Restriction
+ -> ManagerSettings
+ -> IO (ManagerSettings, Maybe ProxyRestricted)
+restrictManagerSettings cfg base = restrictProxy cfg $ base
+ { managerRawConnection = restrictedRawConnection cfg
+ , managerTlsConnection = restrictedTlsConnection cfg
+#if MIN_VERSION_http_client(0,5,0)
+ , managerWrapException = wrapOurExceptions base
+#else
+ , managerWrapIOException = wrapOurExceptions base
+#endif
+ }
+
+restrictProxy
+ :: Restriction
+ -> ManagerSettings
+ -> IO (ManagerSettings, Maybe ProxyRestricted)
+restrictProxy cfg base = do
+ http_proxy_addr <- getproxyaddr False
+ https_proxy_addr <- getproxyaddr True
+ let (http_proxy, http_r) = mkproxy http_proxy_addr
+ let (https_proxy, https_r) = mkproxy https_proxy_addr
+ let ms = managerSetInsecureProxy http_proxy $
+ managerSetSecureProxy https_proxy base
+ return (ms, http_r <|> https_r)
+ where
+ -- This does not use localhost because http-client may choose
+ -- not to use the proxy for localhost.
+ testnetip = "198.51.100.1"
+ dummyreq https = parseRequest_ $
+ "http" ++ (if https then "s" else "") ++ "://" ++ testnetip
+
+ getproxyaddr https = extractproxy >>= \case
+ Nothing -> return Nothing
+ Just p -> do
+ proto <- getProtocolNumber "tcp"
+ let serv = show (proxyPort p)
+ let hints = defaultHints
+ { addrFlags = [AI_ADDRCONFIG]
+ , addrProtocol = proto
+ , addrSocketType = Stream
+ }
+ let h = BU.toString $ proxyHost p
+ getAddrInfo (Just hints) (Just h) (Just serv) >>= \case
+ [] -> return Nothing
+ (addr:_) -> return $ Just addr
+ where
+ -- These contortions are necessary until this issue
+ -- is fixed:
+ -- https://github.com/snoyberg/http-client/issues/355
+ extractproxy = do
+ let po = if https
+ then managerProxySecure base
+ else managerProxyInsecure base
+ f <- runProxyOverride po https
+ return $ proxy $ f $ dummyreq https
+
+ mkproxy Nothing = (noProxy, Nothing)
+ mkproxy (Just proxyaddr) = case addressRestriction cfg proxyaddr of
+ Nothing -> (addrtoproxy (addrAddress proxyaddr), Nothing)
+ Just _ -> (noProxy, Just ProxyRestricted)
+
+ addrtoproxy addr = case addr of
+ SockAddrInet pn _ -> mk pn
+ SockAddrInet6 pn _ _ _ -> mk pn
+ _ -> noProxy
+ where
+ mk pn = useProxy Network.HTTP.Client.Proxy
+ { proxyHost = BU.fromString (showSockAddress addr)
+ , proxyPort = fromIntegral pn
+ }
+
+#if MIN_VERSION_http_client(0,5,0)
+wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a
+wrapOurExceptions base req a =
+ let wrapper se
+ | Just (_ :: ConnectionRestricted) <- fromException se =
+ toException $ HttpExceptionRequest req $
+ InternalException se
+ | otherwise = se
+ in managerWrapException base req (handle (throwIO . wrapper) a)
+#else
+wrapOurExceptions :: ManagerSettings -> IO a -> IO a
+wrapOurExceptions base a =
+ let wrapper se = case fromException se of
+ Just (_ :: ConnectionRestricted) ->
+ -- Not really a TLS exception, but there is no
+ -- way to put SomeException in the
+ -- InternalIOException this old version uses.
+ toException $ TlsException se
+ Nothing -> se
+ in managerWrapIOException base (handle (throwIO . wrapper) a)
+#endif
+
+restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
+restrictedRawConnection cfg = getConnection cfg Nothing
+
+restrictedTlsConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
+restrictedTlsConnection cfg = getConnection cfg $
+ -- It's not possible to access the TLSSettings
+ -- used in the base ManagerSettings. So, use the default
+ -- value, which is the same thing http-client-tls defaults to.
+ -- Since changing from the default settings can only make TLS
+ -- less secure, this is not a big problem.
+ Just def
+
+
+
+-- Based on Network.HTTP.Client.TLS.getTlsConnection.
+--
+-- Checks the Restriction
+--
+-- Does not support SOCKS.
+getConnection :: Restriction -> Maybe NC.TLSSettings -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
+getConnection cfg tls = do
+ context <- NC.initConnectionContext
+ return $ \_ha h p -> bracketOnError
+ (go context h p)
+ NC.connectionClose
+ convertConnection
+ where
+ go context h p = do
+ let connparams = NC.ConnectionParams
+ { NC.connectionHostname = h
+ , NC.connectionPort = fromIntegral p
+ , NC.connectionUseSecure = tls
+ , NC.connectionUseSocks = Nothing -- unsupprted
+ }
+ proto <- getProtocolNumber "tcp"
+ let serv = show p
+ let hints = defaultHints
+ { addrFlags = [AI_ADDRCONFIG]
+ , addrProtocol = proto
+ , addrSocketType = Stream
+ }
+ addrs <- getAddrInfo (Just hints) (Just h) (Just serv)
+ bracketOnError
+ (firstSuccessful $ map tryToConnect addrs)
+ close
+ (\sock -> NC.connectFromSocket context sock connparams)
+ where
+ tryToConnect addr = case addressRestriction cfg addr of
+ Nothing -> bracketOnError
+ (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
+ close
+ (\sock -> connect sock (addrAddress addr) >> return sock)
+ Just r -> throwIO r
+ firstSuccessful [] = throwIO $ NC.HostNotResolved h
+ firstSuccessful (a:as) = a `catch` \(e ::IOException) ->
+ case as of
+ [] -> throwIO e
+ _ -> firstSuccessful as
+
+-- Copied from Network.HTTP.Client.TLS, unfortunately not exported.
+convertConnection :: NC.Connection -> IO Connection
+convertConnection conn = makeConnection
+ (NC.connectionGetChunk conn)
+ (NC.connectionPut conn)
+ -- Closing an SSL connection gracefully involves writing/reading
+ -- on the socket. But when this is called the socket might be
+ -- already closed, and we get a @ResourceVanished@.
+ (NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ())
+
+-- For ipv4 and ipv6, the string will contain only the IP address,
+-- omitting the port that the Show instance includes.
+showSockAddress :: SockAddr -> IPAddrString
+showSockAddress a@(SockAddrInet _ _) =
+ takeWhile (/= ':') $ show a
+showSockAddress a@(SockAddrInet6 _ _ _ _) =
+ takeWhile (/= ']') $ drop 1 $ show a
+showSockAddress a = show a
diff --git a/Utility/IPAddress.hs b/Utility/IPAddress.hs
new file mode 100644
index 0000000..c180a5c
--- /dev/null
+++ b/Utility/IPAddress.hs
@@ -0,0 +1,93 @@
+{- IP addresses
+ -
+ - Copyright 2018 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.IPAddress where
+
+import Utility.Exception
+
+import Network.Socket
+import Data.Word
+import Control.Applicative
+import Prelude
+
+{- Check if an IP address is a loopback address; connecting to it
+ - may connect back to the local host. -}
+isLoopbackAddress :: SockAddr -> Bool
+isLoopbackAddress (SockAddrInet _ ipv4) = case hostAddressToTuple ipv4 of
+ -- localhost
+ (127,_,_,_) -> True
+ -- current network; functions equivilant to loopback
+ (0,_,_, _) -> True
+ _ -> False
+isLoopbackAddress (SockAddrInet6 _ _ ipv6 _) = case hostAddress6ToTuple ipv6 of
+ -- localhost
+ (0,0,0,0,0,0,0,1) -> True
+ -- unspecified address; functions equivilant to loopback
+ (0,0,0,0,0,0,0,0) -> True
+ v -> maybe False
+ (isLoopbackAddress . SockAddrInet 0)
+ (embeddedIpv4 v)
+isLoopbackAddress _ = False
+
+{- Check if an IP address is not globally routed, and is used
+ - for private communication, eg on a LAN. -}
+isPrivateAddress :: SockAddr -> Bool
+isPrivateAddress (SockAddrInet _ ipv4) = case hostAddressToTuple ipv4 of
+ -- lan
+ (10,_,_,_) -> True
+ (172,n,_,_) | n >= 16 && n <= 31 -> True -- 172.16.0.0/12
+ (192,168,_,_) -> True
+ -- carrier-grade NAT
+ (100,n,0,0) | n >= 64 && n <= 127 -> True -- 100.64.0.0/10
+ -- link-local
+ (169,254,_,_) -> True
+ _ -> False
+isPrivateAddress (SockAddrInet6 _ _ ipv6 _) = case hostAddress6ToTuple ipv6 of
+ v@(n,_,_,_,_,_,_,_)
+ -- local to lan or private between orgs
+ | n >= 0xfc00 && n <= 0xfdff -> True -- fc00::/7
+ -- link-local
+ | n >= 0xfe80 && n <= 0xfebf -> True -- fe80::/10
+ | otherwise -> maybe False
+ (isPrivateAddress . SockAddrInet 0)
+ (embeddedIpv4 v)
+isPrivateAddress _ = False
+
+embeddedIpv4 :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> Maybe HostAddress
+embeddedIpv4 v = case v of
+ -- IPv4 mapped address (::ffff:0:0/96)
+ (0,0,0,0,0,0xffff,a,b) -> Just (toipv4 a b)
+ -- IPV4 translated address (::ffff:0:ipv4)
+ (0,0,0,0,0xffff,0,a,b) -> Just (toipv4 a b)
+ -- IPV4/IPV6 translation (64:ff9b::ipv4)
+ (0x64,0xff9b,0,0,0,0,a,b) -> Just (toipv4 a b)
+ _ -> Nothing
+ where
+ toipv4 a b = htonl $ fromIntegral a * (2^halfipv4bits) + fromIntegral b
+ halfipv4bits = 16 :: Word32
+
+{- Given a string containing an IP address, make a function that will
+ - match that address in a SockAddr. Nothing when the address cannot be
+ - parsed.
+ -
+ - This does not involve any DNS lookups.
+ -}
+makeAddressMatcher :: String -> IO (Maybe (SockAddr -> Bool))
+makeAddressMatcher s = go
+ <$> catchDefaultIO [] (getAddrInfo (Just hints) (Just s) Nothing)
+ where
+ hints = defaultHints
+ { addrSocketType = Stream
+ , addrFlags = [AI_NUMERICHOST]
+ }
+
+ go [] = Nothing
+ go l = Just $ \sockaddr -> any (match sockaddr) (map addrAddress l)
+
+ match (SockAddrInet _ a) (SockAddrInet _ b) = a == b
+ match (SockAddrInet6 _ _ a _) (SockAddrInet6 _ _ b _) = a == b
+ match _ _ = False
diff --git a/Utility/Url.hs b/Utility/Url.hs
index d959ba0..31dca28 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -15,6 +15,10 @@ module Utility.Url (
managerSettings,
URLString,
UserAgent,
+ Scheme,
+ mkScheme,
+ allowedScheme,
+ UrlDownloader(..),
UrlOptions(..),
defUrlOptions,
mkUrlOptions,
@@ -34,6 +38,7 @@ module Utility.Url (
import Common
import Utility.Metered
+import Utility.HttpManagerRestricted
import Network.URI
import Network.HTTP.Types
@@ -41,9 +46,10 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B8
import qualified Data.ByteString.Lazy as L
+import qualified Data.Set as S
import Control.Monad.Trans.Resource
import Network.HTTP.Conduit
-import Network.HTTP.Client (brRead, withResponse)
+import Network.HTTP.Client
import Data.Conduit
#if ! MIN_VERSION_http_client(0,5,0)
@@ -65,12 +71,22 @@ type Headers = [String]
type UserAgent = String
+newtype Scheme = Scheme (CI.CI String)
+ deriving (Eq, Ord)
+
+mkScheme :: String -> Scheme
+mkScheme = Scheme . CI.mk
+
+fromScheme :: Scheme -> String
+fromScheme (Scheme s) = CI.original s
+
data UrlOptions = UrlOptions
{ userAgent :: Maybe UserAgent
, reqHeaders :: Headers
, urlDownloader :: UrlDownloader
, applyRequest :: Request -> Request
, httpManager :: Manager
+ , allowedSchemes :: S.Set Scheme
}
data UrlDownloader
@@ -84,20 +100,12 @@ defUrlOptions = UrlOptions
<*> pure DownloadWithConduit
<*> pure id
<*> newManager managerSettings
+ <*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"])
-mkUrlOptions :: Maybe UserAgent -> Headers -> [CommandParam] -> Manager -> UrlOptions
-mkUrlOptions defuseragent reqheaders reqparams manager =
+mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> UrlOptions
+mkUrlOptions defuseragent reqheaders urldownloader manager =
UrlOptions useragent reqheaders urldownloader applyrequest manager
where
- urldownloader = if null reqparams
-#if MIN_VERSION_cryptonite(0,6,0)
- then DownloadWithConduit
-#else
- -- Work around for old cryptonite bug that broke tls.
- -- https://github.com/vincenthz/hs-tls/issues/109
- then DownloadWithCurl reqparams
-#endif
- else DownloadWithCurl reqparams
applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders }
addedheaders = uaheader ++ otherheaders
useragent = maybe defuseragent (Just . B8.toString . snd)
@@ -115,7 +123,7 @@ mkUrlOptions defuseragent reqheaders reqparams manager =
_ -> (h', B8.fromString v)
curlParams :: UrlOptions -> [CommandParam] -> [CommandParam]
-curlParams uo ps = ps ++ uaparams ++ headerparams ++ addedparams
+curlParams uo ps = ps ++ uaparams ++ headerparams ++ addedparams ++ schemeparams
where
uaparams = case userAgent uo of
Nothing -> []
@@ -124,6 +132,31 @@ curlParams uo ps = ps ++ uaparams ++ headerparams ++ addedparams
addedparams = case urlDownloader uo of
DownloadWithConduit -> []
DownloadWithCurl l -> l
+ schemeparams =
+ [ Param "--proto"
+ , Param $ intercalate "," ("-all" : schemelist)
+ ]
+ schemelist = map fromScheme $ S.toList $ allowedSchemes uo
+
+checkPolicy :: UrlOptions -> URI -> a -> IO a -> IO a
+checkPolicy uo u onerr a
+ | allowedScheme uo u = a
+ | otherwise = do
+ hPutStrLn stderr $
+ "Configuration does not allow accessing " ++ show u
+ hFlush stderr
+ return onerr
+
+unsupportedUrlScheme :: URI -> IO ()
+unsupportedUrlScheme u = do
+ hPutStrLn stderr $
+ "Unsupported url scheme" ++ show u
+ hFlush stderr
+
+allowedScheme :: UrlOptions -> URI -> Bool
+allowedScheme uo u = uscheme `S.member` allowedSchemes uo
+ where
+ uscheme = mkScheme $ takeWhile (/=':') (uriScheme u)
{- Checks that an url exists and could be successfully downloaded,
- also checking that its size, if available, matches a specified size. -}
@@ -158,32 +191,26 @@ assumeUrlExists = UrlInfo True Nothing Nothing
- also returning its size and suggested filename if available. -}
getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo
getUrlInfo url uo = case parseURIRelaxed url of
- Just u -> case (urlDownloader uo, parseUrlConduit (show u)) of
- (DownloadWithConduit, Just req) -> catchJust
- -- When http redirects to a protocol which
- -- conduit does not support, it will throw
- -- a StatusCodeException with found302.
- (matchStatusCodeException (== found302))
- (existsconduit req)
- (const (existscurl u))
- `catchNonAsync` (const dne)
- -- http-conduit does not support file:, ftp:, etc urls,
- -- so fall back to reading files and using curl.
- _
- | uriScheme u == "file:" -> do
- let f = unEscapeString (uriPath u)
- s <- catchMaybeIO $ getFileStatus f
- case s of
- Just stat -> do
- sz <- getFileSize' f stat
- found (Just sz) Nothing
- Nothing -> dne
- | otherwise -> existscurl u
- Nothing -> dne
+ Just u -> checkPolicy uo u dne $
+ case (urlDownloader uo, parseUrlConduit (show u)) of
+ (DownloadWithConduit, Just req) ->
+ existsconduit req
+ `catchNonAsync` (const $ return dne)
+ (DownloadWithConduit, Nothing)
+ | isfileurl u -> existsfile u
+ | otherwise -> do
+ unsupportedUrlScheme u
+ return dne
+ (DownloadWithCurl _, _)
+ | isfileurl u -> existsfile u
+ | otherwise -> existscurl u
+ Nothing -> return dne
where
- dne = return $ UrlInfo False Nothing Nothing
+ dne = UrlInfo False Nothing Nothing
found sz f = return $ UrlInfo True sz f
+ isfileurl u = uriScheme u == "file:"
+
curlparams = curlParams uo $
[ Param "-s"
, Param "--head"
@@ -213,7 +240,7 @@ getUrlInfo url uo = case parseURIRelaxed url of
then found
(extractlen resp)
(extractfilename resp)
- else dne
+ else return dne
existscurl u = do
output <- catchDefaultIO "" $
@@ -230,7 +257,16 @@ getUrlInfo url uo = case parseURIRelaxed url of
-- don't try to parse ftp status codes; if curl
-- got a length, it's good
_ | isftp && isJust len -> good
- _ -> dne
+ _ -> return dne
+
+ existsfile u = do
+ let f = unEscapeString (uriPath u)
+ s <- catchMaybeIO $ getFileStatus f
+ case s of
+ Just stat -> do
+ sz <- getFileSize' f stat
+ found (Just sz) Nothing
+ Nothing -> return dne
-- Parse eg: attachment; filename="fname.ext"
-- per RFC 2616
@@ -253,10 +289,6 @@ headRequest r = r
{- Download a perhaps large file, with auto-resume of incomplete downloads.
-
- - By default, conduit is used for the download, except for file: urls,
- - which are copied. If the url scheme is not supported by conduit, falls
- - back to using curl.
- -
- Displays error message on stderr when download failed.
-}
download :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool
@@ -265,22 +297,21 @@ download meterupdate url file uo =
`catchNonAsync` showerr
where
go = case parseURIRelaxed url of
- Just u -> case (urlDownloader uo, parseUrlConduit (show u)) of
- (DownloadWithConduit, Just req) -> catchJust
- -- When http redirects to a protocol which
- -- conduit does not support, it will throw
- -- a StatusCodeException with found302.
- (matchStatusCodeException (== found302))
- (downloadconduit req)
- (const downloadcurl)
- _
- | uriScheme u == "file:" -> do
- let src = unEscapeString (uriPath u)
- withMeteredFile src meterupdate $
- L.writeFile file
- return True
- | otherwise -> downloadcurl
+ Just u -> checkPolicy uo u False $
+ case (urlDownloader uo, parseUrlConduit (show u)) of
+ (DownloadWithConduit, Just req) ->
+ downloadconduit req
+ (DownloadWithConduit, Nothing)
+ | isfileurl u -> downloadfile u
+ | otherwise -> do
+ unsupportedUrlScheme u
+ return False
+ (DownloadWithCurl _, _)
+ | isfileurl u -> downloadfile u
+ | otherwise -> downloadcurl
Nothing -> return False
+
+ isfileurl u = uriScheme u == "file:"
downloadconduit req = catchMaybeIO (getFileSize file) >>= \case
Nothing -> runResourceT $ do
@@ -333,6 +364,10 @@ download meterupdate url file uo =
let msg = case he of
HttpExceptionRequest _ (StatusCodeException _ msgb) ->
B8.toString msgb
+ HttpExceptionRequest _ (InternalException ie) ->
+ case fromException ie of
+ Nothing -> show ie
+ Just (ConnectionRestricted why) -> why
HttpExceptionRequest _ other -> show other
_ -> show he
#else
@@ -365,6 +400,12 @@ download meterupdate url file uo =
, Param "-C", Param "-"
]
boolSystem "curl" (ps ++ [Param "-o", File file, File url])
+
+ downloadfile u = do
+ let src = unEscapeString (uriPath u)
+ withMeteredFile src meterupdate $
+ L.writeFile file
+ return True
{- 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.
diff --git a/doc/git-annex-addurl.mdwn b/doc/git-annex-addurl.mdwn
index 4748073..7947edc 100644
--- a/doc/git-annex-addurl.mdwn
+++ b/doc/git-annex-addurl.mdwn
@@ -10,9 +10,12 @@ git annex addurl `[url ...]`
Downloads each url to its own file, which is added to the annex.
-When `youtube-dl` is installed, it's used to check for a video embedded in
-a web page at the url, and that is added to the annex instead.
-
+When `youtube-dl` is installed, it can be used to check for a video
+embedded in a web page at the url, and that is added to the annex instead.
+(However, this is disabled by default as it can be a security risk.
+See the documentation of annex.security.allowed-http-addresses
+in [[git-annex]](1) for details.)
+
Urls to torrent files (including magnet links) will cause the content of
the torrent to be downloaded, using `aria2c`.
diff --git a/doc/git-annex-groupwanted.mdwn b/doc/git-annex-groupwanted.mdwn
index fd51d50..7df2c02 100644
--- a/doc/git-annex-groupwanted.mdwn
+++ b/doc/git-annex-groupwanted.mdwn
@@ -21,6 +21,10 @@ make repositories in the group want to contain 3 copies of every file:
git annex wanted $repo groupwanted
done
+Note that there must be exactly one groupwanted expression configured
+amoung all the groups that a repository is in; if there's more than one,
+none of them will be used.
+
# SEE ALSO
[[git-annex]](1)
diff --git a/doc/git-annex-importfeed.mdwn b/doc/git-annex-importfeed.mdwn
index 2f146fb..d70b02c 100644
--- a/doc/git-annex-importfeed.mdwn
+++ b/doc/git-annex-importfeed.mdwn
@@ -13,8 +13,11 @@ content has not already been added to the repository before, so you can
delete, rename, etc the resulting files and repeated runs won't duplicate
them.
-When `youtube-dl` is installed, it's used to download links in the feed.
+When `youtube-dl` is installed, it can be used to download links in the feed.
This allows importing e.g., YouTube playlists.
+(However, this is disabled by default as it can be a security risk.
+See the documentation of annex.security.allowed-http-addresses
+in [[git-annex]](1) for details.)
To make the import process add metadata to the imported files from the feed,
`git config annex.genmetadata true`
diff --git a/doc/git-annex-preferred-content.mdwn b/doc/git-annex-preferred-content.mdwn
index 54f0d46..97e5ff6 100644
--- a/doc/git-annex-preferred-content.mdwn
+++ b/doc/git-annex-preferred-content.mdwn
@@ -172,12 +172,13 @@ elsewhere to allow removing it).
* `groupwanted`
The "groupwanted" keyword can be used to refer to a preferred content
- expression that is associated with a group. This is like the "standard"
- keyword, but you can configure the preferred content expressions
- using `git annex groupwanted`.
+ expression that is associated with a group, as long as there is exactly
+ one such expression amoung the groups a repository is in. This is like
+ the "standard" keyword, but you can configure the preferred content
+ expressions using `git annex groupwanted`.
- Note that when writing a groupwanted preferred content expression,
- you can use all of the keywords listed above, including "standard".
+ When writing a groupwanted preferred content expression,
+ you can use all the keywords documented here, including "standard".
(But not "groupwanted".)
For example, to make a variant of the standard client preferred content
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index f829f07..163a628 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -1228,7 +1228,7 @@ Here are all the supported configuration settings.
Note that even when this is set to `false`, git-annex does verification
in some edge cases, where it's likely the case than an
- object was downloaded incorrectly.
+ object was downloaded incorrectly, or when needed for security.
* `remote.<name>.annex-export-tracking`
@@ -1356,12 +1356,16 @@ Here are all the supported configuration settings.
* `annex.web-options`
- Setting this makes git-annex use curl to download urls
+ Options to pass to curl when git-annex uses it to download urls
(rather than the default built-in url downloader).
For example, to force IPv4 only, set it to "-4".
Or to make curl use your ~/.netrc file, set it to "--netrc".
+ Setting this option makes git-annex use curl, but only
+ when annex.security.allowed-http-addresses is configured in a
+ specific way. See its documentation.
+
* `annex.youtube-dl-options`
Options to pass to youtube-dl when using it to find the url to download
@@ -1387,12 +1391,76 @@ Here are all the supported configuration settings.
If set, the command is run and each line of its output is used as a HTTP
header. This overrides annex.http-headers.
-* `annex.web-download-command`
+* `annex.security.allowed-url-schemes`
+
+ List of URL schemes that git-annex is allowed to download content from.
+ The default is "http https ftp".
+
+ Think very carefully before changing this; there are security
+ implications. For example, if it's changed to allow "file" URLs, then
+ anyone who can get a commit into your git-annex repository could
+ `git-annex addurl` a pointer to a private file located outside that
+ repository, possibly causing it to be copied into your repository
+ and transferred on to other remotes, exposing its content.
+
+ Some special remotes support their own domain-specific URL
+ schemes; those are not affected by this configuration setting.
+
+* `annex.security.allowed-http-addresses`
+
+ By default, git-annex only makes HTTP connections to public IP addresses;
+ it will refuse to use HTTP servers on localhost or on a private network.
+
+ This setting can override that behavior, allowing access to particular
+ IP addresses. For example "127.0.0.1 ::1" allows access to localhost
+ (both IPV4 and IPV6). To allow access to all IP addresses, use "all"
+
+ Think very carefully before changing this; there are security
+ implications. Anyone who can get a commit into your git-annex repository
+ could `git annex addurl` an url on a private http server, possibly
+ causing it to be downloaded into your repository and transferred to
+ other remotes, exposing its content.
+
+ Note that, since the interfaces of curl and youtube-dl do not allow
+ these IP address restrictions to be enforced, curl and youtube-dl will
+ never be used unless annex.security.allowed-http-addresses=all.
+
+* `annex.security.allow-unverified-downloads`,
+
+ For security reasons, git-annex refuses to download content from
+ most special remotes when it cannot check a hash to verify
+ that the correct content was downloaded. This particularly impacts
+ downloading the content of URL or WORM keys, which lack hashes.
+
+ The best way to avoid problems due to this is to migrate files
+ away from such keys, before their content reaches a special remote.
+ See [[git-annex-migrate]](1).
+
+ When the content is only available from a special remote, you can
+ use this configuration to force git-annex to download it.
+ But you do so at your own risk, and it's very important you read and
+ understand the information below first!
+
+ Downloading unverified content from encrypted special remotes is
+ prevented, because the special remote could send some other encrypted
+ content than what you expect, causing git-annex to decrypt data that you
+ never checked into git-annex, and risking exposing the decrypted
+ data to any non-encrypted remotes you send content to.
+
+ Downloading unverified content from (non-encrypted)
+ external special remotes is prevented, because they could follow
+ http redirects to web servers on localhost or on a private network,
+ or in some cases to a file:/// url.
+
+ If you decide to bypass this security check, the best thing to do is
+ to only set it temporarily while running the command that gets the file.
+ The value to set the config to is "ACKTHPPT".
+ For example:
- Use to specify a command to run to download a file from the web.
+ git -c annex.security.allow-unverified-downloads=ACKTHPPT annex get myfile
- In the command line, %url is replaced with the url to download,
- and %file is replaced with the file that it should be saved to.
+ It would be a good idea to check that it downloaded the file you expected,
+ too.
* `annex.secure-erase-command`
diff --git a/git-annex.cabal b/git-annex.cabal
index 627e760..a497eea 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 6.20180529
+Version: 6.20180626
Cabal-Version: >= 1.8
License: GPL-3
Maintainer: Joey Hess <id@joeyh.name>
@@ -340,7 +340,9 @@ Executable git-annex
bloomfilter,
edit-distance,
resourcet,
- http-client,
+ connection (>= 0.2.6),
+ http-client (>= 0.4.31),
+ http-client-tls,
http-types (>= 0.7),
http-conduit (>= 2.0),
conduit,
@@ -1032,9 +1034,11 @@ Executable git-annex
Utility.Gpg
Utility.Hash
Utility.HtmlDetect
+ Utility.HttpManagerRestricted
Utility.HumanNumber
Utility.HumanTime
Utility.InodeCache
+ Utility.IPAddress
Utility.LinuxMkLibs
Utility.LockFile
Utility.LockFile.LockStatus