git-annex 6.20180409 → 6.20180427
raw patch · 59 files changed
+678/−310 lines, 59 files
Files
- Annex.hs +4/−4
- Annex/Branch.hs +21/−6
- Annex/Journal.hs +0/−21
- Annex/NumCopies.hs +5/−0
- Annex/SpecialRemote.hs +2/−2
- Assistant/Alert/Utility.hs +2/−3
- Assistant/DaemonStatus.hs +2/−2
- Assistant/Install.hs +19/−6
- Assistant/NamedThread.hs +2/−2
- Assistant/TransferQueue.hs +2/−2
- Assistant/WebApp/Configurators/IA.hs +2/−1
- Assistant/WebApp/Configurators/Local.hs +28/−9
- Assistant/WebApp/Form.hs +5/−0
- Assistant/WebApp/Pairing.hs +2/−2
- Assistant/WebApp/Types.hs +9/−0
- Build/Configure.hs +0/−1
- CHANGELOG +30/−0
- CmdLine/GitAnnex/Options.hs +23/−0
- CmdLine/Seek.hs +12/−9
- Command/AddUrl.hs +1/−3
- Command/Copy.hs +19/−10
- Command/Drop.hs +2/−2
- Command/Get.hs +1/−1
- Command/ImportFeed.hs +2/−1
- Command/Info.hs +19/−12
- Command/MetaData.hs +4/−4
- Command/Mirror.hs +1/−1
- Command/Move.hs +162/−95
- Command/Sync.hs +1/−1
- Command/Unused.hs +2/−1
- Command/Vicfg.hs +8/−6
- Command/WebApp.hs +22/−22
- Command/Whereis.hs +2/−1
- Git/Queue.hs +2/−2
- Key.hs +3/−3
- Limit.hs +1/−1
- Logs/Location.hs +26/−9
- Logs/MapLog.hs +2/−2
- Logs/Trust.hs +1/−1
- Logs/UUID.hs +2/−2
- Messages/JSON.hs +21/−22
- P2P/IO.hs +1/−1
- Remote.hs +8/−8
- Remote/Tahoe.hs +1/−1
- Test.hs +2/−2
- Types/Messages.hs +1/−1
- Types/MetaData.hs +8/−9
- Types/TrustLevel.hs +7/−3
- Utility/Aeson.hs +86/−0
- Utility/Android.hs +17/−0
- Utility/DirWatcher/Kqueue.hs +2/−2
- Utility/Directory/Stream.hs +22/−5
- Utility/Mounts.hs +4/−0
- Utility/Url.hs +16/−1
- Utility/UserInfo.hs +7/−4
- Utility/Yesod.hs +4/−0
- doc/git-annex-copy.mdwn +5/−0
- doc/git-annex-move.mdwn +10/−0
- git-annex.cabal +3/−1
Annex.hs view
@@ -73,7 +73,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Set as S {- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.@@ -262,17 +262,17 @@ {- Sets a flag to True -} setFlag :: String -> Annex () setFlag flag = changeState $ \s ->- s { flags = M.insertWith' const flag True $ flags s }+ s { flags = M.insert flag True $ flags s } {- Sets a field to a value -} setField :: String -> String -> Annex () setField field value = changeState $ \s ->- s { fields = M.insertWith' const field value $ fields s }+ s { fields = M.insert field value $ fields s } {- Adds a cleanup action to perform. -} addCleanup :: CleanupAction -> Annex () -> Annex () addCleanup k a = changeState $ \s ->- s { cleanup = M.insertWith' const k a $ cleanup s }+ s { cleanup = M.insert k a $ cleanup s } {- Sets the type of output to emit. -} setOutput :: OutputType -> Annex ()
Annex/Branch.hs view
@@ -34,6 +34,7 @@ import Data.Function import Data.Char import Control.Concurrent (threadDelay)+import System.IO.Unsafe (unsafeInterleaveIO) import Annex.Common import Annex.BranchState@@ -333,19 +334,33 @@ let racemessage = basemessage ++ " (recovery from race #" ++ show retrynum' ++ "; expected commit parent " ++ show branchref ++ " but found " ++ show lostrefs ++ " )" commitIndex' jl committedref racemessage basemessage retrynum' [committedref] -{- Lists all files on the branch. There may be duplicates in the list. -}+{- Lists all files on the branch. including ones in the journal+ - that have not been committed yet. There may be duplicates in the list.+ - Streams lazily. -} files :: Annex [FilePath] files = do update- (++)- <$> branchFiles- <*> getJournalledFilesStale+ withIndex $ do+ g <- gitRepo+ withJournalHandle (go g)+ where+ go g jh = readDirectory jh >>= \case+ Nothing -> branchFiles' g+ Just file+ | dirCruft file -> go g jh+ | otherwise -> do+ let branchfile = fileJournal file+ rest <- unsafeInterleaveIO (go g jh)+ return (branchfile:rest) {- Files in the branch, not including any from journalled changes, - and without updating the branch. -} branchFiles :: Annex [FilePath]-branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie $- lsTreeParams fullname [Param "--name-only"]+branchFiles = withIndex $ inRepo branchFiles'++branchFiles' :: Git.Repo -> IO [FilePath]+branchFiles' = Git.Command.pipeNullSplitZombie+ (lsTreeParams fullname [Param "--name-only"]) {- Populates the branch's index file with the current branch contents. -
Annex/Journal.hs view
@@ -55,27 +55,6 @@ getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ readFileStrict $ journalFile file g -{- List of files that have updated content in the journal. -}-getJournalledFiles :: JournalLocked -> Annex [FilePath]-getJournalledFiles jl = map fileJournal <$> getJournalFiles jl--getJournalledFilesStale :: Annex [FilePath]-getJournalledFilesStale = map fileJournal <$> getJournalFilesStale--{- List of existing journal files. -}-getJournalFiles :: JournalLocked -> Annex [FilePath]-getJournalFiles _jl = getJournalFilesStale--{- List of existing journal files, but without locking, may miss new ones- - just being added, or may have false positives if the journal is staged- - as it is run. -}-getJournalFilesStale :: Annex [FilePath]-getJournalFilesStale = do- g <- gitRepo- fs <- liftIO $ catchDefaultIO [] $- getDirectoryContents $ gitAnnexJournalDir g- return $ filter (`notElem` [".", ".."]) fs- withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a withJournalHandle a = do d <- fromRepo gitAnnexJournalDir
Annex/NumCopies.hs view
@@ -11,6 +11,7 @@ module Types.NumCopies, module Logs.NumCopies, getFileNumCopies,+ getAssociatedFileNumCopies, getGlobalFileNumCopies, getNumCopies, deprecatedNumCopies,@@ -68,6 +69,10 @@ , getFileNumCopies' f , deprecatedNumCopies ]++getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies+getAssociatedFileNumCopies (AssociatedFile afile) =+ maybe getNumCopies getFileNumCopies afile {- This is the globally visible numcopies value for a file. So it does - not include local configuration in the git config or command line
Annex/SpecialRemote.hs view
@@ -25,10 +25,10 @@ findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig)) findExisting name = do t <- trustMap- matches <- sortBy (comparing $ \(u, _c) -> M.lookup u t)+ headMaybe+ . sortBy (comparing $ \(u, _c) -> Down $ M.lookup u t) . findByName name <$> Logs.Remote.readRemoteLog- return $ headMaybe matches newConfig :: RemoteName -> RemoteConfig newConfig = M.singleton nameKey
Assistant/Alert/Utility.hs view
@@ -13,7 +13,7 @@ import qualified Data.Text as T import Data.Text (Text)-import qualified Data.Map as M+import qualified Data.Map.Strict as M {- This is as many alerts as it makes sense to display at a time. - A display might be smaller, or larger, the point is to not overwhelm the@@ -121,8 +121,7 @@ pruneold l = let (f, rest) = partition (\(_, a) -> isFiller a) l in drop bloat f ++ rest- updatePrune = pruneBloat $ M.filterWithKey pruneSame $- M.insertWith' const i al m+ updatePrune = pruneBloat $ M.filterWithKey pruneSame $ M.insert i al m updateCombine combiner = let combined = M.mapMaybe (combiner al) m in if M.null combined
Assistant/DaemonStatus.hs view
@@ -25,7 +25,7 @@ import Control.Concurrent.STM import System.Posix.Types import Data.Time.Clock.POSIX-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Set as S getDaemonStatus :: Assistant DaemonStatus@@ -181,7 +181,7 @@ - or if already present, updates it while preserving the old transferTid, - transferPaused, and bytesComplete values, which are not written to disk. -} updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()-updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info+updateTransferInfo t info = updateTransferInfo' $ M.insertWith merge t info where merge new old = new { transferTid = maybe (transferTid new) Just (transferTid old)
Assistant/Install.hs view
@@ -23,6 +23,8 @@ #else import Utility.FreeDesktop import Assistant.Install.Menu+import Utility.UserInfo+import Utility.Android #endif standaloneAppBase :: IO (Maybe FilePath)@@ -54,13 +56,24 @@ #ifdef darwin_HOST_OS autostartfile <- userAutoStart osxAutoStartLabel+ installAutoStart program autostartfile #else- menufile <- desktopMenuFilePath "git-annex" <$> userDataDir- icondir <- iconDir <$> userDataDir- installMenu program menufile base icondir- autostartfile <- autoStartPath "git-annex" <$> userConfigDir+ ifM osAndroid+ ( do+ -- Integration with the Termux:Boot app.+ home <- myHomeDir+ let bootfile = home </> ".termux" </> "boot" </> "git-annex"+ unlessM (doesFileExist bootfile) $ do+ createDirectoryIfMissing True (takeDirectory bootfile)+ writeFile bootfile "git-annex assistant --autostart"+ , do+ menufile <- desktopMenuFilePath "git-annex" <$> userDataDir+ icondir <- iconDir <$> userDataDir+ installMenu program menufile base icondir+ autostartfile <- autoStartPath "git-annex" <$> userConfigDir+ installAutoStart program autostartfile+ ) #endif- installAutoStart program autostartfile sshdir <- sshDir let runshell var = "exec " ++ base </> "runshell " ++ var@@ -93,7 +106,7 @@ installFileManagerHooks :: FilePath -> IO () #ifdef linux_HOST_OS-installFileManagerHooks program = do+installFileManagerHooks program = unlessM osAndroid $ do let actions = ["get", "drop", "undo"] -- Gnome
Assistant/NamedThread.hs view
@@ -20,7 +20,7 @@ import Control.Concurrent import Control.Concurrent.Async-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Control.Exception as E #ifdef WITH_WEBAPP@@ -57,7 +57,7 @@ aid <- liftIO $ runner $ d { threadName = name } restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a) modifyDaemonStatus_ $ \s -> s- { startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) }+ { startedThreads = M.insert name (aid, restart) (startedThreads s) } runmanaged first d = do aid <- async $ runAssistant d $ do void first
Assistant/TransferQueue.hs view
@@ -35,7 +35,7 @@ import Utility.TList import Control.Concurrent.STM-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Set as S type Reason = String@@ -198,7 +198,7 @@ if acceptable info then do adjustTransfersSTM dstatus $- M.insertWith' const t info+ M.insert t info return $ Just r else return Nothing
Assistant/WebApp/Configurators/IA.hs view
@@ -205,5 +205,6 @@ #ifdef WITH_S3 url = S3.iaItemUrl bucket #else- url = ""+ url = case bucket of+ _ -> "" #endif
Assistant/WebApp/Configurators/Local.hs view
@@ -38,6 +38,7 @@ import Utility.Gpg import qualified Remote.GCrypt as GCrypt import qualified Types.Remote+import Utility.Android import qualified Data.Text as T import qualified Data.Map as M@@ -98,6 +99,9 @@ {- On first run, if run in the home directory, default to putting it in - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. -+ - When on Android, default to ~/storage/shared/annex, which termux sets up+ - as a link to the sdcard.+ - - If run in another directory, that the user can write to, - the user probably wants to put it there. Unless that directory - contains a git-annex file, in which case the user has probably@@ -120,12 +124,21 @@ if firstrun then inhome else inhome #endif where- inhome = do- desktop <- userDesktopDir- ifM (doesDirectoryExist desktop <&&> canWrite desktop)- ( relHome $ desktop </> gitAnnexAssistantDefaultDir- , return $ "~" </> gitAnnexAssistantDefaultDir- )+ inhome = ifM osAndroid+ ( do+ home <- myHomeDir+ let storageshared = home </> "storage" </> "shared"+ ifM (doesDirectoryExist storageshared)+ ( relHome $ storageshared </> gitAnnexAssistantDefaultDir+ , return $ "~" </> gitAnnexAssistantDefaultDir+ )+ , do+ desktop <- userDesktopDir+ ifM (doesDirectoryExist desktop <&&> canWrite desktop)+ ( relHome $ desktop </> gitAnnexAssistantDefaultDir+ , return $ "~" </> gitAnnexAssistantDefaultDir+ )+ ) #ifndef mingw32_HOST_OS -- Avoid using eg, standalone build's git-annex.linux/ directory -- when run from there.@@ -156,7 +169,7 @@ androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM" let path = "/sdcard/annex" #else- let androidspecial = False+ androidspecial <- liftIO osAndroid path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun #endif ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path@@ -166,8 +179,14 @@ _ -> $(widgetFile "configurators/newrepository/first") getAndroidCameraRepositoryR :: Handler ()-getAndroidCameraRepositoryR = - startFullAssistant "/sdcard/DCIM" SourceGroup $ Just addignore +getAndroidCameraRepositoryR = do+#ifdef __ANDROID__+ let dcim = "/sdcard/DCIM"+#else+ home <- liftIO myHomeDir+ let dcim = home </> "storage" </> "dcim"+#endif+ startFullAssistant dcim SourceGroup $ Just addignore where addignore = do liftIO $ unlessM (doesFileExist ".gitignore") $
Assistant/WebApp/Form.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings, RankNTypes #-} module Assistant.WebApp.Form where@@ -67,7 +68,11 @@ ident = "toggle_" ++ toggle {- Adds a check box to an AForm to control encryption. -}+#if MIN_VERSION_yesod_core(1,6,0)+enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerFor site) EnableEncryption+#else enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption+#endif enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption) where choices :: [(Text, EnableEncryption)]
Assistant/WebApp/Pairing.hs view
@@ -17,7 +17,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import qualified Data.Map as M+import qualified Data.Map.Strict as M data PairingWith = PairingWithSelf | PairingWithFriend deriving (Eq, Show, Read)@@ -37,7 +37,7 @@ m <- readTVar tv -- use of head is safe because allids is infinite let i = Prelude.head $ filter (`notElem` M.keys m) allids- writeTVar tv (M.insertWith' const i h m)+ writeTVar tv (M.insert i h m) return i where allids = map WormholePairingId [1..]
Assistant/WebApp/Types.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Assistant.WebApp.Types (@@ -94,7 +95,11 @@ , liftAssistant $ liftAnnex a ) +#if MIN_VERSION_yesod_core(1,6,0)+instance LiftAnnex (WidgetFor WebApp) where+#else instance LiftAnnex (WidgetT WebApp IO) where+#endif liftAnnex = liftH . liftAnnex class LiftAssistant m where@@ -104,7 +109,11 @@ liftAssistant a = liftIO . flip runAssistant a =<< assistantData <$> getYesod +#if MIN_VERSION_yesod_core(1,6,0)+instance LiftAssistant (WidgetFor WebApp) where+#else instance LiftAssistant (WidgetT WebApp IO) where+#endif liftAssistant = liftH . liftAssistant type MkMForm x = MForm Handler (FormResult x, Widget)
Build/Configure.hs view
@@ -9,7 +9,6 @@ import Utility.SafeCommand import Utility.ExternalSHA import Utility.Env.Basic-import Utility.Exception import qualified Git.Version import Utility.Directory
CHANGELOG view
@@ -1,3 +1,33 @@+git-annex (6.20180427) upstream; urgency=medium++ * move: Now takes numcopies configuration, and required content+ configuration into account, and refuses to reduce the current+ number of copies of a file, or remove content that a repository+ requires. --force can override these checks.+ Note that it's still allowed to move the content of a file+ from one repository to another when numcopies is not satisfied, as long+ as the move does not result in there being fewer copies.+ * Fix mangling of --json output of utf-8 characters when not+ running in a utf-8 locale.+ * Fix build with yesod 1.6.+ * Clean up some build warnings with newer versions of ghc and haskell+ libraries.+ * runshell: Unset LD_PRELOAD since preloaded libraries from the host+ system may not get along with the bundled linker.+ * runshell: Added some tweaks to make git-annex work in termux on+ Android. The regular arm standalone tarball now works in termux.+ * Webapp: Support being run inside termux on Android, and offer to set up+ a repository on the sdcard.+ * Assistant: Integrate with Termux:Boot, so when it's installed, the+ assistant is autostarted on boot.+ * Assistant: Fix installation of menus, icons, etc when run+ from within runshell.+ * import: Avoid buffering all filenames to be imported in memory.+ * Improve memory use and speed of --all and git-annex info remote,+ by not buffering list of all keys.++ -- Joey Hess <id@joeyh.name> Fri, 27 Apr 2018 12:36:20 -0400+ git-annex (6.20180409) upstream; urgency=medium * Added adb special remote which allows exporting files to Android devices.
CmdLine/GitAnnex/Options.hs view
@@ -5,10 +5,14 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}+ module CmdLine.GitAnnex.Options where import Options.Applicative+#if ! MIN_VERSION_optparse_applicative(0,14,1) import Options.Applicative.Builder.Internal+#endif import Control.Concurrent import qualified Data.Map as M @@ -113,6 +117,7 @@ . (fromJust <$$> Remote.byNameWithUUID) . Just +-- | From or To a remote. data FromToOptions = FromRemote (DeferredParse Remote) | ToRemote (DeferredParse Remote)@@ -139,6 +144,24 @@ <> help "destination remote" <> completeRemotes )++-- | Like FromToOptions, but with a special --to=here+type FromToHereOptions = Either ToHere FromToOptions++data ToHere = ToHere++parseFromToHereOptions :: Parser FromToHereOptions+parseFromToHereOptions = parsefrom <|> parseto+ where+ parsefrom = Right . FromRemote . parseRemoteOption <$> parseFromOption+ parseto = herespecialcase <$> parseToOption+ where+ herespecialcase "here" = Left ToHere+ herespecialcase "." = Left ToHere+ herespecialcase n = Right $ ToRemote $ parseRemoteOption n++instance DeferredParseClass FromToHereOptions where+ finishParse = either (pure . Left) (Right <$$> finishParse) -- Options for acting on keys, rather than work tree files. data KeyOptions
CmdLine/Seek.hs view
@@ -93,9 +93,11 @@ withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher- seekActions $ map a <$> (filterM (checkmatch matcher) =<< ps)+ forM_ params $ \p -> do+ fs <- liftIO $ get p+ forM fs $ \f -> whenM (checkmatch matcher f) $+ commandAction (a f) where- ps = concat <$> liftIO (mapM get params) get p = ifM (isDirectory <$> getFileStatus p) ( map (\f -> (f, makeRelative (parentDir p) f)) <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p@@ -194,14 +196,14 @@ giveup "Cannot use --auto in a bare repository" case (null params, ko) of (True, Nothing)- | bare -> noauto $ runkeyaction loggedKeys+ | bare -> noauto $ runkeyaction finishCheck loggedKeys | otherwise -> fallbackaction params (False, Nothing) -> fallbackaction params- (True, Just WantAllKeys) -> noauto $ runkeyaction loggedKeys- (True, Just WantUnusedKeys) -> noauto $ runkeyaction unusedKeys'+ (True, Just WantAllKeys) -> noauto $ runkeyaction finishCheck loggedKeys+ (True, Just WantUnusedKeys) -> noauto $ runkeyaction (pure . Just) unusedKeys' (True, Just WantFailedTransfers) -> noauto runfailedtransfers- (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k])- (True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys+ (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (pure . Just) (return [k])+ (True, Just WantIncompleteKeys) -> noauto $ runkeyaction (pure . Just) incompletekeys (True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs (False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete" where@@ -209,10 +211,11 @@ | auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" | otherwise = a incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True- runkeyaction getks = do+ runkeyaction checker getks = do keyaction <- mkkeyaction ks <- getks- forM_ ks $ \k -> keyaction k (mkActionItem k)+ forM_ ks $ checker >=> maybe noop + (\k -> keyaction k (mkActionItem k)) runbranchkeys bs = do keyaction <- mkkeyaction forM_ bs $ \b -> do
Command/AddUrl.hs view
@@ -27,7 +27,6 @@ import Types.UrlContents import Annex.FileMatcher import Logs.Location-import Messages.Progress import Utility.Metered import Utility.FileSystemEncoding import Utility.HtmlDetect@@ -261,8 +260,7 @@ go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file)) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing- downloader f p = metered (Just p) urlkey (pure Nothing) $ - \_ p' -> downloadUrl urlkey p' [url] f+ downloader f p = downloadUrl urlkey p [url] f go Nothing = return Nothing -- If we downloaded a html file, try to use youtube-dl to -- extract embedded media.
Command/Copy.hs view
@@ -20,46 +20,55 @@ paramPaths (seek <--< optParser) data CopyOptions = CopyOptions- { moveOptions :: Command.Move.MoveOptions+ { copyFiles :: CmdParams+ , fromToOptions :: FromToHereOptions+ , keyOptions :: Maybe KeyOptions , autoMode :: Bool+ , batchOption :: BatchMode } optParser :: CmdParamsDesc -> Parser CopyOptions optParser desc = CopyOptions- <$> Command.Move.optParser desc+ <$> cmdParams desc+ <*> parseFromToHereOptions+ <*> optional (parseKeyOptions <|> parseFailedTransfersOption) <*> parseAutoOption+ <*> parseBatchOption instance DeferredParseClass CopyOptions where finishParse v = CopyOptions- <$> finishParse (moveOptions v)+ <$> pure (copyFiles v)+ <*> finishParse (fromToOptions v)+ <*> pure (keyOptions v) <*> pure (autoMode v)+ <*> pure (batchOption v) seek :: CopyOptions -> CommandSeek seek o = allowConcurrentOutput $ do let go = whenAnnexed $ start o- case Command.Move.batchOption (moveOptions o) of+ case batchOption o of Batch -> batchInput Right (batchCommandAction . go) NoBatch -> withKeyOptions- (Command.Move.keyOptions $ moveOptions o) (autoMode o)- (Command.Move.startKey (moveOptions o) False)+ (keyOptions o) (autoMode o)+ (Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) (withFilesInGit go)- =<< workTreeItems (Command.Move.moveFiles $ moveOptions o)+ =<< workTreeItems (copyFiles o) {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -} start :: CopyOptions -> FilePath -> Key -> CommandStart start o file key = stopUnless shouldCopy $ - Command.Move.start (moveOptions o) False file key+ Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key where shouldCopy | autoMode o = want <||> numCopiesCheck file key (<) | otherwise = return True- want = case Command.Move.fromToOptions (moveOptions o) of+ want = case fromToOptions o of Right (ToRemote dest) -> (Remote.uuid <$> getParsed dest) >>= checkwantsend Right (FromRemote _) -> checkwantget- Left Command.Move.ToHere -> checkwantget+ Left ToHere -> checkwantget checkwantsend = wantSend False (Just key) (AssociatedFile (Just file)) checkwantget = wantGet False (Just key) (AssociatedFile (Just file))
Command/Drop.hs view
@@ -202,8 +202,8 @@ {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. -} checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart-checkDropAuto automode mremote (AssociatedFile afile) key a =- go =<< maybe getNumCopies getFileNumCopies afile+checkDropAuto automode mremote afile key a =+ go =<< getAssociatedFileNumCopies afile where go numcopies | automode = do
Command/Get.hs view
@@ -68,7 +68,7 @@ Nothing -> go $ perform key afile Just src -> stopUnless (Command.Move.fromOk src key) $- go $ Command.Move.fromPerform src False key afile+ go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile where go a = do showStartKey "get" key ai
Command/ImportFeed.hs view
@@ -82,6 +82,7 @@ feedProblem url "bad feed content; no enclosures to download" next $ return True l -> do+ showOutput ok <- and <$> mapM (performDownload opts cache) l unless ok $ feedProblem url "problem downloading item"@@ -226,7 +227,7 @@ case dest of Nothing -> return True Just f -> do- showStart "addurl" f+ showStart "addurl" url ks <- getter f if null ks then do
Command/Info.hs view
@@ -11,9 +11,8 @@ import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M-import qualified Data.Text as T+import qualified Data.Vector as V import Data.Ord-import Data.Aeson hiding (json) import Command import qualified Git@@ -34,6 +33,7 @@ import Git.Config (boolConfig) import qualified Git.LsTree as LsTree import Utility.Percentage+import Utility.Aeson hiding (json) import Types.Transfer import Logs.Transfer import Types.Key@@ -283,7 +283,7 @@ nostat :: Stat nostat = return Nothing -json :: ToJSON j => (j -> String) -> StatState j -> String -> StatState String+json :: ToJSON' j => (j -> String) -> StatState j -> String -> StatState String json fmt a desc = do j <- a lift $ maybeShowJSON $ JSONChunk [(desc, j)]@@ -422,7 +422,7 @@ transfer_list = stat desc $ nojson $ lift $ do uuidmap <- Remote.remoteMap id ts <- getTransfers- maybeShowJSON $ JSONChunk [(desc, map (uncurry jsonify) ts)]+ maybeShowJSON $ JSONChunk [(desc, V.fromList $ map (uncurry jsonify) ts)] return $ if null ts then "none" else multiLine $@@ -438,11 +438,11 @@ , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ]- jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $- [ ("transfer", toJSON (formatDirection (transferDirection t)))- , ("key", toJSON (key2file (transferKey t)))- , ("file", toJSON afile)- , ("remote", toJSON (fromUUID (transferUUID t)))+ jsonify t i = object $ map (\(k, v) -> (packString k, v)) $+ [ ("transfer", toJSON' (formatDirection (transferDirection t)))+ , ("key", toJSON' (transferKey t))+ , ("file", toJSON' afile)+ , ("remote", toJSON' (fromUUID (transferUUID t))) ] where AssociatedFile afile = associatedFile i@@ -476,10 +476,13 @@ numcopies_stats = stat "numcopies stats" $ json fmt $ calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats) where- calc = map (\(variance, count) -> (show variance, count)) + calc = V.fromList+ . map (\(variance, count) -> (show variance, count)) . sortBy (flip (comparing fst)) . M.toList- fmt = multiLine . map (\(variance, count) -> "numcopies " ++ variance ++ ": " ++ show count)+ fmt = multiLine + . map (\(variance, count) -> "numcopies " ++ variance ++ ": " ++ show count)+ . V.toList reposizes_stats :: Stat reposizes_stats = stat desc $ nojson $ do@@ -522,7 +525,11 @@ case M.lookup u (repoData s) of Just v -> return v Nothing -> do- v <- foldKeys <$> lift (loggedKeysFor u)+ let combinedata d uk = finishCheck uk >>= \case+ Nothing -> return d+ Just k -> return $ addKey k d+ v <- lift $ foldM combinedata emptyKeyData+ =<< loggedKeysFor' u put s { repoData = M.insert u v (repoData s) } return v
Command/MetaData.hs view
@@ -14,12 +14,12 @@ import Annex.WorkTree import Messages.JSON (JSONActionItem(..)) import Types.Messages+import Utility.Aeson import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T import qualified Data.ByteString.Lazy.UTF8 as BU-import Data.Aeson import Control.Concurrent cmd :: Command@@ -115,7 +115,7 @@ cleanup :: Key -> CommandCleanup cleanup k = do m <- getCurrentMetaData k- let Object o = toJSON (MetaDataFields m)+ let Object o = toJSON' (MetaDataFields m) maybeShowJSON $ AesonObject o showLongNote $ unlines $ concatMap showmeta $ map unwrapmeta (fromMetaData m)@@ -129,8 +129,8 @@ newtype MetaDataFields = MetaDataFields MetaData deriving (Show) -instance ToJSON MetaDataFields where- toJSON (MetaDataFields m) = object [ (fieldsField, toJSON m) ]+instance ToJSON' MetaDataFields where+ toJSON' (MetaDataFields m) = object [ (fieldsField, toJSON' m) ] instance FromJSON MetaDataFields where parseJSON (Object v) = do
Command/Mirror.hs view
@@ -55,7 +55,7 @@ startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart startKey o afile key ai = onlyActionOn key $ case fromToOptions o of ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)- ( Command.Move.toStart False afile key ai =<< getParsed r+ ( Command.Move.toStart Command.Move.RemoveNever afile key ai =<< getParsed r , do numcopies <- getnumcopies Command.Drop.startRemote afile ai numcopies key =<< getParsed r
Command/Move.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -}@@ -15,6 +15,7 @@ import Annex.UUID import Annex.Transfer import Logs.Presence+import Logs.Trust import Annex.NumCopies import System.Log.Logger (debugM)@@ -27,89 +28,79 @@ data MoveOptions = MoveOptions { moveFiles :: CmdParams- , fromToOptions :: Either ToHere FromToOptions+ , fromToOptions :: FromToHereOptions+ , removeWhen :: RemoveWhen , keyOptions :: Maybe KeyOptions , batchOption :: BatchMode } -data ToHere = ToHere- optParser :: CmdParamsDesc -> Parser MoveOptions optParser desc = MoveOptions <$> cmdParams desc- <*> (parsefrom <|> parseto)+ <*> parseFromToHereOptions+ <*> pure RemoveSafe <*> optional (parseKeyOptions <|> parseFailedTransfersOption) <*> parseBatchOption- where- parsefrom = Right . FromRemote . parseRemoteOption <$> parseFromOption- parseto = herespecialcase <$> parseToOption- where- herespecialcase "here" = Left ToHere- herespecialcase "." = Left ToHere- herespecialcase n = Right $ ToRemote $ parseRemoteOption n instance DeferredParseClass MoveOptions where finishParse v = MoveOptions <$> pure (moveFiles v)- <*> either (pure . Left) (Right <$$> finishParse) (fromToOptions v)+ <*> finishParse (fromToOptions v)+ <*> pure (removeWhen v) <*> pure (keyOptions v) <*> pure (batchOption v) +data RemoveWhen = RemoveSafe | RemoveNever+ deriving (Show, Eq)+ seek :: MoveOptions -> CommandSeek seek o = allowConcurrentOutput $ do- let go = whenAnnexed $ start o True+ let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) case batchOption o of Batch -> batchInput Right (batchCommandAction . go) NoBatch -> withKeyOptions (keyOptions o) False- (startKey o True)+ (startKey (fromToOptions o) (removeWhen o)) (withFilesInGit go) =<< workTreeItems (moveFiles o) -start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart-start o move f k = start' o move afile k (mkActionItem afile)+start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart+start fromto removewhen f k =+ start' fromto removewhen afile k (mkActionItem afile) where afile = AssociatedFile (Just f) -startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart-startKey o move = start' o move (AssociatedFile Nothing)+startKey :: FromToHereOptions -> RemoveWhen -> Key -> ActionItem -> CommandStart+startKey fromto removewhen = start' fromto removewhen (AssociatedFile Nothing) -start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart-start' o move afile key ai = onlyActionOn key $- case fromToOptions o of+start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart+start' fromto removewhen afile key ai = onlyActionOn key $+ case fromto of Right (FromRemote src) -> checkFailedTransferDirection ai Download $- fromStart move afile key ai =<< getParsed src+ fromStart removewhen afile key ai =<< getParsed src Right (ToRemote dest) -> checkFailedTransferDirection ai Upload $- toStart move afile key ai =<< getParsed dest+ toStart removewhen afile key ai =<< getParsed dest Left ToHere -> checkFailedTransferDirection ai Download $- toHereStart move afile key ai+ toHereStart removewhen afile key ai -showMoveAction :: Bool -> Key -> ActionItem -> Annex ()-showMoveAction move = showStartKey (if move then "move" else "copy")+showMoveAction :: RemoveWhen -> Key -> ActionItem -> Annex ()+showMoveAction RemoveNever = showStartKey "copy"+showMoveAction _ = showStartKey "move" -{- Moves (or copies) the content of an annexed file to a remote.- -- - If the remote already has the content, it is still removed from- - the current repository.- -- - Note that unlike drop, this does not honor numcopies.- - A file's content can be moved even if there are insufficient copies to- - allow it to be dropped.- -}-toStart :: Bool -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart-toStart move afile key ai dest = do+toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart+toStart removewhen afile key ai dest = do u <- getUUID ishere <- inAnnex key if not ishere || u == Remote.uuid dest then stop -- not here, so nothing to do- else toStart' dest move afile key ai+ else toStart' dest removewhen afile key ai -toStart' :: Remote -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart-toStart' dest move afile key ai = do+toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart+toStart' dest removewhen afile key ai = do fast <- Annex.getState Annex.fast- if fast && not move+ if fast && removewhen == RemoveNever then ifM (expectedPresent dest key) ( stop , go True (pure $ Right False)@@ -117,16 +108,16 @@ else go False (Remote.hasKey dest key) where go fastcheck isthere = do- showMoveAction move key ai- next $ toPerform dest move key afile fastcheck =<< isthere+ showMoveAction removewhen key ai+ next $ toPerform dest removewhen key afile fastcheck =<< isthere expectedPresent :: Remote -> Key -> Annex Bool expectedPresent dest key = do remotes <- Remote.keyPossibilities key return $ dest `elem` remotes -toPerform :: Remote -> Bool -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform-toPerform dest move key afile fastcheck isthere =+toPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform+toPerform dest removewhen key afile fastcheck isthere = case isthere of Left err -> do showNote err@@ -137,44 +128,62 @@ upload (Remote.uuid dest) key afile stdRetry $ Remote.storeKey dest key afile if ok- then finish $+ then finish False $ Remote.logStatus dest key InfoPresent else do when fastcheck $ warning "This could have failed because --fast is enabled." stop- Right True -> finish $+ Right True -> finish True $ unlessM (expectedPresent dest key) $ Remote.logStatus dest key InfoPresent where- finish :: Annex () -> CommandPerform- finish setpresentremote- | move = lockContentForRemoval key $ \contentlock -> do- -- Drop content before updating location logs,- -- in case disk space is very low this frees up- -- space before writing data to disk.- removeAnnex contentlock- next $ do- setpresentremote- Command.Drop.cleanupLocal key- | otherwise = next $ do+ finish deststartedwithcopy setpresentremote = case removewhen of+ RemoveNever -> do setpresentremote- return True+ next $ return True+ RemoveSafe -> lockContentForRemoval key $ \contentlock -> do+ srcuuid <- getUUID+ let destuuid = Remote.uuid dest+ willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case+ DropAllowed -> drophere setpresentremote contentlock "moved"+ DropCheckNumCopies -> do+ numcopies <- getAssociatedFileNumCopies afile+ (tocheck, verified) <- verifiableCopies key [srcuuid]+ verifyEnoughCopiesToDrop "" key (Just contentlock)+ numcopies [srcuuid] verified+ (UnVerifiedRemote dest : tocheck)+ (drophere setpresentremote contentlock . showproof)+ (faileddrophere setpresentremote)+ DropWorse -> faileddrophere setpresentremote+ showproof proof = "proof: " ++ show proof+ drophere setpresentremote contentlock reason = do+ liftIO $ debugM "move" $ unwords+ [ "Dropping from here"+ , "(" ++ reason ++ ")"+ ]+ -- Drop content before updating location logs,+ -- in case disk space is very low this frees+ -- up space before writing data to disk.+ removeAnnex contentlock+ next $ do+ () <- setpresentremote+ Command.Drop.cleanupLocal key+ faileddrophere setpresentremote = do+ showLongNote "(Use --force to override this check, or adjust numcopies.)"+ showLongNote "Content not dropped from here."+ next $ do+ () <- setpresentremote+ return False -{- Moves (or copies) the content of an annexed file from a remote- - to the current repository.- -- - If the current repository already has the content, it is still removed- - from the remote.- -}-fromStart :: Bool -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart-fromStart move afile key ai src- | move = go- | otherwise = stopUnless (not <$> inAnnex key) go+fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart+fromStart removewhen afile key ai src = case removewhen of+ RemoveNever -> stopUnless (not <$> inAnnex key) go+ RemoveSafe -> go where go = stopUnless (fromOk src key) $ do- showMoveAction move key ai- next $ fromPerform src move key afile+ showMoveAction removewhen key ai+ next $ fromPerform src removewhen key afile fromOk :: Remote -> Key -> Annex Bool fromOk src key = go =<< Annex.getState Annex.force@@ -190,49 +199,107 @@ remotes <- Remote.keyPossibilities key return $ u /= Remote.uuid src && elem src remotes -fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform-fromPerform src move key afile = do+fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform+fromPerform src removewhen key afile = do showAction $ "from " ++ Remote.name src ifM (inAnnex key)- ( dispatch move True- , dispatch move =<< go+ ( dispatch removewhen True True+ , dispatch removewhen False =<< go ) where go = notifyTransfer Download afile $ download (Remote.uuid src) key afile stdRetry $ \p -> getViaTmp (RemoteVerify src) key $ \t -> Remote.retrieveKeyFile src key afile t p- dispatch _ False = stop -- failed- dispatch False True = next $ return True -- copy complete- -- Finish by dropping from remote, taking care to verify that- -- the copy here has not been lost somehow. - -- (NumCopies is 1 since we're moving.)- dispatch True True = verifyEnoughCopiesToDrop "" key Nothing- (NumCopies 1) [] [] [UnVerifiedHere] dropremote faileddropremote- dropremote proof = do- liftIO $ debugM "drop" $ unwords+ dispatch _ _ False = stop -- failed+ dispatch RemoveNever _ True = next $ return True -- copy complete+ dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do+ let srcuuid = Remote.uuid src+ destuuid <- getUUID+ willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case+ DropAllowed -> dropremote "moved"+ DropCheckNumCopies -> do+ numcopies <- getAssociatedFileNumCopies afile+ (tocheck, verified) <- verifiableCopies key [Remote.uuid src]+ verifyEnoughCopiesToDrop "" key Nothing numcopies [Remote.uuid src] verified+ tocheck (dropremote . showproof) faileddropremote+ DropWorse -> faileddropremote + showproof proof = "proof: " ++ show proof+ dropremote reason = do+ liftIO $ debugM "move" $ unwords [ "Dropping from remote" , show src- , "proof:"- , show proof+ , "(" ++ reason ++ ")" ] ok <- Remote.removeKey src key next $ Command.Drop.cleanupRemote key src ok- faileddropremote = giveup "Unable to drop from remote."+ faileddropremote = do+ showLongNote "(Use --force to override this check, or adjust numcopies.)"+ showLongNote $ "Content not dropped from " ++ Remote.name src ++ "."+ next $ return False {- Moves (or copies) the content of an annexed file from reachable remotes - to the current repository. -- - When moving, the content is removed from all the reachable remotes. -}-toHereStart :: Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart-toHereStart move afile key ai- | move = go- | otherwise = stopUnless (not <$> inAnnex key) go+ - When moving, the content is removed from all the reachable remotes that+ - it can safely be removed from. -}+toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart+toHereStart removewhen afile key ai = case removewhen of+ RemoveNever -> stopUnless (not <$> inAnnex key) go+ RemoveSafe -> go where go = do rs <- Remote.keyPossibilities key forM_ rs $ \r -> includeCommandAction $ do- showMoveAction move key ai- next $ fromPerform r move key afile+ showMoveAction removewhen key ai+ next $ fromPerform r removewhen key afile stop++{- The goal of this command is to allow the user maximum freedom to move+ - files as they like, while avoiding making bad situations any worse+ - than they already were.+ -+ - When the destination repository already had a copy of a file+ - before the move operation began, dropping it from the source+ - repository reduces the number of copies, and should fail if+ - that would violate numcopies settings.+ -+ - On the other hand, when the destiation repository does not already+ - have a copy of a file, it can be dropped without making numcopies+ - worse, so the move is allowed even if numcopies is not met.+ -+ - Similarly, a file can move from an untrusted repository to another+ - untrusted repository, even if that is the only copy of the file.+ -+ - But, moving a file from a repository with higher trust to an untrusted+ - repository must still check that there are enough other copies to be+ - safe.+ -+ - Also, required content settings should not be violated.+ -+ - This function checks all that. It needs to know if the destination+ - repository already had a copy of the file before the move began.+ -}+willDropMakeItWorse :: UUID -> UUID -> Bool -> Key -> AssociatedFile -> Annex DropCheck+willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile =+ ifM (Command.Drop.checkRequiredContent srcuuid key afile)+ ( if deststartedwithcopy+ then unlessforced DropCheckNumCopies+ else ifM checktrustlevel+ ( return DropAllowed+ , unlessforced DropCheckNumCopies+ )+ , unlessforced DropWorse+ )+ where+ unlessforced r = ifM (Annex.getState Annex.force)+ ( return DropAllowed+ , return r+ )+ checktrustlevel = do+ desttrust <- lookupTrust destuuid+ srctrust <- lookupTrust srcuuid+ return (desttrust > UnTrusted || desttrust >= srctrust)++data DropCheck = DropWorse | DropAllowed | DropCheckNumCopies
Command/Sync.hs view
@@ -667,7 +667,7 @@ , return [] ) put dest = includeCommandAction $ - Command.Move.toStart' dest False af k (mkActionItem af)+ Command.Move.toStart' dest Command.Move.RemoveNever af k (mkActionItem af) {- When a remote has an export-tracking branch, change the export to - follow the current content of the branch. Otherwise, transfer any files
Command/Unused.hs view
@@ -100,7 +100,8 @@ showAction "checking for unused data" _ <- check "" (remoteUnusedMsg r) (remoteunused r) 0 next $ return True- remoteunused r = excludeReferenced refspec <=< loggedKeysFor $ Remote.uuid r+ remoteunused r = excludeReferenced refspec+ <=< loggedKeysFor $ Remote.uuid r check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int check file msg a c = do
Command/Vicfg.hs view
@@ -15,6 +15,7 @@ import Data.Tuple (swap) import Data.Char (isSpace) import Data.Default+import Data.Ord import Command import Annex.Perms@@ -63,7 +64,7 @@ Right newcfg -> setCfg curcfg newcfg data Cfg = Cfg- { cfgTrustMap :: TrustMap+ { cfgTrustMap :: M.Map UUID (Down TrustLevel) , cfgGroupMap :: M.Map UUID (S.Set Group) , cfgPreferredContentMap :: M.Map UUID PreferredContentExpression , cfgRequiredContentMap :: M.Map UUID PreferredContentExpression@@ -75,7 +76,7 @@ getCfg :: Annex Cfg getCfg = Cfg- <$> trustMapRaw -- without local trust overrides+ <$> (M.map Down <$> trustMapRaw) -- without local trust overrides <*> (groupsByUUID <$> groupMap) <*> preferredContentMapRaw <*> requiredContentMapRaw@@ -87,7 +88,7 @@ setCfg :: Cfg -> Cfg -> Annex () setCfg curcfg newcfg = do let diff = diffCfg curcfg newcfg- mapM_ (uncurry trustSet) $ M.toList $ cfgTrustMap diff+ mapM_ (uncurry trustSet) $ M.toList $ M.map (\(Down v) -> v) $ cfgTrustMap diff mapM_ (uncurry groupSet) $ M.toList $ cfgGroupMap diff mapM_ (uncurry preferredContentSet) $ M.toList $ cfgPreferredContentMap diff mapM_ (uncurry requiredContentSet) $ M.toList $ cfgRequiredContentMap diff@@ -155,10 +156,11 @@ [ com "Repository trust configuration" , com "(Valid trust levels: " ++ trustlevels ++ ")" ]- (\(t, u) -> line "trust" u $ showTrustLevel t)+ (\(Down t, u) -> line "trust" u $ showTrustLevel t) (\u -> lcom $ line "trust" u $ showTrustLevel def) where- trustlevels = unwords $ map showTrustLevel [Trusted .. DeadTrusted]+ trustlevels = unwords $ reverse $+ map showTrustLevel [minBound..maxBound] groups = settings cfg descs cfgGroupMap [ com "Repository groups"@@ -277,7 +279,7 @@ | setting == "trust" = case readTrustLevel val of Nothing -> badval "trust value" val Just t ->- let m = M.insert u t (cfgTrustMap cfg)+ let m = M.insert u (Down t) (cfgTrustMap cfg) in Right $ cfg { cfgTrustMap = m } | setting == "group" = let m = M.insert u (S.fromList $ words val) (cfgGroupMap cfg)
Command/WebApp.hs view
@@ -31,6 +31,7 @@ import Config.Files import Upgrade import Annex.Version+import Utility.Android import Control.Concurrent import Control.Concurrent.STM@@ -207,43 +208,42 @@ openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () #ifndef __ANDROID__-openBrowser' mcmd htmlshim _realurl outh errh = runbrowser+openBrowser' mcmd htmlshim realurl outh errh =+ ifM osAndroid+ {- Android does not support file:// urls well, but neither+ - is the security of the url in the process table important+ - there, so just use the real url. -}+ ( runbrowser realurl+ , runbrowser (fileUrl htmlshim)+ ) #else openBrowser' mcmd htmlshim realurl outh errh = do- recordUrl url+ recordUrl realurl {- Android's `am` command does not work reliably across the - wide range of Android devices. Intead, FIFO should be set to - the filename of a fifo that we can write the URL to. -} v <- getEnv "FIFO" case v of- Nothing -> runbrowser+ Nothing -> runbrowser realurl Just f -> void $ forkIO $ do fd <- openFd f WriteOnly Nothing defaultFileFlags- void $ fdWrite fd url+ void $ fdWrite fd realurl closeFd fd #endif where- p = case mcmd of- Just c -> proc c [htmlshim]- Nothing -> + runbrowser url = do+ let p = case mcmd of+ Just c -> proc c [url]+ Nothing -> #ifndef mingw32_HOST_OS- browserProc url-#else- {- Windows hack to avoid using the full path,- - which might contain spaces that cause problems- - for browserProc. -}- (browserProc (takeFileName htmlshim))- { cwd = Just (takeDirectory htmlshim) } -#endif-#ifdef __ANDROID__- {- Android does not support file:// urls, but neither is- - the security of the url in the process table important- - there, so just use the real url. -}- url = realurl+ browserProc url #else- url = fileUrl htmlshim+ {- Windows hack to avoid using the full path,+ - which might contain spaces that cause problems+ - for browserProc. -}+ (browserProc (takeFileName htmlshim))+ { cwd = Just (takeDirectory htmlshim) } #endif- runbrowser = do hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hFlush stdout environ <- cleanEnvironment
Command/Whereis.hs view
@@ -15,6 +15,7 @@ import Annex.UUID import qualified Data.Map as M+import qualified Data.Vector as V cmd :: Command cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $@@ -77,7 +78,7 @@ untrustedheader = "The following untrusted locations may also have copies:\n" ppwhereis h ls urls = do descm <- uuidDescriptions- let urlvals = map (\(u, us) -> (u, Just us)) $+ let urlvals = map (\(u, us) -> (u, Just (V.fromList us))) $ filter (\(u,_) -> u `elem` ls) urls prettyPrintUUIDsWith (Just "urls") h descm (const Nothing) urlvals
Git/Queue.hs view
@@ -24,7 +24,7 @@ import Git.Command import qualified Git.UpdateIndex -import qualified Data.Map as M+import qualified Data.Map.Strict as M {- Queable actions that can be performed in a git repository. -} data Action@@ -117,7 +117,7 @@ , items = newitems } !newsize = size q' + sizeincrease- !newitems = M.insertWith' combineNewOld (actionKey action) action (items q')+ !newitems = M.insertWith combineNewOld (actionKey action) action (items q') combineNewOld :: Action -> Action -> Action combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) =
Key.hs view
@@ -22,7 +22,6 @@ prop_isomorphic_key_decode ) where -import Data.Aeson import Data.Char import qualified Data.Text as T @@ -30,6 +29,7 @@ import Types.Key import Utility.QuickCheck import Utility.Bloom+import Utility.Aeson import qualified Utility.SimpleProtocol as Proto stubKey :: Key@@ -155,8 +155,8 @@ hashIO32 = hashIO32 . key2file hashIO64 = hashIO64 . key2file -instance ToJSON Key where- toJSON = toJSON . key2file+instance ToJSON' Key where+ toJSON' = toJSON' . key2file instance FromJSON Key where parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t
Limit.hs view
@@ -180,7 +180,7 @@ checktrust checker u = checker <$> lookupTrust u checkgroup g u = S.member g <$> lookupGroups u parsetrustspec s- | "+" `isSuffixOf` s = (>=) <$> readTrustLevel (beginning s)+ | "+" `isSuffixOf` s = (<=) <$> readTrustLevel (beginning s) | otherwise = (==) <$> readTrustLevel s {- Adds a limit to match files that need more copies made. -}
Logs/Location.hs view
@@ -8,7 +8,7 @@ - Repositories record their UUID and the date when they --get or --drop - a value. - - - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -}@@ -23,8 +23,11 @@ isKnownKey, checkDead, setDead,+ Unchecked,+ finishCheck, loggedKeys, loggedKeysFor,+ loggedKeysFor', ) where import Annex.Common@@ -114,24 +117,38 @@ Unknown -> Unknown } +data Unchecked a = Unchecked (Annex (Maybe a))++finishCheck :: Unchecked a -> Annex (Maybe a)+finishCheck (Unchecked a) = a+ {- Finds all keys that have location log information. - (There may be duplicate keys in the list.) - - Keys that have been marked as dead are not included. -}-loggedKeys :: Annex [Key]+loggedKeys :: Annex [Unchecked Key] loggedKeys = loggedKeys' (not <$$> checkDead) -{- Note that sel should be strict, to avoid the filterM building many- - thunks. -} -loggedKeys' :: (Key -> Annex Bool) -> Annex [Key]-loggedKeys' sel = filterM sel =<<- (mapMaybe locationLogFileKey <$> Annex.Branch.files)+loggedKeys' :: (Key -> Annex Bool) -> Annex [Unchecked Key]+loggedKeys' check = mapMaybe (defercheck <$$> locationLogFileKey)+ <$> Annex.Branch.files+ where+ defercheck k = Unchecked $ ifM (check k)+ ( return (Just k)+ , return Nothing+ ) {- Finds all keys that have location log information indicating- - they are present for the specified repository. -}+ - they are present in the specified repository.+ -+ - This does not stream well; use loggedKeysFor' for lazy streaming.+ -} loggedKeysFor :: UUID -> Annex [Key]-loggedKeysFor u = loggedKeys' isthere+loggedKeysFor u = catMaybes <$> (mapM finishCheck =<< loggedKeysFor' u)++loggedKeysFor' :: UUID -> Annex [Unchecked Key]+loggedKeysFor' u = loggedKeys' isthere where isthere k = do us <- loggedLocations k
Logs/MapLog.hs view
@@ -21,7 +21,7 @@ import Annex.VectorClock import Logs.Line -import qualified Data.Map as M+import qualified Data.Map.Strict as M data LogEntry v = LogEntry { changed :: VectorClock@@ -56,7 +56,7 @@ {- Only add an LogEntry if it's newer (or at least as new as) than any - existing LogEntry for a field. -} addMapLog :: Ord f => f -> LogEntry v -> MapLog f v -> MapLog f v-addMapLog = M.insertWith' best+addMapLog = M.insertWith best {- Converts a MapLog into a simple Map without the timestamp information. - This is a one-way trip, but useful for code that never needs to change
Logs/Trust.hs view
@@ -72,7 +72,7 @@ map (\r -> (Types.Remote.uuid r, UnTrusted)) exports logged <- trustMapRaw let configured = M.fromList $ mapMaybe configuredtrust l- let m = M.unionWith max exportoverrides $+ let m = M.unionWith min exportoverrides $ M.union overrides $ M.union configured logged Annex.changeState $ \s -> s { Annex.trustmap = Just m }
Logs/UUID.hs view
@@ -29,7 +29,7 @@ import Logs.UUIDBased import qualified Annex.UUID -import qualified Data.Map as M+import qualified Data.Map.Strict as M {- Records a description for a uuid in the log. -} describeUUID :: UUID -> String -> Annex ()@@ -79,7 +79,7 @@ uuidMapLoad = do m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog u <- Annex.UUID.getUUID- let m' = M.insertWith' preferold u "" m+ let m' = M.insertWith preferold u "" m Annex.changeState $ \s -> s { Annex.uuidmap = Just m' } return m' where
Messages/JSON.hs view
@@ -26,12 +26,10 @@ JSONActionItem(..), ) where -import Data.Aeson import Control.Applicative import qualified Data.Map as M-import qualified Data.Text as T import qualified Data.Vector as V-import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as HM import System.IO import System.IO.Unsafe (unsafePerformIO)@@ -44,6 +42,7 @@ import Key import Utility.Metered import Utility.Percentage+import Utility.Aeson -- A global lock to avoid concurrent threads emitting json at the same time. {-# NOINLINE emitLock #-}@@ -53,7 +52,7 @@ emit :: Object -> IO () emit o = do takeMVar emitLock- B.hPut stdout (encode o)+ L.hPut stdout (encode o) putStr "\n" putMVar emitLock () @@ -67,7 +66,7 @@ start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder start command file key _ = Just (o, False) where- Object o = toJSON $ JSONActionItem+ Object o = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key , itemFile = file@@ -75,7 +74,7 @@ } end :: Bool -> JSONBuilder-end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True)+end b (Just (o, _)) = Just (HM.insert "success" (toJSON' b) o, True) end _ Nothing = Nothing finalize :: JSONOptions -> Object -> Object@@ -91,32 +90,32 @@ where combinearray (Array new) (Array old) = Array (old <> new) combinearray new _old = new- v = Array $ V.fromList $ map (String . T.pack) msg+ v = Array $ V.fromList $ map (String . packString) msg note :: String -> JSONBuilder note _ Nothing = Nothing-note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON s) o, e)+note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON' s) o, e) where combinelines (String new) (String old) =- String (old <> T.pack "\n" <> new)+ String (old <> "\n" <> new) combinelines new _old = new info :: String -> JSONBuilder info s _ = Just (o, True) where- Object o = object ["info" .= toJSON s]+ Object o = object ["info" .= toJSON' s] data JSONChunk v where AesonObject :: Object -> JSONChunk Object- JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)]+ JSONChunk :: ToJSON' v => [(String, v)] -> JSONChunk [(String, v)] add :: JSONChunk v -> JSONBuilder add v (Just (o, e)) = Just (HM.union o' o, e) where Object o' = case v of AesonObject ao -> Object ao- JSONChunk l -> object (map mkPair l)- mkPair (s, d) = (T.pack s, toJSON d)+ JSONChunk l -> object $ map mkPair l+ mkPair (s, d) = (packString s, toJSON' d) add _ Nothing = Nothing complete :: JSONChunk v -> JSONBuilder@@ -145,8 +144,8 @@ , dispJson :: String } -instance ToJSON DualDisp where- toJSON = toJSON . dispJson+instance ToJSON' DualDisp where+ toJSON' = toJSON' . dispJson instance Show DualDisp where show = dispNormal@@ -156,10 +155,10 @@ -- serialization of Map, which uses "[key, value]". data ObjectMap a = ObjectMap { fromObjectMap :: M.Map String a } -instance ToJSON a => ToJSON (ObjectMap a) where- toJSON (ObjectMap m) = object $ map go $ M.toList m+instance ToJSON' a => ToJSON' (ObjectMap a) where+ toJSON' (ObjectMap m) = object $ map go $ M.toList m where- go (k, v) = (T.pack k, toJSON v)+ go (k, v) = (packString k, toJSON' v) -- An item that a git-annex command acts on, and displays a JSON object about. data JSONActionItem a = JSONActionItem@@ -170,13 +169,13 @@ } deriving (Show) -instance ToJSON (JSONActionItem a) where- toJSON i = object $ catMaybes+instance ToJSON' (JSONActionItem a) where+ toJSON' i = object $ catMaybes [ Just $ "command" .= itemCommand i , case itemKey i of Nothing -> Nothing- Just k -> Just $ "key" .= toJSON k- , Just $ "file" .= itemFile i+ Just k -> Just $ "key" .= toJSON' k+ , Just $ "file" .= toJSON' (itemFile i) -- itemAdded is not included; must be added later by 'add' ]
P2P/IO.hs view
@@ -48,7 +48,7 @@ import qualified Network.Socket as S -- Type of interpreters of the Proto free monad.-type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Either String a)+type RunProto m = forall a. Proto a -> m (Either String a) data RunState = Serving UUID (Maybe ChangedRefsHandle) (TVar ProtocolVersion)
Remote.hs view
@@ -57,9 +57,8 @@ ) where import Data.Ord-import Data.Aeson import qualified Data.Map as M-import qualified Data.Text as T+import qualified Data.Vector as V import Annex.Common import Types.Remote@@ -74,6 +73,7 @@ import Config.DynamicConfig import Git.Types (RemoteName) import qualified Git+import Utility.Aeson {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)@@ -197,7 +197,7 @@ {- An optional field can be included in the list of UUIDs. -} prettyPrintUUIDsWith- :: ToJSON v+ :: ToJSON' v => Maybe String -> String -> M.Map UUID RemoteName@@ -206,7 +206,7 @@ -> Annex String prettyPrintUUIDsWith optfield header descm showval uuidvals = do hereu <- getUUID- maybeShowJSON $ JSONChunk [(header, map (jsonify hereu) uuidvals)]+ maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)] return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals where finddescription u = M.findWithDefault "" u descm@@ -224,11 +224,11 @@ Nothing -> s Just val -> val ++ ": " ++ s jsonify hereu (u, optval) = object $ catMaybes- [ Just (T.pack "uuid", toJSON $ fromUUID u)- , Just (T.pack "description", toJSON $ finddescription u)- , Just (T.pack "here", toJSON $ hereu == u)+ [ Just (packString "uuid", toJSON' $ fromUUID u)+ , Just (packString "description", toJSON' $ finddescription u)+ , Just (packString "here", toJSON' $ hereu == u) , case (optfield, optval) of- (Just field, Just val) -> Just (T.pack field, toJSON val)+ (Just field, Just val) -> Just (packString field, toJSON' val) _ -> Nothing ]
Remote/Tahoe.hs view
@@ -23,7 +23,7 @@ module Remote.Tahoe (remote) where import qualified Data.Map as M-import Data.Aeson+import Utility.Aeson import Data.ByteString.Lazy.UTF8 (fromString) import Control.Concurrent.STM
Test.hs view
@@ -21,7 +21,6 @@ import Options.Applicative (switch, long, help, internal) import qualified Data.Map as M-import qualified Data.Aeson import qualified Data.ByteString.Lazy.UTF8 as BU8 import System.Environment @@ -83,6 +82,7 @@ import qualified Utility.Base64 import qualified Utility.Tmp.Dir import qualified Utility.FileSystemEncoding+import qualified Utility.Aeson #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable import qualified Types.Crypto@@ -971,7 +971,7 @@ test_info :: Assertion test_info = intmpclonerepo $ do json <- BU8.fromString <$> git_annex_output "info" ["--json"]- case Data.Aeson.eitherDecode json :: Either String Data.Aeson.Value of+ case Utility.Aeson.eitherDecode json :: Either String Utility.Aeson.Value of Right _ -> return () Left e -> assertFailure e
Types/Messages.hs view
@@ -9,7 +9,7 @@ module Types.Messages where -import qualified Data.Aeson as Aeson+import qualified Utility.Aeson as Aeson import Control.Concurrent #ifdef WITH_CONCURRENTOUTPUT
Types/MetaData.hs view
@@ -43,22 +43,22 @@ import Common import Utility.Base64 import Utility.QuickCheck+import Utility.Aeson import qualified Data.Text as T import qualified Data.Set as S-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.HashMap.Strict as HM import Data.Char import qualified Data.CaseInsensitive as CI-import Data.Aeson newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue)) deriving (Show, Eq, Ord) -instance ToJSON MetaData where- toJSON (MetaData m) = object $ map go (M.toList m)+instance ToJSON' MetaData where+ toJSON' (MetaData m) = object $ map go (M.toList m) where- go (MetaField f, s) = (T.pack (CI.original f), toJSON s)+ go (MetaField f, s) = (packString (CI.original f), toJSON' s) instance FromJSON MetaData where parseJSON (Object o) = do@@ -82,8 +82,8 @@ data MetaValue = MetaValue CurrentlySet String deriving (Read, Show) -instance ToJSON MetaValue where- toJSON (MetaValue _ v) = toJSON v+instance ToJSON' MetaValue where+ toJSON' (MetaValue _ v) = toJSON' v instance FromJSON MetaValue where parseJSON (String v) = return $ MetaValue (CurrentlySet True) (T.unpack v)@@ -207,8 +207,7 @@ updateMetaData f v = updateMetaData' f (S.singleton v) updateMetaData' :: MetaField -> S.Set MetaValue -> MetaData -> MetaData-updateMetaData' f s (MetaData m) = MetaData $- M.insertWith' S.union f s m+updateMetaData' f s (MetaData m) = MetaData $ M.insertWith S.union f s m {- New metadata overrides old._-} unionMetaData :: MetaData -> MetaData -> MetaData
Types/TrustLevel.hs view
@@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE FlexibleInstances #-}+ module Types.TrustLevel ( TrustLevel(..), TrustMap,@@ -15,16 +17,18 @@ import qualified Data.Map as M import Data.Default+import Data.Ord import Types.UUID --- This order may seem backwards, but we generally want to list dead--- remotes last and trusted ones first.-data TrustLevel = Trusted | SemiTrusted | UnTrusted | DeadTrusted+data TrustLevel = DeadTrusted | UnTrusted | SemiTrusted | Trusted deriving (Eq, Enum, Ord, Bounded, Show) instance Default TrustLevel where def = SemiTrusted++instance Default (Down TrustLevel) where+ def = Down def type TrustMap = M.Map UUID TrustLevel
+ Utility/Aeson.hs view
@@ -0,0 +1,86 @@+{- GHC File system encoding support for Aeson.+ -+ - Import instead of Data.Aeson+ -+ - Copyright 2018 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}++module Utility.Aeson (+ module X,+ ToJSON'(..),+ encode,+ packString,+) where++import Data.Aeson as X hiding (ToJSON, toJSON, encode)+import Data.Aeson hiding (encode)+import qualified Data.Aeson+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+import qualified Data.Set+import qualified Data.Vector+import Prelude++import Utility.FileSystemEncoding++-- | Use this instead of Data.Aeson.encode to make sure that the+-- below String instance is used.+encode :: ToJSON' a => a -> L.ByteString+encode = Data.Aeson.encode . toJSON'++-- | Aeson has an unfortunate ToJSON instance for Char and [Char]+-- which does not support Strings containing UTF8 characters+-- encoded using the filesystem encoding when run in a non-utf8 locale.+--+-- Since we can't replace that with a instance that does the right+-- thing, instead here's a new class that handles String right.+class ToJSON' a where+ toJSON' :: a -> Value++instance ToJSON' String where+ toJSON' = toJSON . packString++-- | Pack a String to Text, correctly handling the filesystem encoding.+--+-- Use this instead of Data.Text.pack.+--+-- Note that if the string contains invalid UTF8 characters not using+-- the FileSystemEncoding, this is the same as Data.Text.pack.+packString :: String -> T.Text+packString s = case T.decodeUtf8' (S.concat $ L.toChunks $ encodeBS s) of+ Right t -> t+ Left _ -> T.pack s++-- | An instance for lists cannot be included as it would overlap with+-- the String instance. Instead, you can use a Vector.+instance ToJSON' s => ToJSON' (Data.Vector.Vector s) where+ toJSON' = toJSON . map toJSON' . Data.Vector.toList++-- Aeson generates the same JSON for a Set as for a list.+instance ToJSON' s => ToJSON' (Data.Set.Set s) where+ toJSON' = toJSON . map toJSON' . Data.Set.toList++instance (ToJSON' a, ToJSON a) => ToJSON' (Maybe a) where+ toJSON' (Just a) = toJSON (Just (toJSON' a))+ toJSON' v@Nothing = toJSON v++instance (ToJSON' a, ToJSON a, ToJSON' b, ToJSON b) => ToJSON' (a, b) where+ toJSON' (a, b) = toJSON ((toJSON' a, toJSON' b))++instance ToJSON' Bool where+ toJSON' = toJSON++instance ToJSON' Integer where+ toJSON' = toJSON++instance ToJSON' Object where+ toJSON' = toJSON++instance ToJSON' Value where+ toJSON' = toJSON
+ Utility/Android.hs view
@@ -0,0 +1,17 @@+{- Android stuff+ -+ - Copyright 2018 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.Android where++import Common++-- Detect when the Linux build is running on Android, eg in termux.+--+-- Note that this relies on termux's uname having been built with "Android"+-- as the os name. Often on Android, uname will report "Linux".+osAndroid :: IO Bool+osAndroid = ("Android" `isPrefixOf` ) <$> readProcess "uname" ["-o"]
Utility/DirWatcher/Kqueue.hs view
@@ -25,7 +25,7 @@ import Foreign.C.Error import Foreign.Ptr import Foreign.Marshal-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified System.Posix.Files as Files import Control.Concurrent@@ -212,7 +212,7 @@ newmap' <- foldM removeSubDir newmap (map changedFile deleted) -- Update the cached dirinfo just looked up.- let newmap'' = M.insertWith' const fd newdirinfo newmap'+ let newmap'' = M.insert fd newdirinfo newmap' -- When new directories were added, need to update -- the kqueue to watch them.
Utility/Directory/Stream.hs view
@@ -1,17 +1,19 @@ {- streaming directory traversal -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory.Stream where import Control.Monad import System.FilePath+import System.IO.Unsafe (unsafeInterleaveIO) import Control.Concurrent import Data.Maybe import Prelude@@ -66,9 +68,8 @@ v <- tryTakeMVar mv when (isJust v) f -{- |Reads the next entry from the handle. Once the end of the directory-is reached, returns Nothing and automatically closes the handle.--}+-- | Reads the next entry from the handle. Once the end of the directory+-- is reached, returns Nothing and automatically closes the handle. readDirectory :: DirectoryHandle -> IO (Maybe FilePath) #ifndef mingw32_HOST_OS readDirectory hdl@(DirectoryHandle _ dirp) = do@@ -99,7 +100,23 @@ return (Just filename) #endif --- True only when directory exists and contains nothing.+-- | Like getDirectoryContents, but rather than buffering the whole+-- directory content in memory, lazily streams.+--+-- This is like lazy readFile in that the handle to the directory remains+-- open until the whole list is consumed, or until the list is garbage+-- collected. So use with caution particularly when traversing directory+-- trees.+streamDirectoryContents :: FilePath -> IO [FilePath]+streamDirectoryContents d = openDirectory d >>= collect+ where+ collect hdl = readDirectory hdl >>= \case+ Nothing -> return []+ Just f -> do+ rest <- unsafeInterleaveIO (collect hdl)+ return (f:rest)++-- | True only when directory exists and contains nothing. -- Throws exception if directory does not exist. isDirectoryEmpty :: FilePath -> IO Bool isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
Utility/Mounts.hs view
@@ -13,9 +13,13 @@ import qualified System.MountPoints import System.MountPoints (Mntent(..)) +import Utility.Exception+ getMounts :: IO [Mntent] #ifndef __ANDROID__ getMounts = System.MountPoints.getMounts+ -- That will crash when running on Android, so fall back to this.+ `catchNonAsync` const System.MountPoints.getProcMounts #else getMounts = System.MountPoints.getProcMounts #endif
Utility/Url.hs view
@@ -326,10 +326,25 @@ - - Note that the responseStatus is not checked by this function. -}-sinkResponseFile :: MonadResource m => MeterUpdate -> BytesProcessed -> FilePath -> IOMode -> Response (ResumableSource m B8.ByteString) -> m ()+sinkResponseFile+ :: MonadResource m+ => MeterUpdate+ -> BytesProcessed+ -> FilePath+ -> IOMode+#if MIN_VERSION_http_conduit(2,3,0)+ -> Response (ConduitM () B8.ByteString m ())+#else+ -> Response (ResumableSource m B8.ByteString)+#endif+ -> m () sinkResponseFile meterupdate initialp file mode resp = do (fr, fh) <- allocate (openBinaryFile file mode) hClose+#if MIN_VERSION_http_conduit(2,3,0)+ runConduit $ responseBody resp .| go initialp fh+#else responseBody resp $$+- go initialp fh+#endif release fr where go sofar fh = await >>= \case
Utility/UserInfo.hs view
@@ -57,10 +57,13 @@ myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars where+ go [] = either (const $ envnotset) (Right . extract) <$> get+ go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #ifndef mingw32_HOST_OS- go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)+ -- This may throw an exception if the system doesn't have a+ -- passwd file etc; don't let it crash.+ get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else- go [] = return $ either Left (Right . extract) $- Left ("environment not set: " ++ show envvars)+ get = return envnotset #endif- go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v+ envnotset = Left ("environment not set: " ++ show envvars)
Utility/Yesod.hs view
@@ -47,7 +47,11 @@ #endif {- Lift Handler to Widget -}+#if MIN_VERSION_yesod_core(1,6,0)+liftH :: HandlerFor site a -> WidgetFor site a +#else liftH :: Monad m => HandlerT site m a -> WidgetT site m a+#endif liftH = handlerToWidget #if ! MIN_VERSION_yesod_core(1,2,20)
doc/git-annex-copy.mdwn view
@@ -24,6 +24,11 @@ Copy the content of files from the local repository to the specified remote. +* `--to=here`++ Copy the content of files from all reachable remotes to the local+ repository.+ * `--jobs=N` `-JN` Enables parallel transfers with up to the specified number of jobs
doc/git-annex-move.mdwn view
@@ -25,6 +25,16 @@ Move the content of files from all reachable remotes to the local repository. +* `--force`++ Override numcopies and required content checking, and always remove+ files from the source repository once the destination repository has a+ copy.++ Note that, even without this option, you can move the content of a file+ from one repository to another when numcopies is not satisfied, as long+ as the move does not result in there being fewer copies.+ * `--jobs=N` `-JN` Enables parallel transfers with up to the specified number of jobs
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20180409+Version: 6.20180427 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -999,6 +999,8 @@ Upgrade.V3 Upgrade.V4 Upgrade.V5+ Utility.Aeson+ Utility.Android Utility.Applicative Utility.AuthToken Utility.Base64