diff --git a/Annex/Balanced.hs b/Annex/Balanced.hs --- a/Annex/Balanced.hs +++ b/Annex/Balanced.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE PackageImports #-} + module Annex.Balanced where import Key @@ -15,7 +17,7 @@ import qualified Data.List as L import Data.Bits (shiftL) import qualified Data.Set as S -import qualified Data.ByteArray as BA +import qualified "memory" Data.ByteArray as BA -- The Int is how many UUIDs to pick. type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID] diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -897,19 +897,19 @@ - Otherwise, only displays one error message, from one of the urls - that failed. -} -downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex Bool -downloadUrl listfailedurls k p iv urls file uo = - downloadUrl' listfailedurls k p iv urls file uo >>= \case +downloadUrl :: MeterSize sizer => Bool -> sizer -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex Bool +downloadUrl listfailedurls sizer p iv urls file uo = + downloadUrl' listfailedurls sizer p iv urls file uo >>= \case Right r -> return r Left e -> do warning $ UnquotedString e return False -downloadUrl' :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex (Either String Bool) -downloadUrl' listfailedurls k p iv urls file uo = +downloadUrl' :: MeterSize sizer => Bool -> sizer -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex (Either String Bool) +downloadUrl' listfailedurls sizer p iv urls file uo = -- Poll the file to handle configurations where an external -- download command is used. - meteredFile file (Just p) k (go urls []) + meteredFile file (Just p) sizer (go urls []) where go (u:us) errs p' = Url.download' p' iv u file uo >>= \case Right () -> return (Right True) diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE PackageImports #-} + module Annex.DirHashes ( Hasher, HashLevels(..), @@ -20,7 +22,7 @@ import Data.Default import Data.Bits import qualified Data.List.NonEmpty as NE -import qualified Data.ByteArray as BA +import qualified "memory" Data.ByteArray as BA import qualified Data.ByteString as S import Common diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -30,11 +30,13 @@ warnExportImportConflict :: Remote -> Annex () warnExportImportConflict r = do - isimport <- Remote.isImportSupported r isexport <- Remote.isExportSupported r - let (ops, resolvcmd) = case (isexport, isimport) of - (False, True) -> ("imported from", "git-annex import") - (True, False) -> ("exported to", "git-annex export") + isimport <- Remote.isImportSupported r + isexportimport <- Remote.isExportImportSupported r + let (ops, resolvcmd) = case (isexport, isimport, isexportimport) of + (False, _, True) -> ("exported to and/or imported from", "git-annex import") + (True, _, False) -> ("exported to", "git-annex export") + (False, True, False) -> ("imported from", "git-annex import") _ -> ("exported to and/or imported from", "git-annex export") toplevelWarning True $ UnquotedString $ unwords [ "Conflict detected. Different trees have been" diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-} module Annex.Import ( @@ -71,7 +72,7 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.ByteArray.Encoding as BA +import qualified "memory" Data.ByteArray.Encoding as BA #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix #endif @@ -502,7 +503,7 @@ canImportKeys remote importcontent = importcontent || isJust (Remote.importKey ia) where - ia = Remote.importActions remote + ia = Remote.exportImportActions remote -- Result of an import. data ImportResult t @@ -806,7 +807,7 @@ return (Right job) thirdpartypopulatedimport db (loc, (cid, sz)) = - case Remote.importKey ia of + case Remote.importKey (Remote.exportImportActions remote) of Nothing -> return Nothing Just importkey -> tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case @@ -826,7 +827,7 @@ -- than downloading and retrieving a key, to avoid -- generating trees with different keys for the same content. let act = if importcontent - then case Remote.importKey ia of + then case Remote.importKey (Remote.exportImportActions remote) of Nothing -> dodownload Just _ -> if Utility.Matcher.introspect matchNeedsFileContent (fst matcher) then dodownload @@ -835,7 +836,7 @@ act cidmap (loc, (cid, sz)) f matcher doimport cidmap (loc, (cid, sz)) f matcher = - case Remote.importKey ia of + case Remote.importKey (Remote.exportImportActions remote) of Nothing -> error "internal" -- checked earlier Just importkey -> do when (Utility.Matcher.introspect matchNeedsFileContent (fst matcher)) $ @@ -882,8 +883,9 @@ getcontent k = do let af = AssociatedFile (Just f) let downloader p' tmpfile = do - _ <- Remote.retrieveExportWithContentIdentifier - ia loc [cid] tmpfile + _ <- Remote.retrieveImport + (Remote.importActions remote) + loc [cid] tmpfile (Left k) (combineMeterUpdate p' p) ok <- moveAnnex k tmpfile @@ -900,8 +902,9 @@ -- need to retrieve this file. doimportsmall cidmap loc cid sz p = do let downloader tmpfile = do - (k, _) <- Remote.retrieveExportWithContentIdentifier - ia loc [cid] tmpfile + (k, _) <- Remote.retrieveImport + (Remote.importActions remote) + loc [cid] tmpfile (Right (mkkey tmpfile)) p case keyGitSha k of @@ -923,8 +926,9 @@ dodownload cidmap (loc, (cid, sz)) f matcher = do let af = AssociatedFile (Just f) let downloader tmpfile p = do - (k, _) <- Remote.retrieveExportWithContentIdentifier - ia loc [cid] tmpfile + (k, _) <- Remote.retrieveImport + (Remote.importActions remote) + loc [cid] tmpfile (Right (mkkey tmpfile)) p case keyGitSha k of @@ -970,8 +974,6 @@ } fst <$> genKey ks nullMeterUpdate backend else gitShaKey <$> hashFile tmpfile - - ia = Remote.importActions remote bwlimit = remoteAnnexBwLimitDownload (Remote.gitconfig remote) <|> remoteAnnexBwLimit (Remote.gitconfig remote) diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -428,7 +428,7 @@ return ok warnstall annexrunner = do - threadDelaySeconds (Seconds 10) + threadDelaySeconds (SecondsDelay 10) annexrunner $ do warning "Probing the filesystem for POSIX fcntl lock support is taking a long time." warning "(Setting annex.pidlock will avoid this probe.)" diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -194,7 +194,7 @@ gotall <- liftIO $ receivetofile iv h len liftIO $ hClose h verified <- if gotall - then fst <$> finishVerifyKeyContentIncrementally' True iv + then fst <$> finishVerifyKeyContentIncrementally iv else pure False let store = tryNonAsync (storeput k af tmpfile) >>= \case Right () -> liftIO $ sendmessage SUCCESS diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -288,6 +288,10 @@ yesno "no" = Just False yesno _ = Nothing +yesNoGenerator :: Bool -> String +yesNoGenerator True = "yes" +yesNoGenerator False = "no" + trueFalseParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser trueFalseParser f mdef fd = genParser trueFalseParser' f mdef fd (Just (ValueDesc "true or false")) diff --git a/Annex/StallDetection.hs b/Annex/StallDetection.hs --- a/Annex/StallDetection.hs +++ b/Annex/StallDetection.hs @@ -55,7 +55,7 @@ let BwRate scaledminsz scaledduration = upscale bwrate timepassed detectStalls' scaledminsz scaledduration metervar onstall v where - minwaitsecs = Seconds $ + minwaitsecs = SecondsDelay $ min 60 (fromIntegral (durationSeconds duration)) waitforfirstupdate startval = do liftIO $ threadDelaySeconds minwaitsecs @@ -75,7 +75,7 @@ where duration = Duration 60 - delay = Seconds (fromIntegral (durationSeconds duration) `div` 2) + delay = SecondsDelay (fromIntegral (durationSeconds duration) `div` 2) waitforfirstupdate startval = do liftIO $ threadDelaySeconds delay @@ -115,7 +115,7 @@ | sofar - prev < minsz -> onstall | otherwise -> cont where - delay = Seconds (fromIntegral (durationSeconds duration)) + delay = SecondsDelay (fromIntegral (durationSeconds duration)) readMeterVar :: MonadIO m diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -38,7 +38,7 @@ -- cleaned up by another git-annex process (after they're a week old). -- -- Unlike withOtherTmp, this does not rely on locking working. --- Its main use is in situations where the state of lockfile is not +-- Its main use is in situations where the state of locking is not -- determined yet, eg during initialization. withEventuallyCleanedOtherTmp :: (OsPath -> Annex a) -> Annex a withEventuallyCleanedOtherTmp = bracket setup cleanup diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -360,19 +360,19 @@ - by git configuration. -} configuredRetry :: RetryDecider configuredRetry numretries _old new = do - (maxretries, Seconds initretrydelay) <- getcfg $ + (maxretries, SecondsDelay initretrydelay) <- getcfg $ Remote.gitconfig <$> transferRemote new if numretries < maxretries then do - let retrydelay = Seconds (initretrydelay * 2^(numretries-1)) - showSideAction $ UnquotedString $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying." + let retrydelay = SecondsDelay (initretrydelay * 2^(numretries-1)) + showSideAction $ UnquotedString $ "Delaying " ++ show (fromSecondsDelay retrydelay) ++ "s before retrying." liftIO $ threadDelaySeconds retrydelay return True else return False where globalretrycfg = fromMaybe 0 . annexRetry <$> Annex.getGitConfig - globalretrydelaycfg = fromMaybe (Seconds 1) . annexRetryDelay + globalretrydelaycfg = fromMaybe (SecondsDelay 1) . annexRetryDelay <$> Annex.getGitConfig getcfg Nothing = (,) <$> globalretrycfg <*> globalretrydelaycfg getcfg (Just gc) = (,) diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -247,14 +247,14 @@ (AssistantLevel, Upload) -> AssistantUploadRequest (AssistantLevel, Download) -> AssistantDownloadRequest let r = f tr (transferKey t) (TransferAssociatedFile afile) - let l = unwords $ Proto.formatMessage r + let l = Proto.genMessage r debug "Annex.TransferrerPool" ("> " ++ l) hPutStrLn h l hFlush h sendSerializedOutputResponse :: Handle -> SerializedOutputResponse -> IO () sendSerializedOutputResponse h sor = do - let l = unwords $ Proto.formatMessage $ + let l = Proto.genMessage $ TransferSerializedOutputResponse sor debug "Annex.TransferrerPool" ("> " ++ show l) hPutStrLn h l diff --git a/Annex/Verify.hs b/Annex/Verify.hs --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -1,6 +1,6 @@ {- verification - - - Copyright 2010-2024 Joey Hess + - Copyright 2010-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,8 +19,8 @@ isVerifiable, startVerifyKeyContentIncrementally, finishVerifyKeyContentIncrementally, - finishVerifyKeyContentIncrementally', verifyKeyContentIncrementally, + verifyKeyContentIncrementally', IncrementalVerifier(..), writeVerifyChunk, resumeVerifyFromOffset, @@ -76,6 +76,7 @@ verifyKeyContentPostRetrieval :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> OsPath -> Annex Bool verifyKeyContentPostRetrieval rsp v verification k f = case (rsp, verification) of (_, Verified) -> return True + (_, VerificationFailed) -> return False (RetrievalVerifiableKeysSecure, _) -> ifM (isVerifiable k) ( verify , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) @@ -199,26 +200,25 @@ ) finishVerifyKeyContentIncrementally :: Maybe IncrementalVerifier -> Annex (Bool, Verification) -finishVerifyKeyContentIncrementally = finishVerifyKeyContentIncrementally' False - -finishVerifyKeyContentIncrementally' :: Bool -> Maybe IncrementalVerifier -> Annex (Bool, Verification) -finishVerifyKeyContentIncrementally' _ Nothing = +finishVerifyKeyContentIncrementally Nothing = return (True, UnVerified) -finishVerifyKeyContentIncrementally' quiet (Just iv) = +finishVerifyKeyContentIncrementally (Just iv) = liftIO (finalizeIncrementalVerifier iv) >>= \case Just True -> return (True, Verified) - Just False -> do - unless quiet $ - warning "verification of content failed" - return (False, UnVerified) + Just False -> return (False, VerificationFailed) -- Incremental verification was not able to be done. Nothing -> return (True, UnVerified) -verifyKeyContentIncrementally :: VerifyConfig -> Key -> (Maybe IncrementalVerifier -> Annex ()) -> Annex Verification -verifyKeyContentIncrementally verifyconfig k a = do +verifyKeyContentIncrementally :: VerifyConfig -> Key -> (Maybe IncrementalVerifier -> Annex ()) -> Annex (Verification) +verifyKeyContentIncrementally verifyconfig k a = + snd <$> verifyKeyContentIncrementally' verifyconfig k a + +verifyKeyContentIncrementally' :: VerifyConfig -> Key -> (Maybe IncrementalVerifier -> Annex a) -> Annex (a, Verification) +verifyKeyContentIncrementally' verifyconfig k a = do miv <- startVerifyKeyContentIncrementally verifyconfig k - a miv - snd <$> finishVerifyKeyContentIncrementally miv + r <- a miv + v <- snd <$> finishVerifyKeyContentIncrementally miv + return (r, v) writeVerifyChunk :: Maybe IncrementalVerifier -> Handle -> S.ByteString -> IO () writeVerifyChunk (Just iv) h c = do diff --git a/Assistant/CredPairCache.hs b/Assistant/CredPairCache.hs --- a/Assistant/CredPairCache.hs +++ b/Assistant/CredPairCache.hs @@ -27,7 +27,7 @@ - Note that repeatedly caching the same CredPair - does not reset its expiry time. -} -cacheCred :: CredPair -> Seconds -> Assistant () +cacheCred :: CredPair -> SecondsDelay -> Assistant () cacheCred (login, password) expireafter = do cache <- getAssistant credPairCache liftIO $ do diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -149,7 +149,7 @@ go [] = return () go l = whenM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l)) $ do debug ["Waiting for 60 seconds to check stale git lock file"] - liftIO $ threadDelaySeconds $ Seconds 60 + liftIO $ threadDelaySeconds $ SecondsDelay 60 l' <- getsizes if l' == l then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -52,7 +52,7 @@ modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus void $ liftIO $ forkIO $ do - threadDelaySeconds (Seconds 120) + threadDelaySeconds (SecondsDelay 120) terminateSelf terminateSelf :: IO () diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -59,7 +59,7 @@ commitThread = namedThread "Committer" $ do havelsof <- liftIO $ inSearchPath "lsof" delayadd <- liftAnnex $ - fmap Seconds . annexDelayAdd <$> Annex.getGitConfig + fmap SecondsDelay . annexDelayAdd <$> Annex.getGitConfig largefilematcher <- liftAnnex largeFilesMatcher annexdotfiles <- liftAnnex $ getGitConfigVal annexDotFiles addunlockedmatcher <- liftAnnex $ @@ -111,7 +111,7 @@ where waitchanges lastcommitsize = do -- Wait one one second as a simple rate limiter. - liftIO $ threadDelaySeconds (Seconds 1) + liftIO $ threadDelaySeconds (SecondsDelay 1) -- Now, wait until at least one change is available for -- processing. cs <- getChanges @@ -193,7 +193,7 @@ loop 0 = continue oldchanges loop n = do liftAnnex noop -- ensure Annex state is free - liftIO $ threadDelaySeconds (Seconds 1) + liftIO $ threadDelaySeconds (SecondsDelay 1) changes <- getAnyChanges if null changes then loop (n - 1) @@ -280,7 +280,7 @@ - Any pending adds that are not ready yet are put back into the ChangeChan, - where they will be retried later. -} -handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe AddUnlockedMatcher -> Maybe Seconds -> [Change] -> Assistant [Change] +handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe AddUnlockedMatcher -> Maybe SecondsDelay -> [Change] -> Assistant [Change] handleAdds lockdowndir havelsof largefilematcher annexdotfiles addunlockedmatcher delayadd cs = returnWhen (null incomplete) $ do let (pending, inprocess) = partition isPendingAddChange incomplete let lockdownconfig = LockDownConfig @@ -467,7 +467,7 @@ - - Check by running lsof on the repository. -} -safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change] +safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe SecondsDelay -> [Change] -> [Change] -> Assistant [Either Change Change] safeToAdd _ _ _ _ [] [] = return [] safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do maybe noop (liftIO . threadDelaySeconds) delayadd diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -50,7 +50,7 @@ {- Record a commit to get this config - change pushed out to remotes. -} recordCommit - liftIO $ threadDelaySeconds (Seconds 60) + liftIO $ threadDelaySeconds (SecondsDelay 60) loop new {- Config files, and their checksums. -} diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -116,8 +116,8 @@ desc = fromScheduledActivity activity schedule = getSchedule activity waitrun l t mmaxt = do - seconds <- liftIO $ secondsUntilLocalTime t - when (seconds > Seconds 0) $ do + seconds <- liftIO $ secondsDelayUntilLocalTime t + when (seconds > SecondsDelay 0) $ do debug ["waiting", show seconds, "for next scheduled", desc] liftIO $ threadDelaySeconds seconds now <- liftIO getCurrentTime @@ -161,14 +161,14 @@ go _ = noop -- running at exact time not handled here loop = remoteActivityThread urlrenderer mvar activity -secondsUntilLocalTime :: LocalTime -> IO Seconds -secondsUntilLocalTime t = do +secondsDelayUntilLocalTime :: LocalTime -> IO SecondsDelay +secondsDelayUntilLocalTime t = do now <- getCurrentTime tz <- getTimeZone now let secs = truncate $ diffUTCTime (localTimeToUTC tz t) now return $ if secs > 0 - then Seconds secs - else Seconds 0 + then SecondsDelay secs + else SecondsDelay 0 runActivity :: UrlRenderer -> ScheduledActivity -> LocalTime -> Assistant () runActivity urlrenderer activity nowt = do diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs --- a/Assistant/Threads/DaemonStatus.hs +++ b/Assistant/Threads/DaemonStatus.hs @@ -20,7 +20,7 @@ notifier <- liftIO . newNotificationHandle False =<< changeNotifier <$> getDaemonStatus checkpoint - runEvery (Seconds tenMinutes) <~> do + runEvery (SecondsDelay tenMinutes) <~> do liftIO $ waitNotification notifier checkpoint where diff --git a/Assistant/Threads/Exporter.hs b/Assistant/Threads/Exporter.hs --- a/Assistant/Threads/Exporter.hs +++ b/Assistant/Threads/Exporter.hs @@ -25,7 +25,7 @@ {- This thread retries exports that failed before. -} exportRetryThread :: NamedThread -exportRetryThread = namedThread "ExportRetrier" $ runEvery (Seconds halfhour) <~> do +exportRetryThread = namedThread "ExportRetrier" $ runEvery (SecondsDelay halfhour) <~> do -- We already waited half an hour, now wait until there are failed -- exports to retry. toexport <- getFailedPushesBefore (fromIntegral halfhour) @@ -38,7 +38,7 @@ {- This thread updates exports soon after git commits are made. -} exportThread :: NamedThread -exportThread = namedThread "Exporter" $ runEvery (Seconds 30) <~> do +exportThread = namedThread "Exporter" $ runEvery (SecondsDelay 30) <~> do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made void getExportCommits diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -25,7 +25,7 @@ - downloads. If so, runs glacier-cli to check if the files are now - available, and queues the downloads. -} glacierThread :: NamedThread -glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go +glacierThread = namedThread "Glacier" $ runEvery (SecondsDelay 3600) <~> go where isglacier r = Remote.remotetype r == Glacier.remote go = do diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -131,7 +131,7 @@ pollingThread urlrenderer = go =<< liftIO currentMountPoints where go wasmounted = do - liftIO $ threadDelaySeconds (Seconds 10) + liftIO $ threadDelaySeconds (SecondsDelay 10) nowmounted <- liftIO currentMountPoints handleMounts urlrenderer wasmounted nowmounted go nowmounted diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -48,7 +48,7 @@ -} netWatcherFallbackThread :: NamedThread netWatcherFallbackThread = namedThread "NetWatcherFallback" $ - runEvery (Seconds 3600) <~> handleConnection + runEvery (SecondsDelay 3600) <~> handleConnection #if WITH_DBUS @@ -80,7 +80,7 @@ liftAnnex $ warning $ UnquotedString $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" {- Wait, in hope that dbus will come back -} - liftIO $ threadDelaySeconds (Seconds 60) + liftIO $ threadDelaySeconds (SecondsDelay 60) {- Examine the list of services connected to dbus, to see if there - are any we can use to monitor network connections. -} diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs --- a/Assistant/Threads/ProblemFixer.hs +++ b/Assistant/Threads/ProblemFixer.hs @@ -30,7 +30,7 @@ where go problems = do mapM_ (handleProblem urlrenderer) problems - liftIO $ threadDelaySeconds (Seconds 60) + liftIO $ threadDelaySeconds (SecondsDelay 60) -- Problems may have been re-reported while they were being -- fixed, so ignore those. If a new unique problem happened -- 60 seconds after the last was fixed, we're unlikely diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -18,7 +18,7 @@ {- This thread retries pushes that failed before. -} pushRetryThread :: NamedThread -pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do +pushRetryThread = namedThread "PushRetrier" $ runEvery (SecondsDelay halfhour) <~> do -- We already waited half an hour, now wait until there are failed -- pushes to retry. topush <- getFailedPushesBefore (fromIntegral halfhour) @@ -31,7 +31,7 @@ {- This thread pushes git commits out to remotes soon after they are made. -} pushThread :: NamedThread -pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do +pushThread = namedThread "Pusher" $ runEvery (SecondsDelay 2) <~> do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made void getCommits diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -62,7 +62,7 @@ msg <- liftIO $ readChan clicker debug [show msg] liftIO $ do - hPutStrLn toh $ unwords $ formatMessage msg + hPutStrLn toh $ genMessage msg hFlush toh -- read status messages emitted by the remotedaemon and handle them diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -91,7 +91,7 @@ void $ liftAnnex $ tryNonAsync $ cleanupOtherTmp {- If there's a startup delay, it's done here. -} - liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay + liftIO $ maybe noop (threadDelaySeconds . SecondsDelay . fromIntegral . durationSeconds) startupdelay {- Notify other threads that the startup sanity check is done. -} status <- getDaemonStatus @@ -100,7 +100,7 @@ {- This thread wakes up hourly for inxepensive frequent sanity checks. -} sanityCheckerHourlyThread :: NamedThread sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do - liftIO $ threadDelaySeconds $ Seconds oneHour + liftIO $ threadDelaySeconds $ SecondsDelay oneHour hourlyCheck {- This thread wakes up daily to make sure the tree is in good shape. -} @@ -135,7 +135,7 @@ waitForNextCheck = do v <- lastSanityCheck <$> getDaemonStatus now <- liftIO getPOSIXTime - liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v + liftIO $ threadDelaySeconds $ SecondsDelay $ calcdelay now v where calcdelay _ Nothing = oneDay calcdelay now (Just lastcheck) diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -45,7 +45,7 @@ where go scanned = do scanrunning False - liftIO $ threadDelaySeconds (Seconds 2) + liftIO $ threadDelaySeconds (SecondsDelay 2) (rs, infos) <- unzip <$> getScanRemote scanrunning True if any fullScan infos || any (`S.notMember` scanned) rs diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -80,7 +80,7 @@ -- place.) Not needed when using a distribution bundle, because -- in that case git-annex handles the upgrade in a non-racy way. liftIO $ unlessM usingDistribution $ - threadDelaySeconds (Seconds 120) + threadDelaySeconds (SecondsDelay 120) ifM autoUpgradeEnabled ( do debug ["starting automatic upgrade"] diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -125,7 +125,7 @@ _ -> noop _ -> noop where - pause = runEvery (Seconds 86400) noop + pause = runEvery (SecondsDelay 86400) noop {- Initial scartup scan. The action should return once the scan is complete. -} startupScan :: IO a -> Assistant a diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -96,7 +96,7 @@ Annex.getRead Annex.signalactions withTransferrer' True signalactonsvar mkcheck rt p run pause = catchPauseResume $ - runEvery (Seconds 86400) noop + runEvery (SecondsDelay 86400) noop {- Note: This must use E.try, rather than E.catch. - When E.catch is used, and has called go in its exception - handler, Control.Concurrent.throwTo will block sometimes diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -311,7 +311,7 @@ -- upgrades, manual upgrades, etc. program <- programPath untilM (doesFileExist program <&&> nowriter program) $ - threadDelaySeconds (Seconds 60) + threadDelaySeconds (SecondsDelay 60) boolSystem (fromOsPath program) [Param "version"] ) where diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -365,7 +365,7 @@ ExistingSshKey -> liftIO $ go [passwordprompts 0] Nothing CachedPassword -> setupAskPass Password -> do - cacheCred (login, geti inputPassword) (Seconds $ 60 * 10) + cacheCred (login, geti inputPassword) (SecondsDelay $ 60 * 10) setupAskPass where login = getLogin sshinput diff --git a/Backend/External.hs b/Backend/External.hs --- a/Backend/External.hs +++ b/Backend/External.hs @@ -161,7 +161,7 @@ hPutStrLn (externalSend p) line hFlush (externalSend p) where - line = unwords $ Proto.formatMessage m + line = Proto.genMessage m {- A response handler can yield a result, or it can request that another - message be consumed from the external. -} @@ -347,8 +347,10 @@ deserialize = ProtocolVersion <$$> readish instance Proto.Sendable ExceptionalMessage where - formatMessage (ERROR err) = ["ERROR", Proto.serialize err] - formatMessage (DEBUG msg) = ["DEBUG", Proto.serialize msg] + formatMessage (ERROR err) = Proto.mkMessage + ["ERROR", Proto.serialize err] + formatMessage (DEBUG msg) = Proto.mkMessage + ["DEBUG", Proto.serialize msg] instance Proto.Receivable ExceptionalMessage where parseCommand "ERROR" = Proto.parse1 ERROR @@ -356,12 +358,14 @@ parseCommand _ = Proto.parseFail instance Proto.Sendable Request where - formatMessage GETVERSION = ["GETVERSION"] - formatMessage CANVERIFY = ["CANVERIFY"] - formatMessage ISSTABLE = ["ISSTABLE"] - formatMessage ISCRYPTOGRAPHICALLYSECURE = ["ISCRYPTOGRAPHICALLYSECURE"] - formatMessage (GENKEY file) = ["GENKEY", Proto.serialize file] - formatMessage (VERIFYKEYCONTENT key file) = + formatMessage GETVERSION = Proto.mkMessage ["GETVERSION"] + formatMessage CANVERIFY = Proto.mkMessage ["CANVERIFY"] + formatMessage ISSTABLE = Proto.mkMessage ["ISSTABLE"] + formatMessage ISCRYPTOGRAPHICALLYSECURE = Proto.mkMessage + ["ISCRYPTOGRAPHICALLYSECURE"] + formatMessage (GENKEY file) = Proto.mkMessage + ["GENKEY", Proto.serialize file] + formatMessage (VERIFYKEYCONTENT key file) = Proto.mkMessage ["VERIFYKEYCONTENT", Proto.serialize key, Proto.serialize file] instance Proto.Receivable Response where diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -80,6 +80,9 @@ #else #warning Building without XXH3 support. #endif +#ifdef WITH_NOLLMDEPENDENCIES + , "NoLLMDependencies" +#endif ] -- Not a complete list, let alone a listing transitive deps, but only diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,25 @@ +git-annex (10.20260717) upstream; urgency=medium + + * External special remote protocol extended to support import. + Developers of external special remotes should consider if import makes + sense for them and add support. + * Support importtree=yes with rsync special remotes. + * Added git-annex-remote-internetarchive special remote that imports an + Internet Archive item and serves as an example for how to easily write + importtree=yes external special remotes. + https://git-annex.branchable.com/tips/how_to_make_a_simple_importtree_special_remote/ + * Added DOWNLOAD-URL extension to the external special remote protocol. + * git-annex is guaranteed to not contain LLM generated code, + and will attempt to remain buildable with versions of dependencies + that predate the addition of any LLM generated code. + See https://git-annex.branchable.com/no_llm_code/ + * git-annex.cabal: Added NoLLMDependencies build flag. + * Added stack-NoLLMDependencies.yaml + * Avoid redundant hash verification after a hash verification fails. + * Fix build with time-1.15. + + -- Joey Hess Mon, 20 Jul 2026 13:04:47 -0400 + git-annex (10.20260624) upstream; urgency=medium * Added Botan build flag, which speeds up checksumming significantly diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -114,7 +114,7 @@ liftIO (tryNonAsync $ connectPeer Nothing addr) >>= \case Left e -> do warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propagated to the Tor network. (" ++ show e ++ ") Will retry.." - liftIO $ threadDelaySeconds (Seconds 2) + liftIO $ threadDelaySeconds (SecondsDelay 2) check (n-1) addrs Right conn -> do liftIO $ closeConnection conn diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -74,32 +74,32 @@ {- Delay for either a fraction of a second, or a few seconds, or up - to 1 minute. - - - The MinutesDelay is used as an opportunity to do housekeeping tasks. + - The RandomMinutesDelay is used as an opportunity to do housekeeping tasks. -} -randomDelay :: Delay -> Annex () -randomDelay TinyDelay = liftIO $ +randomDelay :: RandomDelay -> Annex () +randomDelay RandomTinyDelay = liftIO $ threadDelay =<< getStdRandom (randomR (10000, 1000000)) -randomDelay SecondsDelay = liftIO $ - threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10)) -randomDelay MinutesDelay = do - liftIO $ threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60)) +randomDelay RandomSecondsDelay = liftIO $ + threadDelaySeconds =<< SecondsDelay <$> getStdRandom (randomR (1, 10)) +randomDelay RandomMinutesDelay = do + liftIO $ threadDelaySeconds =<< SecondsDelay <$> getStdRandom (randomR (1, 60)) reserve <- annexDiskReserve <$> Annex.getGitConfig free <- liftIO $ getDiskFree "." case free of Just have | have < reserve -> do warning "Low disk space; fuzz test paused." - liftIO $ threadDelaySeconds (Seconds 60) - randomDelay MinutesDelay + liftIO $ threadDelaySeconds (SecondsDelay 60) + randomDelay RandomMinutesDelay _ -> noop -data Delay - = TinyDelay - | SecondsDelay - | MinutesDelay +data RandomDelay + = RandomTinyDelay + | RandomSecondsDelay + | RandomMinutesDelay deriving (Read, Show, Eq) -instance Arbitrary Delay where - arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay] +instance Arbitrary RandomDelay where + arbitrary = elements [RandomTinyDelay, RandomSecondsDelay, RandomMinutesDelay] data FuzzFile = FuzzFile FilePath deriving (Read, Show, Eq) @@ -161,7 +161,7 @@ | FuzzMove FuzzFile FuzzFile | FuzzDeleteDir FuzzDir | FuzzMoveDir FuzzDir FuzzDir - | FuzzPause Delay + | FuzzPause RandomDelay deriving (Read, Show, Eq) instance Arbitrary FuzzAction where diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -141,7 +141,7 @@ `withPathContents` importFiles o seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do r <- getParsed (importFromRemote o) - unlessM (Remote.isImportSupported r) $ + unlessM (Remote.isExportImportSupported r <||> Remote.isImportSupported r) $ giveup "That remote does not support imports." subdir <- maybe (pure Nothing) diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs --- a/Command/NotifyChanges.hs +++ b/Command/NotifyChanges.hs @@ -40,5 +40,5 @@ send :: Notification -> IO () send n = do - putStrLn $ unwords $ formatMessage n + putStrLn $ genMessage n hFlush stdout diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -286,7 +286,7 @@ where go 0 [] _ _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "." go n [] theirauthtoken ourauthtoken = do - liftIO $ threadDelaySeconds (Seconds 2) + liftIO $ threadDelaySeconds (SecondsDelay 2) liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..." go (n-1) theiraddrs theirauthtoken ourauthtoken go n (theiraddr:rest) theirauthtoken ourauthtoken = do diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -117,7 +117,7 @@ sendTransferResponse :: Handle -> TransferResponse -> IO () sendTransferResponse h r = silenceIOErrors $ do - hPutStrLn h $ unwords $ Proto.formatMessage r + hPutStrLn h $ Proto.genMessage r hFlush h getNextLine :: Handle -> IO String diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -1,6 +1,6 @@ {- git-annex progress output - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -51,6 +51,11 @@ instance MeterSize KeySource where getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache +data UnknownSize = UnknownSize + +instance MeterSize UnknownSize where + getMeterSize UnknownSize = pure Nothing + {- When the key's size is not known, the file is statted to get the size. - This allows uploads of keys without size to still have progress - displayed. @@ -171,9 +176,14 @@ minratelimit = min consoleratelimit jsonratelimit {- Poll file size to display meter. -} -meteredFile :: OsPath -> Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a -meteredFile file combinemeterupdate key a = - metered combinemeterupdate key Nothing $ \_ p -> +meteredFile + :: MeterSize sizer + => OsPath + -> Maybe MeterUpdate + -> sizer + -> (MeterUpdate -> Annex a) -> Annex a +meteredFile file combinemeterupdate sizer a = + metered combinemeterupdate sizer Nothing $ \_ p -> watchFileSize file p a {- Progress dots. -} diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -582,7 +582,7 @@ lv <- newEmptyTMVarIO timeoutdisablev <- newEmptyTMVarIO timeouttid <- async $ whenM (atomically $ readTMVar lv) $ do - threadDelaySeconds $ Seconds $ fromIntegral $ + threadDelaySeconds $ SecondsDelay $ fromIntegral $ durationSeconds p2pDefaultLockContentRetentionDuration atomically (tryReadTMVar timeoutdisablev) >>= \case Nothing -> void $ atomically $ @@ -870,7 +870,7 @@ -- Wait until a change has completed and it's idle. atomically (waitidleorend idlev) >>= \case Right () -> do - threadDelaySeconds (Seconds 1) + threadDelaySeconds (SecondsDelay 1) -- Once it's been idle for a second, -- commit the journalled changes. atomically (tryTakeTMVar idlev) >>= \case diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -240,7 +240,7 @@ debugMessage conn "P2P >" m case connOhdl conn of P2PHandle h -> tryNonAsync $ do - hPutStrLn h $ unwords (formatMessage m) + hPutStrLn h $ genMessage m hFlush h P2PHandleTMVar mv _ closedv -> tryNonAsync $ atomically $ putTMVar mv (Right m) @@ -345,7 +345,7 @@ debug "P2P.IO" $ concat $ catMaybes $ [ (\ident -> "[" ++ ident ++ "] ") <$> mident , Just $ "[" ++ show tid ++ "] " - , Just $ prefix ++ " " ++ unwords (formatMessage safem) + , Just $ prefix ++ " " ++ genMessage safem ] where safem = case m of diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -2,7 +2,7 @@ - - See doc/design/p2p_protocol.mdwn - - - Copyright 2016-2024 Joey Hess + - Copyright 2016-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -119,36 +119,57 @@ deriving (Show) instance Proto.Sendable Message where - formatMessage (AUTH uuid authtoken) = ["AUTH", Proto.serialize uuid, Proto.serialize authtoken] - formatMessage (AUTH_SUCCESS uuid) = ["AUTH-SUCCESS", Proto.serialize uuid] - formatMessage AUTH_FAILURE = ["AUTH-FAILURE"] - formatMessage (VERSION v) = ["VERSION", Proto.serialize v] - formatMessage (CONNECT service) = ["CONNECT", Proto.serialize service] - formatMessage (CONNECTDONE exitcode) = ["CONNECTDONE", Proto.serialize exitcode] - formatMessage NOTIFYCHANGE = ["NOTIFYCHANGE"] - formatMessage (CHANGED refs) = ["CHANGED", Proto.serialize refs] - formatMessage (CHECKPRESENT key) = ["CHECKPRESENT", Proto.serialize key] - formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key] - formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"] - formatMessage (REMOVE key) = ["REMOVE", Proto.serialize key] - formatMessage (REMOVE_BEFORE ts key) = ["REMOVE-BEFORE", Proto.serialize ts, Proto.serialize key] - formatMessage GETTIMESTAMP = ["GETTIMESTAMP"] - formatMessage (GET offset af key) = ["GET", Proto.serialize offset, Proto.serialize af, Proto.serialize key] - formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key] - formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] - formatMessage ALREADY_HAVE = ["ALREADY-HAVE"] - formatMessage (ALREADY_HAVE_PLUS uuids) = ("ALREADY-HAVE-PLUS":map Proto.serialize uuids) - formatMessage SUCCESS = ["SUCCESS"] - formatMessage (SUCCESS_PLUS uuids) = ("SUCCESS-PLUS":map Proto.serialize uuids) - formatMessage FAILURE = ["FAILURE"] - formatMessage (FAILURE_PLUS uuids) = ("FAILURE-PLUS":map Proto.serialize uuids) - formatMessage (BYPASS (Bypass uuids)) = ("BYPASS":map Proto.serialize (S.toList uuids)) - formatMessage (DATA len) = ["DATA", Proto.serialize len] - formatMessage DATA_PRESENT = ["DATA-PRESENT"] - formatMessage (VALIDITY Valid) = ["VALID"] - formatMessage (VALIDITY Invalid) = ["INVALID"] - formatMessage (TIMESTAMP ts) = ["TIMESTAMP", Proto.serialize ts] - formatMessage (ERROR err) = ["ERROR", Proto.serialize err] + formatMessage (AUTH uuid authtoken) = Proto.mkMessage + ["AUTH", Proto.serialize uuid, Proto.serialize authtoken] + formatMessage (AUTH_SUCCESS uuid) = Proto.mkMessage + ["AUTH-SUCCESS", Proto.serialize uuid] + formatMessage AUTH_FAILURE = Proto.mkMessage ["AUTH-FAILURE"] + formatMessage (VERSION v) = Proto.mkMessage + ["VERSION", Proto.serialize v] + formatMessage (CONNECT service) = Proto.mkMessage + ["CONNECT", Proto.serialize service] + formatMessage (CONNECTDONE exitcode) = Proto.mkMessage + ["CONNECTDONE", Proto.serialize exitcode] + formatMessage NOTIFYCHANGE = Proto.mkMessage ["NOTIFYCHANGE"] + formatMessage (CHANGED refs) = Proto.mkMessage + ["CHANGED", Proto.serialize refs] + formatMessage (CHECKPRESENT key) = Proto.mkMessage + ["CHECKPRESENT", Proto.serialize key] + formatMessage (LOCKCONTENT key) = Proto.mkMessage + ["LOCKCONTENT", Proto.serialize key] + formatMessage UNLOCKCONTENT = Proto.mkMessage ["UNLOCKCONTENT"] + formatMessage (REMOVE key) = Proto.mkMessage + ["REMOVE", Proto.serialize key] + formatMessage (REMOVE_BEFORE ts key) = Proto.mkMessage + ["REMOVE-BEFORE", Proto.serialize ts, Proto.serialize key] + formatMessage GETTIMESTAMP = Proto.mkMessage ["GETTIMESTAMP"] + formatMessage (GET offset af key) = Proto.mkMessage + ["GET", Proto.serialize offset, Proto.serialize af, Proto.serialize key] + formatMessage (PUT af key) = Proto.mkMessage + ["PUT", Proto.serialize af, Proto.serialize key] + formatMessage (PUT_FROM offset) = Proto.mkMessage + ["PUT-FROM", Proto.serialize offset] + formatMessage ALREADY_HAVE = Proto.mkMessage ["ALREADY-HAVE"] + formatMessage (ALREADY_HAVE_PLUS uuids) = Proto.mkMessage + ("ALREADY-HAVE-PLUS":map Proto.serialize uuids) + formatMessage SUCCESS = Proto.mkMessage ["SUCCESS"] + formatMessage (SUCCESS_PLUS uuids) = + Proto.mkMessage ("SUCCESS-PLUS":map Proto.serialize uuids) + formatMessage FAILURE = Proto.mkMessage ["FAILURE"] + formatMessage (FAILURE_PLUS uuids) = Proto.mkMessage + ("FAILURE-PLUS":map Proto.serialize uuids) + formatMessage (BYPASS (Bypass uuids)) = Proto.mkMessage + ("BYPASS":map Proto.serialize (S.toList uuids)) + formatMessage (DATA len) = Proto.mkMessage + ["DATA", Proto.serialize len] + formatMessage DATA_PRESENT = Proto.mkMessage + ["DATA-PRESENT"] + formatMessage (VALIDITY Valid) = Proto.mkMessage ["VALID"] + formatMessage (VALIDITY Invalid) = Proto.mkMessage ["INVALID"] + formatMessage (TIMESTAMP ts) = + Proto.mkMessage ["TIMESTAMP", Proto.serialize ts] + formatMessage (ERROR err) = Proto.mkMessage + ["ERROR", Proto.serialize err] instance Proto.Receivable Message where parseCommand "AUTH" = Proto.parse2 AUTH diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -54,7 +54,8 @@ ] , setup = adbSetup , exportSupported = exportIsSupported - , importSupported = importIsSupported + , importSupported = importUnsupported + , exportImportSupported = exportImportIsSupported , thirdPartyPopulated = False } @@ -97,8 +98,9 @@ , removeExportDirectory = Just $ removeExportDirectoryM serial adir , renameExport = Just $ renameExportM serial adir } - , importActions = ImportActions - { listImportableContents = listImportableContentsM serial adir c + , importActions = importUnsupported + , exportImportActions = ExportImportActions + { listImportableOrExportedContents = listImportableOrExportedContentsM serial adir c , importKey = Nothing , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM serial adir , storeExportWithContentIdentifier = storeExportWithContentIdentifierM serial adir @@ -297,8 +299,8 @@ , File newloc ] -listImportableContentsM :: AndroidSerial -> AndroidPath -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) -listImportableContentsM serial adir c = adbfind >>= \case +listImportableOrExportedContentsM :: AndroidSerial -> AndroidPath -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableOrExportedContentsM serial adir c = adbfind >>= \case Just ls -> return $ Just $ ImportableContentsComplete $ ImportableContents (mapMaybe mk ls) [] Nothing -> giveup "adb find failed" diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -48,6 +48,7 @@ , setup = giveup "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -79,6 +80,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Borg.hs b/Remote/Borg.hs --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -59,7 +59,8 @@ ] , setup = borgSetup , exportSupported = exportUnsupported - , importSupported = importIsSupported + , importSupported = importUnsupported + , exportImportSupported = exportImportIsSupported , thirdPartyPopulated = True } @@ -94,16 +95,17 @@ , checkPresent = checkPresentDummy , checkPresentCheap = borgLocal borgrepo , exportActions = exportUnsupported - , importActions = ImportActions - { listImportableContents = listImportableContentsM u borgrepo c + , importActions = importUnsupported + , exportImportActions = ExportImportActions + { listImportableOrExportedContents = listImportableOrExportedContentsM u borgrepo c , importKey = Just ThirdPartyPopulated.importKey , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM borgrepo , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM borgrepo -- This remote is thirdPartyPopulated, so these -- actions will never be used. - , storeExportWithContentIdentifier = storeExportWithContentIdentifier importUnsupported - , removeExportDirectoryWhenEmpty = removeExportDirectoryWhenEmpty importUnsupported - , removeExportWithContentIdentifier = removeExportWithContentIdentifier importUnsupported + , storeExportWithContentIdentifier = storeExportWithContentIdentifier exportImportUnsupported + , removeExportDirectoryWhenEmpty = removeExportDirectoryWhenEmpty exportImportUnsupported + , removeExportWithContentIdentifier = removeExportWithContentIdentifier exportImportUnsupported } , whereisKey = Nothing , remoteFsck = Nothing @@ -168,8 +170,8 @@ checkAvailability borgrepo@(BorgRepo r) = checkPathAvailability (borgLocal borgrepo) (toOsPath r) -listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) -listImportableContentsM u borgrepo c = prompt $ do +listImportableOrExportedContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableOrExportedContentsM u borgrepo c = prompt $ do imported <- getImported u ls <- withborglist (locBorgRepo borgrepo) Nothing formatarchivelist $ \as -> forM (filter (not . S.null) as) $ \archivename -> diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -55,6 +55,7 @@ , setup = bupSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -88,6 +89,7 @@ , checkPresentCheap = bupLocal buprepo , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Compute.hs b/Remote/Compute.hs --- a/Remote/Compute.hs +++ b/Remote/Compute.hs @@ -86,6 +86,7 @@ , setup = setupInstance , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -120,6 +121,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -49,6 +49,7 @@ , setup = ddarSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -90,6 +91,7 @@ , checkPresentCheap = ddarLocal ddarrepo , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -68,7 +68,8 @@ ] , setup = directorySetup , exportSupported = exportIsSupported - , importSupported = importIsSupported + , importSupported = importUnsupported + , exportImportSupported = exportImportIsSupported , thirdPartyPopulated = False } @@ -115,8 +116,9 @@ , removeExportDirectory = Nothing , renameExport = Just $ renameExportM dir } - , importActions = ImportActions - { listImportableContents = listImportableContentsM ii dir + , importActions = importUnsupported + , exportImportActions = ExportImportActions + { listImportableOrExportedContents = listImportableOrExportedContentsM ii dir , importKey = Just (importKeyM ii dir) , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM ii dir cow , storeExportWithContentIdentifier = storeExportWithContentIdentifierM ii dir cow fastcopy @@ -383,8 +385,8 @@ let p = exportPath topdir $ mkExportLocation loc' in go (upFrom loc') =<< tryIO (removeDirectory p) -listImportableContentsM :: IgnoreInodes -> OsPath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) -listImportableContentsM ii dir = liftIO $ do +listImportableOrExportedContentsM :: IgnoreInodes -> OsPath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableOrExportedContentsM ii dir = liftIO $ do l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir return $ Just $ ImportableContentsComplete $ ImportableContents (catMaybes l') [] diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -18,6 +18,7 @@ import qualified Annex.ExternalAddonProcess as AddonProcess import Types.Remote import Types.RemoteState +import Types.Import import Types.Export import Types.CleanupActions import Types.UrlContents @@ -33,6 +34,7 @@ import Remote.Helper.ReadOnly import Utility.Metered import Utility.Hash +import Utility.Tmp import Types.Transfer import Logs.PreferredContent.Raw import Logs.RemoteState @@ -47,6 +49,7 @@ import Annex.DisableRemote import Annex.LockFile import Creds +import Messages.Progress import qualified Utility.FileIO as F import Control.Concurrent.STM @@ -60,8 +63,9 @@ , generate = gen remote Nothing , configParser = remoteConfigParser Nothing , setup = externalSetup Nothing Nothing - , exportSupported = checkExportSupported Nothing - , importSupported = importUnsupported + , exportSupported = checkSupportedWith Nothing checkExportSupported + , importSupported = checkSupportedWith Nothing checkImportSupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -71,7 +75,15 @@ readonlyField :: RemoteConfigField readonlyField = Accepted "readonly" -gen :: RemoteType -> Maybe ExternalProgram -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen + :: RemoteType + -> Maybe ExternalProgram + -> Git.Repo + -> UUID + -> RemoteConfig + -> RemoteGitConfig + -> RemoteStateHandle + -> Annex (Maybe Remote) gen rt externalprogram r u rc gc rs -- readonly mode only downloads urls; does not use external program | externalprogram' == ExternalType "readonly" = do @@ -83,7 +95,9 @@ Nothing Nothing exportUnsupported + importUnsupported exportUnsupported + importUnsupported return $ Just $ specialRemote c readonlyStorer (retrieveUrl gc) @@ -97,8 +111,11 @@ Annex.addCleanupAction (RemoteCleanup u) $ stopExternal external cst <- getCost external r gc c exportsupported <- if exportTree c - then checkExportSupported' external + then isExportSupported' <$> checkExportSupported (Just external) else return False + importsupported <- if importTree c + then isImportSupported' <$> checkImportSupported (Just external) + else return False let exportactions = if exportsupported then ExportActions { storeExport = storeExportM external @@ -109,11 +126,21 @@ , renameExport = Just $ renameExportM external } else exportUnsupported - -- Cheap exportSupported that replaces the expensive - -- checkExportSupported now that we've already checked it. + let importactions = if importsupported + then ImportActions + { listImportableContents = listImportableContentsM external + , retrieveImport = retrieveImportM external gc + , checkPresentImport = checkPresentImportM external gc + } + else importUnsupported + -- Replace the expensive checks now that we've already + -- checked them. let cheapexportsupported = if exportsupported then exportIsSupported else exportUnsupported + let cheapimportsupported = if importsupported + then importIsSupported + else importUnsupported let rmt = mk c cst (getOrdered external) (getAvailability external) @@ -122,7 +149,9 @@ (Just (claimUrlM external)) (Just (checkUrlM external)) exportactions + importactions cheapexportsupported + cheapimportsupported return $ Just $ specialRemote c (storeKeyM external) (retrieveKeyFileM external gc) @@ -130,7 +159,7 @@ (checkPresentM external gc) rmt where - mk c cst ordered avail towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = + mk c cst ordered avail towhereis togetinfo toclaimurl tocheckurl exportactions importactions cheapexportsupported cheapimportsupported = Remote { uuid = u , cost = cst @@ -149,7 +178,8 @@ , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = exportactions - , importActions = importUnsupported + , importActions = importactions + , exportImportActions = exportImportUnsupported , whereisKey = towhereis , remoteFsck = Nothing , repairKey = Nothing @@ -163,7 +193,9 @@ , untrustworthy = False , availability = avail , remotetype = rt - { exportSupported = cheapexportsupported } + { exportSupported = cheapexportsupported + , importSupported = cheapimportsupported + } , mkUnavailable = let dneprogram = case externalprogram of Just (ExternalCommand _ _) -> Just (ExternalType "!dne!") @@ -181,7 +213,16 @@ fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc) -externalSetup :: Maybe ExternalProgram -> Maybe (String, String) -> SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) +externalSetup + :: Maybe ExternalProgram + -> Maybe (String, String) + -> SetupStage + -> Maybe UUID + -> RemoteName + -> Maybe CredPair + -> RemoteConfig + -> RemoteGitConfig + -> Annex (RemoteConfig, UUID) externalSetup externalprogram setgitconfig ss mu remotename _ c gc = do u <- maybe (liftIO genUUID) return mu pc <- either giveup return $ parseRemoteConfig c (lenientRemoteConfigParser externalprogram) @@ -225,26 +266,45 @@ [ fromMaybe ("externaltype", externaltype) setgitconfig ] return (M.delete readonlyField c'', u) -checkExportSupported :: Maybe ExternalProgram -> ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool -checkExportSupported Nothing c gc = do +checkSupportedWith + :: Maybe ExternalProgram + -> (Maybe External -> Annex a) + -> ParsedRemoteConfig + -> RemoteGitConfig + -> Annex a +checkSupportedWith Nothing checker c gc = do let externaltype = fromMaybe (giveup "Specify externaltype=") $ remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c if externaltype == "readonly" - then return False - else checkExportSupported (Just (ExternalType externaltype)) c gc -checkExportSupported (Just externalprogram) c gc = - checkExportSupported' + then checker Nothing + else checkSupportedWith (Just (ExternalType externaltype)) checker c gc +checkSupportedWith (Just externalprogram) checker c gc = + checker . Just =<< newExternal externalprogram Nothing c (Just gc) Nothing Nothing -checkExportSupported' :: External -> Annex Bool -checkExportSupported' external = go `catchNonAsync` (const (return False)) +checkExportSupported :: Maybe External -> Annex ExportSupported +checkExportSupported (Just external) = go + `catchNonAsync` (const (return (ExportSupported False))) where go = handleRequest external EXPORTSUPPORTED Nothing $ \resp -> case resp of - EXPORTSUPPORTED_SUCCESS -> result True - EXPORTSUPPORTED_FAILURE -> result False - UNSUPPORTED_REQUEST -> result False + EXPORTSUPPORTED_SUCCESS -> result (ExportSupported True) + EXPORTSUPPORTED_FAILURE -> result (ExportSupported False) + UNSUPPORTED_REQUEST -> result (ExportSupported False) _ -> Nothing +checkExportSupported Nothing = return (ExportSupported False) +checkImportSupported :: Maybe External -> Annex ImportSupported +checkImportSupported (Just external) = go + `catchNonAsync` (const (return (ImportSupported False))) + where + go = handleRequest external IMPORTSUPPORTED Nothing $ \resp -> case resp of + IMPORTSUPPORTED_SUCCESS -> result (ImportSupported True) + IMPORTSUPPORTED_FAILURE -> result (ImportSupported False) + IMPORTREQUIRED -> result ImportRequired + UNSUPPORTED_REQUEST -> result (ImportSupported False) + _ -> Nothing +checkImportSupported Nothing = return (ImportSupported False) + storeKeyM :: External -> Storer storeKeyM external = fileStorer $ \k f p -> either giveup return =<< go k f p @@ -256,10 +316,10 @@ result (Right ()) TRANSFER_FAILURE Upload k' errmsg | k == k' -> result (Left (respErrorMessage "TRANSFER" errmsg)) - DELEGATE ps -> Just $ do + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps storeKey delegate k (AssociatedFile Nothing) (Just f) p - return (Result (Right ())) + return (Right ()) _ -> Nothing retrieveKeyFileM :: External -> RemoteGitConfig -> Retriever @@ -274,13 +334,13 @@ | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg TRANSFER_RETRIEVE_URL k' url - | k == k' -> retrieveUrl' gc url dest k p - DELEGATE ps -> Just $ do + | k == k' -> getResult $ retrieveUrl' gc url dest k p + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- retrieveKeyFile delegate k (AssociatedFile Nothing) dest p NoVerify - return (Result (Right ())) + return (Right ()) _ -> Nothing removeKeyM :: External -> Remover @@ -293,10 +353,10 @@ REMOVE_FAILURE k' errmsg | k == k' -> result $ Left $ respErrorMessage "REMOVE" errmsg - DELEGATE ps -> Just $ do + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- removeKey delegate proof k - return (Result (Right ())) + return (Right ()) _ -> Nothing checkPresentM :: External -> RemoteGitConfig -> CheckPresent @@ -330,23 +390,36 @@ UNSUPPORTED_REQUEST -> result [] _ -> Nothing -storeExportM :: External -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM + :: External + -> OsPath + -> Key + -> ExportLocation + -> MeterUpdate + -> Annex () storeExportM external f k loc p = either giveup return =<< go where go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Upload k' | k == k' -> result $ Right () TRANSFER_FAILURE Upload k' errmsg | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg - DELEGATE ps -> Just $ do + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- storeExport (exportActions delegate) f k loc p - return (Result (Right ())) + return (Right ()) UNSUPPORTED_REQUEST -> result $ Left "TRANSFEREXPORT not implemented by external special remote" _ -> Nothing req sk = TRANSFEREXPORT Upload sk (fromOsPath f) -retrieveExportM :: External -> RemoteGitConfig -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification +retrieveExportM + :: External + -> RemoteGitConfig + -> Key + -> ExportLocation + -> OsPath + -> MeterUpdate + -> Annex Verification retrieveExportM external gc k loc dest p = do verifyKeyContentIncrementally AlwaysVerify k $ \iv -> tailVerify iv dest $ @@ -358,34 +431,102 @@ TRANSFER_FAILURE Download k' errmsg | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg TRANSFER_RETRIEVE_URL k' url - | k == k' -> retrieveUrl' gc url dest k p - DELEGATE ps -> Just $ do + | k == k' -> Just $ Result <$> retrieveUrl' gc url dest k p + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- retrieveExport (exportActions delegate) k loc dest p - return (Result (Right ())) + return (Right ()) UNSUPPORTED_REQUEST -> result $ Left "TRANSFEREXPORT not implemented by external special remote" _ -> Nothing req sk = TRANSFEREXPORT Download sk (fromOsPath dest) -checkPresentExportM :: External -> RemoteGitConfig -> Key -> ExportLocation -> Annex Bool -checkPresentExportM external gc k loc = either giveup id <$> go +retrieveImportM + :: External + -> RemoteGitConfig + -> ImportLocation + -> [ContentIdentifier] + -> OsPath + -> Either Key (Annex Key) + -> MeterUpdate + -> Annex (Key, Verification) +retrieveImportM external gc loc cids dest gk p = + case gk of + Right _ -> do + k <- go Nothing + return (k, UnVerified) + Left k -> verifyKeyContentIncrementally' AlwaysVerify k go where - go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of + go iv = tailVerify iv dest $ + either giveup return =<< go' + go' = handleRequestImport' external loc req (Just p) $ \resp -> case resp of + RETRIEVEIMPORT_SUCCESS -> getResult $ + Right <$> either pure id gk + RETRIEVEIMPORT_FAILURE errmsg -> + result $ Left $ respErrorMessage "RETRIEVEIMPORT" errmsg + RETRIEVEIMPORT_URL url -> getResult $ do + retrieveUrl' gc url dest UnknownSize p >>= \case + Right () -> Right <$> either pure id gk + Left msg -> pure (Left msg) + DELEGATE ps -> getResult $ do + delegate <- getDelegateRemote external ps + Right . fst <$> retrieveImport (importActions delegate) loc cids dest gk p + UNSUPPORTED_REQUEST -> + result $ Left "RETRIEVEIMPORT not implemented by external special remote" + _ -> Nothing + req = RETRIEVEIMPORT (fromOsPath dest) + +checkPresentExportM + :: External + -> RemoteGitConfig + -> Key + -> ExportLocation + -> Annex Bool +checkPresentExportM = checkPresentExportImport + CHECKPRESENTEXPORT + "CHECKPRESENTEXPORT" + (checkPresentExport . exportActions) + handleRequestExport + +checkPresentImportM + :: External + -> RemoteGitConfig + -> Key + -> ExportLocation + -> Annex Bool +checkPresentImportM = checkPresentExportImport + CHECKPRESENTIMPORT + "CHECKPRESENTIMPORT" + (checkPresentImport . importActions) + handleRequestImport + +checkPresentExportImport + :: (SafeKey -> Request) + -> String + -> (Remote -> Key -> ExportLocation -> Annex Bool) + -> (External -> ImportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler (Either String Bool) -> Annex (Either String Bool)) + -> External + -> RemoteGitConfig + -> Key + -> ExportLocation + -> Annex Bool +checkPresentExportImport request srequest delegateaction handlereq external gc k loc = either giveup id <$> go + where + go = handlereq external loc request k Nothing $ \resp -> case resp of CHECKPRESENT_SUCCESS k' | k' == k -> result $ Right True CHECKPRESENT_FAILURE k' | k' == k -> result $ Right False CHECKPRESENT_UNKNOWN k' errmsg | k' == k -> result $ Left $ - respErrorMessage "CHECKPRESENT" errmsg + respErrorMessage srequest errmsg CHECKPRESENT_URL k' url | k == k' -> checkKeyUrl' gc k url DELEGATE ps -> Just $ do delegate <- getDelegateRemote external ps - Result . Right <$> checkPresentExport (exportActions delegate) k loc + Result . Right <$> delegateaction delegate k loc UNSUPPORTED_REQUEST -> result $ - Left "CHECKPRESENTEXPORT not implemented by external special remote" + Left $ srequest ++ " not implemented by external special remote" _ -> Nothing removeExportM :: External -> Key -> ExportLocation -> Annex () @@ -396,10 +537,10 @@ | k == k' -> result $ Right () REMOVE_FAILURE k' errmsg | k == k' -> result $ Left $ respErrorMessage "REMOVE" errmsg - DELEGATE ps -> Just $ do + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps _ <- removeExport (exportActions delegate) k loc - return (Result (Right ())) + return (Right ()) UNSUPPORTED_REQUEST -> result $ Left $ "REMOVEEXPORT not implemented by external special remote" _ -> Nothing @@ -411,17 +552,22 @@ REMOVEEXPORTDIRECTORY_SUCCESS -> result $ Right () REMOVEEXPORTDIRECTORY_FAILURE -> result $ Left "failed to remove directory" - DELEGATE ps -> Just $ do + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps case removeExportDirectory (exportActions delegate) of Just a -> a dir Nothing -> return () - return (Result (Right ())) + return (Right ()) UNSUPPORTED_REQUEST -> result $ Right () _ -> Nothing req = REMOVEEXPORTDIRECTORY dir -renameExportM :: External -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) +renameExportM + :: External + -> Key + -> ExportLocation + -> ExportLocation + -> Annex (Maybe ()) renameExportM external k src dest = either giveup return =<< go where go = handleRequestExport external src req k Nothing $ \resp -> case resp of @@ -429,15 +575,43 @@ | k' == k -> result $ Right (Just ()) RENAMEEXPORT_FAILURE k' | k' == k -> result $ Left "failed to rename exported file" - DELEGATE ps -> Just $ do + DELEGATE ps -> getResult $ do delegate <- getDelegateRemote external ps case renameExport (exportActions delegate) of - Just a -> Result . Right <$> a k src dest - Nothing -> return $ Result $ Right Nothing + Just a -> Right <$> a k src dest + Nothing -> return $ Right Nothing UNSUPPORTED_REQUEST -> result (Right Nothing) _ -> Nothing req sk = RENAMEEXPORT sk dest +listImportableContentsM + :: External + -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableContentsM external = + handleRequest external LISTIMPORTABLECONTENTS Nothing + (go [] Nothing) + where + go c _ (IMPORTABLECONTENT sz loc) = + let loc' = mkImportLocation (toOsPath loc) + in Just $ return $ GetNextMessage $ + go c (Just (sz, loc')) + go c (Just (sz, loc)) (IMPORTABLECONTENTIDENTIFIER cid) = + Just $ return $ GetNextMessage $ + go ((loc, (cid, sz)):c) Nothing + go c _ LISTIMPORTABLECONTENTS_SUCCESS = + result $ Just $ + ImportableContentsComplete $ ImportableContents + { importableContents = c + , importableHistory = [] + } + go _ _ (LISTIMPORTABLECONTENTS_FAILURE err) = + giveup err + go _ _ (DELEGATE ps) = Just $ do + delegate <- getDelegateRemote external ps + Result <$> listImportableContents (importActions delegate) + go _ _ UNSUPPORTED_REQUEST = result Nothing + go _ _ _ = Nothing + {- Sends a Request to the external remote, and waits for it to generate - a Response. That is fed into the responsehandler, which should return - the action to run for it (or Nothing if there's a protocol error). @@ -451,12 +625,23 @@ - May throw exceptions, for example on protocol errors, or - when the repository cannot be used. -} -handleRequest :: External -> Request -> Maybe MeterUpdate -> ResponseHandler 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 -> ResponseHandler a -> Annex a +handleRequestKey + :: External + -> (SafeKey -> Request) + -> Key + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a handleRequestKey external mkreq k mp responsehandler = withSafeKey k $ \sk -> handleRequest external (mkreq sk) mp responsehandler @@ -465,21 +650,72 @@ Right sk -> a sk Left e -> giveup e -{- 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 -> ResponseHandler a -> Annex a -handleRequestExport external loc mkreq k mp responsehandler = +handleRequestExport + :: External + -> ExportLocation + -> (SafeKey -> Request) + -> Key + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a +handleRequestExport = handleRequestExportImport EXPORT + +handleRequestImport + :: External + -> ImportLocation + -> (SafeKey -> Request) + -> Key + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a +handleRequestImport = handleRequestExportImport IMPORT + +handleRequestImport' + :: External + -> ImportLocation + -> Request + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a +handleRequestImport' = handleRequestExportImport' IMPORT + +handleRequestExportImport + :: (ExportLocation -> Request) + -> External + -> ImportLocation + -> (SafeKey -> Request) + -> Key + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a +handleRequestExportImport mklocrequest external loc mkreq k mp responsehandler = withSafeKey k $ \sk -> - -- Both the EXPORT and subsequent request must be sent to the - -- same external process, so run both with the same external - -- state. - withExternalState external $ \st -> do - checkPrepared st external - sendMessage st (EXPORT loc) - handleRequest' st external (mkreq sk) mp responsehandler + handleRequestExportImport' mklocrequest external loc (mkreq sk) mp responsehandler -handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a +handleRequestExportImport' + :: (ExportLocation -> Request) + -> External + -> ImportLocation + -> Request + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a +handleRequestExportImport' mklocrequest external loc req mp responsehandler = + -- Both the location request and subsequent request must be + -- sent to the same external process, so run both with the + -- same external state. + withExternalState external $ \st -> do + checkPrepared st external + sendMessage st (mklocrequest loc) + handleRequest' st external req mp responsehandler + +handleRequest' + :: ExternalState + -> External + -> Request + -> Maybe MeterUpdate + -> ResponseHandler a + -> Annex a handleRequest' st external req mp responsehandler | needsPREPARE req = do checkPrepared st external @@ -488,18 +724,24 @@ where go = do sendMessage st req - loop - loop = receiveMessage st external responsehandler - (\rreq -> Just $ handleRemoteRequest rreq >> loop) - (\msg -> Just $ handleExceptionalMessage msg >> loop) + cleanupv <- liftIO $ atomically $ newTMVar [] + loop cleanupv + `finally` cleanup cleanupv + + loop cleanupv = receiveMessage st external responsehandler + (\rreq -> Just $ handleRemoteRequest cleanupv rreq >> loop cleanupv) + (\msg -> Just $ handleExceptionalMessage msg >> loop cleanupv) - handleRemoteRequest (PROGRESS bytesprocessed) = + cleanup cleanupv = liftIO $ + sequence =<< atomically (takeTMVar cleanupv) + + handleRemoteRequest _ (PROGRESS bytesprocessed) = maybe noop (\a -> liftIO $ a bytesprocessed) mp - handleRemoteRequest (DIRHASH k) = + handleRemoteRequest _ (DIRHASH k) = send $ VALUE $ fromOsPath $ hashDirMixed def k - handleRemoteRequest (DIRHASH_LOWER k) = + handleRemoteRequest _ (DIRHASH_LOWER k) = send $ VALUE $ fromOsPath $ hashDirLower def k - handleRemoteRequest (SETCONFIG setting value) = + handleRemoteRequest _ (SETCONFIG setting value) = liftIO $ atomically $ do ParsedRemoteConfig m c <- takeTMVar (externalConfig st) let !m' = M.insert @@ -514,13 +756,13 @@ f <- takeTMVar (externalConfigChanges st) let !f' = M.insert (Accepted setting) (Accepted value) . f putTMVar (externalConfigChanges st) f' - handleRemoteRequest (GETCONFIG setting) = do + handleRemoteRequest _ (GETCONFIG setting) = do value <- maybe "" fromProposedAccepted . (M.lookup (Accepted setting)) . unparsedRemoteConfig <$> liftIO (atomically $ readTMVar $ externalConfig st) send $ VALUE value - handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of + handleRemoteRequest _ (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of (Just u, Just gc) -> do pc <- liftIO $ atomically $ takeTMVar (externalConfig st) pc' <- setRemoteCredPair' pc encryptionAlreadySetup gc @@ -536,56 +778,78 @@ let !f' = M.union configchanges . f putTMVar (externalConfigChanges st) f' _ -> senderror "cannot send SETCREDS here" - handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of + handleRemoteRequest _ (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of (Just u, Just gc) -> do c <- liftIO $ atomically $ readTMVar $ externalConfig st creds <- fromMaybe ("", "") <$> getRemoteCredPair c gc (credstorage setting u) send $ CREDS (fst creds) (snd creds) _ -> senderror "cannot send GETCREDS here" - handleRemoteRequest GETUUID = case externalUUID external of + handleRemoteRequest _ GETUUID = case externalUUID external of Just u -> send $ VALUE $ fromUUID u Nothing -> senderror "cannot send GETUUID here" - handleRemoteRequest GETGITDIR = + handleRemoteRequest _ GETGITDIR = send . VALUE . fromOsPath =<< fromRepo Git.localGitDir - handleRemoteRequest GETGITREMOTENAME = + handleRemoteRequest _ GETGITREMOTENAME = case externalRemoteName external of Just n -> send $ VALUE n Nothing -> senderror "git remote name not known" - handleRemoteRequest (SETWANTED expr) = case externalUUID external of + handleRemoteRequest _ (SETWANTED expr) = case externalUUID external of Just u -> preferredContentSet u expr Nothing -> senderror "cannot send SETWANTED here" - handleRemoteRequest GETWANTED = case externalUUID external of + handleRemoteRequest _ GETWANTED = case externalUUID external of Just u -> do expr <- fromMaybe "" . M.lookup u <$> preferredContentMapRaw send $ VALUE expr Nothing -> senderror "cannot send GETWANTED here" - handleRemoteRequest (SETSTATE key state) = + handleRemoteRequest _ (SETSTATE key state) = case externalRemoteStateHandle external of Just h -> setRemoteState h key state Nothing -> senderror "cannot send SETSTATE here" - handleRemoteRequest (GETSTATE key) = + handleRemoteRequest _ (GETSTATE key) = case externalRemoteStateHandle external of Just h -> do state <- fromMaybe "" <$> getRemoteState h key send $ VALUE state Nothing -> senderror "cannot send GETSTATE here" - handleRemoteRequest (SETURLPRESENT key url) = + handleRemoteRequest _ (SETURLPRESENT key url) = setUrlPresent key url - handleRemoteRequest (SETURLMISSING key url) = + handleRemoteRequest _ (SETURLMISSING key url) = setUrlMissing key url - handleRemoteRequest (SETURIPRESENT key uri) = - withurl (SETURLPRESENT key) uri - handleRemoteRequest (SETURIMISSING key uri) = - withurl (SETURLMISSING key) uri - handleRemoteRequest (GETURLS key prefix) = do + handleRemoteRequest cleanupv (SETURIPRESENT key uri) = + withurl cleanupv (SETURLPRESENT key) uri + handleRemoteRequest cleanupv (SETURIMISSING key uri) = + withurl cleanupv (SETURLMISSING key) uri + handleRemoteRequest _ (GETURLS key prefix) = do mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix send (VALUE "") -- end of list - handleRemoteRequest (DEBUG msg) = fastDebug "Remote.External" msg - handleRemoteRequest (INFO msg) = showInfo (UnquotedString msg) - handleRemoteRequest (VERSION _) = senderror "too late to send VERSION" + handleRemoteRequest _ (DEBUG msg) = fastDebug "Remote.External" msg + handleRemoteRequest _ (INFO msg) = showInfo (UnquotedString msg) + handleRemoteRequest cleanupv (DOWNLOAD_URL url) = do + case externalGitConfig external of + Just gc -> do + (tmpf, h) <- liftIO $ do + tmpdir <- systemTmpDirectory + openTmpFileIn tmpdir (literalOsPath "url") + liftIO $ hClose h + liftIO $ atomically $ do + l <- takeTMVar cleanupv + putTMVar cleanupv (removeTmpFile tmpf:l) + res <- withUrlOptions (Just gc) $ + downloadUrl' False UnknownSize + nullMeterUpdate Nothing [url] + tmpf + case res of + Right True -> + send $ DOWNLOAD_URL_SUCCESS (fromOsPath tmpf) + Left err -> + send $ DOWNLOAD_URL_FAILURE err + Right False -> + send $ DOWNLOAD_URL_FAILURE "download failed" + _ -> senderror "cannot send DOWNLOAD-URL here" + handleRemoteRequest _ (VERSION _) = senderror "too late to send VERSION" handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err @@ -599,23 +863,33 @@ } where base = replace "/" "_" $ fromUUID u ++ "-" ++ setting - - withurl mk uri = handleRemoteRequest $ mk $ + + withurl cleanupv mk uri = handleRemoteRequest cleanupv $ mk $ setDownloader (show uri) OtherDownloader -sendMessage :: (Sendable m, ToAsyncWrapped m) => ExternalState -> m -> Annex () +sendMessage + :: (Sendable m, ToAsyncWrapped m) + => ExternalState + -> m + -> Annex () sendMessage st m = liftIO $ externalSend st m -sendMessageAddonProcess :: Sendable m => AddonProcess.ExternalAddonProcess -> m -> IO () +sendMessageAddonProcess + :: Sendable m + => AddonProcess.ExternalAddonProcess + -> m + -> IO () sendMessageAddonProcess p m = do AddonProcess.protocolDebug p True line hPutStrLn h line hFlush h where h = AddonProcess.externalSend p - line = unwords $ formatMessage m + line = genMessage m -receiveMessageAddonProcess :: AddonProcess.ExternalAddonProcess -> IO (Maybe String) +receiveMessageAddonProcess + :: AddonProcess.ExternalAddonProcess + -> IO (Maybe String) receiveMessageAddonProcess p = do v <- catchMaybeIO $ hGetLine $ AddonProcess.externalReceive p maybe noop (AddonProcess.protocolDebug p False) v @@ -635,6 +909,9 @@ result :: a -> Maybe (Annex (ResponseHandlerResult a)) result = Just . return . Result +getResult :: Annex a -> Maybe (Annex (ResponseHandlerResult a)) +getResult a = Just $ Result <$> a + {- Waits for a message from the external remote, and passes it to the - appropriate handler. - @@ -827,9 +1104,8 @@ Unprepared -> handleRequest' st external PREPARE Nothing $ \resp -> case resp of - PREPARE_SUCCESS -> Just $ do + PREPARE_SUCCESS -> getResult $ setprepared Prepared - return (Result ()) PREPARE_FAILURE errmsg -> Just $ do let errmsg' = respErrorMessage "PREPARE" errmsg setprepared $ FailedPrepare errmsg' @@ -908,13 +1184,13 @@ unlessM (withUrlOptions (Just gc) $ downloadUrl True k p iv us f) $ giveup downloadFailed -retrieveUrl' :: RemoteGitConfig -> URLString -> OsPath -> Key -> MeterUpdate -> Maybe (Annex (ResponseHandlerResult (Either String ()))) -retrieveUrl' gc url dest k p = - Just $ withUrlOptions (Just gc) $ \uo -> - downloadUrl' False k p Nothing [url] dest uo >>= return . \case - Left msg -> Result (Left msg) - Right True -> Result (Right ()) - Right False -> Result (Left downloadFailed) +retrieveUrl' :: MeterSize sizer => RemoteGitConfig -> URLString -> OsPath -> sizer -> MeterUpdate -> Annex (Either String ()) +retrieveUrl' gc url dest sizer p = + withUrlOptions (Just gc) $ \uo -> + downloadUrl' False sizer p Nothing [url] dest uo >>= return . \case + Left msg -> Left msg + Right True -> Right () + Right False -> Left downloadFailed downloadFailed :: String downloadFailed = "failed to download content" diff --git a/Remote/External/AsyncExtension.hs b/Remote/External/AsyncExtension.hs --- a/Remote/External/AsyncExtension.hs +++ b/Remote/External/AsyncExtension.hs @@ -111,7 +111,7 @@ sendloop st sendq Nothing -> return () where - wrapjid msg jid = AsyncMessage jid $ unwords $ Proto.formatMessage msg + wrapjid msg jid = AsyncMessage jid $ Proto.genMessage msg shutdown :: External -> ExternalState -> SendQueue -> Async () -> Async () -> Bool -> IO () shutdown external st sendq sendthread receivethread b = do diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -21,6 +21,7 @@ ExternalAsync(..), ExternalAsyncRelay(..), Proto.parseMessage, + Proto.genMessage, Proto.Sendable(..), Proto.Receivable(..), Request(..), @@ -49,6 +50,7 @@ import Config.Cost (Cost) import Types.RemoteState import Types.RemoteConfig +import Types.Import import Types.Export import Types.Availability (Availability(..)) import Types.Key @@ -191,6 +193,11 @@ | REMOVEEXPORT SafeKey | REMOVEEXPORTDIRECTORY ExportDirectory | RENAMEEXPORT SafeKey ExportLocation + | IMPORTSUPPORTED + | LISTIMPORTABLECONTENTS + | IMPORT ImportLocation + | RETRIEVEIMPORT FilePath + | CHECKPRESENTIMPORT SafeKey deriving (Show) -- Does PREPARE need to have been sent before this request? @@ -199,49 +206,69 @@ needsPREPARE (EXTENSIONS _) = False needsPREPARE INITREMOTE = False needsPREPARE EXPORTSUPPORTED = False +needsPREPARE IMPORTSUPPORTED = False needsPREPARE LISTCONFIGS = False needsPREPARE _ = True instance Proto.Sendable Request where - formatMessage (EXTENSIONS l) = ["EXTENSIONS", Proto.serialize l] - formatMessage PREPARE = ["PREPARE"] - formatMessage INITREMOTE = ["INITREMOTE"] - formatMessage GETCOST = ["GETCOST"] - formatMessage GETAVAILABILITY = ["GETAVAILABILITY"] - formatMessage GETORDERED = ["GETORDERED"] - formatMessage (CLAIMURL url) = [ "CLAIMURL", Proto.serialize url ] - formatMessage (CHECKURL url) = [ "CHECKURL", Proto.serialize url ] - formatMessage (TRANSFER direction key file) = + formatMessage (EXTENSIONS l) = Proto.mkMessage + ["EXTENSIONS", Proto.serialize l] + formatMessage PREPARE = Proto.mkMessage ["PREPARE"] + formatMessage INITREMOTE = Proto.mkMessage ["INITREMOTE"] + formatMessage GETCOST = Proto.mkMessage ["GETCOST"] + formatMessage GETAVAILABILITY = Proto.mkMessage ["GETAVAILABILITY"] + formatMessage GETORDERED = Proto.mkMessage ["GETORDERED"] + formatMessage (CLAIMURL url) = Proto.mkMessage + [ "CLAIMURL", Proto.serialize url ] + formatMessage (CHECKURL url) = Proto.mkMessage + [ "CHECKURL", Proto.serialize url ] + formatMessage (TRANSFER direction key file) = Proto.mkMessage [ "TRANSFER" , Proto.serialize direction , Proto.serialize key , Proto.serialize file ] - formatMessage (CHECKPRESENT key) = + formatMessage (CHECKPRESENT key) = Proto.mkMessage [ "CHECKPRESENT", Proto.serialize key ] - formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ] - formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ] - formatMessage LISTCONFIGS = [ "LISTCONFIGS" ] - formatMessage GETINFO = [ "GETINFO" ] - formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"] - formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ] - formatMessage (TRANSFEREXPORT direction key file) = + formatMessage (REMOVE key) = Proto.mkMessage + [ "REMOVE", Proto.serialize key ] + formatMessage (WHEREIS key) = Proto.mkMessage + [ "WHEREIS", Proto.serialize key ] + formatMessage LISTCONFIGS = Proto.mkMessage ["LISTCONFIGS"] + formatMessage GETINFO = Proto.mkMessage ["GETINFO"] + formatMessage EXPORTSUPPORTED = Proto.mkMessage ["EXPORTSUPPORTED"] + formatMessage (EXPORT loc) = Proto.mkMessage + [ "EXPORT", Proto.serialize loc ] + formatMessage (TRANSFEREXPORT direction key file) = Proto.mkMessage [ "TRANSFEREXPORT" , Proto.serialize direction , Proto.serialize key , Proto.serialize file ] - formatMessage (CHECKPRESENTEXPORT key) = + formatMessage (CHECKPRESENTEXPORT key) = Proto.mkMessage [ "CHECKPRESENTEXPORT", Proto.serialize key ] - formatMessage (REMOVEEXPORT key) = + formatMessage (REMOVEEXPORT key) = Proto.mkMessage [ "REMOVEEXPORT", Proto.serialize key ] - formatMessage (REMOVEEXPORTDIRECTORY dir) = + formatMessage (REMOVEEXPORTDIRECTORY dir) = Proto.mkMessage [ "REMOVEEXPORTDIRECTORY", Proto.serialize dir ] - formatMessage (RENAMEEXPORT key newloc) = + formatMessage (RENAMEEXPORT key newloc) = Proto.mkMessage [ "RENAMEEXPORT" , Proto.serialize key , Proto.serialize newloc ] + formatMessage IMPORTSUPPORTED = Proto.mkMessage ["IMPORTSUPPORTED"] + formatMessage LISTIMPORTABLECONTENTS = Proto.mkMessage + [ "LISTIMPORTABLECONTENTS" ] + formatMessage (IMPORT loc) = Proto.mkMessage + [ "IMPORT", Proto.serialize loc ] + formatMessage (RETRIEVEIMPORT file) = Proto.mkMessage + [ "RETRIEVEIMPORT" + , Proto.serialize file + ] + formatMessage (CHECKPRESENTIMPORT key) = Proto.mkMessage + [ "CHECKPRESENTIMPORT" + , Proto.serialize key + ] -- Responses the external remote can make to requests. data Response @@ -265,8 +292,8 @@ | INITREMOTE_FAILURE ErrorMsg | CLAIMURL_SUCCESS | CLAIMURL_FAILURE - | CHECKURL_CONTENTS Size FilePath - | CHECKURL_MULTI [(URLString, Size, FilePath)] + | CHECKURL_CONTENTS MaybeSize FilePath + | CHECKURL_MULTI [(URLString, MaybeSize, FilePath)] | CHECKURL_FAILURE ErrorMsg | WHEREIS_SUCCESS String | WHEREIS_FAILURE @@ -281,6 +308,16 @@ | REMOVEEXPORTDIRECTORY_FAILURE | RENAMEEXPORT_SUCCESS Key | RENAMEEXPORT_FAILURE Key + | IMPORTSUPPORTED_SUCCESS + | IMPORTSUPPORTED_FAILURE + | IMPORTREQUIRED + | IMPORTABLECONTENT Size FilePath + | IMPORTABLECONTENTIDENTIFIER ContentIdentifier + | LISTIMPORTABLECONTENTS_SUCCESS + | LISTIMPORTABLECONTENTS_FAILURE ErrorMsg + | RETRIEVEIMPORT_SUCCESS + | RETRIEVEIMPORT_FAILURE ErrorMsg + | RETRIEVEIMPORT_URL URLString | DELEGATE [String] | UNSUPPORTED_REQUEST deriving (Show) @@ -322,6 +359,16 @@ parseCommand "REMOVEEXPORTDIRECTORY-FAILURE" = Proto.parse0 REMOVEEXPORTDIRECTORY_FAILURE parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE + parseCommand "IMPORTSUPPORTED-SUCCESS" = Proto.parse0 IMPORTSUPPORTED_SUCCESS + parseCommand "IMPORTSUPPORTED-FAILURE" = Proto.parse0 IMPORTSUPPORTED_FAILURE + parseCommand "IMPORTREQUIRED" = Proto.parse0 IMPORTREQUIRED + parseCommand "IMPORTABLECONTENT" = Proto.parse2 IMPORTABLECONTENT + parseCommand "IMPORTABLECONTENTIDENTIFIER" = Proto.parse1 IMPORTABLECONTENTIDENTIFIER + parseCommand "LISTIMPORTABLECONTENTS-SUCCESS" = Proto.parse0 LISTIMPORTABLECONTENTS_SUCCESS + parseCommand "LISTIMPORTABLECONTENTS-FAILURE" = Proto.parse1 LISTIMPORTABLECONTENTS_FAILURE + parseCommand "RETRIEVEIMPORT-SUCCESS" = Proto.parse0 RETRIEVEIMPORT_SUCCESS + parseCommand "RETRIEVEIMPORT-FAILURE" = Proto.parse1 RETRIEVEIMPORT_FAILURE + parseCommand "RETRIEVEIMPORT-URL" = Proto.parse1 RETRIEVEIMPORT_URL parseCommand "DELEGATE" = Proto.parseList DELEGATE parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST parseCommand _ = Proto.parseFail @@ -350,6 +397,7 @@ | GETURLS Key String | DEBUG String | INFO String + | DOWNLOAD_URL URLString deriving (Show) instance Proto.Receivable RemoteRequest where @@ -375,17 +423,26 @@ parseCommand "GETURLS" = Proto.parse2 GETURLS parseCommand "DEBUG" = Proto.parse1 DEBUG parseCommand "INFO" = Proto.parse1 INFO + parseCommand "DOWNLOAD-URL" = Proto.parse1 DOWNLOAD_URL parseCommand _ = Proto.parseFail -- Responses to RemoteRequest. data RemoteResponse = VALUE String | CREDS String String + | DOWNLOAD_URL_SUCCESS FilePath + | DOWNLOAD_URL_FAILURE String deriving (Show) instance Proto.Sendable RemoteResponse where - formatMessage (VALUE s) = [ "VALUE", Proto.serialize s ] - formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ] + formatMessage (VALUE s) = Proto.mkMessage + [ "VALUE", Proto.serialize s ] + formatMessage (CREDS login password) = Proto.mkMessage + [ "CREDS", Proto.serialize login, Proto.serialize password ] + formatMessage (DOWNLOAD_URL_SUCCESS file) = Proto.mkMessage + [ "DOWNLOAD-URL-SUCCESS", Proto.serialize file ] + formatMessage (DOWNLOAD_URL_FAILURE msg) = Proto.mkMessage + [ "DOWNLOAD-URL-FAILURE", Proto.serialize msg ] -- Messages that can be sent at any time by either git-annex or the remote. data ExceptionalMessage @@ -393,7 +450,8 @@ deriving (Show) instance Proto.Sendable ExceptionalMessage where - formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ] + formatMessage (ERROR err) = Proto.mkMessage + [ "ERROR", Proto.serialize err ] instance Proto.Receivable ExceptionalMessage where parseCommand "ERROR" = Proto.parse1 ERROR @@ -406,7 +464,8 @@ parseCommand _ = Proto.parseFail instance Proto.Sendable AsyncMessage where - formatMessage (AsyncMessage jid msg) = ["J", Proto.serialize jid, msg] + formatMessage (AsyncMessage jid msg) = Proto.mkMessage + ["J", Proto.serialize jid, msg] data AsyncWrapped = AsyncWrappedRemoteResponse RemoteResponse @@ -435,7 +494,8 @@ type Setting = String type Description = String type ProtocolVersion = Int -type Size = Maybe Integer +type Size = Integer +type MaybeSize = Maybe Integer type WrappedMsg = String newtype JobId = JobId Integer deriving (Eq, Ord, Show) @@ -463,7 +523,7 @@ serialize = show deserialize = readish -instance Proto.Serializable Size where +instance Proto.Serializable MaybeSize where serialize (Just s) = show s serialize Nothing = "UNKNOWN" deserialize "UNKNOWN" = Just Nothing @@ -479,7 +539,7 @@ deserialize "UNAVAILABLE" = Just Unavailable deserialize _ = Nothing -instance Proto.Serializable [(URLString, Size, FilePath)] where +instance Proto.Serializable [(URLString, MaybeSize, FilePath)] where serialize = unwords . map go where go (url, sz, f) = url ++ " " ++ maybe "UNKNOWN" show sz ++ " " ++ f @@ -503,3 +563,8 @@ instance Proto.Serializable ExtensionList where serialize (ExtensionList l) = unwords l deserialize = Just . ExtensionList . words + +instance Proto.Serializable ContentIdentifier where + serialize (ContentIdentifier cid) = decodeBS cid + deserialize = Just . ContentIdentifier . encodeBS + diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -76,6 +76,7 @@ , setup = gCryptSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -146,6 +147,7 @@ , checkPresentCheap = repoCheap r , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -93,6 +93,7 @@ , setup = gitSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -243,6 +244,7 @@ , checkPresentCheap = repoCheap r , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = if Git.repoIsUrl r then Nothing diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -73,6 +73,7 @@ , setup = mySetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -124,6 +125,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -50,6 +50,7 @@ , setup = glacierSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -94,6 +95,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -1,6 +1,6 @@ {- Helper to make remotes support export and import (or not). - - - Copyright 2017-2024 Joey Hess + - Copyright 2017-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -33,8 +33,8 @@ class HasExportUnsupported a where exportUnsupported :: a -instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where - exportUnsupported = \_ _ -> return False +instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex ExportSupported) where + exportUnsupported = \_ _ -> return (ExportSupported False) instance HasExportUnsupported (ExportActions Annex) where exportUnsupported = ExportActions @@ -52,12 +52,28 @@ class HasImportUnsupported a where importUnsupported :: a -instance HasImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where - importUnsupported = \_ _ -> return False +instance HasImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex ImportSupported) where + importUnsupported = \_ _ -> return (ImportSupported False) instance HasImportUnsupported (ImportActions Annex) where importUnsupported = ImportActions { listImportableContents = nope + , retrieveImport = nope + , checkPresentImport = \_ _ -> return False + } + where + nope = giveup "import not supported" + +-- | Use for remotes that do not support exports and imports. +class HasExportImportUnsupported a where + exportImportUnsupported :: a + +instance HasExportImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where + exportImportUnsupported = \_ _ -> return False + +instance HasExportImportUnsupported (ExportImportActions Annex) where + exportImportUnsupported = ExportImportActions + { listImportableOrExportedContents = nope , importKey = Nothing , retrieveExportWithContentIdentifier = nope , storeExportWithContentIdentifier = nope @@ -66,14 +82,17 @@ , checkPresentExportWithContentIdentifier = \_ _ _ -> return False } where - nope = giveup "import not supported" + nope = giveup "import combined with export not supported" -exportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool -exportIsSupported = \_ _ -> return True +exportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex ExportSupported +exportIsSupported = \_ _ -> return (ExportSupported True) -importIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool -importIsSupported = \_ _ -> return True +importIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex ImportSupported +importIsSupported = \_ _ -> return (ImportSupported True) +exportImportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool +exportImportIsSupported = \_ _ -> return True + -- | Prevent or allow exporttree=yes and importtree=yes when -- setting up a new remote, depending on the remote's capabilities. adjustExportImportRemoteType :: RemoteType -> RemoteType @@ -83,7 +102,11 @@ pc <- either giveup return . parseRemoteConfig c =<< configParser rt c let checkconfig supported configured configfield cont = - ifM (supported rt pc gc <&&> pure (not (thirdPartyPopulated rt))) + let allowed = + ( pure supported + <||> exportImportSupported rt pc gc) + <&&> pure (not (thirdPartyPopulated rt)) + in ifM allowed ( case st of Init | configured pc && encryptionIsEnabled pc -> @@ -95,9 +118,25 @@ then giveup $ fromProposedAccepted configfield ++ " is not supported by this special remote" else cont ) - checkconfig exportSupported exportTree exportTreeField $ - checkconfig importSupported importTree importTreeField $ - setup rt st mu remotename cp c gc + let checkexportimport cont + | importTree pc && exportTree pc = + ifM (exportImportSupported rt pc gc) + ( cont + , giveup $ "This special remote does not support enabling both " + ++ fromProposedAccepted importTreeField + ++ " and " + ++ fromProposedAccepted exportTreeField + ) + | otherwise = cont + exportsupported <- exportSupported rt pc gc + importsupported <- importSupported rt pc gc + when (isImportRequired importsupported && not (importTree pc)) $ + giveup $ "This special remote must be configured with " ++ + fromProposedAccepted importTreeField ++ "=" ++ yesNoGenerator True + checkconfig (isExportSupported' exportsupported) exportTree exportTreeField $ + checkconfig (isImportSupported' importsupported) importTree importTreeField $ + checkexportimport $ + setup rt st mu remotename cp c gc enable oldc pc configured configfield cont = do oldpc <- parsedRemoteConfig rt oldc @@ -108,13 +147,19 @@ -- | Adjust a remote to support exporttree=yes and/or importree=yes. adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote adjustExportImport r rs = do - isexport <- pure (exportTree (config r)) - <&&> isExportSupported r - -- When thirdPartyPopulated is True, the remote - -- does not need to be configured with importTree to support - -- imports. - isimport <- pure (importTree (config r) || thirdPartyPopulated (remotetype r)) - <&&> isImportSupported r + isexport <- pure exportconfigured <&&> isExportSupported r + isimport <- pure importconfigured <&&> isImportSupported r + isexportimport <- pure + -- Use ExportImportActions even when + -- not configured with exporttree=yes, + -- when it's supported, since it + -- handles content identifiers more + -- strongly than ImportActions does. + ( importconfigured + -- thirdPartyPopulated is handled using + -- ExportImportActions + || thirdPartyPopulated (remotetype r)) + <&&> isExportImportSupported r let r' = r { remotetype = (remotetype r) { exportSupported = if isexport @@ -123,28 +168,39 @@ , importSupported = if isimport then importSupported (remotetype r) else importUnsupported + , exportImportSupported = if isexportimport + then exportImportSupported (remotetype r) + else exportImportUnsupported } } let annexobjects = isexport && annexObjects (config r) - if not isexport && not isimport + if not isexport && not isimport && not isexportimport then return r' else do gc <- Annex.getGitConfig - adjustExportImport' isexport isimport annexobjects r' rs gc + adjustExportImport' isexport isimport isexportimport annexobjects r' rs gc + where + exportconfigured = exportTree (config r) + importconfigured = importTree (config r) -adjustExportImport' :: Bool -> Bool -> Bool -> Remote -> RemoteStateHandle -> GitConfig -> Annex Remote -adjustExportImport' isexport isimport annexobjects r rs gc = do +adjustExportImport' :: Bool -> Bool -> Bool -> Bool -> Remote -> RemoteStateHandle -> GitConfig -> Annex Remote +adjustExportImport' isexport isimport isexportimport annexobjects r rs gc = do dbv <- prepdbv ciddbv <- prepciddb return $ r { exportActions = if isexport - then if isimport - then exportActionsForImport dbv ciddbv (exportActions r) + then if isexportimport + then exportActionsForExportImport dbv ciddbv (exportActions r) else exportActions r else exportUnsupported - , importActions = if isimport - then importActions r - else importUnsupported + , importActions = if isexportimport + then importActionsForExportImport ciddbv + else if isimport + then importActions r + else importUnsupported + , exportImportActions = if isexportimport + then exportImportActions r + else exportImportUnsupported , storeKey = \k af o p -> -- Storing a key to an export location could be -- implemented, but it would perform unnecessary work @@ -157,7 +213,7 @@ then if annexobjects then storeannexobject k o p else giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it" - else if isimport + else if isexportimport || isimport then giveup "remote is configured with importtree=yes and without exporttree=yes; cannot modify content stored on it" else storeKey r k af o p , removeKey = \proof k -> @@ -173,14 +229,14 @@ then if annexobjects then removeannexobject dbv k else giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove" - else if isimport + else if isexportimport || isimport then giveup "dropping content from this remote is not supported because it is configured with importtree=yes" else removeKey r proof k , lockContent = if versioned then lockContent r else Nothing , retrieveKeyFile = \k af dest p vc -> - if isimport || isexport + if isexportimport || isexport || isimport then supportversionedretrieve k af dest p vc $ supportretrieveannexobject dbv k af dest p $ retrieveFromImportOrExport (tryexportlocs dbv k) ciddbv k af dest p @@ -190,26 +246,19 @@ else Nothing , checkPresent = \k -> if versioned then checkPresent r k - else if isimport + else if isexportimport then checkpresentwith k $ - anyM (checkPresentImport ciddbv k) + anyM (checkPresentExportImport ciddbv k) =<< getanyexportlocs dbv k else if isexport - -- Check if any of the files a key - -- was exported to are present. This - -- doesn't guarantee the export - -- contains the right content, - -- if the remote is an export, - -- or if something else can write - -- to it. Remotes that have such - -- problems are made untrusted, - -- so it's not worried about here. - then checkpresentwith k $ - anyM (checkPresentExport (exportActions r) k) - =<< getanyexportlocs dbv k - else checkPresent r k - -- checkPresent from an export is more expensive - -- than otherwise, so not cheap. Also, this + then checkpresentloc dbv k + (checkPresentExport (exportActions r)) + else if isimport + then checkpresentloc dbv k + (checkPresentImport (importActions r)) + else checkPresent r k + -- checkPresent from an export or import is more + -- expensive than otherwise, so not cheap. Also, this -- avoids things that look at checkPresentCheap and -- silently skip non-present files from behaving -- in confusing ways when there's an export @@ -242,7 +291,7 @@ else Nothing ] else return is - return $ if isimport && not thirdpartypopulated + return $ if (isexportimport || isimport) && not thirdpartypopulated then (is'++[("importtree", "yes")]) else is' } @@ -251,32 +300,42 @@ thirdpartypopulated = thirdPartyPopulated (remotetype r) - -- exportActions adjusted to use the equivalent import actions, - -- which take ContentIdentifiers into account. - exportActionsForImport dbv ciddbv ea = ea + -- exportActions adjusted to use the equivalent + -- exportImportActions, which take ContentIdentifiers + -- into account. + exportActionsForExportImport dbv ciddbv ia = ia { storeExport = \f k loc p -> do db <- getciddb ciddbv exportdb <- getexportdb dbv oldks <- liftIO $ Export.getExportTreeKey exportdb loc oldcids <- liftIO $ concat <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks - newcid <- storeExportWithContentIdentifier (importActions r) f k loc oldcids p + newcid <- storeExportWithContentIdentifier (exportImportActions r) f k loc oldcids p cidlck <- calcRepo' gitAnnexContentIdentifierLock withExclusiveLock cidlck $ do liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k liftIO $ ContentIdentifier.flushDbQueue db recordContentIdentifier rs newcid k , removeExport = \k loc -> - removeExportWithContentIdentifier (importActions r) k loc + removeExportWithContentIdentifier (exportImportActions r) k loc =<< getkeycids ciddbv k - , removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r) + , removeExportDirectory = removeExportDirectoryWhenEmpty (exportImportActions r) -- renameExport is optional, and the remote's -- implementation may lose modifications to the file -- (by eg copying and then deleting) so don't use it , renameExport = Nothing - , checkPresentExport = checkPresentImport ciddbv + , checkPresentExport = checkPresentExportImport ciddbv } + -- importActions adjusted to use the equivalent + -- exportImportActions, which check ContentIdentifiers + -- more strongly. + importActionsForExportImport ciddbv = ImportActions + { listImportableContents = listImportableOrExportedContents (exportImportActions r) + , retrieveImport = retrieveExportWithContentIdentifier (exportImportActions r) + , checkPresentImport = checkPresentExportImport ciddbv + } + prepciddb = do lcklckv <- liftIO newEmptyTMVarIO dbtv <- liftIO newEmptyTMVarIO @@ -366,8 +425,9 @@ liftIO $ ContentIdentifier.getContentIdentifiers db rs k retrieveFromImportOrExport getlocs ciddbv k af dest p - | isimport = retrieveFromImport getlocs ciddbv k af dest p - | otherwise = retrieveFromExport getlocs k af dest p + | isexportimport = retrieveFromExportImport getlocs ciddbv k af dest p + | isexport = retrieveFromExport getlocs k af dest p + | otherwise = retrieveFromImport getlocs ciddbv k af dest p -- Keys can be retrieved using retrieveExport, but since that -- retrieves from a path in the remote that another writer could @@ -375,34 +435,60 @@ -- has to be strongly verified. retrieveFromExport getlocs k _af dest p = ifM (isVerifiable k) ( getlocs $ \loc -> - retrieveExport (exportActions r) k loc dest p >>= return . \case - UnVerified -> MustVerify - IncompleteVerify iv -> MustFinishIncompleteVerify iv - v -> v + stronglyverify $ + retrieveExport (exportActions r) k loc dest p , giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" ) + retrieveFromExportImport getlocs ciddbv k af dest p = do + cids <- getkeycids ciddbv k + if not (null cids) + then getlocs $ \loc -> + snd <$> retrieveExportWithContentIdentifier (exportImportActions r) loc cids dest (Left k) p + -- In case a content identifier is somehow missing, + -- try this instead. + else retrieveWithoutContentIdentifier $ + retrieveFromExport getlocs k af dest p + retrieveFromImport getlocs ciddbv k af dest p = do cids <- getkeycids ciddbv k if not (null cids) then getlocs $ \loc -> - snd <$> retrieveExportWithContentIdentifier (importActions r) loc cids dest (Left k) p + -- retrieveImport does not guarantee that + -- the file it retrieves has the content + -- identifier, so it must be strongly + -- verified. + stronglyverify $ + snd <$> retrieveImport (importActions r) loc cids dest (Left k) p -- In case a content identifier is somehow missing, -- try this instead. - else if isexport - then retrieveFromExport getlocs k af dest p - else giveup "no content identifier is recorded, unable to retrieve" + else retrieveWithoutContentIdentifier $ + retrieveFromExport getlocs k af dest p + retrieveWithoutContentIdentifier a + | isexport = a + | otherwise = giveup "no content identifier is recorded, unable to retrieve" + checkpresentwith k a = ifM a ( return True , if annexobjects then checkpresentannexobject k else return False ) + + -- Check if any of the recorded locations for a key + -- are present. The action doesn't guarantee that the + -- file contains the right content if the remote + -- is an export or import something else can write to + -- it. Such remotes are made untrusted, so it's not + -- worried about here. + checkpresentloc dbv k a = + checkpresentwith k $ + anyM (a k) =<< getanyexportlocs dbv k - checkPresentImport ciddbv k loc = + checkPresentExportImport ciddbv k loc = checkPresentExportWithContentIdentifier - (importActions r) + (exportImportActions r) k loc =<< getkeycids ciddbv k @@ -466,3 +552,8 @@ retrieveKeyFile r k af dest p vc `catchNonAsync` const a | otherwise = a + + stronglyverify a = a >>= return . \case + UnVerified -> MustVerify + IncompleteVerify iv -> MustFinishIncompleteVerify iv + v -> v diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -36,7 +36,7 @@ , removeExportDirectory = Just readonlyRemoveExportDirectory , renameExport = Nothing } - , importActions = (importActions r) + , exportImportActions = (exportImportActions r) { storeExportWithContentIdentifier = readonlyStoreExportWithContentIdentifier , removeExportWithContentIdentifier = readonlyRemoveExportWithContentIdentifier , removeExportDirectoryWhenEmpty = Just readonlyRemoveExportDirectory diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -41,6 +41,7 @@ , setup = hookSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -73,6 +74,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -42,6 +42,7 @@ , setup = httpAlsoSetup , exportSupported = exportIsSupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -85,6 +86,7 @@ , renameExport = cannotModify } , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Mask.hs b/Remote/Mask.hs --- a/Remote/Mask.hs +++ b/Remote/Mask.hs @@ -41,6 +41,7 @@ , setup = maskSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -64,6 +65,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -43,6 +43,7 @@ , setup = giveup "P2P remotes are set up using git-annex p2p" , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -68,6 +69,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/Rclone.hs b/Remote/Rclone.hs --- a/Remote/Rclone.hs +++ b/Remote/Rclone.hs @@ -1,6 +1,6 @@ {- Rclone special remote, using "rclone gitannex" - - - Copyright 2024 Joey Hess + - Copyright 2024-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -22,8 +22,9 @@ , generate = External.gen remote p , configParser = External.remoteConfigParser p , setup = External.externalSetup p setgitconfig - , exportSupported = External.checkExportSupported p - , importSupported = importUnsupported + , exportSupported = External.checkSupportedWith p External.checkExportSupported + , importSupported = External.checkSupportedWith p External.checkImportSupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } where diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -1,11 +1,11 @@ {- A remote that is only accessible by rsync. - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Remote.Rsync ( remote, @@ -32,6 +32,7 @@ import Remote.Helper.Special import Remote.Helper.ExportImport import Remote.Helper.Path +import Types.Import import Types.Export import Types.ProposedAccepted import Remote.Rsync.RsyncUrl @@ -52,6 +53,7 @@ import qualified Data.Map as M import qualified Data.List.NonEmpty as NE +import Text.Read remote :: RemoteType remote = specialRemoteType $ RemoteType @@ -64,7 +66,8 @@ ] , setup = rsyncSetup , exportSupported = exportIsSupported - , importSupported = importUnsupported + , importSupported = importIsSupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -105,11 +108,16 @@ { storeExport = storeExportM o , retrieveExport = retrieveExportM o , removeExport = removeExportM o - , checkPresentExport = checkPresentExportM o + , checkPresentExport = checkPresentImportExportM o , removeExportDirectory = Nothing , renameExport = Just $ renameExportM o } - , importActions = importUnsupported + , importActions = ImportActions + { listImportableContents = listImportableContentsM o + , retrieveImport = retrieveImportM o + , checkPresentImport = checkPresentImportExportM o + } + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -330,8 +338,8 @@ where rsyncurl = mkRsyncUrl o (fromOsPath (fromExportLocation loc)) -checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool -checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl] +checkPresentImportExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool +checkPresentImportExportM o _k loc = checkPresentGeneric o [rsyncurl] where rsyncurl = mkRsyncUrl o (fromOsPath (fromExportLocation loc)) @@ -345,6 +353,59 @@ renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM _ _ _ _ = return Nothing + +listImportableContentsM :: RsyncOpts -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableContentsM o = + withRsyncScratchDir $ \tmp -> do + opts <- rsyncOptions o + let p = rsyncCreateProcess $ opts ++ + [ Param "--recursive" + , Param "--dry-run" + , Param $ "--out-format=" ++ formatstring + , Param url + , Param $ fromOsPath tmp + ] + l <- mapMaybe parse . lines <$> liftIO (readProcess' p) + return $ Just $ ImportableContentsComplete $ ImportableContents + { importableContents = l + , importableHistory = [] + } + where + -- Make the url end in a slash so rsync will avoid prefixing + -- filenames it outputs with part of the url. + url = fromOsPath $ addTrailingPathSeparator $ toOsPath $ rsyncUrl o + + formatstring = "%l|%M|%L|%n" + + parse s + | "/" `isSuffixOf` s = Nothing + | otherwise = case splitc '|' s of + (ssz:sdate:ssymlink:rest) + | not (null ssymlink) -> Nothing + | otherwise -> do + sz <- readMaybe ssz + let loc = mkImportLocation $ toOsPath $ + rsyncPathUnescape $ + intercalate "|" rest + let cid = ContentIdentifier $ encodeBS $ + ssz ++ "|" ++ sdate + Just (loc, (cid, sz)) + _ -> Nothing + +retrieveImportM :: RsyncOpts -> ImportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) +retrieveImportM o loc _ dest gk p = + case gk of + Right mkkey -> do + go Nothing + k <- mkkey + return (k, UnVerified) + Left k -> do + v <- verifyKeyContentIncrementally AlwaysVerify k go + return (k, v) + where + go iv = tailVerify iv dest $ + rsyncRetrieve o [rsyncurl] dest (Just p) + rsyncurl = mkRsyncUrl o (fromOsPath (fromImportLocation loc)) {- Rsync params to enable resumes of sending files safely, - ensure that files are only moved into place once complete diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -127,7 +127,8 @@ } , setup = s3Setup , exportSupported = exportIsSupported - , importSupported = importIsSupported + , importSupported = importUnsupported + , exportImportSupported = exportImportIsSupported , thirdPartyPopulated = False } @@ -240,8 +241,9 @@ , removeExportDirectory = Nothing , renameExport = Just $ renameExportS3 hdl this rs info } - , importActions = ImportActions - { listImportableContents = listImportableContentsS3 hdl this info c + , importActions = importUnsupported + , exportImportActions = ExportImportActions + { listImportableOrExportedContents = listImportableOrExportedContentsS3 hdl this info c , importKey = Nothing , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this rs info , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this rs info magic @@ -609,8 +611,8 @@ srcobject = T.pack $ bucketExportLocation info src dstobject = T.pack $ bucketExportLocation info dest -listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) -listImportableContentsS3 hv r info c = +listImportableOrExportedContentsS3 :: S3HandleVar -> Remote -> S3Info -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) +listImportableOrExportedContentsS3 hv r info c = withS3Handle hv $ \case Right h -> Just <$> go h Left p -> giveupS3HandleProblem p (uuid r) @@ -786,7 +788,7 @@ -- Does not check if content on S3 is safe to overwrite, because there -- is no atomic way to do so. When the bucket is versioned, this is --- acceptable because listImportableContentsS3 will find versions +-- acceptable because listImportableOrExportedContentsS3 will find versions -- of files that were overwritten by this and no data is lost. -- -- When the bucket is not versioned, data loss can result. @@ -806,7 +808,7 @@ -- Does not guarantee that the removed object has the content identifier, -- but when the bucket is versioned, the removed object content can still --- be recovered (and listImportableContentsS3 will find it). +-- be recovered (and listImportableOrExportedContentsS3 will find it). -- -- When the bucket is not versioned, data loss can result. -- This is why that configuration requires --force to enable. @@ -1513,7 +1515,7 @@ return True Left problem -> giveupS3HandleProblem problem (uuid r) Nothing -> return False - v <- snd <$> finishVerifyKeyContentIncrementally' True miv + v <- snd <$> finishVerifyKeyContentIncrementally miv case v of Verified -> return True _ diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -70,6 +70,7 @@ , setup = tahoeSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -106,6 +107,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Just (getWhereisKey rs) , remoteFsck = Nothing , repairKey = Nothing @@ -233,7 +235,7 @@ Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s -> return $ takeWhile (`notElem` ("\n\r" :: String)) s _ -> do - threadDelaySeconds (Seconds 1) + threadDelaySeconds (SecondsDelay 1) go (n - 1) convergenceFile :: TahoeConfigDir -> OsPath @@ -274,7 +276,7 @@ if ok then return () else do - threadDelaySeconds (Seconds 1) + threadDelaySeconds (SecondsDelay 1) waitready (pred n) {- Ensures that tahoe has been started, before running an action diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -47,6 +47,7 @@ , setup = setupInstance , exportSupported = exportUnsupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -87,6 +88,7 @@ , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -58,6 +58,7 @@ , setup = webdavSetup , exportSupported = exportIsSupported , importSupported = importUnsupported + , exportImportSupported = exportImportUnsupported , thirdPartyPopulated = False } @@ -107,6 +108,7 @@ , renameExport = Just $ renameExportDav hdl } , importActions = importUnsupported + , exportImportActions = exportImportUnsupported , whereisKey = Nothing , remoteFsck = Nothing , repairKey = Nothing diff --git a/RemoteDaemon/Common.hs b/RemoteDaemon/Common.hs --- a/RemoteDaemon/Common.hs +++ b/RemoteDaemon/Common.hs @@ -60,7 +60,7 @@ where caught ConnectionStopping = return () caught ConnectionClosed = do - threadDelaySeconds (Seconds backoff) + threadDelaySeconds (SecondsDelay backoff) robustConnection increasedbackoff a increasedbackoff diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -44,7 +44,7 @@ Just cmd -> atomically $ writeTChan ichan cmd let writer = forever $ do msg <- atomically $ readTChan ochan - hPutStrLn writeh $ unwords $ formatMessage msg + hPutStrLn writeh $ genMessage msg hFlush writeh let controller = runController ichan ochan @@ -59,7 +59,7 @@ ochan <- newTChanIO :: IO (TChan Emitted) let reader = forever $ do - threadDelaySeconds (Seconds (60*60)) + threadDelaySeconds (SecondsDelay (60*60)) atomically $ writeTChan ichan RELOAD let writer = forever $ void $ atomically $ readTChan ochan diff --git a/RemoteDaemon/Transport/Ssh/Types.hs b/RemoteDaemon/Transport/Ssh/Types.hs --- a/RemoteDaemon/Transport/Ssh/Types.hs +++ b/RemoteDaemon/Transport/Ssh/Types.hs @@ -23,8 +23,9 @@ | CHANGED ChangedRefs instance Proto.Sendable Notification where - formatMessage READY = ["READY"] - formatMessage (CHANGED shas) = ["CHANGED", Proto.serialize shas] + formatMessage READY = Proto.mkMessage ["READY"] + formatMessage (CHANGED shas) = Proto.mkMessage + ["CHANGED", Proto.serialize shas] instance Proto.Receivable Notification where parseCommand "READY" = Proto.parse0 READY diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs --- a/RemoteDaemon/Types.hs +++ b/RemoteDaemon/Types.hs @@ -63,24 +63,25 @@ deriving (Show) instance Proto.Sendable Emitted where - formatMessage (CONNECTED remote) = + formatMessage (CONNECTED remote) = Proto.mkMessage ["CONNECTED", Proto.serialize remote] - formatMessage (DISCONNECTED remote) = + formatMessage (DISCONNECTED remote) = Proto.mkMessage ["DISCONNECTED", Proto.serialize remote] - formatMessage (SYNCING remote) = + formatMessage (SYNCING remote) = Proto.mkMessage ["SYNCING", Proto.serialize remote] - formatMessage (DONESYNCING remote status) = + formatMessage (DONESYNCING remote status) = Proto.mkMessage ["DONESYNCING", Proto.serialize remote, Proto.serialize status] - formatMessage (WARNING remote message) = + formatMessage (WARNING remote message) = Proto.mkMessage ["WARNING", Proto.serialize remote, Proto.serialize message] instance Proto.Sendable Consumed where - formatMessage PAUSE = ["PAUSE"] - formatMessage LOSTNET = ["LOSTNET"] - formatMessage RESUME = ["RESUME"] - formatMessage (CHANGED refs) =["CHANGED", Proto.serialize refs] - formatMessage RELOAD = ["RELOAD"] - formatMessage STOP = ["STOP"] + formatMessage PAUSE = Proto.mkMessage ["PAUSE"] + formatMessage LOSTNET = Proto.mkMessage ["LOSTNET"] + formatMessage RESUME = Proto.mkMessage ["RESUME"] + formatMessage (CHANGED refs) = Proto.mkMessage + ["CHANGED", Proto.serialize refs] + formatMessage RELOAD = Proto.mkMessage ["RELOAD"] + formatMessage STOP = Proto.mkMessage ["STOP"] instance Proto.Receivable Emitted where parseCommand "CONNECTED" = Proto.parse1 CONNECTED diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -365,7 +365,7 @@ print e putStrLn "sleeping 10 seconds and will retry directory cleanup" Utility.ThreadScheduler.threadDelaySeconds $ - Utility.ThreadScheduler.Seconds 10 + Utility.ThreadScheduler.SecondsDelay 10 whenM (doesDirectoryExist (toOsPath tmpdir)) $ removeDirectoryForCleanup tmpdir diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -56,7 +56,7 @@ import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd) import Utility.StatelessOpenPGP (SOPCmd(..), SOPProfile(..)) -import Utility.ThreadScheduler (Seconds(..)) +import Utility.ThreadScheduler (SecondsDelay(..)) import Utility.Url (Scheme, mkScheme) import Network.Socket (PortNumber) import P2P.Http.Url @@ -138,13 +138,13 @@ , annexVerify :: Bool , annexFastCopy :: Bool , annexPidLock :: Bool - , annexPidLockTimeout :: Seconds + , annexPidLockTimeout :: SecondsDelay , annexDbDir :: Maybe OsPath , annexAddUnlocked :: GlobalConfigurable (Maybe String) , annexSecureHashesOnly :: Bool , annexRetry :: Maybe Integer , annexForwardRetry :: Maybe Integer - , annexRetryDelay :: Maybe Seconds + , annexRetryDelay :: Maybe SecondsDelay , annexAllowedUrlSchemes :: S.Set Scheme , annexAllowedIPAddresses :: String , annexAllowInsecureHttps :: Bool @@ -253,7 +253,7 @@ , annexVerify = getbool (annexConfig "verify") True , annexFastCopy = getbool (annexConfig "fastcopy") False , annexPidLock = getbool (annexConfig "pidlock") False - , annexPidLockTimeout = Seconds $ fromMaybe 300 $ + , annexPidLockTimeout = SecondsDelay $ fromMaybe 300 $ getmayberead (annexConfig "pidlocktimeout") , annexDbDir = (\d -> toOsPath d fromUUID hereuuid) <$> getmaybe (annexConfig "dbdir") @@ -262,7 +262,7 @@ , annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False , annexRetry = getmayberead (annexConfig "retry") , annexForwardRetry = getmayberead (annexConfig "forward-retry") - , annexRetryDelay = Seconds + , annexRetryDelay = SecondsDelay <$> getmayberead (annexConfig "retrydelay") , annexAllowedUrlSchemes = S.fromList $ map mkScheme $ maybe ["http", "https", "ftp"] words $ @@ -421,7 +421,7 @@ , remoteAnnexBare :: Maybe Bool , remoteAnnexRetry :: Maybe Integer , remoteAnnexForwardRetry :: Maybe Integer - , remoteAnnexRetryDelay :: Maybe Seconds + , remoteAnnexRetryDelay :: Maybe SecondsDelay , remoteAnnexStallDetection :: Maybe StallDetection , remoteAnnexStallDetectionUpload :: Maybe StallDetection , remoteAnnexStallDetectionDownload :: Maybe StallDetection @@ -507,7 +507,7 @@ , remoteAnnexBare = getmaybebool BareField , remoteAnnexRetry = getmayberead RetryField , remoteAnnexForwardRetry = getmayberead ForwardRetryField - , remoteAnnexRetryDelay = Seconds + , remoteAnnexRetryDelay = SecondsDelay <$> getmayberead RetryDelayField , remoteAnnexStallDetection = readStallDetection =<< getmaybe StallDetectionField diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,9 +20,16 @@ , Verification(..) , unVerified , RetrievalSecurityPolicy(..) + , ExportSupported(..) , isExportSupported + , isExportSupported' + , ImportSupported(..) , isImportSupported + , isImportSupported' + , isImportRequired + , isExportImportSupported , ExportActions(..) + , ExportImportActions(..) , ImportActions(..) , ByteSize , SafeDropProof @@ -67,9 +74,12 @@ -- initializes or enables a remote , setup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) -- check if a remote of this type is able to support export - , exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool + , exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a ExportSupported -- check if a remote of this type is able to support import - , importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool + , importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a ImportSupported + -- check if a remote of this type is able to support both import + -- and export at the same time + , exportImportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool -- is a remote of this type not a usual key/value store, -- or export/import of a tree of files, but instead a collection -- of files, populated by something outside git-annex, some of @@ -134,6 +144,8 @@ , exportActions :: ExportActions a -- Some remotes support import. , importActions :: ImportActions a + -- Some remotes support import as well as export. + , exportImportActions :: ExportImportActions a -- Some remotes can provide additional details for whereis. , whereisKey :: Maybe (Key -> a [String]) -- Some remotes can run a fsck operation on the remote, @@ -233,6 +245,8 @@ | MustFinishIncompleteVerify IncrementalVerifier -- ^ Content likely to have been altered during transfer, -- finish verification even if verification is normally disabled. + | VerificationFailed + -- ^ Content verification has failed. unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do @@ -265,12 +279,36 @@ | RetrievalAllKeysSecure -- ^ Any key can be securely retrieved. -isExportSupported :: RemoteA a -> a Bool -isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r) +newtype ExportSupported = ExportSupported Bool -isImportSupported :: RemoteA a -> a Bool -isImportSupported r = importSupported (remotetype r) (config r) (gitconfig r) +isExportSupported :: Monad a => RemoteA a -> a Bool +isExportSupported r = + exportSupported (remotetype r) (config r) (gitconfig r) + >>= return . isExportSupported' +isExportSupported' :: ExportSupported -> Bool +isExportSupported' (ExportSupported b) = b + +data ImportSupported = ImportSupported Bool | ImportRequired + +isImportSupported :: Monad a => RemoteA a -> a Bool +isImportSupported r = + importSupported (remotetype r) (config r) (gitconfig r) + >>= return . \case + ImportSupported b -> b + ImportRequired -> True + +isImportSupported' :: ImportSupported -> Bool +isImportSupported' (ImportSupported b) = b +isImportSupported' ImportRequired = True + +isImportRequired :: ImportSupported -> Bool +isImportRequired (ImportSupported _) = False +isImportRequired ImportRequired = True + +isExportImportSupported :: RemoteA a -> a Bool +isExportImportSupported r = exportImportSupported (remotetype r) (config r) (gitconfig r) + data ExportActions a = ExportActions -- Exports content to an ExportLocation. -- The exported file should not appear to be present on the remote @@ -315,7 +353,7 @@ , renameExport :: Maybe (Key -> ExportLocation -> ExportLocation -> a (Maybe ())) } -data ImportActions a = ImportActions +data ExportImportActions a = ExportImportActions -- Finds the current set of files that are stored in the remote, -- along with their content identifiers and size. -- @@ -324,7 +362,13 @@ -- -- Throws exception on failure to access the remote. -- May return Nothing when the remote is unchanged since last time. - { listImportableContents :: a (Maybe (ImportableContentsChunkable a (ContentIdentifier, ByteSize))) + -- + -- The ContentIdentifier this returns must be sufficient to detect + -- any change to a file stored on the remote. Eg, a mtime and + -- inode. When storeExportWithContentIdentifier was used to store + -- content to the remote, this should return the same + -- ContentIdentifier that did. + { listImportableOrExportedContents :: a (Maybe (ImportableContentsChunkable a (ContentIdentifier, ByteSize))) -- Generates a Key (of any type) for the file stored on the -- remote at the ImportLocation. Does not download the file -- from the remote. @@ -419,3 +463,27 @@ -> a Bool } +data ImportActions a = ImportActions + -- Like listImportableOrExportedContents, but here the + -- ContentIdentifier is only used to avoid repeatedly + -- importing the same content from the remote, and does + -- not need to uniquely identify content. + -- Eg, a mtime is sufficient. + { listImportableContents :: a (Maybe (ImportableContentsChunkable a (ContentIdentifier, ByteSize))) + -- Like retrieveExportWithContentIdentifier, but does not + -- need to guarantee that the file it retrieves has one + -- of the requested ContentIdentifiers. + , retrieveImport + :: ImportLocation + -> [ContentIdentifier] + -> OsPath + -> Either Key (a Key) + -> MeterUpdate + -> a (Key, Verification) + -- Checks if anything is present on the remote at the specified + -- ImportLocation. It may check the size or other characteristics + -- of the Key, but does not need to guarantee that the content on + -- the remote is the same as the Key's content. + -- Throws an exception if the remote cannot be accessed. + , checkPresentImport :: Key -> ImportLocation -> a Bool + } diff --git a/Types/Transferrer.hs b/Types/Transferrer.hs --- a/Types/Transferrer.hs +++ b/Types/Transferrer.hs @@ -48,25 +48,25 @@ deriving (Show) instance Proto.Sendable TransferRequest where - formatMessage (UploadRequest r kd af) = + formatMessage (UploadRequest r kd af) = Proto.mkMessage [ "u" , Proto.serialize r , Proto.serialize kd , Proto.serialize af ] - formatMessage (DownloadRequest r kd af) = + formatMessage (DownloadRequest r kd af) = Proto.mkMessage [ "d" , Proto.serialize r , Proto.serialize kd , Proto.serialize af ] - formatMessage (AssistantUploadRequest r kd af) = + formatMessage (AssistantUploadRequest r kd af) = Proto.mkMessage [ "au" , Proto.serialize r , Proto.serialize kd , Proto.serialize af ] - formatMessage (AssistantDownloadRequest r kd af) = + formatMessage (AssistantDownloadRequest r kd af) = Proto.mkMessage [ "ad" , Proto.serialize r , Proto.serialize kd @@ -81,27 +81,27 @@ parseCommand _ = Proto.parseFail instance Proto.Sendable TransferResponse where - formatMessage (TransferOutput (OutputMessage m)) = + formatMessage (TransferOutput (OutputMessage m)) = Proto.mkMessage ["om", Proto.serialize (decodeBS (encode_c isUtf8Byte m))] - formatMessage (TransferOutput (OutputError e)) = + formatMessage (TransferOutput (OutputError e)) = Proto.mkMessage ["oe", Proto.serialize (decodeBS (encode_c isUtf8Byte (encodeBS e)))] - formatMessage (TransferOutput BeginProgressMeter) = + formatMessage (TransferOutput BeginProgressMeter) = Proto.mkMessage ["opb"] - formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) = + formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) = Proto.mkMessage ["ops", Proto.serialize sz] - formatMessage (TransferOutput (UpdateProgressMeter n)) = + formatMessage (TransferOutput (UpdateProgressMeter n)) = Proto.mkMessage ["op", Proto.serialize n] - formatMessage (TransferOutput EndProgressMeter) = + formatMessage (TransferOutput EndProgressMeter) = Proto.mkMessage ["ope"] - formatMessage (TransferOutput BeginPrompt) = + formatMessage (TransferOutput BeginPrompt) = Proto.mkMessage ["oprb"] - formatMessage (TransferOutput EndPrompt) = + formatMessage (TransferOutput EndPrompt) = Proto.mkMessage ["opre"] - formatMessage (TransferOutput (JSONObject b)) = + formatMessage (TransferOutput (JSONObject b)) = Proto.mkMessage ["oj", Proto.serialize (decodeBS (encode_c isUtf8Byte (L.toStrict b)))] - formatMessage (TransferResult True) = + formatMessage (TransferResult True) = Proto.mkMessage ["t"] - formatMessage (TransferResult False) = + formatMessage (TransferResult False) = Proto.mkMessage ["f"] instance Proto.Receivable TransferResponse where @@ -130,7 +130,8 @@ parseCommand _ = Proto.parseFail instance Proto.Sendable TransferSerializedOutputResponse where - formatMessage (TransferSerializedOutputResponse ReadyPrompt) = ["opr"] + formatMessage (TransferSerializedOutputResponse ReadyPrompt) = + Proto.mkMessage ["opr"] instance Proto.Receivable TransferSerializedOutputResponse where parseCommand "opr" = Proto.parse0 (TransferSerializedOutputResponse ReadyPrompt) diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs --- a/Utility/AuthToken.hs +++ b/Utility/AuthToken.hs @@ -25,7 +25,7 @@ import Data.Maybe import Data.Char -import qualified Data.ByteArray as BA +import qualified "memory" Data.ByteArray as BA import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L diff --git a/Utility/Hash/Crypton.hs b/Utility/Hash/Crypton.hs --- a/Utility/Hash/Crypton.hs +++ b/Utility/Hash/Crypton.hs @@ -69,7 +69,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.IORef -import qualified Data.ByteArray as BA +import qualified "memory" Data.ByteArray as BA import "crypton" Crypto.Hash import Utility.Hash.Types diff --git a/Utility/Hash/Types.hs b/Utility/Hash/Types.hs --- a/Utility/Hash/Types.hs +++ b/Utility/Hash/Types.hs @@ -6,12 +6,13 @@ -} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PackageImports #-} module Utility.Hash.Types where import qualified Data.ByteString as S -import Data.ByteArray -import qualified Data.ByteArray.Encoding as BAE +import "memory" Data.ByteArray +import qualified "memory" Data.ByteArray.Encoding as BAE import Data.String import Control.DeepSeq import GHC.Generics diff --git a/Utility/IPAddress.hs b/Utility/IPAddress.hs --- a/Utility/IPAddress.hs +++ b/Utility/IPAddress.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE PackageImports #-} -- Note that some extensions are necessary for reasons outlined in -- my July 2021 blog post. -- JEH @@ -21,7 +22,7 @@ import Network.Socket import Data.Word -import Data.Memory.Endian +import "memory" Data.Memory.Endian import Data.List import Text.Printf diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -265,25 +265,25 @@ -- -- After the first second waiting, runs the callback to display a message, -- so the user knows why it's stalled. -waitLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> (Bool -> IO ()) -> m LockHandle -waitLock (Seconds timeout) lockfile displaymessage sem = go timeout +waitLock :: MonadIO m => SecondsDelay -> PidLockFile -> (String -> m ()) -> (Bool -> IO ()) -> m LockHandle +waitLock (SecondsDelay timeout) lockfile displaymessage sem = go timeout where go n | n > 0 = liftIO (tryLock lockfile) >>= \case Nothing -> do when (n == pred timeout) $ displaymessage $ "waiting for pid lock file " ++ fromOsPath lockfile ++ " which is held by another process (or may be stale)" - liftIO $ threadDelaySeconds (Seconds 1) + liftIO $ threadDelaySeconds (SecondsDelay 1) go (pred n) Just lckh -> do liftIO $ sem True return lckh | otherwise = do liftIO $ sem False - waitedLock (Seconds timeout) lockfile displaymessage + waitedLock (SecondsDelay timeout) lockfile displaymessage -waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m a -waitedLock (Seconds timeout) lockfile displaymessage = do +waitedLock :: MonadIO m => SecondsDelay -> PidLockFile -> (String -> m ()) -> m a +waitedLock (SecondsDelay timeout) lockfile displaymessage = do displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromOsPath lockfile giveup $ "Gave up waiting for pid lock file " ++ fromOsPath lockfile diff --git a/Utility/LockPool/PidLock.hs b/Utility/LockPool/PidLock.hs --- a/Utility/LockPool/PidLock.hs +++ b/Utility/LockPool/PidLock.hs @@ -33,7 +33,7 @@ import Control.Monad.IO.Class -- Does locking using a pid lock, blocking until the lock is available --- or the Seconds timeout if the pid lock is held by another process. +-- or the SecondsDelay timeout if the pid lock is held by another process. -- -- There are two levels of locks. A STM lock is used to handle -- fine-grained locking among threads, locking a specific lockfile, @@ -47,7 +47,7 @@ :: (MonadIO m, MonadMask m) => LockFile -> LockMode - -> Seconds + -> SecondsDelay -> F.PidLockFile -> (String -> m ()) -> m LockHandle diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -1,6 +1,6 @@ {- various rsync stuff - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2026 Joey Hess - - License: BSD-2-clause -} @@ -13,10 +13,12 @@ rsyncServerReceive, rsyncUseDestinationPermissions, rsync, + rsyncCreateProcess, rsyncUrlIsShell, rsyncUrlIsPath, rsyncProgress, filterRsyncSafeOptions, + rsyncPathUnescape, ) where import Common @@ -69,6 +71,9 @@ rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" . rsyncParamsFixup +rsyncCreateProcess :: [CommandParam] -> CreateProcess +rsyncCreateProcess = proc "rsync" . toCommand . rsyncParamsFixup + {- On Windows, rsync is from msys2, and expects to get msys2 formatted - paths to files. (It thinks that C:foo refers to a host named "C"). - Fix up the Params appropriately. -} @@ -187,3 +192,17 @@ | otherwise = s #endif +{- When listing files with eg --dry-run, rsync escapes some characters + - to 3 octal digits. Eg, "\#012" is '\n' + -} +rsyncPathUnescape :: String -> FilePath +rsyncPathUnescape = go + where + go [] = [] + go ('\\':'#':d1:d2:d3:cs) + | isOctDigit d1 && isOctDigit d2 && isOctDigit d3 = + case (readish [d1], readish [d2], readish [d3]) of + (Just n1, Just n2, Just n3) -> + chr (n3+8*n2+8*8*n1) : go cs + _ -> error "internal" + go (c:cs) = c : go cs diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -1,6 +1,6 @@ {- Simple line-based protocols. - - - Copyright 2013-2024 Joey Hess + - Copyright 2013-2026 Joey Hess - - License: BSD-2-clause -} @@ -11,6 +11,9 @@ module Utility.SimpleProtocol ( Sendable(..), Receivable(..), + SendableMessage, + mkMessage, + genMessage, parseMessage, Serializable(..), Parser, @@ -34,7 +37,7 @@ -- Messages that can be sent. class Sendable m where - formatMessage :: m -> [String] + formatMessage :: m -> SendableMessage -- Messages that can be received. class Receivable m where @@ -42,6 +45,25 @@ -- a Parser that can be be fed the rest of the message to generate -- the value. parseCommand :: String -> Parser m + +-- Destructor not exported, to force use of genMessage. +newtype SendableMessage = SendableMessage [String] + +mkMessage :: [String] -> SendableMessage +mkMessage = SendableMessage + +-- Generate a message to be sent, not including the trailing newline. +genMessage :: Sendable m => m -> String +genMessage m = + let (SendableMessage l) = formatMessage m + in unwords $ map removeunsafe l + where + -- Guard against a newline somehow slipping into the message, + -- which is not supported since this is a line-based protocol. + -- If it somehow happens, it's stripped, so the protocol may + -- request the wrong filename, for example, but at least won't + -- get messed up at the line level. + removeunsafe s = filter (/= '\n') s parseMessage :: (Receivable m) => String -> Maybe m parseMessage s = parseCommand command rest diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -8,8 +8,8 @@ {-# LANGUAGE CPP #-} module Utility.ThreadScheduler ( - Seconds(..), - Microseconds, + SecondsDelay(..), + MicrosecondsDelay, runEvery, threadDelaySeconds, waitForTermination, @@ -29,30 +29,30 @@ import System.Posix.Terminal #endif -newtype Seconds = Seconds { fromSeconds :: Int } +newtype SecondsDelay = SecondsDelay { fromSecondsDelay :: Int } deriving (Eq, Ord, Show) -type Microseconds = Integer +type MicrosecondsDelay = Integer {- Runs an action repeatedly forever, sleeping at least the specified number - of seconds in between. -} -runEvery :: Seconds -> IO a -> IO a +runEvery :: SecondsDelay -> IO a -> IO a runEvery n a = forever $ do threadDelaySeconds n a -threadDelaySeconds :: Seconds -> IO () -threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) +threadDelaySeconds :: SecondsDelay -> IO () +threadDelaySeconds (SecondsDelay n) = unboundDelay (fromIntegral n * oneSecond) {- Like threadDelay, but not bounded by an Int. -} -unboundDelay :: Microseconds -> IO () +unboundDelay :: MicrosecondsDelay -> IO () unboundDelay = Unbounded.delay {- Pauses the main thread, letting children run until program termination. -} waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - forever $ threadDelaySeconds (Seconds 6000) + forever $ threadDelaySeconds (SecondsDelay 6000) #else lock <- newEmptyMVar let check sig = void $ @@ -63,5 +63,5 @@ takeMVar lock #endif -oneSecond :: Microseconds +oneSecond :: MicrosecondsDelay oneSecond = 1000000 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,6 +1,6 @@ {- Temporary files. - - - Copyright 2010-2025 Joey Hess + - Copyright 2010-2026 Joey Hess - - License: BSD-2-clause -} @@ -15,12 +15,15 @@ withTmpFile, withTmpFileIn, openTmpFileIn, + removeTmpFile, + systemTmpDirectory, relatedTemplate, relatedTemplate', ) where import System.IO import Control.Monad.IO.Class +import Control.Monad import System.IO.Error #ifndef mingw32_HOST_OS import Data.Char @@ -49,6 +52,10 @@ let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template) in annotateIOError e loc Nothing Nothing +{- Remove a temporary file if it is still present. -} +removeTmpFile :: OsPath -> IO () +removeTmpFile = void . tryIO . removeFile + {- Runs an action like writeFileString, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. @@ -85,8 +92,12 @@ - (or in "." if there is none) then removes the file. -} withTmpFile :: (MonadIO m, MonadMask m) => Template -> (OsPath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- liftIO $ catchDefaultIO (literalOsPath ".") getTemporaryDirectory + tmpdir <- liftIO systemTmpDirectory withTmpFileIn tmpdir template a + +{- The system's tmp directory (or "." if there is none). -} +systemTmpDirectory :: IO OsPath +systemTmpDirectory = catchDefaultIO (literalOsPath ".") getTemporaryDirectory {- Runs an action with a tmp file located in the specified directory, - then removes the file. @@ -100,7 +111,7 @@ create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h - tryIO $ removeFile name + removeTmpFile name use (name, h) = a name h {- It's not safe to use a FilePath of an existing file as the template diff --git a/Utility/Tor.hs b/Utility/Tor.hs --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -118,7 +118,7 @@ Right s | ".onion\n" `isSuffixOf` s -> return (OnionAddress (takeWhile (/= '\n') s), p) _ -> do - threadDelaySeconds (Seconds 1) + threadDelaySeconds (SecondsDelay 1) waithiddenservice (n-1) p -- | A hidden service directory to use. diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20260624 +Version: 10.20260717 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -36,6 +36,7 @@ Extra-Source-Files: stack.yaml stack-botan.yaml + stack-NoLLMDependencies.yaml README CHANGELOG NEWS @@ -146,6 +147,12 @@ templates/notifications/longpolling.julius Utility/libkqueue.h +Flag NoLLMDependencies + Description: Avoid building with versions of dependencies that contain + LLM generated code + Default: False + Manual: True + Flag Assistant Description: Enable git-annex assistant, webapp, and watch command Default: True @@ -213,7 +220,6 @@ Executable git-annex Main-Is: git-annex.hs Build-Depends: - base (>= 4.18.2.1 && < 5), network-uri (>= 2.6), optparse-applicative (>= 0.14.2), containers (>= 0.5.8), @@ -252,7 +258,6 @@ conduit, time (>= 1.9.1), persistent-sqlite (>= 2.13.3), - persistent (>= 2.13.3), persistent-template (>= 2.8.0), unliftio-core, microlens, @@ -277,22 +282,22 @@ tasty-quickcheck, tasty-rerun, ansi-terminal >= 0.9, - aws (>= 0.24.1), DAV (>= 1.0), network (>= 3.0.0.0), network-bsd, git-lfs (>= 1.2.0), clock (>= 0.3.0), - crypton, - crypton-connection (>= 0.4.3), - crypton-x509-store, - tls, servant, servant-server, servant-client, servant-client-core, warp (>= 3.2.8), - warp-tls (>= 3.2.2) + warp-tls (>= 3.2.2), + crypton, + crypton-connection (>= 0.4.3), + crypton-x509-store, + tls, + aws (>= 0.24.1) CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell2010 @@ -300,6 +305,17 @@ Other-Extensions: TemplateHaskell -- Some things don't work with the non-threaded RTS. GHC-Options: -threaded + + if flag(NoLLMDependencies) + CPP-Options: -DWITH_NOLLMDEPENDENCIES + Build-Depends: + base (>= 4.18.2.1 && < 4.23), + ram (< 0.21.0), + persistent (>= 2.13.3) && (< 2.15.0.0) + else + Build-Depends: + base (>= 4.18.2.1 && < 5), + persistent (>= 2.13.3) -- Fully optimize for production. if flag(Production) @@ -366,10 +382,6 @@ CPP-Options: -DWITH_ASSISTANT -DWITH_WEBAPP Build-Depends: mountpoints, - yesod (>= 1.4.3), - yesod-static (>= 1.5.1), - yesod-form (>= 1.4.8), - yesod-core (>= 1.6.0), path-pieces (>= 0.2.1), wai, wai-extra, @@ -377,6 +389,18 @@ clientsession, template-haskell, shakespeare (>= 2.0.11) + if flag(NoLLMDependencies) + Build-Depends: + yesod (>= 1.4.3) && (< 1.7.0.0), + yesod-static (>= 1.5.1) && (<1.6.1.3), + yesod-form (>= 1.4.8) && (< 1.7.9.3), + yesod-core (>= 1.6.0) && (< 1.7.0.0) + else + Build-Depends: + yesod (>= 1.4.3), + yesod-static (>= 1.5.1), + yesod-form (>= 1.4.8), + yesod-core (>= 1.6.0) Other-Modules: Assistant Assistant.Alert diff --git a/stack-NoLLMDependencies.yaml b/stack-NoLLMDependencies.yaml new file mode 100644 --- /dev/null +++ b/stack-NoLLMDependencies.yaml @@ -0,0 +1,30 @@ +flags: + git-annex: + NoLLMDependencies: true + production: true + parallelbuild: true + assistant: true + torrentparser: true + magicmime: false + dbus: false + debuglocks: false + benchmark: true + ospath: true + botan: false + blake3: true + xxh3: true + file-io: + os-string: true + xxhash-ffi: + pkg-config: false +packages: +- '.' +resolver: lts-24.26 +extra-deps: +- aws-0.25.2 +- file-io-0.2.0 +- blake3-0.3 +- xxhash-ffi-0.3.1 +- ram-0.20.1 +- persistent-2.14.6.3 +- persistent-sqlite-2.13.3.0 diff --git a/stack-botan.yaml b/stack-botan.yaml --- a/stack-botan.yaml +++ b/stack-botan.yaml @@ -1,5 +1,6 @@ flags: git-annex: + NoLLMDependencies: false production: true parallelbuild: true assistant: true diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,6 @@ flags: git-annex: + NoLLMDependencies: false production: true parallelbuild: true assistant: true