git-annex 6.20180529 → 6.20180626
raw patch · 76 files changed
+1573/−542 lines, 76 filesdep +connectiondep +http-client-tlsdep ~http-client
Dependencies added: connection, http-client-tls
Dependency ranges changed: http-client
Files
- Annex/Content.hs +58/−28
- Annex/Ssh.hs +5/−7
- Annex/Url.hs +59/−7
- Annex/YoutubeDl.hs +57/−22
- Assistant/DaemonStatus.hs +1/−2
- Assistant/Pairing/MakeRemote.hs +2/−1
- Assistant/Sync.hs +18/−19
- Assistant/Threads/Cronner.hs +3/−3
- Assistant/Threads/MountWatcher.hs +2/−1
- Assistant/Threads/ProblemFixer.hs +9/−6
- Assistant/Threads/RemoteControl.hs +1/−1
- Assistant/TransferSlots.hs +8/−4
- Assistant/WebApp/Configurators/Edit.hs +15/−10
- Assistant/WebApp/MakeRemote.hs +2/−1
- Assistant/WebApp/RepoList.hs +9/−8
- CHANGELOG +55/−0
- COPYRIGHT +27/−21
- Command/AddUrl.hs +1/−1
- Command/EnableRemote.hs +3/−1
- Command/Export.hs +6/−1
- Command/Get.hs +1/−1
- Command/Info.hs +24/−7
- Command/Move.hs +1/−1
- Command/Multicast.hs +1/−1
- Command/ReKey.hs +1/−1
- Command/RecvKey.hs +4/−1
- Command/Reinject.hs +1/−1
- Command/SetKey.hs +1/−1
- Command/Sync.hs +27/−22
- Command/TestRemote.hs +11/−9
- Command/TransferKey.hs +1/−1
- Command/TransferKeys.hs +1/−1
- Command/Version.hs +8/−10
- Git/Fsck.hs +26/−8
- Limit.hs +2/−0
- NEWS +26/−0
- P2P/Annex.hs +5/−1
- P2P/IO.hs +4/−4
- Remote.hs +8/−14
- Remote/Adb.hs +3/−2
- Remote/BitTorrent.hs +3/−1
- Remote/Bup.hs +4/−1
- Remote/Ddar.hs +4/−1
- Remote/Directory.hs +2/−1
- Remote/External.hs +112/−66
- Remote/External/Types.hs +9/−1
- Remote/GCrypt.hs +48/−27
- Remote/Git.hs +136/−84
- Remote/Glacier.hs +6/−1
- Remote/Helper/Git.hs +2/−1
- Remote/Helper/Special.hs +8/−0
- Remote/Helper/Ssh.hs +49/−14
- Remote/Hook.hs +4/−1
- Remote/List.hs +1/−1
- Remote/P2P.hs +3/−3
- Remote/Rsync.hs +2/−1
- Remote/S3.hs +4/−1
- Remote/Tahoe.hs +3/−1
- Remote/Web.hs +4/−1
- Remote/WebDAV.hs +4/−1
- Test.hs +4/−2
- Types/DesktopNotify.hs +20/−2
- Types/Difference.hs +25/−7
- Types/GitConfig.hs +22/−9
- Types/Key.hs +18/−1
- Types/Remote.hs +32/−3
- Types/Test.hs +24/−6
- Utility/HttpManagerRestricted.hs +232/−0
- Utility/IPAddress.hs +93/−0
- Utility/Url.hs +98/−57
- doc/git-annex-addurl.mdwn +6/−3
- doc/git-annex-groupwanted.mdwn +4/−0
- doc/git-annex-importfeed.mdwn +4/−1
- doc/git-annex-preferred-content.mdwn +6/−5
- doc/git-annex.mdwn +74/−6
- git-annex.cabal +6/−2
Annex/Content.hs view
@@ -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 @@ lockContentShared, lockContentForRemoval, ContentRemovalLock,+ RetrievalSecurityPolicy(..), getViaTmp, getViaTmpFromDisk, checkDiskSpaceToGet,@@ -78,7 +79,7 @@ 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 @@ {- 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 @@ _ -> 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 @@ ) , 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 @@ 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 @@ 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 @@ -- 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. -}
Annex/Ssh.hs view
@@ -73,7 +73,7 @@ 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 @@ - 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 @@ 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 @@ case msockfile of Nothing -> use [] Just sockfile -> do- prepSocket sockfile gc sshhost $ concat+ prepSocket sockfile sshhost $ concat [ cacheparams , map Param (remoteAnnexSshOptions gc) , portParams port
Annex/Url.hs view
@@ -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 @@ 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 @@ { 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
Annex/YoutubeDl.hs view
@@ -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 @@ youtubeDlSupported, youtubeDlCheck, youtubeDlFileName,- youtubeDlFileName',+ youtubeDlFileNameHtmlOnly, ) where import Annex.Common@@ -27,6 +27,12 @@ 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 @@ -- (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 @@ -- 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 @@ -- 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 @@ -- -- (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 @@ 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
Assistant/DaemonStatus.hs view
@@ -55,8 +55,7 @@ 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
Assistant/Pairing/MakeRemote.hs view
@@ -47,7 +47,8 @@ ("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:
Assistant/Sync.hs view
@@ -64,26 +64,25 @@ 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 @@ <$> 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 @@ 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 @@ | 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 @@ 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 @@ 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 @@ 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
Assistant/Threads/Cronner.hs view
@@ -210,11 +210,11 @@ - 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
Assistant/Threads/MountWatcher.hs view
@@ -144,7 +144,8 @@ 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
Assistant/Threads/ProblemFixer.hs view
@@ -49,20 +49,23 @@ 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
Assistant/Threads/RemoteControl.hs view
@@ -99,7 +99,7 @@ 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
Assistant/TransferSlots.hs view
@@ -106,13 +106,13 @@ - 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,10 +124,14 @@ 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,
Assistant/WebApp/Configurators/Edit.hs view
@@ -146,8 +146,8 @@ 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 @@ <*> 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 @@ 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 @@ 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 @@ | 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 @@ 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
Assistant/WebApp/MakeRemote.hs view
@@ -38,8 +38,9 @@ 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
Assistant/WebApp/RepoList.hs view
@@ -139,10 +139,11 @@ 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 @@ 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 @@ 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
CHANGELOG view
@@ -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
COPYRIGHT view
@@ -10,7 +10,7 @@ © 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 @@ 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 @@ 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 @@ 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
Command/AddUrl.hs view
@@ -277,7 +277,7 @@ -- 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)
Command/EnableRemote.hs view
@@ -92,7 +92,9 @@ 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
Command/Export.hs view
@@ -201,7 +201,7 @@ 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 @@ 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
Command/Get.hs view
@@ -109,7 +109,7 @@ | 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
Command/Info.hs view
@@ -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 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 @@ , 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
Command/Move.hs view
@@ -207,7 +207,7 @@ 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
Command/Multicast.hs view
@@ -213,7 +213,7 @@ 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
Command/ReKey.hs view
@@ -83,7 +83,7 @@ - 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
Command/RecvKey.hs view
@@ -13,6 +13,7 @@ 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 @@ 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
Command/Reinject.hs view
@@ -45,7 +45,7 @@ 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" )
Command/SetKey.hs view
@@ -33,7 +33,7 @@ -- 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
Command/Sync.hs view
@@ -275,8 +275,7 @@ 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 @@ 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 @@ 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 (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.
Command/TestRemote.hs view
@@ -123,11 +123,13 @@ -- 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 @@ 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 @@ 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 @@ , 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
Command/TransferKey.hs view
@@ -60,7 +60,7 @@ 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
Command/TransferKeys.hs view
@@ -42,7 +42,7 @@ 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,
Command/Version.hs view
@@ -48,16 +48,9 @@ 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 @@ 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
Git/Fsck.hs view
@@ -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 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 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
Limit.hs view
@@ -163,6 +163,8 @@ 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
NEWS view
@@ -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
P2P/Annex.hs view
@@ -22,6 +22,7 @@ import P2P.IO import Logs.Location import Types.NumCopies+import Types.Remote (RetrievalSecurityPolicy(..)) import Utility.Metered import Control.Monad.Free@@ -63,9 +64,12 @@ 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
P2P/IO.hs view
@@ -164,10 +164,10 @@ 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
Remote.hs view
@@ -12,6 +12,7 @@ storeKey, retrieveKeyFile, retrieveKeyFileCheap,+ retrievalSecurityPolicy, removeKey, hasKey, hasKeyCheap,@@ -51,7 +52,6 @@ forceTrust, logStatus, checkAvailable,- isXMPPRemote, claimingUrl, isExportSupported, ) where@@ -72,21 +72,20 @@ 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 @@ 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 )@@ -356,12 +356,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)
Remote/Adb.hs view
@@ -48,6 +48,7 @@ , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = \_ _ _ -> return False+ , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing , checkPresent = checkPresentDummy@@ -64,7 +65,7 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = Nothing , remotetype = remote@@ -236,7 +237,7 @@ 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)
Remote/BitTorrent.hs view
@@ -59,6 +59,8 @@ , storeKey = uploadKey , retrieveKeyFile = downloadKey , retrieveKeyFileCheap = downloadKeyCheap+ -- Bittorrent does its own hash checks.+ , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = dropKey , lockContent = Nothing , checkPresent = checkKey@@ -70,7 +72,7 @@ , config = c , gitconfig = gc , localpath = Nothing- , repo = r+ , getRepo = return r , readonly = True , availability = GloballyAvailable , remotetype = remote
Remote/Bup.hs view
@@ -59,6 +59,9 @@ , 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 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = if bupLocal buprepo && not (null buprepo) then Just buprepo
Remote/Ddar.hs view
@@ -58,6 +58,9 @@ , 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 @@ , 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
Remote/Directory.hs view
@@ -58,6 +58,7 @@ , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveKeyFileCheapM dir chunkconfig+ , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing , checkPresent = checkPresentDummy@@ -76,7 +77,7 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = Just dir , readonly = False
Remote/External.hs view
@@ -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 @@ readonlyRemoveKey (checkKeyUrl r) Nothing+ (externalInfo externaltype) Nothing Nothing exportUnsupported@@ -94,12 +95,13 @@ (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 @@ , 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 @@ , repairRepo = Nothing , config = c , localpath = Nothing- , repo = r+ , getRepo = return r , gitconfig = gc , readonly = False , availability = avail@@ -125,7 +132,7 @@ { 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 @@ _ -> 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 = 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 @@ 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 @@ 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 @@ 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 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 @@ 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 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 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 @@ - 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 @@ {- 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 @@ 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 @@ receiveMessage :: ExternalState -> External - -> (Response -> Maybe (Annex a))+ -> ResponseHandler a -> (RemoteRequest -> Maybe (Annex a)) -> (AsyncMessage -> Maybe (Annex a)) -> Annex a@@ -467,14 +483,21 @@ 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 @@ -- 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 @@ 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 @@ - 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 @@ -} 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 = 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
Remote/External/Types.hs view
@@ -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 @@ | CHECKPRESENT SafeKey | REMOVE SafeKey | WHEREIS SafeKey+ | GETINFO | EXPORTSUPPORTED | EXPORT ExportLocation | TRANSFEREXPORT Direction SafeKey FilePath@@ -162,6 +163,7 @@ [ "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 @@ | CHECKURL_FAILURE ErrorMsg | WHEREIS_SUCCESS String | WHEREIS_FAILURE+ | INFOFIELD String+ | INFOVALUE String+ | INFOEND | EXPORTSUPPORTED_SUCCESS | EXPORTSUPPORTED_FAILURE | REMOVEEXPORTDIRECTORY_SUCCESS@@ -236,6 +241,9 @@ 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
Remote/GCrypt.hs view
@@ -113,6 +113,7 @@ , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = \_ _ _ -> return False+ , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing , checkPresent = checkPresentDummy@@ -123,8 +124,8 @@ , 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 @@ 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 @@ | 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 @@ 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
Remote/Git.hs view
@@ -161,6 +161,7 @@ , 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 @@ 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 @@ {- 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 @@ 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 @@ 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 = 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ - 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 @@ - 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 @@ 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 @@ , 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 @@ - 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)
Remote/Glacier.hs view
@@ -55,6 +55,11 @@ , 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 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = Nothing , readonly = False
Remote/Helper/Git.hs view
@@ -42,7 +42,8 @@ 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) ]
Remote/Helper/Special.hs view
@@ -162,6 +162,14 @@ (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
Remote/Helper/Ssh.hs view
@@ -27,6 +27,8 @@ 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 @@ -- 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 @@ -- 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 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 @@ 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 @@ 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
Remote/Hook.hs view
@@ -49,6 +49,9 @@ , 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 @@ , repairRepo = Nothing , config = c , localpath = Nothing- , repo = r+ , getRepo = return r , gitconfig = gc , readonly = False , availability = GloballyAvailable
Remote/List.hs view
@@ -111,7 +111,7 @@ 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
Remote/P2P.hs view
@@ -18,7 +18,6 @@ import P2P.IO import P2P.Auth import Types.Remote-import Types.GitConfig import qualified Git import Annex.UUID import Config@@ -54,6 +53,7 @@ , 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 @@ , repairRepo = Nothing , config = c , localpath = Nothing- , repo = r- , gitconfig = gc { remoteGitConfig = extractGitConfig r }+ , getRepo = return r+ , gitconfig = gc , readonly = False , availability = GloballyAvailable , remotetype = remote
Remote/Rsync.hs view
@@ -72,6 +72,7 @@ , storeKey = storeKeyDummy , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap o+ , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy , lockContent = Nothing , checkPresent = checkPresentDummy@@ -88,7 +89,7 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = if islocal then Just $ rsyncUrl o
Remote/S3.hs view
@@ -84,6 +84,9 @@ , 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 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = Nothing , readonly = False
Remote/Tahoe.hs view
@@ -73,6 +73,8 @@ , 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 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = Nothing , readonly = False
Remote/Web.hs view
@@ -48,6 +48,9 @@ , 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 @@ , config = c , gitconfig = gc , localpath = Nothing- , repo = r+ , getRepo = return r , readonly = True , availability = GloballyAvailable , remotetype = remote
Remote/WebDAV.hs view
@@ -72,6 +72,9 @@ , 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 @@ , remoteFsck = Nothing , repairRepo = Nothing , config = c- , repo = r+ , getRepo = return r , gitconfig = gc , localpath = Nothing , readonly = False
Test.hs view
@@ -1714,10 +1714,12 @@ 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")
Types/DesktopNotify.hs view
@@ -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 @@ } 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
Types/Difference.hs view
@@ -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 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 @@ , 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
Types/GitConfig.hs view
@@ -19,6 +19,7 @@ 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 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 @@ , annexWebOptions :: [String] , annexYoutubeDlOptions :: [String] , annexAriaTorrentOptions :: [String]- , annexWebDownloadCommand :: Maybe String , annexCrippledFileSystem :: Bool , annexLargeFiles :: Maybe String , annexAddSmallFiles :: Bool@@ -92,12 +94,14 @@ , 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 @@ , 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 @@ , 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 @@ {- 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 @@ , 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 @@ , remoteAnnexDdarRepo = getmaybe "ddarrepo" , remoteAnnexHookType = notempty $ getmaybe "hooktype" , remoteAnnexExternalType = notempty $ getmaybe "externaltype"- , remoteGitConfig = extractGitConfig r } where getbool k d = fromMaybe d $ getmaybebool k
Types/Key.hs view
@@ -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. -}@@ -87,6 +87,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
Types/Remote.hs view
@@ -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 @@ , Availability(..) , Verification(..) , unVerified+ , RetrievalSecurityPolicy(..) , isExportSupported , ExportActions(..) )@@ -85,6 +86,8 @@ -- 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 @@ , 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@@ -164,6 +167,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)
Types/Test.hs view
@@ -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 @@ , 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 ()
+ Utility/HttpManagerRestricted.hs view
@@ -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
+ Utility/IPAddress.hs view
@@ -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
Utility/Url.hs view
@@ -15,6 +15,10 @@ managerSettings, URLString, UserAgent,+ Scheme,+ mkScheme,+ allowedScheme,+ UrlDownloader(..), UrlOptions(..), defUrlOptions, mkUrlOptions,@@ -34,6 +38,7 @@ import Common import Utility.Metered+import Utility.HttpManagerRestricted import Network.URI import Network.HTTP.Types@@ -41,9 +46,10 @@ 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 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 @@ <*> 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 @@ _ -> (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,7 +132,32 @@ 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. -} checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO Bool@@ -158,32 +191,26 @@ - 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 @@ then found (extractlen resp) (extractfilename resp)- else dne+ else return dne existscurl u = do output <- catchDefaultIO "" $@@ -230,7 +257,16 @@ -- 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 @@ {- 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 @@ `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 @@ 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 @@ , 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.
doc/git-annex-addurl.mdwn view
@@ -10,9 +10,12 @@ 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`.
doc/git-annex-groupwanted.mdwn view
@@ -21,6 +21,10 @@ 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)
doc/git-annex-importfeed.mdwn view
@@ -13,8 +13,11 @@ 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`
doc/git-annex-preferred-content.mdwn view
@@ -172,12 +172,13 @@ * `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
doc/git-annex.mdwn view
@@ -1228,7 +1228,7 @@ 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 @@ * `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 @@ 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` - Use to specify a command to run to download a file from the web.+ List of URL schemes that git-annex is allowed to download content from.+ The default is "http https ftp". - 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.+ 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:++ git -c annex.security.allow-unverified-downloads=ACKTHPPT annex get myfile++ It would be a good idea to check that it downloaded the file you expected,+ too. * `annex.secure-erase-command`
git-annex.cabal view
@@ -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 @@ 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 @@ Utility.Gpg Utility.Hash Utility.HtmlDetect+ Utility.HttpManagerRestricted Utility.HumanNumber Utility.HumanTime Utility.InodeCache+ Utility.IPAddress Utility.LinuxMkLibs Utility.LockFile Utility.LockFile.LockStatus