summaryrefslogtreecommitdiff
path: root/Command
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@debian.org>2014-04-02 21:42:53 +0100
committerGravatar Joey Hess <joeyh@debian.org>2014-04-02 21:42:53 +0100
commit6da7cdf0fbf26f1faf7d5710e6ed488f1a4e9589 (patch)
tree7a903e2eca579335b7ce73d0220854e7a25c3bb9 /Command
git-annex (5.20140402) unstable; urgency=medium
* unannex, uninit: Avoid committing after every file is unannexed, for massive speedup. * --notify-finish switch will cause desktop notifications after each file upload/download/drop completes (using the dbus Desktop Notifications Specification) * --notify-start switch will show desktop notifications when each file upload/download starts. * webapp: Automatically install Nautilus integration scripts to get and drop files. * tahoe: Pass -d parameter before subcommand; putting it after the subcommand no longer works with tahoe-lafs version 1.10. (Thanks, Alberto Berti) * forget --drop-dead: Avoid removing the dead remote from the trust.log, so that if git remotes for it still exist anywhere, git annex info will still know it's dead and not show it. * git-annex-shell: Make configlist automatically initialize a remote git repository, as long as a git-annex branch has been pushed to it, to simplify setup of remote git repositories, including via gitolite. * add --include-dotfiles: New option, perhaps useful for backups. * Version 5.20140227 broke creation of glacier repositories, not including the datacenter and vault in their configuration. This bug is fixed, but glacier repositories set up with the broken version of git-annex need to have the datacenter and vault set in order to be usable. This can be done using git annex enableremote to add the missing settings. For details, see http://git-annex.branchable.com/bugs/problems_with_glacier/ * Added required content configuration. * assistant: Improve ssh authorized keys line generated in local pairing or for a remote ssh server to set environment variables in an alternative way that works with the non-POSIX fish shell, as well as POSIX shells. # imported from the archive
Diffstat (limited to 'Command')
-rw-r--r--Command/Add.hs274
-rw-r--r--Command/AddUnused.hs41
-rw-r--r--Command/AddUrl.hs241
-rw-r--r--Command/Assistant.hs88
-rw-r--r--Command/Commit.hs29
-rw-r--r--Command/ConfigList.hs46
-rw-r--r--Command/Copy.hs40
-rw-r--r--Command/Dead.hs19
-rw-r--r--Command/Describe.hs32
-rw-r--r--Command/Direct.hs71
-rw-r--r--Command/Drop.hs185
-rw-r--r--Command/DropKey.hs38
-rw-r--r--Command/DropUnused.hs45
-rw-r--r--Command/EnableRemote.hs56
-rw-r--r--Command/ExamineKey.hs29
-rw-r--r--Command/Find.hs72
-rw-r--r--Command/Fix.hs59
-rw-r--r--Command/Forget.hs52
-rw-r--r--Command/FromKey.hs44
-rw-r--r--Command/Fsck.hs513
-rw-r--r--Command/FuzzTest.hs281
-rw-r--r--Command/GCryptSetup.hs39
-rw-r--r--Command/Get.hs92
-rw-r--r--Command/Group.hs35
-rw-r--r--Command/Help.hs65
-rw-r--r--Command/Import.hs115
-rw-r--r--Command/ImportFeed.hs257
-rw-r--r--Command/InAnnex.hs27
-rw-r--r--Command/Indirect.hs110
-rw-r--r--Command/Info.hs385
-rw-r--r--Command/Init.hs31
-rw-r--r--Command/InitRemote.hs98
-rw-r--r--Command/List.hs85
-rw-r--r--Command/Lock.hs34
-rw-r--r--Command/Log.hs171
-rw-r--r--Command/LookupKey.hs26
-rw-r--r--Command/Map.hs252
-rw-r--r--Command/Merge.hs37
-rw-r--r--Command/MetaData.hs98
-rw-r--r--Command/Migrate.hs77
-rw-r--r--Command/Mirror.hs65
-rw-r--r--Command/Move.hs173
-rw-r--r--Command/NumCopies.hs56
-rw-r--r--Command/PreCommit.hs111
-rw-r--r--Command/ReKey.hs71
-rw-r--r--Command/RecvKey.hs87
-rw-r--r--Command/Reinject.hs58
-rw-r--r--Command/Repair.hs84
-rw-r--r--Command/RmUrl.hs30
-rw-r--r--Command/Schedule.hs53
-rw-r--r--Command/Semitrust.hs19
-rw-r--r--Command/SendKey.hs49
-rw-r--r--Command/Status.hs90
-rw-r--r--Command/Sync.hs380
-rw-r--r--Command/Test.hs37
-rw-r--r--Command/TransferInfo.hs64
-rw-r--r--Command/TransferKey.hs57
-rw-r--r--Command/TransferKeys.hs140
-rw-r--r--Command/Trust.hs41
-rw-r--r--Command/Unannex.hs111
-rw-r--r--Command/Ungroup.hs35
-rw-r--r--Command/Uninit.hs99
-rw-r--r--Command/Unlock.hs50
-rw-r--r--Command/Untrust.hs19
-rw-r--r--Command/Unused.hs371
-rw-r--r--Command/Upgrade.hs26
-rw-r--r--Command/VAdd.hs36
-rw-r--r--Command/VCycle.hs41
-rw-r--r--Command/VFilter.hs30
-rw-r--r--Command/VPop.hs50
-rw-r--r--Command/Version.hs49
-rw-r--r--Command/Vicfg.hs278
-rw-r--r--Command/View.hs82
-rw-r--r--Command/Wanted.hs51
-rw-r--r--Command/Watch.hs36
-rw-r--r--Command/WebApp.hs237
-rw-r--r--Command/Whereis.hs65
-rw-r--r--Command/XMPPGit.hs46
78 files changed, 7666 insertions, 0 deletions
diff --git a/Command/Add.hs b/Command/Add.hs
new file mode 100644
index 000000000..f9e2b3342
--- /dev/null
+++ b/Command/Add.hs
@@ -0,0 +1,274 @@
+{- git-annex command
+ -
+ - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.Add where
+
+import Common.Annex
+import Annex.Exception
+import Command
+import Types.KeySource
+import Backend
+import Logs.Location
+import Annex.Content
+import Annex.Content.Direct
+import Annex.Perms
+import Annex.Link
+import Annex.MetaData
+import qualified Annex
+import qualified Annex.Queue
+#ifdef WITH_CLIBS
+#ifndef __ANDROID__
+import Utility.Touch
+#endif
+#endif
+import Config
+import Utility.InodeCache
+import Annex.FileMatcher
+import Annex.ReplaceFile
+import Utility.Tmp
+
+def :: [Command]
+def = [notBareRepo $ withOptions [includeDotFilesOption] $
+ command "add" paramPaths seek SectionCommon
+ "add files to annex"]
+
+includeDotFilesOption :: Option
+includeDotFilesOption = flagOption [] "include-dotfiles" "don't skip dotfiles"
+
+{- Add acts on both files not checked into git yet, and unlocked files.
+ -
+ - In direct mode, it acts on any files that have changed. -}
+seek :: CommandSeek
+seek ps = do
+ matcher <- largeFilesMatcher
+ let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
+ ( start file
+ , stop
+ )
+ skipdotfiles <- not <$> Annex.getFlag (optionName includeDotFilesOption)
+ go $ withFilesNotInGit skipdotfiles
+ ifM isDirect
+ ( go withFilesMaybeModified
+ , go withFilesUnlocked
+ )
+
+{- The add subcommand annexes a file, generating a key for it using a
+ - backend, and then moving it into the annex directory and setting up
+ - the symlink pointing to its content. -}
+start :: FilePath -> CommandStart
+start file = ifAnnexed file addpresent add
+ where
+ add = do
+ ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+ case ms of
+ Nothing -> stop
+ Just s
+ | isSymbolicLink s || not (isRegularFile s) -> stop
+ | otherwise -> do
+ showStart "add" file
+ next $ perform file
+ addpresent (key, _) = ifM isDirect
+ ( ifM (goodContent key file) ( stop , add )
+ , fixup key
+ )
+ fixup key = do
+ -- fixup from an interrupted add; the symlink
+ -- is present but not yet added to git
+ showStart "add" file
+ liftIO $ removeFile file
+ next $ next $ cleanup file key Nothing =<< inAnnex key
+
+{- The file that's being added is locked down before a key is generated,
+ - to prevent it from being modified in between. This lock down is not
+ - perfect at best (and pretty weak at worst). For example, it does not
+ - guard against files that are already opened for write by another process.
+ - So a KeySource is returned. Its inodeCache can be used to detect any
+ - changes that might be made to the file after it was locked down.
+ -
+ - When possible, the file is hard linked to a temp directory. This guards
+ - against some changes, like deletion or overwrite of the file, and
+ - allows lsof checks to be done more efficiently when adding a lot of files.
+ -
+ - Lockdown can fail if a file gets deleted, and Nothing will be returned.
+ -}
+lockDown :: FilePath -> Annex (Maybe KeySource)
+lockDown = either (\e -> showErr e >> return Nothing) (return . Just) <=< lockDown'
+
+lockDown' :: FilePath -> Annex (Either IOException KeySource)
+lockDown' file = ifM crippledFileSystem
+ ( liftIO $ tryIO nohardlink
+ , tryAnnexIO $ do
+ tmp <- fromRepo gitAnnexTmpMiscDir
+ createAnnexDirectory tmp
+ go tmp
+ )
+ where
+ {- In indirect mode, the write bit is removed from the file as part
+ - of lock down to guard against further writes, and because objects
+ - in the annex have their write bit disabled anyway.
+ -
+ - Freezing the content early also lets us fail early when
+ - someone else owns the file.
+ -
+ - This is not done in direct mode, because files there need to
+ - remain writable at all times.
+ -}
+ go tmp = do
+ unlessM isDirect $
+ freezeContent file
+ liftIO $ do
+ (tmpfile, h) <- openTempFile tmp $
+ relatedTemplate $ takeFileName file
+ hClose h
+ nukeFile tmpfile
+ withhardlink tmpfile `catchIO` const nohardlink
+ nohardlink = do
+ cache <- genInodeCache file
+ return KeySource
+ { keyFilename = file
+ , contentLocation = file
+ , inodeCache = cache
+ }
+ withhardlink tmpfile = do
+ createLink file tmpfile
+ cache <- genInodeCache tmpfile
+ return KeySource
+ { keyFilename = file
+ , contentLocation = tmpfile
+ , inodeCache = cache
+ }
+
+{- Ingests a locked down file into the annex.
+ -
+ - In direct mode, leaves the file alone, and just updates bookkeeping
+ - information.
+ -}
+ingest :: Maybe KeySource -> Annex (Maybe Key, Maybe InodeCache)
+ingest Nothing = return (Nothing, Nothing)
+ingest (Just source) = do
+ backend <- chooseBackend $ keyFilename source
+ k <- genKey source backend
+ ms <- liftIO $ catchMaybeIO $ getFileStatus $ contentLocation source
+ let mcache = toInodeCache =<< ms
+ case (mcache, inodeCache source) of
+ (_, Nothing) -> go k mcache ms
+ (Just newc, Just c) | compareStrong c newc -> go k mcache ms
+ _ -> failure "changed while it was being added"
+ where
+ go k mcache ms = ifM isDirect
+ ( godirect k mcache ms
+ , goindirect k mcache ms
+ )
+
+ goindirect (Just (key, _)) mcache ms = do
+ catchAnnex (moveAnnex key $ contentLocation source)
+ (undo (keyFilename source) key)
+ maybe noop (genMetaData key (keyFilename source)) ms
+ liftIO $ nukeFile $ keyFilename source
+ return $ (Just key, mcache)
+ goindirect _ _ _ = failure "failed to generate a key"
+
+ godirect (Just (key, _)) (Just cache) ms = do
+ addInodeCache key cache
+ maybe noop (genMetaData key (keyFilename source)) ms
+ finishIngestDirect key source
+ return $ (Just key, Just cache)
+ godirect _ _ _ = failure "failed to generate a key"
+
+ failure msg = do
+ warning $ keyFilename source ++ " " ++ msg
+ when (contentLocation source /= keyFilename source) $
+ liftIO $ nukeFile $ contentLocation source
+ return (Nothing, Nothing)
+
+finishIngestDirect :: Key -> KeySource -> Annex ()
+finishIngestDirect key source = do
+ void $ addAssociatedFile key $ keyFilename source
+ when (contentLocation source /= keyFilename source) $
+ liftIO $ nukeFile $ contentLocation source
+
+ {- Copy to any other locations using the same key. -}
+ otherfs <- filter (/= keyFilename source) <$> associatedFiles key
+ forM_ otherfs $
+ addContentWhenNotPresent key (keyFilename source)
+
+perform :: FilePath -> CommandPerform
+perform file = lockDown file >>= ingest >>= go
+ where
+ go (Just key, cache) = next $ cleanup file key cache True
+ go (Nothing, _) = stop
+
+{- On error, put the file back so it doesn't seem to have vanished.
+ - This can be called before or after the symlink is in place. -}
+undo :: FilePath -> Key -> IOException -> Annex a
+undo file key e = do
+ whenM (inAnnex key) $ do
+ liftIO $ nukeFile file
+ catchAnnex (fromAnnex key file) tryharder
+ logStatus key InfoMissing
+ throwAnnex e
+ where
+ -- fromAnnex could fail if the file ownership is weird
+ tryharder :: IOException -> Annex ()
+ tryharder _ = do
+ src <- calcRepo $ gitAnnexLocation key
+ liftIO $ moveFile src file
+
+{- Creates the symlink to the annexed content, returns the link target. -}
+link :: FilePath -> Key -> Maybe InodeCache -> Annex String
+link file key mcache = flip catchAnnex (undo file key) $ do
+ l <- inRepo $ gitAnnexLink file key
+ replaceFile file $ makeAnnexLink l
+
+ -- touch symlink to have same time as the original file,
+ -- as provided in the InodeCache
+ case mcache of
+#if defined(WITH_CLIBS) && ! defined(__ANDROID__)
+ Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
+#else
+ Just _ -> noop
+#endif
+ Nothing -> noop
+
+ return l
+
+{- Creates the symlink to the annexed content, and stages it in git.
+ -
+ - As long as the filesystem supports symlinks, we use
+ - git add, rather than directly staging the symlink to git.
+ - Using git add is best because it allows the queuing to work
+ - and is faster (staging the symlink runs hash-object commands each time).
+ - Also, using git add allows it to skip gitignored files, unless forced
+ - to include them.
+ -}
+addLink :: FilePath -> Key -> Maybe InodeCache -> Annex ()
+addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)
+ ( do
+ _ <- link file key mcache
+ params <- ifM (Annex.getState Annex.force)
+ ( return [Param "-f"]
+ , return []
+ )
+ Annex.Queue.addCommand "add" (params++[Param "--"]) [file]
+ , do
+ l <- link file key mcache
+ addAnnexLink l file
+ )
+
+cleanup :: FilePath -> Key -> Maybe InodeCache -> Bool -> CommandCleanup
+cleanup file key mcache hascontent = do
+ ifM (isDirect <&&> pure hascontent)
+ ( do
+ l <- inRepo $ gitAnnexLink file key
+ stageSymlink file =<< hashSymlink l
+ , addLink file key mcache
+ )
+ when hascontent $
+ logStatus key InfoPresent
+ return True
diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs
new file mode 100644
index 000000000..91427e819
--- /dev/null
+++ b/Command/AddUnused.hs
@@ -0,0 +1,41 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.AddUnused where
+
+import Common.Annex
+import Logs.Location
+import Command
+import qualified Command.Add
+import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
+import Types.Key
+
+def :: [Command]
+def = [notDirect $ command "addunused" (paramRepeating paramNumRange)
+ seek SectionMaintenance "add back unused files"]
+
+seek :: CommandSeek
+seek = withUnusedMaps start
+
+start :: UnusedMaps -> Int -> CommandStart
+start = startUnused "addunused" perform
+ (performOther "bad")
+ (performOther "tmp")
+
+perform :: Key -> CommandPerform
+perform key = next $ do
+ logStatus key InfoPresent
+ Command.Add.addLink file key Nothing
+ return True
+ where
+ file = "unused." ++ key2file key
+
+{- The content is not in the annex, but in another directory, and
+ - it seems better to error out, rather than moving bad/tmp content into
+ - the annex. -}
+performOther :: String -> Key -> CommandPerform
+performOther other _ = error $ "cannot addunused " ++ otherĀ ++ "content"
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
new file mode 100644
index 000000000..b108be507
--- /dev/null
+++ b/Command/AddUrl.hs
@@ -0,0 +1,241 @@
+{- git-annex command
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.AddUrl where
+
+import Network.URI
+
+import Common.Annex
+import Command
+import Backend
+import qualified Command.Add
+import qualified Annex
+import qualified Annex.Queue
+import qualified Annex.Url as Url
+import qualified Backend.URL
+import Annex.Content
+import Logs.Web
+import Types.Key
+import Types.KeySource
+import Config
+import Annex.Content.Direct
+import Logs.Location
+import qualified Annex.Transfer as Transfer
+#ifdef WITH_QUVI
+import Annex.Quvi
+import qualified Utility.Quvi as Quvi
+#endif
+
+def :: [Command]
+def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $
+ command "addurl" (paramRepeating paramUrl) seek
+ SectionCommon "add urls to annex"]
+
+fileOption :: Option
+fileOption = fieldOption [] "file" paramFile "specify what file the url is added to"
+
+pathdepthOption :: Option
+pathdepthOption = fieldOption [] "pathdepth" paramNumber "path components to use in filename"
+
+relaxedOption :: Option
+relaxedOption = flagOption [] "relaxed" "skip size check"
+
+seek :: CommandSeek
+seek ps = do
+ f <- getOptionField fileOption return
+ relaxed <- getOptionFlag relaxedOption
+ d <- getOptionField pathdepthOption (return . maybe Nothing readish)
+ withStrings (start relaxed f d) ps
+
+start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
+start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s
+ where
+ (s', downloader) = getDownloader s
+ bad = fromMaybe (error $ "bad url " ++ s') $
+ parseURI $ escapeURIString isUnescapedInURI s'
+ choosefile = flip fromMaybe optfile
+ go url = case downloader of
+ QuviDownloader -> usequvi
+ DefaultDownloader ->
+#ifdef WITH_QUVI
+ ifM (quviSupported s')
+ ( usequvi
+ , regulardownload url
+ )
+#else
+ regulardownload url
+#endif
+ regulardownload url = do
+ pathmax <- liftIO $ fileNameLengthLimit "."
+ let file = choosefile $ url2file url pathdepth pathmax
+ showStart "addurl" file
+ next $ perform relaxed s' file
+#ifdef WITH_QUVI
+ badquvi = error $ "quvi does not know how to download url " ++ s'
+ usequvi = do
+ page <- fromMaybe badquvi
+ <$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] s'
+ let link = fromMaybe badquvi $ headMaybe $ Quvi.pageLinks page
+ pathmax <- liftIO $ fileNameLengthLimit "."
+ let file = choosefile $ truncateFilePath pathmax $ sanitizeFilePath $
+ Quvi.pageTitle page ++ "." ++ Quvi.linkSuffix link
+ showStart "addurl" file
+ next $ performQuvi relaxed s' (Quvi.linkUrl link) file
+#else
+ usequvi = error "not built with quvi support"
+#endif
+
+#ifdef WITH_QUVI
+performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform
+performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl
+ where
+ quviurl = setDownloader pageurl QuviDownloader
+ addurl (key, _backend) = next $ cleanup quviurl file key Nothing
+ geturl = next $ addUrlFileQuvi relaxed quviurl videourl file
+#endif
+
+#ifdef WITH_QUVI
+addUrlFileQuvi :: Bool -> URLString -> URLString -> FilePath -> Annex Bool
+addUrlFileQuvi relaxed quviurl videourl file = do
+ key <- Backend.URL.fromUrl quviurl Nothing
+ ifM (pure relaxed <||> Annex.getState Annex.fast)
+ ( cleanup quviurl file key Nothing
+ , do
+ {- Get the size, and use that to check
+ - disk space. However, the size info is not
+ - retained, because the size of a video stream
+ - might change and we want to be able to download
+ - it later. -}
+ sizedkey <- addSizeUrlKey videourl key
+ prepGetViaTmpChecked sizedkey $ do
+ tmp <- fromRepo $ gitAnnexTmpObjectLocation key
+ showOutput
+ ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
+ Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
+ liftIO $ createDirectoryIfMissing True (parentDir tmp)
+ downloadUrl [videourl] tmp
+ if ok
+ then cleanup quviurl file key (Just tmp)
+ else return False
+ )
+#endif
+
+perform :: Bool -> URLString -> FilePath -> CommandPerform
+perform relaxed url file = ifAnnexed file addurl geturl
+ where
+ geturl = next $ addUrlFile relaxed url file
+ addurl (key, _backend)
+ | relaxed = do
+ setUrlPresent key url
+ next $ return True
+ | otherwise = ifM (elem url <$> getUrls key)
+ ( stop
+ , do
+ (exists, samesize) <- Url.withUrlOptions $ Url.check url (keySize key)
+ if exists && samesize
+ then do
+ setUrlPresent key url
+ next $ return True
+ else do
+ warning $ "while adding a new url to an already annexed file, " ++ if exists
+ then "url does not have expected file size (use --relaxed to bypass this check) " ++ url
+ else "failed to verify url exists: " ++ url
+ stop
+ )
+
+addUrlFile :: Bool -> URLString -> FilePath -> Annex Bool
+addUrlFile relaxed url file = do
+ liftIO $ createDirectoryIfMissing True (parentDir file)
+ ifM (Annex.getState Annex.fast <||> pure relaxed)
+ ( nodownload relaxed url file
+ , do
+ showAction $ "downloading " ++ url ++ " "
+ download url file
+ )
+
+download :: URLString -> FilePath -> Annex Bool
+download url file = do
+ {- Generate a dummy key to use for this download, before we can
+ - examine the file and find its real key. This allows resuming
+ - downloads, as the dummy key for a given url is stable. -}
+ dummykey <- addSizeUrlKey url =<< Backend.URL.fromUrl url Nothing
+ prepGetViaTmpChecked dummykey $ do
+ tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey
+ showOutput
+ ifM (runtransfer dummykey tmp)
+ ( do
+ backend <- chooseBackend file
+ let source = KeySource
+ { keyFilename = file
+ , contentLocation = tmp
+ , inodeCache = Nothing
+ }
+ k <- genKey source backend
+ case k of
+ Nothing -> return False
+ Just (key, _) -> cleanup url file key (Just tmp)
+ , return False
+ )
+ where
+ runtransfer dummykey tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
+ Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
+ liftIO $ createDirectoryIfMissing True (parentDir tmp)
+ downloadUrl [url] tmp
+
+{- Hits the url to get the size, if available.
+ -
+ - This is needed to avoid exceeding the diskreserve when downloading,
+ - and so the assistant can display a pretty progress bar.
+ -}
+addSizeUrlKey :: URLString -> Key -> Annex Key
+addSizeUrlKey url key = do
+ size <- snd <$> Url.withUrlOptions (Url.exists url)
+ return $ key { keySize = size }
+
+cleanup :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex Bool
+cleanup url file key mtmp = do
+ when (isJust mtmp) $
+ logStatus key InfoPresent
+ setUrlPresent key url
+ Command.Add.addLink file key Nothing
+ whenM isDirect $ do
+ void $ addAssociatedFile key file
+ {- For moveAnnex to work in direct mode, the symlink
+ - must already exist, so flush the queue. -}
+ Annex.Queue.flush
+ maybe noop (moveAnnex key) mtmp
+ return True
+
+nodownload :: Bool -> URLString -> FilePath -> Annex Bool
+nodownload relaxed url file = do
+ (exists, size) <- if relaxed
+ then pure (True, Nothing)
+ else Url.withUrlOptions (Url.exists url)
+ if exists
+ then do
+ key <- Backend.URL.fromUrl url size
+ cleanup url file key Nothing
+ else do
+ warning $ "unable to access url: " ++ url
+ return False
+
+url2file :: URI -> Maybe Int -> Int -> FilePath
+url2file url pathdepth pathmax = case pathdepth of
+ Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl
+ Just depth
+ | depth >= length urlbits -> frombits id
+ | depth > 0 -> frombits $ drop depth
+ | depth < 0 -> frombits $ reverse . take (negate depth) . reverse
+ | otherwise -> error "bad --pathdepth"
+ where
+ fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
+ frombits a = intercalate "/" $ a urlbits
+ urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $
+ filter (not . null) $ split "/" fullurl
+ auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
diff --git a/Command/Assistant.hs b/Command/Assistant.hs
new file mode 100644
index 000000000..496df1dd2
--- /dev/null
+++ b/Command/Assistant.hs
@@ -0,0 +1,88 @@
+{- git-annex assistant
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Assistant where
+
+import Common.Annex
+import Command
+import qualified Command.Watch
+import Annex.Init
+import Config.Files
+import qualified Build.SysConfig
+import Utility.HumanTime
+
+import System.Environment
+
+def :: [Command]
+def = [noRepo checkAutoStart $ dontCheck repoExists $ withOptions options $
+ notBareRepo $ command "assistant" paramNothing seek SectionCommon
+ "automatically handle changes"]
+
+options :: [Option]
+options =
+ [ Command.Watch.foregroundOption
+ , Command.Watch.stopOption
+ , autoStartOption
+ , startDelayOption
+ ]
+
+autoStartOption :: Option
+autoStartOption = flagOption [] "autostart" "start in known repositories"
+
+startDelayOption :: Option
+startDelayOption = fieldOption [] "startdelay" paramNumber "delay before running startup scan"
+
+seek :: CommandSeek
+seek ps = do
+ stopdaemon <- getOptionFlag Command.Watch.stopOption
+ foreground <- getOptionFlag Command.Watch.foregroundOption
+ autostart <- getOptionFlag autoStartOption
+ startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration)
+ withNothing (start foreground stopdaemon autostart startdelay) ps
+
+start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
+start foreground stopdaemon autostart startdelay
+ | autostart = do
+ liftIO $ autoStart startdelay
+ stop
+ | otherwise = do
+ ensureInitialized
+ Command.Watch.start True foreground stopdaemon startdelay
+
+{- Run outside a git repository. Check to see if any parameter is
+ - --autostart and enter autostart mode. -}
+checkAutoStart :: CmdParams -> IO ()
+checkAutoStart _ = ifM (elem "--autostart" <$> getArgs)
+ ( autoStart Nothing
+ , error "Not in a git repository."
+ )
+
+autoStart :: Maybe Duration -> IO ()
+autoStart startdelay = do
+ dirs <- liftIO readAutoStartFile
+ when (null dirs) $ do
+ f <- autoStartFile
+ error $ "Nothing listed in " ++ f
+ program <- readProgramFile
+ haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
+ forM_ dirs $ \d -> do
+ putStrLn $ "git-annex autostart in " ++ d
+ ifM (catchBoolIO $ go haveionice program d)
+ ( putStrLn "ok"
+ , putStrLn "failed"
+ )
+ where
+ go haveionice program dir = do
+ setCurrentDirectory dir
+ if haveionice
+ then boolSystem "ionice" (Param "-c3" : Param program : baseparams)
+ else boolSystem program baseparams
+ where
+ baseparams =
+ [ Param "assistant"
+ , Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) startdelay)
+ ]
diff --git a/Command/Commit.hs b/Command/Commit.hs
new file mode 100644
index 000000000..f5f13d248
--- /dev/null
+++ b/Command/Commit.hs
@@ -0,0 +1,29 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Commit where
+
+import Common.Annex
+import Command
+import qualified Annex.Branch
+import qualified Git
+
+def :: [Command]
+def = [command "commit" paramNothing seek
+ SectionPlumbing "commits any staged changes to the git-annex branch"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = next $ next $ do
+ Annex.Branch.commit "update"
+ _ <- runhook <=< inRepo $ Git.hookPath "annex-content"
+ return True
+ where
+ runhook (Just hook) = liftIO $ boolSystem hook []
+ runhook Nothing = return True
diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs
new file mode 100644
index 000000000..219685c21
--- /dev/null
+++ b/Command/ConfigList.hs
@@ -0,0 +1,46 @@
+{- git-annex command
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.ConfigList where
+
+import Common.Annex
+import Command
+import Annex.UUID
+import Annex.Init
+import qualified Annex.Branch
+import qualified Git.Config
+import Remote.GCrypt (coreGCryptId)
+
+def :: [Command]
+def = [noCommit $ command "configlist" paramNothing seek
+ SectionPlumbing "outputs relevant git configuration"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = do
+ u <- findOrGenUUID
+ showConfig "annex.uuid" $ fromUUID u
+ showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "")
+ stop
+ where
+ showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v
+
+{- The repository may not yet have a UUID; automatically initialize it
+ - when there's a git-annex branch available. -}
+findOrGenUUID :: Annex UUID
+findOrGenUUID = do
+ u <- getUUID
+ if u /= NoUUID
+ then return u
+ else ifM Annex.Branch.hasSibling
+ ( do
+ initialize Nothing
+ getUUID
+ , return NoUUID
+ )
diff --git a/Command/Copy.hs b/Command/Copy.hs
new file mode 100644
index 000000000..29606061d
--- /dev/null
+++ b/Command/Copy.hs
@@ -0,0 +1,40 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Copy where
+
+import Common.Annex
+import Command
+import qualified Command.Move
+import qualified Remote
+import Annex.Wanted
+import Config.NumCopies
+
+def :: [Command]
+def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
+ SectionCommon "copy content of files to/from another repository"]
+
+seek :: CommandSeek
+seek ps = do
+ to <- getOptionField toOption Remote.byNameWithUUID
+ from <- getOptionField fromOption Remote.byNameWithUUID
+ withKeyOptions
+ (Command.Move.startKey to from False)
+ (withFilesInGit $ whenAnnexed $ start to from)
+ ps
+
+{- 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 :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start to from file (key, backend) = stopUnless shouldCopy $
+ Command.Move.start to from False file (key, backend)
+ where
+ shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
+ check = case to of
+ Nothing -> wantGet False (Just key) (Just file)
+ Just r -> wantSend False (Just key) (Just file) (Remote.uuid r)
diff --git a/Command/Dead.hs b/Command/Dead.hs
new file mode 100644
index 000000000..f9e5c2e27
--- /dev/null
+++ b/Command/Dead.hs
@@ -0,0 +1,19 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Dead where
+
+import Command
+import Types.TrustLevel
+import Command.Trust (trustCommand)
+
+def :: [Command]
+def = [command "dead" (paramRepeating paramRemote) seek
+ SectionSetup "hide a lost repository"]
+
+seek :: CommandSeek
+seek = trustCommand "dead" DeadTrusted
diff --git a/Command/Describe.hs b/Command/Describe.hs
new file mode 100644
index 000000000..601b3fcc9
--- /dev/null
+++ b/Command/Describe.hs
@@ -0,0 +1,32 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Describe where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.UUID
+
+def :: [Command]
+def = [command "describe" (paramPair paramRemote paramDesc) seek
+ SectionSetup "change description of a repository"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start (name:description) = do
+ showStart "describe" name
+ u <- Remote.nameToUUID name
+ next $ perform u $ unwords description
+start _ = error "Specify a repository and a description."
+
+perform :: UUID -> String -> CommandPerform
+perform u description = do
+ describeUUID u description
+ next $ return True
diff --git a/Command/Direct.hs b/Command/Direct.hs
new file mode 100644
index 000000000..47f622a81
--- /dev/null
+++ b/Command/Direct.hs
@@ -0,0 +1,71 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Direct where
+
+import Control.Exception.Extensible
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Git.LsFiles
+import Config
+import Annex.Direct
+import Annex.Exception
+
+def :: [Command]
+def = [notBareRepo $ noDaemonRunning $
+ command "direct" paramNothing seek
+ SectionSetup "switch repository to direct mode"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = ifM isDirect ( stop , next perform )
+
+perform :: CommandPerform
+perform = do
+ showStart "commit" ""
+ showOutput
+ _ <- inRepo $ Git.Command.runBool
+ [ Param "commit"
+ , Param "-a"
+ , Param "-m"
+ , Param "commit before switching to direct mode"
+ ]
+ showEndOk
+
+ top <- fromRepo Git.repoPath
+ (l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+ forM_ l go
+ void $ liftIO clean
+ next cleanup
+ where
+ go = whenAnnexed $ \f (k, _) -> do
+ r <- toDirectGen k f
+ case r of
+ Nothing -> noop
+ Just a -> do
+ showStart "direct" f
+ r' <- tryAnnex a
+ case r' of
+ Left e -> warnlocked e
+ Right _ -> showEndOk
+ return Nothing
+
+ warnlocked :: SomeException -> Annex ()
+ warnlocked e = do
+ warning $ show e
+ warning "leaving this file as-is; correct this problem and run git annex fsck on it"
+
+cleanup :: CommandCleanup
+cleanup = do
+ showStart "direct" ""
+ setDirect True
+ return True
diff --git a/Command/Drop.hs b/Command/Drop.hs
new file mode 100644
index 000000000..269c4c26b
--- /dev/null
+++ b/Command/Drop.hs
@@ -0,0 +1,185 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Drop where
+
+import Common.Annex
+import Command
+import qualified Remote
+import qualified Annex
+import Annex.UUID
+import Logs.Location
+import Logs.Trust
+import Logs.PreferredContent
+import Config.NumCopies
+import Annex.Content
+import Annex.Wanted
+import Annex.Notification
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [withOptions [dropFromOption] $ command "drop" paramPaths seek
+ SectionCommon "indicate content of files not currently wanted"]
+
+dropFromOption :: Option
+dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote"
+
+seek :: CommandSeek
+seek ps = do
+ from <- getOptionField dropFromOption Remote.byNameWithUUID
+ withFilesInGit (whenAnnexed $ start from) ps
+
+start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start from file (key, _) = checkDropAuto from file key $ \numcopies ->
+ stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just key) (Just file)) $
+ case from of
+ Nothing -> startLocal (Just file) numcopies key Nothing
+ Just remote -> do
+ u <- getUUID
+ if Remote.uuid remote == u
+ then startLocal (Just file) numcopies key Nothing
+ else startRemote (Just file) numcopies key remote
+
+startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart
+startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do
+ showStart' "drop" key afile
+ next $ performLocal key afile numcopies knownpresentremote
+
+startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart
+startRemote afile numcopies key remote = do
+ showStart' ("drop " ++ Remote.name remote) key afile
+ next $ performRemote key afile numcopies remote
+
+performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform
+performLocal key afile numcopies knownpresentremote = lockContent key $ do
+ (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+ let trusteduuids' = case knownpresentremote of
+ Nothing -> trusteduuids
+ Just r -> nub (Remote.uuid r:trusteduuids)
+ untrusteduuids <- trustGet UnTrusted
+ let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids)
+ u <- getUUID
+ ifM (canDrop u key afile numcopies trusteduuids' tocheck [])
+ ( do
+ removeAnnex key
+ notifyDrop afile True
+ next $ cleanupLocal key
+ , do
+ notifyDrop afile False
+ stop
+ )
+
+performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform
+performRemote key afile numcopies remote = lockContent key $ do
+ -- Filter the remote it's being dropped from out of the lists of
+ -- places assumed to have the key, and places to check.
+ -- When the local repo has the key, that's one additional copy.
+ (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+ present <- inAnnex key
+ u <- getUUID
+ let have = filter (/= uuid) $
+ if present then u:trusteduuids else trusteduuids
+ untrusteduuids <- trustGet UnTrusted
+ let tocheck = filter (/= remote) $
+ Remote.remotesWithoutUUID remotes (have++untrusteduuids)
+ stopUnless (canDrop uuid key afile numcopies have tocheck [uuid]) $ do
+ ok <- Remote.removeKey remote key
+ next $ cleanupRemote key remote ok
+ where
+ uuid = Remote.uuid remote
+
+cleanupLocal :: Key -> CommandCleanup
+cleanupLocal key = do
+ logStatus key InfoMissing
+ return True
+
+cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup
+cleanupRemote key remote ok = do
+ when ok $
+ Remote.logStatus remote key InfoMissing
+ return ok
+
+{- Checks specified remotes to verify that enough copies of a key exist to
+ - allow it to be safely removed (with no data loss). Can be provided with
+ - some locations where the key is known/assumed to be present.
+ -
+ - Also checks if it's required content, and refuses to drop if so.
+ -
+ - --force overrides and always allows dropping.
+ -}
+canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
+canDrop dropfrom key afile numcopies have check skip = ifM (Annex.getState Annex.force)
+ ( return True
+ , checkRequiredContent dropfrom key afile
+ <&&>
+ findCopies key numcopies skip have check
+ )
+
+findCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+findCopies key need skip = helper [] []
+ where
+ helper bad missing have []
+ | NumCopies (length have) >= need = return True
+ | otherwise = notEnoughCopies key need have (skip++missing) bad
+ helper bad missing have (r:rs)
+ | NumCopies (length have) >= need = return True
+ | otherwise = do
+ let u = Remote.uuid r
+ let duplicate = u `elem` have
+ haskey <- Remote.hasKey r key
+ case (duplicate, haskey) of
+ (False, Right True) -> helper bad missing (u:have) rs
+ (False, Left _) -> helper (r:bad) missing have rs
+ (False, Right False) -> helper bad (u:missing) have rs
+ _ -> helper bad missing have rs
+
+notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
+notEnoughCopies key need have skip bad = do
+ unsafe
+ showLongNote $
+ "Could only verify the existence of " ++
+ show (length have) ++ " out of " ++ show (fromNumCopies need) ++
+ " necessary copies"
+ Remote.showTriedRemotes bad
+ Remote.showLocations key (have++skip)
+ "Rather than dropping this file, try using: git annex move"
+ hint
+ return False
+ where
+ unsafe = showNote "unsafe"
+ hint = showLongNote "(Use --force to override this check, or adjust numcopies.)"
+
+checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool
+checkRequiredContent u k afile =
+ ifM (isRequiredContent (Just u) S.empty (Just k) afile False)
+ ( requiredContent
+ , return True
+ )
+
+requiredContent :: Annex Bool
+requiredContent = do
+ showLongNote "That file is required content, it cannot be dropped!"
+ showLongNote "(Use --force to override this check, or adjust required content configuration.)"
+ return False
+
+{- In auto mode, only runs the action if there are enough
+ - copies on other semitrusted repositories. -}
+checkDropAuto :: Maybe Remote -> FilePath -> Key -> (NumCopies -> CommandStart) -> CommandStart
+checkDropAuto mremote file key a = do
+ numcopies <- getFileNumCopies file
+ Annex.getState Annex.auto >>= auto numcopies
+ where
+ auto numcopies False = a numcopies
+ auto numcopies True = do
+ locs <- Remote.keyLocations key
+ uuid <- getUUID
+ let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote
+ locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs
+ if NumCopies (length locs') >= numcopies
+ then a numcopies
+ else stop
diff --git a/Command/DropKey.hs b/Command/DropKey.hs
new file mode 100644
index 000000000..125e6ded4
--- /dev/null
+++ b/Command/DropKey.hs
@@ -0,0 +1,38 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.DropKey where
+
+import Common.Annex
+import Command
+import qualified Annex
+import Logs.Location
+import Annex.Content
+
+def :: [Command]
+def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek
+ SectionPlumbing "drops annexed content for specified keys"]
+
+seek :: CommandSeek
+seek = withKeys start
+
+start :: Key -> CommandStart
+start key = stopUnless (inAnnex key) $ do
+ unlessM (Annex.getState Annex.force) $
+ error "dropkey can cause data loss; use --force if you're sure you want to do this"
+ showStart' "dropkey" key Nothing
+ next $ perform key
+
+perform :: Key -> CommandPerform
+perform key = lockContent key $ do
+ removeAnnex key
+ next $ cleanup key
+
+cleanup :: Key -> CommandCleanup
+cleanup key = do
+ logStatus key InfoMissing
+ return True
diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs
new file mode 100644
index 000000000..ce49795c9
--- /dev/null
+++ b/Command/DropUnused.hs
@@ -0,0 +1,45 @@
+{- git-annex command
+ -
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.DropUnused where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Command.Drop
+import qualified Remote
+import qualified Git
+import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
+import Config.NumCopies
+
+def :: [Command]
+def = [withOptions [Command.Drop.dropFromOption] $
+ command "dropunused" (paramRepeating paramNumRange)
+ seek SectionMaintenance "drop unused file content"]
+
+seek :: CommandSeek
+seek ps = do
+ numcopies <- getNumCopies
+ withUnusedMaps (start numcopies) ps
+
+start :: NumCopies -> UnusedMaps -> Int -> CommandStart
+start numcopies = startUnused "dropunused" (perform numcopies) (performOther gitAnnexBadLocation) (performOther gitAnnexTmpObjectLocation)
+
+perform :: NumCopies -> Key -> CommandPerform
+perform numcopies key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from
+ where
+ dropremote r = do
+ showAction $ "from " ++ Remote.name r
+ Command.Drop.performRemote key Nothing numcopies r
+ droplocal = Command.Drop.performLocal key Nothing numcopies Nothing
+ from = Annex.getField $ optionName Command.Drop.dropFromOption
+
+performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
+performOther filespec key = do
+ f <- fromRepo $ filespec key
+ liftIO $ nukeFile f
+ next $ return True
diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs
new file mode 100644
index 000000000..42ab43374
--- /dev/null
+++ b/Command/EnableRemote.hs
@@ -0,0 +1,56 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.EnableRemote where
+
+import Common.Annex
+import Command
+import qualified Logs.Remote
+import qualified Types.Remote as R
+import qualified Command.InitRemote as InitRemote
+
+import qualified Data.Map as M
+
+def :: [Command]
+def = [command "enableremote"
+ (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
+ seek SectionSetup "enables use of an existing special remote"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = unknownNameError "Specify the name of the special remote to enable."
+start (name:ws) = go =<< InitRemote.findExisting name
+ where
+ config = Logs.Remote.keyValToConfig ws
+
+ go Nothing = unknownNameError "Unknown special remote name."
+ go (Just (u, c)) = do
+ let fullconfig = config `M.union` c
+ t <- InitRemote.findType fullconfig
+
+ showStart "enableremote" name
+ next $ perform t u fullconfig
+
+unknownNameError :: String -> Annex a
+unknownNameError prefix = do
+ names <- InitRemote.remoteNames
+ error $ prefix ++ "\n" ++
+ if null names
+ then "(No special remotes are currently known; perhaps use initremote instead?)"
+ else "Known special remotes: " ++ unwords names
+
+perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
+perform t u c = do
+ (c', u') <- R.setup t (Just u) Nothing c
+ next $ cleanup u' c'
+
+cleanup :: UUID -> R.RemoteConfig -> CommandCleanup
+cleanup u c = do
+ Logs.Remote.configSet u c
+ return True
diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs
new file mode 100644
index 000000000..dd2bec507
--- /dev/null
+++ b/Command/ExamineKey.hs
@@ -0,0 +1,29 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.ExamineKey where
+
+import Common.Annex
+import Command
+import qualified Utility.Format
+import Command.Find (formatOption, getFormat, showFormatted, keyVars)
+import Types.Key
+
+def :: [Command]
+def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
+ command "examinekey" (paramRepeating paramKey) seek
+ SectionPlumbing "prints information from a key"]
+
+seek :: CommandSeek
+seek ps = do
+ format <- getFormat
+ withKeys (start format) ps
+
+start :: Maybe Utility.Format.Format -> Key -> CommandStart
+start format key = do
+ showFormatted format (key2file key) (keyVars key)
+ stop
diff --git a/Command/Find.hs b/Command/Find.hs
new file mode 100644
index 000000000..c6a32a944
--- /dev/null
+++ b/Command/Find.hs
@@ -0,0 +1,72 @@
+{- git-annex command
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Find where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import Annex.Content
+import Limit
+import qualified Annex
+import qualified Utility.Format
+import Utility.DataUnits
+import Types.Key
+
+def :: [Command]
+def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOption] $
+ command "find" paramPaths seek SectionQuery "lists available files"]
+
+formatOption :: Option
+formatOption = fieldOption [] "format" paramFormat "control format of output"
+
+getFormat :: Annex (Maybe Utility.Format.Format)
+getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen
+
+print0Option :: Option
+print0Option = Option [] ["print0"] (NoArg set)
+ "terminate output with null"
+ where
+ set = Annex.setField (optionName formatOption) "${file}\0"
+
+seek :: CommandSeek
+seek ps = do
+ format <- getFormat
+ withFilesInGit (whenAnnexed $ start format) ps
+
+start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
+start format file (key, _) = do
+ -- only files inAnnex are shown, unless the user has requested
+ -- others via a limit
+ whenM (limited <||> inAnnex key) $
+ showFormatted format file $ ("file", file) : keyVars key
+ stop
+
+showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex ()
+showFormatted format unformatted vars =
+ unlessM (showFullJSON vars) $
+ case format of
+ Nothing -> liftIO $ putStrLn unformatted
+ Just formatter -> liftIO $ putStr $
+ Utility.Format.format formatter $
+ M.fromList vars
+
+keyVars :: Key -> [(String, String)]
+keyVars key =
+ [ ("key", key2file key)
+ , ("backend", keyBackendName key)
+ , ("bytesize", size show)
+ , ("humansize", size $ roughSize storageUnits True)
+ , ("keyname", keyName key)
+ , ("hashdirlower", hashDirLower key)
+ , ("hashdirmixed", hashDirMixed key)
+ , ("mtime", whenavail show $ keyMtime key)
+ ]
+ where
+ size c = whenavail c $ keySize key
+ whenavail = maybe "unknown"
diff --git a/Command/Fix.hs b/Command/Fix.hs
new file mode 100644
index 000000000..f730226e3
--- /dev/null
+++ b/Command/Fix.hs
@@ -0,0 +1,59 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.Fix where
+
+import Common.Annex
+import Command
+import qualified Annex.Queue
+#ifdef WITH_CLIBS
+#ifndef __ANDROID__
+import Utility.Touch
+#endif
+#endif
+
+def :: [Command]
+def = [notDirect $ noCommit $ command "fix" paramPaths seek
+ SectionMaintenance "fix up symlinks to point to annexed content"]
+
+seek :: CommandSeek
+seek = withFilesInGit $ whenAnnexed start
+
+{- Fixes the symlink to an annexed file. -}
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, _) = do
+ link <- inRepo $ gitAnnexLink file key
+ stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do
+ showStart "fix" file
+ next $ perform file link
+
+perform :: FilePath -> FilePath -> CommandPerform
+perform file link = do
+ liftIO $ do
+#ifdef WITH_CLIBS
+#ifndef __ANDROID__
+ -- preserve mtime of symlink
+ mtime <- catchMaybeIO $ TimeSpec . modificationTime
+ <$> getSymbolicLinkStatus file
+#endif
+#endif
+ createDirectoryIfMissing True (parentDir file)
+ removeFile file
+ createSymbolicLink link file
+#ifdef WITH_CLIBS
+#ifndef __ANDROID__
+ maybe noop (\t -> touch file t False) mtime
+#endif
+#endif
+ next $ cleanup file
+
+cleanup :: FilePath -> CommandCleanup
+cleanup file = do
+ Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file]
+ return True
diff --git a/Command/Forget.hs b/Command/Forget.hs
new file mode 100644
index 000000000..dbcce6cc3
--- /dev/null
+++ b/Command/Forget.hs
@@ -0,0 +1,52 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Forget where
+
+import Common.Annex
+import Command
+import qualified Annex.Branch as Branch
+import Logs.Transitions
+import qualified Annex
+
+import Data.Time.Clock.POSIX
+
+def :: [Command]
+def = [withOptions forgetOptions $ command "forget" paramNothing seek
+ SectionMaintenance "prune git-annex branch history"]
+
+forgetOptions :: [Option]
+forgetOptions = [dropDeadOption]
+
+dropDeadOption :: Option
+dropDeadOption = flagOption [] "drop-dead" "drop references to dead repositories"
+
+seek :: CommandSeek
+seek ps = do
+ dropdead <- getOptionFlag dropDeadOption
+ withNothing (start dropdead) ps
+
+start :: Bool -> CommandStart
+start dropdead = do
+ showStart "forget" "git-annex"
+ now <- liftIO getPOSIXTime
+ let basets = addTransition now ForgetGitHistory noTransitions
+ let ts = if dropdead
+ then addTransition now ForgetDeadRemotes basets
+ else basets
+ next $ perform ts =<< Annex.getState Annex.force
+
+perform :: Transitions -> Bool -> CommandPerform
+perform ts True = do
+ recordTransitions Branch.change ts
+ -- get branch committed before contining with the transition
+ Branch.update
+ void $ Branch.performTransitions ts True []
+ next $ return True
+perform _ False = do
+ showLongNote "To forget git-annex branch history, you must specify --force. This deletes metadata!"
+ stop
diff --git a/Command/FromKey.hs b/Command/FromKey.hs
new file mode 100644
index 000000000..7eb62fa4e
--- /dev/null
+++ b/Command/FromKey.hs
@@ -0,0 +1,44 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FromKey where
+
+import Common.Annex
+import Command
+import qualified Annex.Queue
+import Annex.Content
+import Types.Key
+
+def :: [Command]
+def = [notDirect $ notBareRepo $
+ command "fromkey" (paramPair paramKey paramPath) seek
+ SectionPlumbing "adds a file using a specific key"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start (keyname:file:[]) = do
+ let key = fromMaybe (error "bad key") $ file2key keyname
+ inbackend <- inAnnex key
+ unless inbackend $ error $
+ "key ("++ keyname ++") is not present in backend"
+ showStart "fromkey" file
+ next $ perform key file
+start _ = error "specify a key and a dest file"
+
+perform :: Key -> FilePath -> CommandPerform
+perform key file = do
+ link <- inRepo $ gitAnnexLink file key
+ liftIO $ createDirectoryIfMissing True (parentDir file)
+ liftIO $ createSymbolicLink link file
+ next $ cleanup file
+
+cleanup :: FilePath -> CommandCleanup
+cleanup file = do
+ Annex.Queue.addCommand "add" [Param "--"] [file]
+ return True
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
new file mode 100644
index 000000000..88a9915c4
--- /dev/null
+++ b/Command/Fsck.hs
@@ -0,0 +1,513 @@
+{- git-annex command
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.Fsck where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Remote
+import qualified Types.Backend
+import qualified Types.Key
+import qualified Backend
+import Annex.Content
+import Annex.Content.Direct
+import Annex.Direct
+import Annex.Perms
+import Annex.Link
+import Logs.Location
+import Logs.Trust
+import Config.NumCopies
+import Annex.UUID
+import Utility.DataUnits
+import Utility.FileMode
+import Config
+import Types.Key
+import Types.CleanupActions
+import Utility.HumanTime
+import Git.FilePath
+import Utility.PID
+
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Posix.Types (EpochTime)
+import System.Locale
+
+def :: [Command]
+def = [withOptions fsckOptions $ command "fsck" paramPaths seek
+ SectionMaintenance "check for problems"]
+
+fsckFromOption :: Option
+fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote"
+
+startIncrementalOption :: Option
+startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck"
+
+moreIncrementalOption :: Option
+moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck"
+
+incrementalScheduleOption :: Option
+incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime
+ "schedule incremental fscking"
+
+fsckOptions :: [Option]
+fsckOptions =
+ [ fsckFromOption
+ , startIncrementalOption
+ , moreIncrementalOption
+ , incrementalScheduleOption
+ ] ++ keyOptions
+
+seek :: CommandSeek
+seek ps = do
+ from <- getOptionField fsckFromOption Remote.byNameWithUUID
+ i <- getIncremental
+ withKeyOptions
+ (\k -> startKey i k =<< getNumCopies)
+ (withFilesInGit $ whenAnnexed $ start from i)
+ ps
+
+getIncremental :: Annex Incremental
+getIncremental = do
+ i <- maybe (return False) (checkschedule . parseDuration)
+ =<< Annex.getField (optionName incrementalScheduleOption)
+ starti <- Annex.getFlag (optionName startIncrementalOption)
+ morei <- Annex.getFlag (optionName moreIncrementalOption)
+ case (i, starti, morei) of
+ (False, False, False) -> return NonIncremental
+ (False, True, False) -> startIncremental
+ (False ,False, True) -> ContIncremental <$> getStartTime
+ (True, False, False) ->
+ maybe startIncremental (return . ContIncremental . Just)
+ =<< getStartTime
+ _ -> error "Specify only one of --incremental, --more, or --incremental-schedule"
+ where
+ startIncremental = do
+ recordStartTime
+ return StartIncremental
+
+ checkschedule Nothing = error "bad --incremental-schedule value"
+ checkschedule (Just delta) = do
+ Annex.addCleanup FsckCleanup $ do
+ v <- getStartTime
+ case v of
+ Nothing -> noop
+ Just started -> do
+ now <- liftIO getPOSIXTime
+ when (now - realToFrac started >= durationToPOSIXTime delta)
+ resetStartTime
+ return True
+
+start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart
+start from inc file (key, backend) = do
+ numcopies <- getFileNumCopies file
+ case from of
+ Nothing -> go $ perform key file backend numcopies
+ Just r -> go $ performRemote key file backend numcopies r
+ where
+ go = runFsck inc file key
+
+perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
+perform key file backend numcopies = check
+ -- order matters
+ [ fixLink key file
+ , verifyLocationLog key file
+ , verifyDirectMapping key file
+ , verifyDirectMode key file
+ , checkKeySize key
+ , checkBackend backend key (Just file)
+ , checkKeyNumCopies key file numcopies
+ ]
+
+{- To fsck a remote, the content is retrieved to a tmp file,
+ - and checked locally. -}
+performRemote :: Key -> FilePath -> Backend -> NumCopies -> Remote -> Annex Bool
+performRemote key file backend numcopies remote =
+ dispatch =<< Remote.hasKey remote key
+ where
+ dispatch (Left err) = do
+ showNote err
+ return False
+ dispatch (Right True) = withtmp $ \tmpfile ->
+ ifM (getfile tmpfile)
+ ( go True (Just tmpfile)
+ , go True Nothing
+ )
+ dispatch (Right False) = go False Nothing
+ go present localcopy = check
+ [ verifyLocationLogRemote key file remote present
+ , checkKeySizeRemote key remote localcopy
+ , checkBackendRemote backend key remote localcopy
+ , checkKeyNumCopies key file numcopies
+ ]
+ withtmp a = do
+ pid <- liftIO getPID
+ t <- fromRepo gitAnnexTmpObjectDir
+ createAnnexDirectory t
+ let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
+ let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
+ cleanup
+ cleanup `after` a tmp
+ getfile tmp =
+ ifM (Remote.retrieveKeyFileCheap remote key tmp)
+ ( return True
+ , ifM (Annex.getState Annex.fast)
+ ( return False
+ , Remote.retrieveKeyFile remote key Nothing tmp dummymeter
+ )
+ )
+ dummymeter _ = noop
+
+startKey :: Incremental -> Key -> NumCopies -> CommandStart
+startKey inc key numcopies =
+ case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
+ Nothing -> stop
+ Just backend -> runFsck inc (key2file key) key $
+ performKey key backend numcopies
+
+performKey :: Key -> Backend -> NumCopies -> Annex Bool
+performKey key backend numcopies = check
+ [ verifyLocationLog key (key2file key)
+ , checkKeySize key
+ , checkBackend backend key Nothing
+ , checkKeyNumCopies key (key2file key) numcopies
+ ]
+
+check :: [Annex Bool] -> Annex Bool
+check cs = and <$> sequence cs
+
+{- Checks that the file's link points correctly to the content.
+ -
+ - In direct mode, there is only a link when the content is not present.
+ -}
+fixLink :: Key -> FilePath -> Annex Bool
+fixLink key file = do
+ want <- inRepo $ gitAnnexLink file key
+ have <- getAnnexLinkTarget file
+ maybe noop (go want) have
+ return True
+ where
+ go want have
+ | want /= fromInternalGitPath have = do
+ showNote "fixing link"
+ liftIO $ createDirectoryIfMissing True (parentDir file)
+ liftIO $ removeFile file
+ addAnnexLink want file
+ | otherwise = noop
+
+{- Checks that the location log reflects the current status of the key,
+ - in this repository only. -}
+verifyLocationLog :: Key -> String -> Annex Bool
+verifyLocationLog key desc = do
+ present <- inAnnex key
+ direct <- isDirect
+ u <- getUUID
+
+ {- Since we're checking that a key's file is present, throw
+ - in a permission fixup here too. -}
+ file <- calcRepo $ gitAnnexLocation key
+ when (present && not direct) $
+ freezeContent file
+ whenM (liftIO $ doesDirectoryExist $ parentDir file) $
+ freezeContentDir file
+
+ {- In direct mode, modified files will show up as not present,
+ - but that is expected and not something to do anything about. -}
+ if direct && not present
+ then return True
+ else verifyLocationLog' key desc present u (logChange key u)
+
+verifyLocationLogRemote :: Key -> String -> Remote -> Bool -> Annex Bool
+verifyLocationLogRemote key desc remote present =
+ verifyLocationLog' key desc present (Remote.uuid remote)
+ (Remote.logStatus remote key)
+
+verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
+verifyLocationLog' key desc present u updatestatus = do
+ uuids <- Remote.keyLocations key
+ case (present, u `elem` uuids) of
+ (True, False) -> do
+ fix InfoPresent
+ -- There is no data loss, so do not fail.
+ return True
+ (False, True) -> do
+ fix InfoMissing
+ warning $
+ "** Based on the location log, " ++ desc
+ ++ "\n** was expected to be present, " ++
+ "but its content is missing."
+ return False
+ _ -> return True
+ where
+ fix s = do
+ showNote "fixing location log"
+ updatestatus s
+
+{- Ensures the direct mode mapping file is consistent. Each file
+ - it lists for the key should exist, and the specified file should be
+ - included in it.
+ -}
+verifyDirectMapping :: Key -> FilePath -> Annex Bool
+verifyDirectMapping key file = do
+ whenM isDirect $ do
+ fs <- addAssociatedFile key file
+ forM_ fs $ \f ->
+ unlessM (liftIO $ doesFileExist f) $
+ void $ removeAssociatedFile key f
+ return True
+
+{- Ensures that files whose content is available are in direct mode. -}
+verifyDirectMode :: Key -> FilePath -> Annex Bool
+verifyDirectMode key file = do
+ whenM (isDirect <&&> isJust <$> isAnnexLink file) $ do
+ v <- toDirectGen key file
+ case v of
+ Nothing -> noop
+ Just a -> do
+ showNote "fixing direct mode"
+ a
+ return True
+
+{- The size of the data for a key is checked against the size encoded in
+ - the key's metadata, if available.
+ -
+ - Not checked in direct mode, because files can be changed directly.
+ -}
+checkKeySize :: Key -> Annex Bool
+checkKeySize key = ifM isDirect
+ ( return True
+ , do
+ file <- calcRepo $ gitAnnexLocation key
+ ifM (liftIO $ doesFileExist file)
+ ( checkKeySizeOr badContent key file
+ , return True
+ )
+ )
+
+checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool
+checkKeySizeRemote _ _ Nothing = return True
+checkKeySizeRemote key remote (Just file) =
+ checkKeySizeOr (badContentRemote remote) key file
+
+checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> Annex Bool
+checkKeySizeOr bad key file = case Types.Key.keySize key of
+ Nothing -> return True
+ Just size -> do
+ size' <- fromIntegral . fileSize
+ <$> liftIO (getFileStatus file)
+ comparesizes size size'
+ where
+ comparesizes a b = do
+ let same = a == b
+ unless same $ badsize a b
+ return same
+ badsize a b = do
+ msg <- bad key
+ warning $ concat
+ [ "Bad file size ("
+ , compareSizes storageUnits True a b
+ , "); "
+ , msg
+ ]
+
+{- Runs the backend specific check on a key's content.
+ -
+ - In direct mode this is not done if the file has clearly been modified,
+ - because modification of direct mode files is allowed. It's still done
+ - if the file does not appear modified, to catch disk corruption, etc.
+ -}
+checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool
+checkBackend backend key mfile = go =<< isDirect
+ where
+ go False = do
+ content <- calcRepo $ gitAnnexLocation key
+ checkBackendOr badContent backend key content
+ go True = maybe nocheck checkdirect mfile
+ checkdirect file = ifM (goodContent key file)
+ ( checkBackendOr' (badContentDirect file) backend key file
+ (goodContent key file)
+ , nocheck
+ )
+ nocheck = return True
+
+checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool
+checkBackendRemote backend key remote = maybe (return True) go
+ where
+ go = checkBackendOr (badContentRemote remote) backend key
+
+checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool
+checkBackendOr bad backend key file =
+ checkBackendOr' bad backend key file (return True)
+
+checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool -> Annex Bool
+checkBackendOr' bad backend key file postcheck =
+ case Types.Backend.fsckKey backend of
+ Nothing -> return True
+ Just a -> do
+ ok <- a key file
+ ifM postcheck
+ ( do
+ unless ok $ do
+ msg <- bad key
+ warning $ "Bad file content; " ++ msg
+ return ok
+ , return True
+ )
+
+checkKeyNumCopies :: Key -> String -> NumCopies -> Annex Bool
+checkKeyNumCopies key file numcopies = do
+ (untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key
+ let present = NumCopies (length safelocations)
+ if present < numcopies
+ then do
+ ppuuids <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
+ warning $ missingNote file present numcopies ppuuids
+ return False
+ else return True
+
+missingNote :: String -> NumCopies -> NumCopies -> String -> String
+missingNote file (NumCopies 0) _ [] =
+ "** No known copies exist of " ++ file
+missingNote file (NumCopies 0) _ untrusted =
+ "Only these untrusted locations may have copies of " ++ file ++
+ "\n" ++ untrusted ++
+ "Back it up to trusted locations with git-annex copy."
+missingNote file present needed [] =
+ "Only " ++ show (fromNumCopies present) ++ " of " ++ show (fromNumCopies needed) ++
+ " trustworthy copies exist of " ++ file ++
+ "\nBack it up with git-annex copy."
+missingNote file present needed untrusted =
+ missingNote file present needed [] ++
+ "\nThe following untrusted locations may also have copies: " ++
+ "\n" ++ untrusted
+
+{- Bad content is moved aside. -}
+badContent :: Key -> Annex String
+badContent key = do
+ dest <- moveBad key
+ return $ "moved to " ++ dest
+
+{- Bad content is left where it is, but we touch the file, so it'll be
+ - committed to a new key. -}
+badContentDirect :: FilePath -> Key -> Annex String
+badContentDirect file key = do
+ void $ liftIO $ catchMaybeIO $ touchFile file
+ logStatus key InfoMissing
+ return "left in place for you to examine"
+
+badContentRemote :: Remote -> Key -> Annex String
+badContentRemote remote key = do
+ ok <- Remote.removeKey remote key
+ when ok $
+ Remote.logStatus remote key InfoMissing
+ return $ (if ok then "dropped from " else "failed to drop from ")
+ ++ Remote.name remote
+
+data Incremental = StartIncremental | ContIncremental (Maybe EpochTime) | NonIncremental
+ deriving (Eq, Show)
+
+runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart
+runFsck inc file key a = ifM (needFsck inc key)
+ ( do
+ showStart "fsck" file
+ next $ do
+ ok <- a
+ when ok $
+ recordFsckTime key
+ next $ return ok
+ , stop
+ )
+
+{- Check if a key needs to be fscked, with support for incremental fscks. -}
+needFsck :: Incremental -> Key -> Annex Bool
+needFsck (ContIncremental Nothing) _ = return True
+needFsck (ContIncremental starttime) key = do
+ fscktime <- getFsckTime key
+ return $ fscktime < starttime
+needFsck _ _ = return True
+
+{- To record the time that a key was last fscked, without
+ - modifying its mtime, we set the timestamp of its parent directory.
+ - Each annexed file is the only thing in its directory, so this is fine.
+ -
+ - To record that the file was fscked, the directory's sticky bit is set.
+ - (None of the normal unix behaviors of the sticky bit should matter, so
+ - we can reuse this permission bit.)
+ -
+ - Note that this relies on the parent directory being deleted when a file
+ - is dropped. That way, if it's later added back, the fsck record
+ - won't still be present.
+ -}
+recordFsckTime :: Key -> Annex ()
+recordFsckTime key = do
+ parent <- parentDir <$> calcRepo (gitAnnexLocation key)
+ liftIO $ void $ tryIO $ do
+ touchFile parent
+#ifndef mingw32_HOST_OS
+ setSticky parent
+#endif
+
+getFsckTime :: Key -> Annex (Maybe EpochTime)
+getFsckTime key = do
+ parent <- parentDir <$> calcRepo (gitAnnexLocation key)
+ liftIO $ catchDefaultIO Nothing $ do
+ s <- getFileStatus parent
+ return $ if isSticky $ fileMode s
+ then Just $ modificationTime s
+ else Nothing
+
+{- Records the start time of an incremental fsck.
+ -
+ - To guard against time stamp damange (for example, if an annex directory
+ - is copied without -a), the fsckstate file contains a time that should
+ - be identical to its modification time.
+ - (This is not possible to do on Windows, and so the timestamp in
+ - the file will only be equal or greater than the modification time.)
+ -}
+recordStartTime :: Annex ()
+recordStartTime = do
+ f <- fromRepo gitAnnexFsckState
+ createAnnexDirectory $ parentDir f
+ liftIO $ do
+ nukeFile f
+ withFile f WriteMode $ \h -> do
+#ifndef mingw32_HOST_OS
+ t <- modificationTime <$> getFileStatus f
+#else
+ t <- getPOSIXTime
+#endif
+ hPutStr h $ showTime $ realToFrac t
+ where
+ showTime :: POSIXTime -> String
+ showTime = show
+
+resetStartTime :: Annex ()
+resetStartTime = liftIO . nukeFile =<< fromRepo gitAnnexFsckState
+
+{- Gets the incremental fsck start time. -}
+getStartTime :: Annex (Maybe EpochTime)
+getStartTime = do
+ f <- fromRepo gitAnnexFsckState
+ liftIO $ catchDefaultIO Nothing $ do
+ timestamp <- modificationTime <$> getFileStatus f
+ let fromstatus = Just (realToFrac timestamp)
+ fromfile <- readishTime <$> readFile f
+ return $ if matchingtimestamp fromfile fromstatus
+ then Just timestamp
+ else Nothing
+ where
+ readishTime :: String -> Maybe POSIXTime
+ readishTime s = utcTimeToPOSIXSeconds <$>
+ parseTime defaultTimeLocale "%s%Qs" s
+ matchingtimestamp fromfile fromstatus =
+#ifndef mingw32_HOST_OS
+ fromfile == fromstatus
+#else
+ fromfile >= fromstatus
+#endif
diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs
new file mode 100644
index 000000000..08103edc8
--- /dev/null
+++ b/Command/FuzzTest.hs
@@ -0,0 +1,281 @@
+{- git-annex fuzz generator
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FuzzTest where
+
+import Common.Annex
+import qualified Annex
+import Command
+import qualified Git.Config
+import Config
+import Utility.ThreadScheduler
+import Annex.Exception
+import Utility.DiskFree
+
+import Data.Time.Clock
+import System.Random (getStdRandom, random, randomR)
+import Test.QuickCheck
+import Control.Concurrent
+
+def :: [Command]
+def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing
+ "generates fuzz test files"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = do
+ guardTest
+ logf <- fromRepo gitAnnexFuzzTestLogFile
+ showStart "fuzztest" logf
+ logh <-liftIO $ openFile logf WriteMode
+ void $ forever $ fuzz logh
+ stop
+
+guardTest :: Annex ()
+guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
+ error $ unlines
+ [ "Running fuzz tests *writes* to and *deletes* files in"
+ , "this repository, and pushes those changes to other"
+ , "repositories! This is a developer tool, not something"
+ , "to play with."
+ , ""
+ , "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!"
+ ]
+ where
+ key = annexConfig "eat-my-repository"
+ (ConfigKey keyname) = key
+
+
+fuzz :: Handle -> Annex ()
+fuzz logh = do
+ action <- genFuzzAction
+ record logh $ flip Started action
+ result <- tryAnnex $ runFuzzAction action
+ record logh $ flip Finished $
+ either (const False) (const True) result
+
+record :: Handle -> (UTCTime -> TimeStampedFuzzAction) -> Annex ()
+record h tmpl = liftIO $ do
+ now <- getCurrentTime
+ let s = show $ tmpl now
+ print s
+ hPrint h s
+ hFlush h
+
+{- 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.
+ -}
+randomDelay :: Delay -> Annex ()
+randomDelay TinyDelay = 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))
+ 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
+ _ -> noop
+
+data Delay
+ = TinyDelay
+ | SecondsDelay
+ | MinutesDelay
+ deriving (Read, Show, Eq)
+
+instance Arbitrary Delay where
+ arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay]
+
+data FuzzFile = FuzzFile FilePath
+ deriving (Read, Show, Eq)
+
+data FuzzDir = FuzzDir FilePath
+ deriving (Read, Show, Eq)
+
+instance Arbitrary FuzzFile where
+ arbitrary = FuzzFile <$> arbitrary
+
+instance Arbitrary FuzzDir where
+ arbitrary = FuzzDir <$> arbitrary
+
+class ToFilePath a where
+ toFilePath :: a -> FilePath
+
+instance ToFilePath FuzzFile where
+ toFilePath (FuzzFile f) = f
+
+instance ToFilePath FuzzDir where
+ toFilePath (FuzzDir d) = d
+
+isFuzzFile :: FilePath -> Bool
+isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f
+
+isFuzzDir :: FilePath -> Bool
+isFuzzDir d = "fuzzdir_" `isPrefixOf` d
+
+mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile
+mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file)
+
+mkFuzzDir :: Int -> FuzzDir
+mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n
+
+{- File is placed inside a directory hierarchy up to 4 subdirectories deep. -}
+genFuzzFile :: IO FuzzFile
+genFuzzFile = do
+ n <- getStdRandom $ randomR (0, 4)
+ dirs <- replicateM n genFuzzDir
+ file <- show <$> (getStdRandom random :: IO Int)
+ return $ mkFuzzFile file dirs
+
+{- Only 16 distinct subdirectories are used. When nested 4 deep, this
+ - yields 69904 total directories max, which is below the default Linux
+ - inotify limit of 81920. The goal is not to run the assistant out of
+ - inotify descriptors. -}
+genFuzzDir :: IO FuzzDir
+genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)
+
+data TimeStampedFuzzAction
+ = Started UTCTime FuzzAction
+ | Finished UTCTime Bool
+ deriving (Read, Show)
+
+data FuzzAction
+ = FuzzAdd FuzzFile
+ | FuzzDelete FuzzFile
+ | FuzzMove FuzzFile FuzzFile
+ | FuzzModify FuzzFile
+ | FuzzDeleteDir FuzzDir
+ | FuzzMoveDir FuzzDir FuzzDir
+ | FuzzPause Delay
+ deriving (Read, Show, Eq)
+
+instance Arbitrary FuzzAction where
+ arbitrary = frequency
+ [ (50, FuzzAdd <$> arbitrary)
+ , (50, FuzzDelete <$> arbitrary)
+ , (10, FuzzMove <$> arbitrary <*> arbitrary)
+ , (10, FuzzModify <$> arbitrary)
+ , (10, FuzzDeleteDir <$> arbitrary)
+ , (10, FuzzMoveDir <$> arbitrary <*> arbitrary)
+ , (10, FuzzPause <$> arbitrary)
+ ]
+
+runFuzzAction :: FuzzAction -> Annex ()
+runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do
+ createDirectoryIfMissing True $ parentDir f
+ n <- getStdRandom random :: IO Int
+ writeFile f $ show n ++ "\n"
+runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f
+runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
+ rename src dest
+runFuzzAction (FuzzModify (FuzzFile f)) = whenM isDirect $ liftIO $ do
+ n <- getStdRandom random :: IO Int
+ appendFile f $ show n ++ "\n"
+runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
+ removeDirectoryRecursive d
+runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
+ rename src dest
+runFuzzAction (FuzzPause d) = randomDelay d
+
+genFuzzAction :: Annex FuzzAction
+genFuzzAction = do
+ tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)
+ -- Fix up template action to make sense in the current repo tree.
+ case tmpl of
+ FuzzAdd _ -> do
+ f <- liftIO newFile
+ maybe genFuzzAction (return . FuzzAdd) f
+ FuzzDelete _ -> do
+ f <- liftIO $ existingFile 0 ""
+ maybe genFuzzAction (return . FuzzDelete) f
+ FuzzMove _ _ -> do
+ src <- liftIO $ existingFile 0 ""
+ dest <- liftIO newFile
+ case (src, dest) of
+ (Just s, Just d) -> return $ FuzzMove s d
+ _ -> genFuzzAction
+ FuzzMoveDir _ _ -> do
+ md <- liftIO existingDir
+ case md of
+ Nothing -> genFuzzAction
+ Just d -> do
+ newd <- liftIO $ newDir (parentDir $ toFilePath d)
+ maybe genFuzzAction (return . FuzzMoveDir d) newd
+ FuzzDeleteDir _ -> do
+ d <- liftIO existingDir
+ maybe genFuzzAction (return . FuzzDeleteDir) d
+ FuzzModify _ -> do
+ f <- liftIO $ existingFile 0 ""
+ maybe genFuzzAction (return . FuzzModify) f
+ FuzzPause _ -> return tmpl
+
+existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
+existingFile 0 _ = return Nothing
+existingFile n top = do
+ dir <- existingDirIncludingTop
+ contents <- catchDefaultIO [] (getDirectoryContents dir)
+ let files = filter isFuzzFile contents
+ if null files
+ then do
+ let dirs = filter isFuzzDir contents
+ if null dirs
+ then return Nothing
+ else do
+ i <- getStdRandom $ randomR (0, length dirs - 1)
+ existingFile (n - 1) (top </> dirs !! i)
+ else do
+ i <- getStdRandom $ randomR (0, length files - 1)
+ return $ Just $ FuzzFile $ top </> dir </> files !! i
+
+existingDirIncludingTop :: IO FilePath
+existingDirIncludingTop = do
+ dirs <- filter isFuzzDir <$> getDirectoryContents "."
+ if null dirs
+ then return "."
+ else do
+ n <- getStdRandom $ randomR (0, length dirs)
+ return $ ("." : dirs) !! n
+
+existingDir :: IO (Maybe FuzzDir)
+existingDir = do
+ d <- existingDirIncludingTop
+ return $ if isFuzzDir d
+ then Just $ FuzzDir d
+ else Nothing
+
+newFile :: IO (Maybe FuzzFile)
+newFile = go (100 :: Int)
+ where
+ go 0 = return Nothing
+ go n = do
+ f <- genFuzzFile
+ ifM (doesnotexist (toFilePath f))
+ ( return $ Just f
+ , go (n - 1)
+ )
+
+newDir :: FilePath -> IO (Maybe FuzzDir)
+newDir parent = go (100 :: Int)
+ where
+ go 0 = return Nothing
+ go n = do
+ (FuzzDir d) <- genFuzzDir
+ ifM (doesnotexist (parent </> d))
+ ( return $ Just $ FuzzDir d
+ , go (n - 1)
+ )
+
+doesnotexist :: FilePath -> IO Bool
+doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f)
diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs
new file mode 100644
index 000000000..2448467fd
--- /dev/null
+++ b/Command/GCryptSetup.hs
@@ -0,0 +1,39 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.GCryptSetup where
+
+import Common.Annex
+import Command
+import Annex.UUID
+import qualified Remote.GCrypt
+import qualified Git
+
+def :: [Command]
+def = [dontCheck repoExists $ noCommit $
+ command "gcryptsetup" paramValue seek
+ SectionPlumbing "sets up gcrypt repository"]
+
+seek :: CommandSeek
+seek = withStrings start
+
+start :: String -> CommandStart
+start gcryptid = next $ next $ do
+ u <- getUUID
+ when (u /= NoUUID) $
+ error "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
+
+ g <- gitRepo
+ gu <- Remote.GCrypt.getGCryptUUID True g
+ let newgu = genUUIDInNameSpace gCryptNameSpaceĀ gcryptid
+ if gu == Nothing || gu == Just newgu
+ then if Git.repoIsLocalBare g
+ then do
+ void $ Remote.GCrypt.setupRepo gcryptid g
+ return True
+ else error "cannot use gcrypt in a non-bare repository"
+ else error "gcryptsetup uuid mismatch"
diff --git a/Command/Get.hs b/Command/Get.hs
new file mode 100644
index 000000000..bef466724
--- /dev/null
+++ b/Command/Get.hs
@@ -0,0 +1,92 @@
+{- git-annex command
+ -
+ - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Get where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Annex.Content
+import Annex.Transfer
+import Config.NumCopies
+import Annex.Wanted
+import qualified Command.Move
+
+def :: [Command]
+def = [withOptions getOptions $ command "get" paramPaths seek
+ SectionCommon "make content of annexed files available"]
+
+getOptions :: [Option]
+getOptions = fromOption : keyOptions
+
+seek :: CommandSeek
+seek ps = do
+ from <- getOptionField fromOption Remote.byNameWithUUID
+ withKeyOptions
+ (startKeys from)
+ (withFilesInGit $ whenAnnexed $ start from)
+ ps
+
+start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start from file (key, _) = start' expensivecheck from key (Just file)
+ where
+ expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file))
+
+startKeys :: Maybe Remote -> Key -> CommandStart
+startKeys from key = start' (return True) from key Nothing
+
+start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart
+start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $
+ stopUnless expensivecheck $
+ case from of
+ Nothing -> go $ perform key afile
+ Just src ->
+ stopUnless (Command.Move.fromOk src key) $
+ go $ Command.Move.fromPerform src False key afile
+ where
+ go a = do
+ showStart' "get" key afile
+ next a
+
+perform :: Key -> AssociatedFile -> CommandPerform
+perform key afile = stopUnless (getViaTmp key $ getKeyFile key afile) $
+ next $ return True -- no cleanup needed
+
+{- Try to find a copy of the file in one of the remotes,
+ - and copy it to here. -}
+getKeyFile :: Key -> AssociatedFile -> FilePath -> Annex Bool
+getKeyFile key afile dest = getKeyFile' key afile dest
+ =<< Remote.keyPossibilities key
+
+getKeyFile' :: Key -> AssociatedFile -> FilePath -> [Remote] -> Annex Bool
+getKeyFile' key afile dest = dispatch
+ where
+ dispatch [] = do
+ showNote "not available"
+ showlocs
+ return False
+ dispatch remotes = notifyTransfer Download afile $ trycopy remotes remotes
+ trycopy full [] _ = do
+ Remote.showTriedRemotes full
+ showlocs
+ return False
+ trycopy full (r:rs) witness =
+ ifM (probablyPresent r)
+ ( docopy r witness <||> trycopy full rs witness
+ , trycopy full rs witness
+ )
+ showlocs = Remote.showLocations key []
+ "No other repository is known to contain the file."
+ -- This check is to avoid an ugly message if a remote is a
+ -- drive that is not mounted.
+ probablyPresent r
+ | Remote.hasKeyCheap r =
+ either (const False) id <$> Remote.hasKey r key
+ | otherwise = return True
+ docopy r = download (Remote.uuid r) key afile noRetry $ \p -> do
+ showAction $ "from " ++ Remote.name r
+ Remote.retrieveKeyFile r key afile dest p
diff --git a/Command/Group.hs b/Command/Group.hs
new file mode 100644
index 000000000..b0dbc1465
--- /dev/null
+++ b/Command/Group.hs
@@ -0,0 +1,35 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Group where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Group
+import Types.Group
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "group" (paramPair paramRemote paramDesc) seek
+ SectionSetup "add a repository to a group"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start (name:g:[]) = do
+ showStart "group" name
+ u <- Remote.nameToUUID name
+ next $ perform u g
+start _ = error "Specify a repository and a group."
+
+perform :: UUID -> Group -> CommandPerform
+perform uuid g = do
+ groupChange uuid (S.insert g)
+ next $ return True
diff --git a/Command/Help.hs b/Command/Help.hs
new file mode 100644
index 000000000..7998ed796
--- /dev/null
+++ b/Command/Help.hs
@@ -0,0 +1,65 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Help where
+
+import Common.Annex
+import Command
+import qualified Command.Init
+import qualified Command.Add
+import qualified Command.Drop
+import qualified Command.Get
+import qualified Command.Move
+import qualified Command.Copy
+import qualified Command.Sync
+import qualified Command.Whereis
+import qualified Command.Fsck
+
+import System.Console.GetOpt
+
+def :: [Command]
+def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
+ command "help" paramNothing seek SectionQuery "display help"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start params = do
+ liftIO $ start' params
+ stop
+
+startNoRepo :: CmdParams -> IO ()
+startNoRepo = start'
+
+start' :: [String] -> IO ()
+start' ["options"] = showCommonOptions
+start' _ = showGeneralHelp
+
+showCommonOptions :: IO ()
+showCommonOptions = putStrLn $ usageInfo "Common options:" gitAnnexOptions
+
+showGeneralHelp :: IO ()
+showGeneralHelp = putStrLn $ unlines
+ [ "The most frequently used git-annex commands are:"
+ , unlines $ map cmdline $ concat
+ [ Command.Init.def
+ , Command.Add.def
+ , Command.Drop.def
+ , Command.Get.def
+ , Command.Move.def
+ , Command.Copy.def
+ , Command.Sync.def
+ , Command.Whereis.def
+ , Command.Fsck.def
+ ]
+ , "Run 'git-annex' for a complete command list."
+ , "Run 'git-annex command --help' for help on a specific command."
+ , "Run `git annex help options' for a list of common options."
+ ]
+ where
+ cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c
diff --git a/Command/Import.hs b/Command/Import.hs
new file mode 100644
index 000000000..db3601a1b
--- /dev/null
+++ b/Command/Import.hs
@@ -0,0 +1,115 @@
+{- git-annex command
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Import where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Command.Add
+import Utility.CopyFile
+import Backend
+import Remote
+import Types.KeySource
+
+def :: [Command]
+def = [withOptions opts $ notBareRepo $ command "import" paramPaths seek
+ SectionCommon "move and add files from outside git working copy"]
+
+opts :: [Option]
+opts =
+ [ duplicateOption
+ , deduplicateOption
+ , cleanDuplicatesOption
+ , skipDuplicatesOption
+ ]
+
+duplicateOption :: Option
+duplicateOption = flagOption [] "duplicate" "do not delete source files"
+
+deduplicateOption :: Option
+deduplicateOption = flagOption [] "deduplicate" "delete source files whose content was imported before"
+
+cleanDuplicatesOption :: Option
+cleanDuplicatesOption = flagOption [] "clean-duplicates" "delete duplicate source files (import nothing)"
+
+skipDuplicatesOption :: Option
+skipDuplicatesOption = flagOption [] "skip-duplicates" "import only new files"
+
+data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates
+ deriving (Eq)
+
+getDuplicateMode :: Annex DuplicateMode
+getDuplicateMode = gen
+ <$> getflag duplicateOption
+ <*> getflag deduplicateOption
+ <*> getflag cleanDuplicatesOption
+ <*> getflag skipDuplicatesOption
+ where
+ getflag = Annex.getFlag . optionName
+ gen False False False False = Default
+ gen True False False False = Duplicate
+ gen False True False False = DeDuplicate
+ gen False False True False = CleanDuplicates
+ gen False False False True = SkipDuplicates
+ gen _ _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates, --skip-duplicates"
+
+seek :: CommandSeek
+seek ps = do
+ mode <- getDuplicateMode
+ withPathContents (start mode) ps
+
+start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart
+start mode (srcfile, destfile) =
+ ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
+ ( do
+ isdup <- do
+ backend <- chooseBackend destfile
+ let ks = KeySource srcfile srcfile Nothing
+ v <- genKey ks backend
+ case v of
+ Just (k, _) -> not . null <$> keyLocations k
+ _ -> return False
+ case pickaction isdup of
+ Nothing -> stop
+ Just a -> do
+ showStart "import" destfile
+ next a
+ , stop
+ )
+ where
+ deletedup = do
+ showNote "duplicate"
+ liftIO $ removeFile srcfile
+ next $ return True
+ importfile = do
+ handleexisting =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)
+ liftIO $ createDirectoryIfMissing True (parentDir destfile)
+ liftIO $ if mode == Duplicate || mode == SkipDuplicates
+ then void $ copyFileExternal srcfile destfile
+ else moveFile srcfile destfile
+ Command.Add.perform destfile
+ handleexisting Nothing = noop
+ handleexisting (Just s)
+ | isDirectory s = notoverwriting "(is a directory)"
+ | otherwise = ifM (Annex.getState Annex.force) $
+ ( liftIO $ nukeFile destfile
+ , notoverwriting "(use --force to override)"
+ )
+ notoverwriting why = error $ "not overwriting existing " ++ destfile ++ " " ++ why
+ pickaction isdup = case mode of
+ DeDuplicate
+ | isdup -> Just deletedup
+ | otherwise -> Just importfile
+ CleanDuplicates
+ | isdup -> Just deletedup
+ | otherwise -> Nothing
+ SkipDuplicates
+ | isdup -> Nothing
+ | otherwise -> Just importfile
+ _ -> Just importfile
+
diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs
new file mode 100644
index 000000000..50f4278b6
--- /dev/null
+++ b/Command/ImportFeed.hs
@@ -0,0 +1,257 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.ImportFeed where
+
+import Text.Feed.Import
+import Text.Feed.Query
+import Text.Feed.Types
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Time.Clock
+
+import Common.Annex
+import qualified Annex
+import Command
+import qualified Annex.Url as Url
+import Logs.Web
+import qualified Utility.Format
+import Utility.Tmp
+import Command.AddUrl (addUrlFile, relaxedOption)
+import Annex.Perms
+import Backend.URL (fromUrl)
+#ifdef WITH_QUVI
+import Annex.Quvi
+import qualified Utility.Quvi as Quvi
+import Command.AddUrl (addUrlFileQuvi)
+#endif
+
+def :: [Command]
+def = [notBareRepo $ withOptions [templateOption, relaxedOption] $
+ command "importfeed" (paramRepeating paramUrl) seek
+ SectionCommon "import files from podcast feeds"]
+
+templateOption :: Option
+templateOption = fieldOption [] "template" paramFormat "template for filenames"
+
+seek :: CommandSeek
+seek ps = do
+ tmpl <- getOptionField templateOption return
+ relaxed <- getOptionFlag relaxedOption
+ cache <- getCache tmpl
+ withStrings (start relaxed cache) ps
+
+start :: Bool -> Cache -> URLString -> CommandStart
+start relaxed cache url = do
+ showStart "importfeed" url
+ next $ perform relaxed cache url
+
+perform :: Bool -> Cache -> URLString -> CommandPerform
+perform relaxed cache url = do
+ v <- findDownloads url
+ case v of
+ [] -> do
+ feedProblem url "bad feed content"
+ next $ return True
+ l -> do
+ ok <- and <$> mapM (performDownload relaxed cache) l
+ unless ok $
+ feedProblem url "problem downloading item"
+ next $ cleanup url True
+
+cleanup :: URLString -> Bool -> CommandCleanup
+cleanup url ok = do
+ when ok $
+ clearFeedProblem url
+ return ok
+
+data ToDownload = ToDownload
+ { feed :: Feed
+ , feedurl :: URLString
+ , item :: Item
+ , location :: DownloadLocation
+ }
+
+data DownloadLocation = Enclosure URLString | QuviLink URLString
+
+data Cache = Cache
+ { knownurls :: S.Set URLString
+ , template :: Utility.Format.Format
+ }
+
+getCache :: Maybe String -> Annex Cache
+getCache opttemplate = ifM (Annex.getState Annex.force)
+ ( ret S.empty
+ , do
+ showSideAction "checking known urls"
+ ret =<< S.fromList <$> knownUrls
+ )
+ where
+ tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate
+ ret s = return $ Cache s tmpl
+
+findDownloads :: URLString -> Annex [ToDownload]
+findDownloads u = go =<< downloadFeed u
+ where
+ go Nothing = pure []
+ go (Just f) = catMaybes <$> mapM (mk f) (feedItems f)
+
+ mk f i = case getItemEnclosure i of
+ Just (enclosureurl, _, _) -> return $
+ Just $ ToDownload f u i $ Enclosure enclosureurl
+ Nothing -> mkquvi f i
+#ifdef WITH_QUVI
+ mkquvi f i = case getItemLink i of
+ Just link -> ifM (quviSupported link)
+ ( return $ Just $ ToDownload f u i $ QuviLink link
+ , return Nothing
+ )
+ Nothing -> return Nothing
+#else
+ mkquvi = return Nothing
+#endif
+
+{- Feeds change, so a feed download cannot be resumed. -}
+downloadFeed :: URLString -> Annex (Maybe Feed)
+downloadFeed url = do
+ showOutput
+ uo <- Url.getUrlOptions
+ liftIO $ withTmpFile "feed" $ \f h -> do
+ fileEncoding h
+ ifM (Url.download url f uo)
+ ( parseFeedString <$> hGetContentsStrict h
+ , return Nothing
+ )
+
+performDownload :: Bool -> Cache -> ToDownload -> Annex Bool
+performDownload relaxed cache todownload = case location todownload of
+ Enclosure url -> checkknown url $
+ rundownload url (takeExtension url) $
+ addUrlFile relaxed url
+ QuviLink pageurl -> do
+ let quviurl = setDownloader pageurl QuviDownloader
+ checkknown quviurl $ do
+ mp <- withQuviOptions Quvi.query [Quvi.quiet, Quvi.httponly] pageurl
+ case mp of
+ Nothing -> return False
+ Just page -> case headMaybe $ Quvi.pageLinks page of
+ Nothing -> return False
+ Just link -> do
+ let videourl = Quvi.linkUrl link
+ checkknown videourl $
+ rundownload videourl ("." ++ Quvi.linkSuffix link) $
+ addUrlFileQuvi relaxed quviurl videourl
+ where
+ forced = Annex.getState Annex.force
+
+ {- Avoids downloading any urls that are already known to be
+ - associated with a file in the annex, unless forced. -}
+ checkknown url a
+ | S.member url (knownurls cache) = ifM forced (a, return True)
+ | otherwise = a
+
+ rundownload url extension getter = do
+ dest <- makeunique url (1 :: Integer) $
+ feedFile (template cache) todownload extension
+ case dest of
+ Nothing -> return True
+ Just f -> do
+ showStart "addurl" f
+ ok <- getter f
+ if ok
+ then do
+ showEndOk
+ return True
+ else do
+ showEndFail
+ checkFeedBroken (feedurl todownload)
+
+ {- Find a unique filename to save the url to.
+ - If the file exists, prefixes it with a number.
+ - When forced, the file may already exist and have the same
+ - url, in which case Nothing is returned as it does not need
+ - to be re-downloaded. -}
+ makeunique url n file = ifM alreadyexists
+ ( ifM forced
+ ( ifAnnexed f checksameurl tryanother
+ , tryanother
+ )
+ , return $ Just f
+ )
+ where
+ f = if n < 2
+ then file
+ else
+ let (d, base) = splitFileName file
+ in d </> show n ++ "_" ++ base
+ tryanother = makeunique url (n + 1) file
+ alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f)
+ checksameurl (k, _) = ifM (elem url <$> getUrls k)
+ ( return Nothing
+ , tryanother
+ )
+
+defaultTemplate :: String
+defaultTemplate = "${feedtitle}/${itemtitle}${extension}"
+
+{- Generates a filename to use for a feed item by filling out the template.
+ - The filename may not be unique. -}
+feedFile :: Utility.Format.Format -> ToDownload -> String -> FilePath
+feedFile tmpl i extension = Utility.Format.format tmpl $ M.fromList
+ [ field "feedtitle" $ getFeedTitle $ feed i
+ , fieldMaybe "itemtitle" $ getItemTitle $ item i
+ , fieldMaybe "feedauthor" $ getFeedAuthor $ feed i
+ , fieldMaybe "itemauthor" $ getItemAuthor $ item i
+ , fieldMaybe "itemsummary" $ getItemSummary $ item i
+ , fieldMaybe "itemdescription" $ getItemDescription $ item i
+ , fieldMaybe "itemrights" $ getItemRights $ item i
+ , fieldMaybe "itemid" $ snd <$> getItemId (item i)
+ , ("extension", sanitizeFilePath extension)
+ ]
+ where
+ field k v =
+ let s = sanitizeFilePath v in
+ if null s then (k, "none") else (k, s)
+ fieldMaybe k Nothing = (k, "none")
+ fieldMaybe k (Just v) = field k v
+
+{- Called when there is a problem with a feed.
+ - Throws an error if the feed is broken, otherwise shows a warning. -}
+feedProblem :: URLString -> String -> Annex ()
+feedProblem url message = ifM (checkFeedBroken url)
+ ( error $ message ++ " (having repeated problems with this feed!)"
+ , warning $ "warning: " ++ message
+ )
+
+{- A feed is only broken if problems have occurred repeatedly, for at
+ - least 23 hours. -}
+checkFeedBroken :: URLString -> Annex Bool
+checkFeedBroken url = checkFeedBroken' url =<< feedState url
+checkFeedBroken' :: URLString -> FilePath -> Annex Bool
+checkFeedBroken' url f = do
+ prev <- maybe Nothing readish <$> liftIO (catchMaybeIO $ readFile f)
+ now <- liftIO getCurrentTime
+ case prev of
+ Nothing -> do
+ createAnnexDirectory (parentDir f)
+ liftIO $ writeFile f $ show now
+ return False
+ Just prevtime -> do
+ let broken = diffUTCTime now prevtime > 60 * 60 * 23
+ when broken $
+ -- Avoid repeatedly complaining about
+ -- broken feed.
+ clearFeedProblem url
+ return broken
+
+clearFeedProblem :: URLString -> Annex ()
+clearFeedProblem url = void $ liftIO . tryIO . removeFile =<< feedState url
+
+feedState :: URLString -> Annex FilePath
+feedState url = fromRepo . gitAnnexFeedState =<< fromUrl url Nothing
diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs
new file mode 100644
index 000000000..11cbdb73d
--- /dev/null
+++ b/Command/InAnnex.hs
@@ -0,0 +1,27 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.InAnnex where
+
+import Common.Annex
+import Command
+import Annex.Content
+
+def :: [Command]
+def = [noCommit $ command "inannex" (paramRepeating paramKey) seek
+ SectionPlumbing "checks if keys are present in the annex"]
+
+seek :: CommandSeek
+seek = withKeys start
+
+start :: Key -> CommandStart
+start key = inAnnexSafe key >>= dispatch
+ where
+ dispatch (Just True) = stop
+ dispatch (Just False) = exit 1
+ dispatch Nothing = exit 100
+ exit n = liftIO $ exitWith $ ExitFailure n
diff --git a/Command/Indirect.hs b/Command/Indirect.hs
new file mode 100644
index 000000000..c0dd57959
--- /dev/null
+++ b/Command/Indirect.hs
@@ -0,0 +1,110 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Indirect where
+
+import Control.Exception.Extensible
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Git.LsFiles
+import Git.FileMode
+import Config
+import qualified Annex
+import Annex.Direct
+import Annex.Content
+import Annex.Content.Direct
+import Annex.CatFile
+import Annex.Exception
+import Annex.Init
+import qualified Command.Add
+
+def :: [Command]
+def = [notBareRepo $ noDaemonRunning $
+ command "indirect" paramNothing seek
+ SectionSetup "switch repository to indirect mode"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = ifM isDirect
+ ( do
+ unlessM (coreSymlinks <$> Annex.getGitConfig) $
+ error "Git is configured to not use symlinks, so you must use direct mode."
+ whenM probeCrippledFileSystem $
+ error "This repository seems to be on a crippled filesystem, you must use direct mode."
+ next perform
+ , stop
+ )
+
+perform :: CommandPerform
+perform = do
+ showStart "commit" ""
+ whenM stageDirect $ do
+ showOutput
+ void $ inRepo $ Git.Command.runBool
+ [ Param "commit"
+ , Param "-m"
+ , Param "commit before switching to indirect mode"
+ ]
+ showEndOk
+
+ -- Note that we set indirect mode early, so that we can use
+ -- moveAnnex in indirect mode.
+ setDirect False
+
+ top <- fromRepo Git.repoPath
+ (l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
+ forM_ l go
+ void $ liftIO clean
+ next cleanup
+ where
+ {- Walk tree from top and move all present direct mode files into
+ - the annex, replacing with symlinks. Also delete direct mode
+ - caches and mappings. -}
+ go (f, Just sha, Just mode) | isSymLink mode = do
+ r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
+ case r of
+ Just s
+ | isSymbolicLink s -> void $ flip whenAnnexed f $
+ \_ (k, _) -> do
+ removeInodeCache k
+ removeAssociatedFiles k
+ return Nothing
+ | otherwise ->
+ maybe noop (fromdirect f)
+ =<< catKey sha mode
+ _ -> noop
+ go _ = noop
+
+ fromdirect f k = do
+ showStart "indirect" f
+ removeInodeCache k
+ removeAssociatedFiles k
+ whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
+ v <-tryAnnexIO (moveAnnex k f)
+ case v of
+ Right _ -> do
+ l <- inRepo $ gitAnnexLink f k
+ liftIO $ createSymbolicLink l f
+ Left e -> catchAnnex (Command.Add.undo f k e)
+ warnlocked
+ showEndOk
+
+ warnlocked :: SomeException -> Annex ()
+ warnlocked e = do
+ warning $ show e
+ warning "leaving this file as-is; correct this problem and run git annex add on it"
+
+cleanup :: CommandCleanup
+cleanup = do
+ showStart "indirect" ""
+ showEndOk
+ return True
diff --git a/Command/Info.hs b/Command/Info.hs
new file mode 100644
index 000000000..11ed98cd9
--- /dev/null
+++ b/Command/Info.hs
@@ -0,0 +1,385 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Command.Info where
+
+import "mtl" Control.Monad.State.Strict
+import qualified Data.Map as M
+import Text.JSON
+import Data.Tuple
+import Data.Ord
+
+import Common.Annex
+import qualified Remote
+import qualified Command.Unused
+import qualified Git
+import qualified Annex
+import Command
+import Utility.DataUnits
+import Utility.DiskFree
+import Annex.Content
+import Types.Key
+import Logs.UUID
+import Logs.Trust
+import Config.NumCopies
+import Remote
+import Config
+import Utility.Percentage
+import Logs.Transfer
+import Types.TrustLevel
+import Types.FileMatcher
+import qualified Limit
+
+-- a named computation that produces a statistic
+type Stat = StatState (Maybe (String, StatState String))
+
+-- data about a set of keys
+data KeyData = KeyData
+ { countKeys :: Integer
+ , sizeKeys :: Integer
+ , unknownSizeKeys :: Integer
+ , backendsKeys :: M.Map String Integer
+ }
+
+data NumCopiesStats = NumCopiesStats
+ { numCopiesVarianceMap :: M.Map Variance Integer
+ }
+
+newtype Variance = Variance Int
+ deriving (Eq, Ord)
+
+instance Show Variance where
+ show (Variance n)
+ | n >= 0 = "numcopies +" ++ show n
+ | otherwise = "numcopies " ++ show n
+
+-- cached info that multiple Stats use
+data StatInfo = StatInfo
+ { presentData :: Maybe KeyData
+ , referencedData :: Maybe KeyData
+ , numCopiesStats :: Maybe NumCopiesStats
+ }
+
+-- a state monad for running Stats in
+type StatState = StateT StatInfo Annex
+
+def :: [Command]
+def = [noCommit $ withOptions [jsonOption] $
+ command "info" paramPaths seek SectionQuery
+ "shows general information about the annex"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [FilePath] -> CommandStart
+start [] = do
+ globalInfo
+ stop
+start ps = do
+ mapM_ localInfo =<< filterM isdir ps
+ stop
+ where
+ isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
+
+globalInfo :: Annex ()
+globalInfo = do
+ stats <- selStats global_fast_stats global_slow_stats
+ showCustom "info" $ do
+ evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
+ return True
+
+localInfo :: FilePath -> Annex ()
+localInfo dir = showCustom (unwords ["info", dir]) $ do
+ stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
+ evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
+ return True
+ where
+ tostats = map (\s -> s dir)
+
+selStats :: [Stat] -> [Stat] -> Annex [Stat]
+selStats fast_stats slow_stats = do
+ fast <- Annex.getState Annex.fast
+ return $ if fast
+ then fast_stats
+ else fast_stats ++ slow_stats
+
+{- Order is significant. Less expensive operations, and operations
+ - that share data go together.
+ -}
+global_fast_stats :: [Stat]
+global_fast_stats =
+ [ repository_mode
+ , remote_list Trusted
+ , remote_list SemiTrusted
+ , remote_list UnTrusted
+ , transfer_list
+ , disk_size
+ ]
+global_slow_stats :: [Stat]
+global_slow_stats =
+ [ tmp_size
+ , bad_data_size
+ , local_annex_keys
+ , local_annex_size
+ , known_annex_files
+ , known_annex_size
+ , bloom_info
+ , backend_usage
+ ]
+local_fast_stats :: [FilePath -> Stat]
+local_fast_stats =
+ [ local_dir
+ , const local_annex_keys
+ , const local_annex_size
+ , const known_annex_files
+ , const known_annex_size
+ ]
+local_slow_stats :: [FilePath -> Stat]
+local_slow_stats =
+ [ const numcopies_stats
+ ]
+
+stat :: String -> (String -> StatState String) -> Stat
+stat desc a = return $ Just (desc, a desc)
+
+nostat :: Stat
+nostat = return Nothing
+
+json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
+json serialize a desc = do
+ j <- a
+ lift $ maybeShowJSON [(desc, j)]
+ return $ serialize j
+
+nojson :: StatState String -> String -> StatState String
+nojson a _ = a
+
+showStat :: Stat -> StatState ()
+showStat s = maybe noop calc =<< s
+ where
+ calc (desc, a) = do
+ (lift . showHeader) desc
+ lift . showRaw =<< a
+
+repository_mode :: Stat
+repository_mode = stat "repository mode" $ json id $ lift $
+ ifM isDirect
+ ( return "direct", return "indirect" )
+
+remote_list :: TrustLevel -> Stat
+remote_list level = stat n $ nojson $ lift $ do
+ us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
+ rs <- fst <$> trustPartition level us
+ s <- prettyPrintUUIDs n rs
+ return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
+ where
+ n = showTrustLevel level ++ " repositories"
+
+local_dir :: FilePath -> Stat
+local_dir dir = stat "directory" $ json id $ return dir
+
+local_annex_keys :: Stat
+local_annex_keys = stat "local annex keys" $ json show $
+ countKeys <$> cachedPresentData
+
+local_annex_size :: Stat
+local_annex_size = stat "local annex size" $ json id $
+ showSizeKeys <$> cachedPresentData
+
+known_annex_files :: Stat
+known_annex_files = stat "annexed files in working tree" $ json show $
+ countKeys <$> cachedReferencedData
+
+known_annex_size :: Stat
+known_annex_size = stat "size of annexed files in working tree" $ json id $
+ showSizeKeys <$> cachedReferencedData
+
+tmp_size :: Stat
+tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir
+
+bad_data_size :: Stat
+bad_data_size = staleSize "bad keys size" gitAnnexBadDir
+
+bloom_info :: Stat
+bloom_info = stat "bloom filter size" $ json id $ do
+ localkeys <- countKeys <$> cachedPresentData
+ capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
+ let note = aside $
+ if localkeys >= capacity
+ then "appears too small for this repository; adjust annex.bloomcapacity"
+ else showPercentage 1 (percentage capacity localkeys) ++ " full"
+
+ -- Two bloom filters are used at the same time, so double the size
+ -- of one.
+ size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
+ lift Command.Unused.bloomBitsHashes
+
+ return $ size ++ note
+
+transfer_list :: Stat
+transfer_list = stat "transfers in progress" $ nojson $ lift $ do
+ uuidmap <- Remote.remoteMap id
+ ts <- getTransfers
+ return $ if null ts
+ then "none"
+ else multiLine $
+ map (uncurry $ line uuidmap) $ sort ts
+ where
+ line uuidmap t i = unwords
+ [ showLcDirection (transferDirection t) ++ "ing"
+ , fromMaybe (key2file $ transferKey t) (associatedFile i)
+ , if transferDirection t == Upload then "to" else "from"
+ , maybe (fromUUID $ transferUUID t) Remote.name $
+ M.lookup (transferUUID t) uuidmap
+ ]
+
+disk_size :: Stat
+disk_size = stat "available local disk space" $ json id $ lift $
+ calcfree
+ <$> (annexDiskReserve <$> Annex.getGitConfig)
+ <*> inRepo (getDiskFree . gitAnnexDir)
+ where
+ calcfree reserve (Just have) = unwords
+ [ roughSize storageUnits False $ nonneg $ have - reserve
+ , "(+" ++ roughSize storageUnits False reserve
+ , "reserved)"
+ ]
+ calcfree _ _ = "unknown"
+
+ nonneg x
+ | x >= 0 = x
+ | otherwise = 0
+
+backend_usage :: Stat
+backend_usage = stat "backend usage" $ nojson $
+ calc
+ <$> (backendsKeys <$> cachedReferencedData)
+ <*> (backendsKeys <$> cachedPresentData)
+ where
+ calc x y = multiLine $
+ map (\(n, b) -> b ++ ": " ++ show n) $
+ reverse $ sort $ map swap $ M.toList $
+ M.unionWith (+) x y
+
+numcopies_stats :: Stat
+numcopies_stats = stat "numcopies stats" $ nojson $
+ calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
+ where
+ calc = multiLine
+ . map (\(variance, count) -> show variance ++ ": " ++ show count)
+ . reverse . sortBy (comparing snd) . M.toList
+
+cachedPresentData :: StatState KeyData
+cachedPresentData = do
+ s <- get
+ case presentData s of
+ Just v -> return v
+ Nothing -> do
+ v <- foldKeys <$> lift (getKeysPresent InRepository)
+ put s { presentData = Just v }
+ return v
+
+cachedReferencedData :: StatState KeyData
+cachedReferencedData = do
+ s <- get
+ case referencedData s of
+ Just v -> return v
+ Nothing -> do
+ !v <- lift $ Command.Unused.withKeysReferenced
+ emptyKeyData addKey
+ put s { referencedData = Just v }
+ return v
+
+-- currently only available for local info
+cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
+cachedNumCopiesStats = numCopiesStats <$> get
+
+getLocalStatInfo :: FilePath -> Annex StatInfo
+getLocalStatInfo dir = do
+ fast <- Annex.getState Annex.fast
+ matcher <- Limit.getMatcher
+ (presentdata, referenceddata, numcopiesstats) <-
+ Command.Unused.withKeysFilesReferencedIn dir initial
+ (update matcher fast)
+ return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats)
+ where
+ initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
+ update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
+ ifM (matcher $ MatchingFile $ FileInfo file file)
+ ( do
+ !presentdata' <- ifM (inAnnex key)
+ ( return $ addKey key presentdata
+ , return presentdata
+ )
+ let !referenceddata' = addKey key referenceddata
+ !numcopiesstats' <- if fast
+ then return numcopiesstats
+ else updateNumCopiesStats key file numcopiesstats
+ return $! (presentdata', referenceddata', numcopiesstats')
+ , return vs
+ )
+
+emptyKeyData :: KeyData
+emptyKeyData = KeyData 0 0 0 M.empty
+
+emptyNumCopiesStats :: NumCopiesStats
+emptyNumCopiesStats = NumCopiesStats M.empty
+
+foldKeys :: [Key] -> KeyData
+foldKeys = foldl' (flip addKey) emptyKeyData
+
+addKey :: Key -> KeyData -> KeyData
+addKey key (KeyData count size unknownsize backends) =
+ KeyData count' size' unknownsize' backends'
+ where
+ {- All calculations strict to avoid thunks when repeatedly
+ - applied to many keys. -}
+ !count' = count + 1
+ !backends' = M.insertWith' (+) (keyBackendName key) 1 backends
+ !size' = maybe size (+ size) ks
+ !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
+ ks = keySize key
+
+updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats
+updateNumCopiesStats key file (NumCopiesStats m) = do
+ !variance <- Variance <$> numCopiesCheck file key (-)
+ let !m' = M.insertWith' (+) variance 1 m
+ let !ret = NumCopiesStats m'
+ return ret
+
+showSizeKeys :: KeyData -> String
+showSizeKeys d = total ++ missingnote
+ where
+ total = roughSize storageUnits False $ sizeKeys d
+ missingnote
+ | unknownSizeKeys d == 0 = ""
+ | otherwise = aside $
+ "+ " ++ show (unknownSizeKeys d) ++
+ " unknown size"
+
+staleSize :: String -> (Git.Repo -> FilePath) -> Stat
+staleSize label dirspec = go =<< lift (dirKeys dirspec)
+ where
+ go [] = nostat
+ go keys = onsize =<< sum <$> keysizes keys
+ onsize 0 = nostat
+ onsize size = stat label $
+ json (++ aside "clean up with git-annex unused") $
+ return $ roughSize storageUnits False size
+ keysizes keys = do
+ dir <- lift $ fromRepo dirspec
+ liftIO $ forM keys $ \k -> catchDefaultIO 0 $
+ fromIntegral . fileSize
+ <$> getFileStatus (dir </> keyFile k)
+
+aside :: String -> String
+aside s = " (" ++ s ++ ")"
+
+multiLine :: [String] -> String
+multiLine = concatMap (\l -> "\n\t" ++ l)
diff --git a/Command/Init.hs b/Command/Init.hs
new file mode 100644
index 000000000..e8d9af167
--- /dev/null
+++ b/Command/Init.hs
@@ -0,0 +1,31 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Init where
+
+import Common.Annex
+import Command
+import Annex.Init
+
+def :: [Command]
+def = [dontCheck repoExists $
+ command "init" paramDesc seek SectionSetup "initialize git-annex"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start ws = do
+ showStart "init" description
+ next $ perform description
+ where
+ description = unwords ws
+
+perform :: String -> CommandPerform
+perform description = do
+ initialize $ if null description then Nothing else Just description
+ next $ return True
diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs
new file mode 100644
index 000000000..dc54023cc
--- /dev/null
+++ b/Command/InitRemote.hs
@@ -0,0 +1,98 @@
+{- git-annex command
+ -
+ - Copyright 2011,2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.InitRemote where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import qualified Remote
+import qualified Logs.Remote
+import qualified Types.Remote as R
+import Logs.UUID
+import Logs.Trust
+
+import Data.Ord
+
+def :: [Command]
+def = [command "initremote"
+ (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
+ seek SectionSetup "creates a special (non-git) remote"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = error "Specify a name for the remote."
+start (name:ws) = ifM (isJust <$> findExisting name)
+ ( error $ "There is already a special remote named \"" ++ name ++
+ "\". (Use enableremote to enable an existing special remote.)"
+ , do
+ let c = newConfig name
+ t <- findType config
+
+ showStart "initremote" name
+ next $ perform t name $ M.union config c
+ )
+ where
+ config = Logs.Remote.keyValToConfig ws
+
+perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
+perform t name c = do
+ (c', u) <- R.setup t Nothing Nothing c
+ next $ cleanup u name c'
+
+cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup
+cleanup u name c = do
+ describeUUID u name
+ Logs.Remote.configSet u c
+ return True
+
+{- See if there's an existing special remote with this name. -}
+findExisting :: String -> Annex (Maybe (UUID, R.RemoteConfig))
+findExisting name = do
+ t <- trustMap
+ matches <- sortBy (comparing $ \(u, _c) -> M.lookup u t )
+ . findByName name
+ <$> Logs.Remote.readRemoteLog
+ return $ headMaybe matches
+
+newConfig :: String -> R.RemoteConfig
+newConfig name = M.singleton nameKey name
+
+findByName :: String -> M.Map UUID R.RemoteConfig -> [(UUID, R.RemoteConfig)]
+findByName n = filter (matching . snd) . M.toList
+ where
+ matching c = case M.lookup nameKey c of
+ Nothing -> False
+ Just n'
+ | n' == n -> True
+ | otherwise -> False
+
+remoteNames :: Annex [String]
+remoteNames = do
+ m <- Logs.Remote.readRemoteLog
+ return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m
+
+{- find the specified remote type -}
+findType :: R.RemoteConfig -> Annex RemoteType
+findType config = maybe unspecified specified $ M.lookup typeKey config
+ where
+ unspecified = error "Specify the type of remote with type="
+ specified s = case filter (findtype s) Remote.remoteTypes of
+ [] -> error $ "Unknown remote type " ++ s
+ (t:_) -> return t
+ findtype s i = R.typename i == s
+
+{- The name of a configured remote is stored in its config using this key. -}
+nameKey :: String
+nameKey = "name"
+
+{- The type of a remote is stored in its config using this key. -}
+typeKey :: String
+typeKey = "type"
diff --git a/Command/List.hs b/Command/List.hs
new file mode 100644
index 000000000..1fa206405
--- /dev/null
+++ b/Command/List.hs
@@ -0,0 +1,85 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Antoine BeauprƩ
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.List where
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Function
+import Data.Tuple.Utils
+import Data.Ord
+
+import Common.Annex
+import Command
+import Remote
+import Logs.Trust
+import Logs.UUID
+import Annex.UUID
+import qualified Annex
+import Git.Types (RemoteName)
+
+def :: [Command]
+def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
+ SectionQuery "show which remotes contain files"]
+
+allrepos :: Option
+allrepos = flagOption [] "allrepos" "show all repositories, not only remotes"
+
+seek :: CommandSeek
+seek ps = do
+ list <- getList
+ printHeader list
+ withFilesInGit (whenAnnexed $ start list) ps
+
+getList :: Annex [(UUID, RemoteName, TrustLevel)]
+getList = ifM (Annex.getFlag $ optionName allrepos)
+ ( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAllUUIDs)
+ , getRemotes
+ )
+ where
+ getRemotes = do
+ rs <- remoteList
+ ts <- mapM (lookupTrust . uuid) rs
+ hereu <- getUUID
+ heretrust <- lookupTrust hereu
+ return $ (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts
+ getAllUUIDs = do
+ rs <- M.toList <$> uuidMap
+ rs3 <- forM rs $ \(u, n) -> (,,)
+ <$> pure u
+ <*> pure n
+ <*> lookupTrust u
+ return $ sortBy (comparing snd3) $
+ filter (\t -> thd3 t /= DeadTrusted) rs3
+
+printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
+printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
+
+start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart
+start l file (key, _) = do
+ ls <- S.fromList <$> keyLocations key
+ liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
+ stop
+
+type Present = Bool
+
+header :: [(RemoteName, TrustLevel)] -> String
+header remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length remotes)
+ where
+ formatheader n (remotename, trustlevel) = pipes n ++ remotename ++ trust trustlevel
+ pipes = flip replicate '|'
+ trust UnTrusted = " (untrusted)"
+ trust _ = ""
+
+format :: [(TrustLevel, Present)] -> FilePath -> String
+format remotes file = thereMap ++ " " ++ file
+ where
+ thereMap = concatMap there remotes
+ there (UnTrusted, True) = "x"
+ there (_, True) = "X"
+ there (_, False) = "_"
diff --git a/Command/Lock.hs b/Command/Lock.hs
new file mode 100644
index 000000000..e6733dcb1
--- /dev/null
+++ b/Command/Lock.hs
@@ -0,0 +1,34 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Lock where
+
+import Common.Annex
+import Command
+import qualified Annex.Queue
+import qualified Annex
+
+def :: [Command]
+def = [notDirect $ command "lock" paramPaths seek SectionCommon
+ "undo unlock command"]
+
+seek :: CommandSeek
+seek ps = do
+ withFilesUnlocked start ps
+ withFilesUnlockedToBeCommitted start ps
+
+start :: FilePath -> CommandStart
+start file = do
+ showStart "lock" file
+ unlessM (Annex.getState Annex.force) $
+ error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"
+ next $ perform file
+
+perform :: FilePath -> CommandPerform
+perform file = do
+ Annex.Queue.addCommand "checkout" [Param "--"] [file]
+ next $ return True -- no cleanup needed
diff --git a/Command/Log.hs b/Command/Log.hs
new file mode 100644
index 000000000..84583a93a
--- /dev/null
+++ b/Command/Log.hs
@@ -0,0 +1,171 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Log where
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import Data.Char
+
+import Common.Annex
+import Command
+import Logs
+import qualified Logs.Presence
+import Annex.CatFile
+import qualified Annex.Branch
+import qualified Git
+import Git.Command
+import qualified Remote
+import qualified Annex
+
+data RefChange = RefChange
+ { changetime :: POSIXTime
+ , oldref :: Git.Ref
+ , newref :: Git.Ref
+ }
+
+type Outputter = Bool -> POSIXTime -> [UUID] -> Annex ()
+
+def :: [Command]
+def = [withOptions options $
+ command "log" paramPaths seek SectionQuery "shows location log"]
+
+options :: [Option]
+options = passthruOptions ++ [gourceOption]
+
+passthruOptions :: [Option]
+passthruOptions = map odate ["since", "after", "until", "before"] ++
+ [ fieldOption ['n'] "max-count" paramNumber
+ "limit number of logs displayed"
+ ]
+ where
+ odate n = fieldOption [] n paramDate $ "show log " ++ n ++ " date"
+
+gourceOption :: Option
+gourceOption = flagOption [] "gource" "format output for gource"
+
+seek :: CommandSeek
+seek ps = do
+ m <- Remote.uuidDescriptions
+ zone <- liftIO getCurrentTimeZone
+ os <- concat <$> mapM getoption passthruOptions
+ gource <- getOptionFlag gourceOption
+ withFilesInGit (whenAnnexed $ start m zone os gource) ps
+ where
+ getoption o = maybe [] (use o) <$>
+ Annex.getField (optionName o)
+ use o v = [Param ("--" ++ optionName o), Param v]
+
+start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
+ FilePath -> (Key, Backend) -> CommandStart
+start m zone os gource file (key, _) = do
+ showLog output =<< readLog <$> getLog key os
+ -- getLog produces a zombie; reap it
+ liftIO reapZombies
+ stop
+ where
+ output
+ | gource = gourceOutput lookupdescription file
+ | otherwise = normalOutput lookupdescription file zone
+ lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m
+
+showLog :: Outputter -> [RefChange] -> Annex ()
+showLog outputter ps = do
+ sets <- mapM (getset newref) ps
+ previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)
+ sequence_ $ compareChanges outputter $ sets ++ [previous]
+ where
+ genesis = (0, S.empty)
+ getset select change = do
+ s <- S.fromList <$> get (select change)
+ return (changetime change, s)
+ get ref = map toUUID . Logs.Presence.getLog . L.unpack <$>
+ catObject ref
+
+normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter
+normalOutput lookupdescription file zone present ts us =
+ liftIO $ mapM_ (putStrLn . format) us
+ where
+ time = showTimeStamp zone ts
+ addel = if present then "+" else "-"
+ format u = unwords [ addel, time, file, "|",
+ fromUUID u ++ " -- " ++ lookupdescription u ]
+
+gourceOutput :: (UUID -> String) -> FilePath -> Outputter
+gourceOutput lookupdescription file present ts us =
+ liftIO $ mapM_ (putStrLn . intercalate "|" . format) us
+ where
+ time = takeWhile isDigit $ show ts
+ addel = if present then "A" else "M"
+ format u = [ time, lookupdescription u, addel, file ]
+
+{- Generates a display of the changes (which are ordered with newest first),
+ - by comparing each change with the previous change.
+ - Uses a formatter to generate a display of items that are added and
+ - removed. -}
+compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b]
+compareChanges format changes = concatMap diff $ zip changes (drop 1 changes)
+ where
+ diff ((ts, new), (_, old)) =
+ [format True ts added, format False ts removed]
+ where
+ added = S.toList $ S.difference new old
+ removed = S.toList $ S.difference old new
+
+{- Gets the git log for a given location log file.
+ -
+ - This is complicated by git log using paths relative to the current
+ - directory, even when looking at files in a different branch. A wacky
+ - relative path to the log file has to be used.
+ -
+ - The --remove-empty is a significant optimisation. It relies on location
+ - log files never being deleted in normal operation. Letting git stop
+ - once the location log file is gone avoids it checking all the way back
+ - to commit 0 to see if it used to exist, so generally speeds things up a
+ - *lot* for newish files. -}
+getLog :: Key -> [CommandParam] -> Annex [String]
+getLog key os = do
+ top <- fromRepo Git.repoPath
+ p <- liftIO $ relPathCwdToFile top
+ let logfile = p </> locationLogFile key
+ inRepo $ pipeNullSplitZombie $
+ [ Params "log -z --pretty=format:%ct --raw --abbrev=40"
+ , Param "--remove-empty"
+ ] ++ os ++
+ [ Param $ Git.fromRef Annex.Branch.fullname
+ , Param "--"
+ , Param logfile
+ ]
+
+readLog :: [String] -> [RefChange]
+readLog = mapMaybe (parse . lines)
+ where
+ parse (ts:raw:[]) = let (old, new) = parseRaw raw in
+ Just RefChange
+ { changetime = parseTimeStamp ts
+ , oldref = old
+ , newref = new
+ }
+ parse _ = Nothing
+
+-- Parses something like ":100644 100644 oldsha newsha M"
+parseRaw :: String -> (Git.Ref, Git.Ref)
+parseRaw l = go $ words l
+ where
+ go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha)
+ go _ = error $ "unable to parse git log output: " ++ l
+
+parseTimeStamp :: String -> POSIXTime
+parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
+ parseTime defaultTimeLocale "%s"
+
+showTimeStamp :: TimeZone -> POSIXTime -> String
+showTimeStamp zone = show . utcToLocalTime zone . posixSecondsToUTCTime
diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs
new file mode 100644
index 000000000..814c5d2d7
--- /dev/null
+++ b/Command/LookupKey.hs
@@ -0,0 +1,26 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.LookupKey where
+
+import Common.Annex
+import Command
+import Annex.CatFile
+import Types.Key
+
+def :: [Command]
+def = [notBareRepo $ noCommit $ noMessages $
+ command "lookupkey" (paramRepeating paramFile) seek
+ SectionPlumbing "looks up key used for file"]
+
+seek :: CommandSeek
+seek = withStrings start
+
+start :: String -> CommandStart
+start file = do
+ liftIO . maybe exitFailure (putStrLn . key2file) =<< catKeyFile file
+ stop
diff --git a/Command/Map.hs b/Command/Map.hs
new file mode 100644
index 000000000..7c11fb2ef
--- /dev/null
+++ b/Command/Map.hs
@@ -0,0 +1,252 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Map where
+
+import Control.Exception.Extensible
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Url
+import qualified Git.Config
+import qualified Git.Construct
+import qualified Annex
+import Annex.UUID
+import Logs.UUID
+import Logs.Trust
+import qualified Remote.Helper.Ssh as Ssh
+import qualified Utility.Dot as Dot
+
+-- a link from the first repository to the second (its remote)
+data Link = Link Git.Repo Git.Repo
+
+def :: [Command]
+def = [dontCheck repoExists $
+ command "map" paramNothing seek SectionQuery
+ "generate map of repositories"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = do
+ rs <- combineSame <$> (spider =<< gitRepo)
+
+ umap <- uuidMap
+ trusted <- trustGet Trusted
+
+ file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"
+
+ liftIO $ writeFile file (drawMap rs umap trusted)
+ next $ next $
+ ifM (Annex.getState Annex.fast)
+ ( return True
+ , do
+ showLongNote $ "running: dot -Tx11 " ++ file
+ showOutput
+ liftIO $ boolSystem "dot" [Param "-Tx11", File file]
+ )
+
+{- Generates a graph for dot(1). Each repository, and any other uuids, are
+ - displayed as a node, and each of its remotes is represented as an edge
+ - pointing at the node for the remote.
+ -
+ - The order nodes are added to the graph matters, since dot will draw
+ - the first ones near to the top and left. So it looks better to put
+ - the repositories first, followed by uuids that were not matched
+ - to a repository.
+ -}
+drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String
+drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
+ where
+ repos = map (node umap rs) rs
+ ruuids = ts ++ map getUncachedUUID rs
+ others = map (unreachable . uuidnode) $
+ filter (`notElem` ruuids) (M.keys umap)
+ trusted = map (trustworthy . uuidnode) ts
+ uuidnode u = Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap
+
+hostname :: Git.Repo -> String
+hostname r
+ | Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r)
+ | otherwise = "localhost"
+
+basehostname :: Git.Repo -> String
+basehostname r = fromMaybe "" $ headMaybe $ split "." $ hostname r
+
+{- A name to display for a repo. Uses the name from uuid.log if available,
+ - or the remote name if not. -}
+repoName :: M.Map UUID String -> Git.Repo -> String
+repoName umap r
+ | repouuid == NoUUID = fallback
+ | otherwise = M.findWithDefault fallback repouuid umap
+ where
+ repouuid = getUncachedUUID r
+ fallback = fromMaybe "unknown" $ Git.remoteName r
+
+{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
+nodeId :: Git.Repo -> String
+nodeId r =
+ case getUncachedUUID r of
+ NoUUID -> Git.repoLocation r
+ UUID u -> u
+
+{- A node representing a repo. -}
+node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String
+node umap fullinfo r = unlines $ n:edges
+ where
+ n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
+ decorate $ Dot.graphNode (nodeId r) (repoName umap r)
+ edges = map (edge umap fullinfo r) (Git.remotes r)
+ decorate
+ | Git.config r == M.empty = unreachable
+ | otherwise = reachable
+
+{- An edge between two repos. The second repo is a remote of the first. -}
+edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
+edge umap fullinfo from to =
+ Dot.graphEdge (nodeId from) (nodeId fullto) edgename
+ where
+ -- get the full info for the remote, to get its UUID
+ fullto = findfullinfo to
+ findfullinfo n =
+ case filter (same n) fullinfo of
+ [] -> n
+ (n':_) -> n'
+ {- Only name an edge if the name is different than the name
+ - that will be used for the destination node, and is
+ - different from its hostname. (This reduces visual clutter.) -}
+ edgename = maybe Nothing calcname $ Git.remoteName to
+ calcname n
+ | n `elem` [repoName umap fullto, hostname fullto] = Nothing
+ | otherwise = Just n
+
+unreachable :: String -> String
+unreachable = Dot.fillColor "red"
+reachable :: String -> String
+reachable = Dot.fillColor "white"
+trustworthy :: String -> String
+trustworthy = Dot.fillColor "green"
+
+{- Recursively searches out remotes starting with the specified repo. -}
+spider :: Git.Repo -> Annex [Git.Repo]
+spider r = spider' [r] []
+spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
+spider' [] known = return known
+spider' (r:rs) known
+ | any (same r) known = spider' rs known
+ | otherwise = do
+ r' <- scan r
+
+ -- The remotes will be relative to r', and need to be
+ -- made absolute for later use.
+ remotes <- mapM (absRepo r') (Git.remotes r')
+ let r'' = r' { Git.remotes = remotes }
+
+ spider' (rs ++ remotes) (r'':known)
+
+{- Converts repos to a common absolute form. -}
+absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
+absRepo reference r
+ | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
+ | Git.repoIsUrl r = return r
+ | otherwise = liftIO $ do
+ r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
+ r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r'
+ return (fromMaybe r' r'')
+
+{- Checks if two repos are the same. -}
+same :: Git.Repo -> Git.Repo -> Bool
+same a b
+ | both Git.repoIsSsh = matching Git.Url.authority && matching Git.repoPath
+ | both Git.repoIsUrl && neither Git.repoIsSsh = matching show
+ | neither Git.repoIsSsh = matching Git.repoPath
+ | otherwise = False
+ where
+ matching t = t a == t b
+ both t = t a && t b
+ neither t = not (t a) && not (t b)
+
+{- reads the config of a remote, with progress display -}
+scan :: Git.Repo -> Annex Git.Repo
+scan r = do
+ showStart "map" $ Git.repoDescribe r
+ v <- tryScan r
+ case v of
+ Just r' -> do
+ showEndOk
+ return r'
+ Nothing -> do
+ showOutput
+ showEndFail
+ return r
+
+{- tries to read the config of a remote, returning it only if it can
+ - be accessed -}
+tryScan :: Git.Repo -> Annex (Maybe Git.Repo)
+tryScan r
+ | Git.repoIsSsh r = sshscan
+ | Git.repoIsUrl r = return Nothing
+ | otherwise = liftIO $ safely $ Git.Config.read r
+ where
+ pipedconfig cmd params = liftIO $ safely $
+ withHandle StdoutHandle createProcessSuccess p $
+ Git.Config.hRead r
+ where
+ p = proc cmd $ toCommand params
+
+ configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] []
+ manualconfiglist = do
+ sshparams <- Ssh.toRepo r [Param sshcmd]
+ liftIO $ pipedconfig "ssh" sshparams
+ where
+ sshcmd = cddir ++ " && " ++
+ "git config --null --list"
+ dir = Git.repoPath r
+ cddir
+ | "/~" `isPrefixOf` dir =
+ let (userhome, reldir) = span (/= '/') (drop 1 dir)
+ in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir)
+ | otherwise = "cd " ++ shellEscape dir
+
+ -- First, try sshing and running git config manually,
+ -- only fall back to git-annex-shell configlist if that
+ -- fails.
+ --
+ -- This is done for two reasons, first I'd like this
+ -- subcommand to be usable on non-git-annex repos.
+ -- Secondly, configlist doesn't include information about
+ -- the remote's remotes.
+ sshscan = do
+ sshnote
+ v <- manualconfiglist
+ case v of
+ Nothing -> do
+ sshnote
+ configlist
+ ok -> return ok
+
+ sshnote = do
+ showAction "sshing"
+ showOutput
+
+{- Spidering can find multiple paths to the same repo, so this is used
+ - to combine (really remove) duplicate repos with the same UUID. -}
+combineSame :: [Git.Repo] -> [Git.Repo]
+combineSame = map snd . nubBy sameuuid . map pair
+ where
+ sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID
+ pair r = (getUncachedUUID r, r)
+
+safely :: IO Git.Repo -> IO (Maybe Git.Repo)
+safely a = do
+ result <- try a :: IO (Either SomeException Git.Repo)
+ case result of
+ Left _ -> return Nothing
+ Right r' -> return $ Just r'
diff --git a/Command/Merge.hs b/Command/Merge.hs
new file mode 100644
index 000000000..51a8b9c52
--- /dev/null
+++ b/Command/Merge.hs
@@ -0,0 +1,37 @@
+{- git-annex command
+ -
+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Merge where
+
+import Common.Annex
+import Command
+import qualified Annex.Branch
+import qualified Git.Branch
+import Command.Sync (prepMerge, mergeLocal)
+
+def :: [Command]
+def = [command "merge" paramNothing seek SectionMaintenance
+ "automatically merge changes from remotes"]
+
+seek :: CommandSeek
+seek ps = do
+ withNothing mergeBranch ps
+ withNothing mergeSynced ps
+
+mergeBranch :: CommandStart
+mergeBranch = do
+ showStart "merge" "git-annex"
+ next $ do
+ Annex.Branch.update
+ -- commit explicitly, in case no remote branches were merged
+ Annex.Branch.commit "update"
+ next $ return True
+
+mergeSynced :: CommandStart
+mergeSynced = do
+ prepMerge
+ mergeLocal =<< inRepo Git.Branch.current
diff --git a/Command/MetaData.hs b/Command/MetaData.hs
new file mode 100644
index 000000000..d932315ab
--- /dev/null
+++ b/Command/MetaData.hs
@@ -0,0 +1,98 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.MetaData where
+
+import Common.Annex
+import qualified Annex
+import Command
+import Annex.MetaData
+import Logs.MetaData
+
+import qualified Data.Set as S
+import Data.Time.Clock.POSIX
+
+def :: [Command]
+def = [withOptions metaDataOptions $
+ command "metadata" paramPaths seek
+ SectionMetaData "sets metadata of a file"]
+
+metaDataOptions :: [Option]
+metaDataOptions =
+ [ setOption
+ , tagOption
+ , untagOption
+ , getOption
+ , jsonOption
+ ] ++ keyOptions
+
+storeModMeta :: ModMeta -> Annex ()
+storeModMeta modmeta = Annex.changeState $
+ \s -> s { Annex.modmeta = modmeta:Annex.modmeta s }
+
+setOption :: Option
+setOption = Option ['s'] ["set"] (ReqArg mkmod "FIELD[+-]=VALUE") "set metadata"
+ where
+ mkmod = either error storeModMeta . parseModMeta
+
+getOption :: Option
+getOption = fieldOption ['g'] "get" paramField "get single metadata field"
+
+tagOption :: Option
+tagOption = Option ['t'] ["tag"] (ReqArg mkmod "TAG") "set a tag"
+ where
+ mkmod = storeModMeta . AddMeta tagMetaField . toMetaValue
+
+untagOption :: Option
+untagOption = Option ['u'] ["untag"] (ReqArg mkmod "TAG") "remove a tag"
+ where
+ mkmod = storeModMeta . AddMeta tagMetaField . mkMetaValue (CurrentlySet False)
+
+seek :: CommandSeek
+seek ps = do
+ modmeta <- Annex.getState Annex.modmeta
+ getfield <- getOptionField getOption $ \ms ->
+ return $ either error id . mkMetaField <$> ms
+ now <- liftIO getPOSIXTime
+ withKeyOptions
+ (startKeys now getfield modmeta)
+ (withFilesInGit (whenAnnexed $ start now getfield modmeta))
+ ps
+
+start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> (Key, Backend) -> CommandStart
+start now f ms file (k, _) = start' (Just file) now f ms k
+
+startKeys :: POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart
+startKeys = start' Nothing
+
+start' :: AssociatedFile -> POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart
+start' afile now Nothing ms k = do
+ showStart' "metadata" k afile
+ next $ perform now ms k
+start' _ _ (Just f) _ k = do
+ l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k
+ liftIO $ forM_ l $
+ putStrLn . fromMetaValue
+ stop
+
+perform :: POSIXTime -> [ModMeta] -> Key -> CommandPerform
+perform _ [] k = next $ cleanup k
+perform now ms k = do
+ oldm <- getCurrentMetaData k
+ let m = combineMetaData $ map (modMeta oldm) ms
+ addMetaData' k m now
+ next $ cleanup k
+
+cleanup :: Key -> CommandCleanup
+cleanup k = do
+ l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k
+ maybeShowJSON l
+ showLongNote $ unlines $ concatMap showmeta l
+ return True
+ where
+ unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))
+ showmeta (f, vs) = map ((f ++ "=") ++) vs
diff --git a/Command/Migrate.hs b/Command/Migrate.hs
new file mode 100644
index 000000000..c14c07bdd
--- /dev/null
+++ b/Command/Migrate.hs
@@ -0,0 +1,77 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Migrate where
+
+import Common.Annex
+import Command
+import Backend
+import qualified Types.Key
+import qualified Types.Backend
+import Types.KeySource
+import Annex.Content
+import qualified Command.ReKey
+import qualified Command.Fsck
+
+def :: [Command]
+def = [notDirect $
+ command "migrate" paramPaths seek
+ SectionUtility "switch data to different backend"]
+
+seek :: CommandSeek
+seek = withFilesInGit $ whenAnnexed start
+
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, oldbackend) = do
+ exists <- inAnnex key
+ newbackend <- choosebackend =<< chooseBackend file
+ if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists
+ then do
+ showStart "migrate" file
+ next $ perform file key oldbackend newbackend
+ else stop
+ where
+ choosebackend Nothing = Prelude.head <$> orderedList
+ choosebackend (Just backend) = return backend
+
+{- Checks if a key is upgradable to a newer representation.
+ -
+ - Reasons for migration:
+ - - Ideally, all keys have file size metadata. Old keys may not.
+ - - Something has changed in the backend, such as a bug fix.
+ -}
+upgradableKey :: Backend -> Key -> Bool
+upgradableKey backend key = isNothing (Types.Key.keySize key) || backendupgradable
+ where
+ backendupgradable = maybe False (\a -> a key)
+ (Types.Backend.canUpgradeKey backend)
+
+{- Store the old backend's key in the new backend
+ - The old backend's key is not dropped from it, because there may
+ - be other files still pointing at that key.
+ -
+ - To ensure that the data we have for the old key is valid, it's
+ - fscked here. First we generate the new key. This ensures that the
+ - data cannot get corrupted after the fsck but before the new key is
+ - generated.
+ -}
+perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform
+perform file oldkey oldbackend newbackend = go =<< genkey
+ where
+ go Nothing = stop
+ go (Just newkey) = stopUnless checkcontent $ finish newkey
+ checkcontent = Command.Fsck.checkBackend oldbackend oldkey $ Just file
+ finish newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
+ next $ Command.ReKey.cleanup file oldkey newkey
+ genkey = do
+ content <- calcRepo $ gitAnnexLocation oldkey
+ let source = KeySource
+ { keyFilename = file
+ , contentLocation = content
+ , inodeCache = Nothing
+ }
+ liftM fst <$> genKey source (Just newbackend)
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
new file mode 100644
index 000000000..4a7a8dd99
--- /dev/null
+++ b/Command/Mirror.hs
@@ -0,0 +1,65 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Mirror where
+
+import Common.Annex
+import Command
+import qualified Command.Move
+import qualified Command.Drop
+import qualified Command.Get
+import qualified Remote
+import Annex.Content
+import qualified Annex
+import Config.NumCopies
+
+def :: [Command]
+def = [withOptions (fromToOptions ++ keyOptions) $
+ command "mirror" paramPaths seek
+ SectionCommon "mirror content of files to/from another repository"]
+
+seek :: CommandSeek
+seek ps = do
+ to <- getOptionField toOption Remote.byNameWithUUID
+ from <- getOptionField fromOption Remote.byNameWithUUID
+ withKeyOptions
+ (startKey to from Nothing)
+ (withFilesInGit $ whenAnnexed $ start to from)
+ ps
+
+start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start to from file (key, _backend) = startKey to from (Just file) key
+
+startKey :: Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart
+startKey to from afile key = do
+ noAuto
+ case (from, to) of
+ (Nothing, Nothing) -> error "specify either --from or --to"
+ (Nothing, Just r) -> mirrorto r
+ (Just r, Nothing) -> mirrorfrom r
+ _ -> error "only one of --from or --to can be specified"
+ where
+ noAuto = whenM (Annex.getState Annex.auto) $
+ error "--auto is not supported for mirror"
+ mirrorto r = ifM (inAnnex key)
+ ( Command.Move.toStart r False afile key
+ , do
+ numcopies <- getnumcopies
+ Command.Drop.startRemote afile numcopies key r
+ )
+ mirrorfrom r = do
+ haskey <- Remote.hasKey r key
+ case haskey of
+ Left _ -> stop
+ Right True -> Command.Get.start' (return True) Nothing key afile
+ Right False -> ifM (inAnnex key)
+ ( do
+ numcopies <- getnumcopies
+ Command.Drop.startLocal afile numcopies key Nothing
+ , stop
+ )
+ getnumcopies = maybe getNumCopies getFileNumCopies afile
diff --git a/Command/Move.hs b/Command/Move.hs
new file mode 100644
index 000000000..206a875b7
--- /dev/null
+++ b/Command/Move.hs
@@ -0,0 +1,173 @@
+{- git-annex command
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Move where
+
+import Common.Annex
+import Command
+import qualified Command.Drop
+import qualified Annex
+import Annex.Content
+import qualified Remote
+import Annex.UUID
+import Annex.Transfer
+import Logs.Presence
+
+def :: [Command]
+def = [withOptions moveOptions $ command "move" paramPaths seek
+ SectionCommon "move content of files to/from another repository"]
+
+moveOptions :: [Option]
+moveOptions = fromToOptions ++ keyOptions
+
+seek :: CommandSeek
+seek ps = do
+ to <- getOptionField toOption Remote.byNameWithUUID
+ from <- getOptionField fromOption Remote.byNameWithUUID
+ withKeyOptions
+ (startKey to from True)
+ (withFilesInGit $ whenAnnexed $ start to from True)
+ ps
+
+start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
+start to from move file (key, _) = start' to from move (Just file) key
+
+startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
+startKey to from move = start' to from move Nothing
+
+start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+start' to from move afile key = do
+ noAuto
+ case (from, to) of
+ (Nothing, Nothing) -> error "specify either --from or --to"
+ (Nothing, Just dest) -> toStart dest move afile key
+ (Just src, Nothing) -> fromStart src move afile key
+ _ -> error "only one of --from or --to can be specified"
+ where
+ noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
+ "--auto is not supported for move"
+
+showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
+showMoveAction move = showStart' (if move then "move" else "copy")
+
+{- 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 :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+toStart dest move afile key = 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
+
+toStart' :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+toStart' dest move afile key = do
+ fast <- Annex.getState Annex.fast
+ if fast && not move && not (Remote.hasKeyCheap dest)
+ then ifM (expectedPresent dest key)
+ ( stop
+ , go True (pure $ Right False)
+ )
+ else go False (Remote.hasKey dest key)
+ where
+ go fastcheck isthere = do
+ showMoveAction move key afile
+ next $ toPerform dest move 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 = moveLock move key $
+ case isthere of
+ Left err -> do
+ showNote err
+ stop
+ Right False -> do
+ showAction $ "to " ++ Remote.name dest
+ ok <- notifyTransfer Upload afile $
+ upload (Remote.uuid dest) key afile noRetry $
+ Remote.storeKey dest key afile
+ if ok
+ then do
+ Remote.logStatus dest key InfoPresent
+ finish
+ else do
+ when fastcheck $
+ warning "This could have failed because --fast is enabled."
+ stop
+ Right True -> do
+ unlessM (expectedPresent dest key) $
+ Remote.logStatus dest key InfoPresent
+ finish
+ where
+ finish
+ | move = do
+ removeAnnex key
+ next $ Command.Drop.cleanupLocal key
+ | otherwise = next $ return True
+
+{- 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 :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+fromStart src move afile key
+ | move = go
+ | otherwise = stopUnless (not <$> inAnnex key) go
+ where
+ go = stopUnless (fromOk src key) $ do
+ showMoveAction move key afile
+ next $ fromPerform src move key afile
+
+fromOk :: Remote -> Key -> Annex Bool
+fromOk src key = go =<< Annex.getState Annex.force
+ where
+ go True = either (const $ return True) return =<< haskey
+ go False
+ | Remote.hasKeyCheap src =
+ either (const expensive) return =<< haskey
+ | otherwise = expensive
+ haskey = Remote.hasKey src key
+ expensive = do
+ u <- getUUID
+ remotes <- Remote.keyPossibilities key
+ return $ u /= Remote.uuid src && elem src remotes
+
+fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
+fromPerform src move key afile = moveLock move key $
+ ifM (inAnnex key)
+ ( handle move True
+ , handle move =<< go
+ )
+ where
+ go = notifyTransfer Download afile $
+ download (Remote.uuid src) key afile noRetry $ \p -> do
+ showAction $ "from " ++ Remote.name src
+ getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
+ handle _ False = stop -- failed
+ handle False True = next $ return True -- copy complete
+ handle True True = do -- finish moving
+ ok <- Remote.removeKey src key
+ next $ Command.Drop.cleanupRemote key src ok
+
+{- Locks a key in order for it to be moved.
+ - No lock is needed when a key is being copied. -}
+moveLock :: Bool -> Key -> Annex a -> Annex a
+moveLock True key a = lockContent key a
+moveLock False _ a = a
diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs
new file mode 100644
index 000000000..b7323ae35
--- /dev/null
+++ b/Command/NumCopies.hs
@@ -0,0 +1,56 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.NumCopies where
+
+import Common.Annex
+import qualified Annex
+import Command
+import Config.NumCopies
+import Types.Messages
+
+def :: [Command]
+def = [command "numcopies" paramNumber seek
+ SectionSetup "configure desired number of copies"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = startGet
+start [s] = do
+ case readish s of
+ Nothing -> error $ "Bad number: " ++ s
+ Just n
+ | n > 0 -> startSet n
+ | n == 0 -> ifM (Annex.getState Annex.force)
+ ( startSet n
+ , error "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
+ )
+ | otherwise -> error "Number cannot be negative!"
+start _ = error "Specify a single number."
+
+startGet :: CommandStart
+startGet = next $ next $ do
+ Annex.setOutput QuietOutput
+ v <- getGlobalNumCopies
+ case v of
+ Just n -> liftIO $ putStrLn $ show $ fromNumCopies n
+ Nothing -> do
+ liftIO $ putStrLn $ "global numcopies is not set"
+ old <- deprecatedNumCopies
+ case old of
+ Nothing -> liftIO $ putStrLn "(default is 1)"
+ Just n -> liftIO $ putStrLn $ "(deprecated git config annex.numcopies is set to " ++ show (fromNumCopies n) ++ " locally)"
+ return True
+
+startSet :: Int -> CommandStart
+startSet n = do
+ showStart "numcopies" (show n)
+ next $ next $ do
+ setGlobalNumCopies $ NumCopies n
+ return True
diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs
new file mode 100644
index 000000000..412b9ae08
--- /dev/null
+++ b/Command/PreCommit.hs
@@ -0,0 +1,111 @@
+{- git-annex command
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.PreCommit where
+
+import Common.Annex
+import Command
+import Config
+import qualified Command.Add
+import qualified Command.Fix
+import Annex.Direct
+import Annex.Hook
+import Annex.View
+import Annex.View.ViewedFile
+import Annex.Perms
+import Annex.Exception
+import Logs.View
+import Logs.MetaData
+import Types.View
+import Types.MetaData
+
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "pre-commit" paramPaths seek SectionPlumbing
+ "run by git pre-commit hook"]
+
+seek :: CommandSeek
+seek ps = lockPreCommitHook $ ifM isDirect
+ ( do
+ -- update direct mode mappings for committed files
+ withWords startDirect ps
+ runAnnexHook preCommitAnnexHook
+ , do
+ -- fix symlinks to files being committed
+ withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
+ -- inject unlocked files into the annex
+ withFilesUnlockedToBeCommitted startIndirect ps
+ runAnnexHook preCommitAnnexHook
+ -- committing changes to a view updates metadata
+ mv <- currentView
+ case mv of
+ Nothing -> noop
+ Just v -> withViewChanges
+ (addViewMetaData v)
+ (removeViewMetaData v)
+ )
+
+
+startIndirect :: FilePath -> CommandStart
+startIndirect f = next $ do
+ unlessM (callCommandAction $ Command.Add.start f) $
+ error $ "failed to add " ++ f ++ "; canceling commit"
+ next $ return True
+
+startDirect :: [String] -> CommandStart
+startDirect _ = next $ next $ preCommitDirect
+
+addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
+addViewMetaData v f k = do
+ showStart "metadata" f
+ next $ next $ changeMetaData k $ fromView v f
+
+removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
+removeViewMetaData v f k = do
+ showStart "metadata" f
+ next $ next $ changeMetaData k $ unsetMetaData $ fromView v f
+
+changeMetaData :: Key -> MetaData -> CommandCleanup
+changeMetaData k metadata = do
+ showMetaDataChange metadata
+ addMetaData k metadata
+ return True
+
+showMetaDataChange :: MetaData -> Annex ()
+showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
+ where
+ showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
+ showmetavalue f v = fromMetaField f ++ showset v ++ "=" ++ fromMetaValue v
+ showset v
+ | isSet v = "+"
+ | otherwise = "-"
+
+{- Takes exclusive lock; blocks until available. -}
+lockPreCommitHook :: Annex a -> Annex a
+lockPreCommitHook a = do
+ lockfile <- fromRepo gitAnnexPreCommitLock
+ createAnnexDirectory $ takeDirectory lockfile
+ mode <- annexFileMode
+ bracketIO (lock lockfile mode) unlock (const a)
+ where
+#ifndef mingw32_HOST_OS
+ lock lockfile mode = do
+ l <- liftIO $ noUmask mode $ createFile lockfile mode
+ liftIO $ waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
+ return l
+ unlock = closeFd
+#else
+ lock lockfile _mode = liftIO $ waitToLock $ lockExclusive lockfile
+ unlock = dropLock
+#endif
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
new file mode 100644
index 000000000..805300f9f
--- /dev/null
+++ b/Command/ReKey.hs
@@ -0,0 +1,71 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.ReKey where
+
+import Common.Annex
+import Command
+import qualified Annex
+import Types.Key
+import Annex.Content
+import qualified Command.Add
+import Logs.Web
+import Logs.Location
+import Utility.CopyFile
+
+def :: [Command]
+def = [notDirect $ command "rekey"
+ (paramOptional $ paramRepeating $ paramPair paramPath paramKey)
+ seek SectionPlumbing "change keys used for files"]
+
+seek :: CommandSeek
+seek = withPairs start
+
+start :: (FilePath, String) -> CommandStart
+start (file, keyname) = ifAnnexed file go stop
+ where
+ newkey = fromMaybe (error "bad key") $ file2key keyname
+ go (oldkey, _)
+ | oldkey == newkey = stop
+ | otherwise = do
+ showStart "rekey" file
+ next $ perform file oldkey newkey
+
+perform :: FilePath -> Key -> Key -> CommandPerform
+perform file oldkey newkey = do
+ present <- inAnnex oldkey
+ _ <- if present
+ then linkKey oldkey newkey
+ else do
+ unlessM (Annex.getState Annex.force) $
+ error $ file ++ " is not available (use --force to override)"
+ return True
+ next $ cleanup file oldkey newkey
+
+{- Make a hard link to the old key content (when supported),
+ - to avoid wasting disk space. -}
+linkKey :: Key -> Key -> Annex Bool
+linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do
+ src <- calcRepo $ gitAnnexLocation oldkey
+ liftIO $ ifM (doesFileExist tmp)
+ ( return True
+ , createLinkOrCopy src tmp
+ )
+
+cleanup :: FilePath -> Key -> Key -> CommandCleanup
+cleanup file oldkey newkey = do
+ -- If the old key had some associated urls, record them for
+ -- the new key as well.
+ urls <- getUrls oldkey
+ unless (null urls) $
+ mapM_ (setUrlPresent newkey) urls
+
+ -- Update symlink to use the new key.
+ liftIO $ removeFile file
+ Command.Add.addLink file newkey Nothing
+ logStatus newkey InfoPresent
+ return True
diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
new file mode 100644
index 000000000..1794596c5
--- /dev/null
+++ b/Command/RecvKey.hs
@@ -0,0 +1,87 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.RecvKey where
+
+import Common.Annex
+import Command
+import CmdLine
+import Annex.Content
+import Annex
+import Utility.Rsync
+import Logs.Transfer
+import Command.SendKey (fieldTransfer)
+import qualified CmdLine.GitAnnexShell.Fields as Fields
+import qualified Types.Key
+import qualified Types.Backend
+import qualified Backend
+
+def :: [Command]
+def = [noCommit $ command "recvkey" paramKey seek
+ SectionPlumbing "runs rsync in server mode to receive content"]
+
+seek :: CommandSeek
+seek = withKeys start
+
+start :: Key -> CommandStart
+start key = ifM (inAnnex key)
+ ( error "key is already present in annex"
+ , fieldTransfer Download key $ \_p ->
+ ifM (getViaTmp key go)
+ ( do
+ -- forcibly quit after receiving one key,
+ -- and shutdown cleanly
+ _ <- shutdown True
+ return True
+ , return False
+ )
+ )
+ where
+ go tmp = do
+ opts <- filterRsyncSafeOptions . maybe [] words
+ <$> getField "RsyncOptions"
+ ok <- liftIO $ rsyncServerReceive (map Param opts) tmp
+
+ -- The file could have been received with permissions that
+ -- do not allow reading it, so this is done before the
+ -- directcheck.
+ freezeContent tmp
+
+ if ok
+ then ifM (isJust <$> Fields.getField Fields.direct)
+ ( directcheck tmp
+ , return True
+ )
+ else return False
+ {- If the sending repository uses direct mode, the file
+ - it sends could be modified as it's sending it. So check
+ - that the right size file was received, and that the key/value
+ - Backend is happy with it. -}
+ directcheck tmp = do
+ oksize <- case Types.Key.keySize key of
+ Nothing -> return True
+ Just size -> do
+ size' <- fromIntegral . fileSize
+ <$> liftIO (getFileStatus tmp)
+ return $ size == size'
+ if oksize
+ then case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
+ Nothing -> do
+ warning "recvkey: received key from direct mode repository using unknown backend; cannot check; discarding"
+ return False
+ Just backend -> maybe (return True) runfsck
+ (Types.Backend.fsckKey backend)
+ else do
+ warning "recvkey: received key with wrong size; discarding"
+ return False
+ where
+ runfsck check = ifM (check key tmp)
+ ( return True
+ , do
+ warning "recvkey: received key from direct mode repository seems to have changed as it was transferred; discarding"
+ return False
+ )
diff --git a/Command/Reinject.hs b/Command/Reinject.hs
new file mode 100644
index 000000000..1609c6097
--- /dev/null
+++ b/Command/Reinject.hs
@@ -0,0 +1,58 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Reinject where
+
+import Common.Annex
+import Command
+import Logs.Location
+import Annex.Content
+import qualified Command.Fsck
+
+def :: [Command]
+def = [command "reinject" (paramPair "SRC" "DEST") seek
+ SectionUtility "sets content of annexed file"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [FilePath] -> CommandStart
+start (src:dest:[])
+ | src == dest = stop
+ | otherwise =
+ ifAnnexed src
+ (error $ "cannot used annexed file as src: " ++ src)
+ go
+ where
+ go = do
+ showStart "reinject" dest
+ next $ whenAnnexed (perform src) dest
+start _ = error "specify a src file and a dest file"
+
+perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
+perform src _dest (key, backend) =
+ {- Check the content before accepting it. -}
+ ifM (Command.Fsck.checkKeySizeOr reject key src
+ <&&> Command.Fsck.checkBackendOr reject backend key src)
+ ( do
+ unlessM move $ error "mv failed!"
+ next $ cleanup key
+ , error "not reinjecting"
+ )
+ where
+ -- the file might be on a different filesystem,
+ -- so mv is used rather than simply calling
+ -- moveToObjectDir; disk space is also
+ -- checked this way.
+ move = getViaTmp key $ \tmp ->
+ liftIO $ boolSystem "mv" [File src, File tmp]
+ reject = const $ return "wrong file?"
+
+cleanup :: Key -> CommandCleanup
+cleanup key = do
+ logStatus key InfoPresent
+ return True
diff --git a/Command/Repair.hs b/Command/Repair.hs
new file mode 100644
index 000000000..56925d83d
--- /dev/null
+++ b/Command/Repair.hs
@@ -0,0 +1,84 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Repair where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Git.Repair
+import qualified Annex.Branch
+import qualified Git.Ref
+import Git.Types
+import Annex.Version
+
+def :: [Command]
+def = [noCommit $ dontCheck repoExists $
+ command "repair" paramNothing seek SectionMaintenance "recover broken git repository"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = next $ next $ runRepair =<< Annex.getState Annex.force
+
+runRepair :: Bool -> Annex Bool
+runRepair forced = do
+ (ok, modifiedbranches) <- inRepo $
+ Git.Repair.runRepair isAnnexSyncBranch forced
+ -- This command can be run in git repos not using git-annex,
+ -- so avoid git annex branch stuff in that case.
+ whenM (isJust <$> getVersion) $
+ repairAnnexBranch modifiedbranches
+ return ok
+
+{- After git repository repair, the .git/annex/index file could
+ - still be broken, by pointing to bad objects, or might just be corrupt on
+ - its own. Since this index file is not used to stage things
+ - for long durations of time, it can safely be deleted if it is broken.
+ -
+ - Otherwise, if the git-annex branch was modified by the repair,
+ - commit the index file to the git-annex branch.
+ - This way, if the git-annex branch got rewound to an old version by
+ - the repository repair, or was completely deleted, this will get it back
+ - to a good state. Note that in the unlikely case where the git-annex
+ - branch was rewound to a state that, had new changes from elsewhere not
+ - yet reflected in the index, this does properly merge those into the
+ - index before committing.
+ -}
+repairAnnexBranch :: [Branch] -> Annex ()
+repairAnnexBranch modifiedbranches
+ | Annex.Branch.fullname `elem` modifiedbranches = ifM okindex
+ ( commitindex
+ , do
+ nukeindex
+ missingbranch
+ )
+ | otherwise = ifM okindex
+ ( noop
+ , do
+ nukeindex
+ ifM (null <$> inRepo (Git.Ref.matching [Annex.Branch.fullname]))
+ ( missingbranch
+ , liftIO $ putStrLn "No data was lost."
+ )
+ )
+ where
+ okindex = Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndex
+ commitindex = do
+ Annex.Branch.forceCommit "committing index after git repository repair"
+ liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
+ nukeindex = do
+ inRepo $ nukeFile . gitAnnexIndex
+ liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt."
+ missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast"
+
+trackingOrSyncBranch :: Ref -> Bool
+trackingOrSyncBranch b = Git.Repair.isTrackingBranch b || isAnnexSyncBranch b
+
+isAnnexSyncBranch :: Ref -> Bool
+isAnnexSyncBranch b = "refs/synced/" `isPrefixOf` fromRef b
diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs
new file mode 100644
index 000000000..3f304b76e
--- /dev/null
+++ b/Command/RmUrl.hs
@@ -0,0 +1,30 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.RmUrl where
+
+import Common.Annex
+import Command
+import Logs.Web
+
+def :: [Command]
+def = [notBareRepo $
+ command "rmurl" (paramPair paramFile paramUrl) seek
+ SectionCommon "record file is not available at url"]
+
+seek :: CommandSeek
+seek = withPairs start
+
+start :: (FilePath, String) -> CommandStart
+start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do
+ showStart "rmurl" file
+ next $ next $ cleanup url key
+
+cleanup :: String -> Key -> CommandCleanup
+cleanup url key = do
+ setUrlMissing key url
+ return True
diff --git a/Command/Schedule.hs b/Command/Schedule.hs
new file mode 100644
index 000000000..a088dbef8
--- /dev/null
+++ b/Command/Schedule.hs
@@ -0,0 +1,53 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Schedule where
+
+import Common.Annex
+import qualified Annex
+import Command
+import qualified Remote
+import Logs.Schedule
+import Types.ScheduledActivity
+import Types.Messages
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek
+ SectionSetup "get or set scheduled jobs"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start = parse
+ where
+ parse (name:[]) = go name performGet
+ parse (name:expr:[]) = go name $ \uuid -> do
+ showStart "schedile" name
+ performSet expr uuid
+ parse _ = error "Specify a repository."
+
+ go name a = do
+ u <- Remote.nameToUUID name
+ next $ a u
+
+performGet :: UUID -> CommandPerform
+performGet uuid = do
+ Annex.setOutput QuietOutput
+ s <- scheduleGet uuid
+ liftIO $ putStrLn $ intercalate "; " $
+ map fromScheduledActivity $ S.toList s
+ next $ return True
+
+performSet :: String -> UUID -> CommandPerform
+performSet expr uuid = case parseScheduledActivities expr of
+ Left e -> error $ "Parse error: " ++ e
+ Right l -> do
+ scheduleSet uuid l
+ next $ return True
diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs
new file mode 100644
index 000000000..edba27346
--- /dev/null
+++ b/Command/Semitrust.hs
@@ -0,0 +1,19 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Semitrust where
+
+import Command
+import Types.TrustLevel
+import Command.Trust (trustCommand)
+
+def :: [Command]
+def = [command "semitrust" (paramRepeating paramRemote) seek
+ SectionSetup "return repository to default trust level"]
+
+seek :: CommandSeek
+seek = trustCommand "semitrust" SemiTrusted
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
new file mode 100644
index 000000000..a201d1b89
--- /dev/null
+++ b/Command/SendKey.hs
@@ -0,0 +1,49 @@
+{- git-annex command
+ -
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.SendKey where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Annex
+import Utility.Rsync
+import Annex.Transfer
+import qualified CmdLine.GitAnnexShell.Fields as Fields
+import Utility.Metered
+
+def :: [Command]
+def = [noCommit $ command "sendkey" paramKey seek
+ SectionPlumbing "runs rsync in server mode to send content"]
+
+seek :: CommandSeek
+seek = withKeys start
+
+start :: Key -> CommandStart
+start key = do
+ opts <- filterRsyncSafeOptions . maybe [] words
+ <$> getField "RsyncOptions"
+ ifM (inAnnex key)
+ ( fieldTransfer Upload key $ \_p ->
+ sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts)
+ , do
+ warning "requested key is not present"
+ liftIO exitFailure
+ )
+ where
+ {- No need to do any rollback; when sendAnnex fails, a nonzero
+ - exit will be propigated, and the remote will know the transfer
+ - failed. -}
+ rollback = noop
+
+fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
+fieldTransfer direction key a = do
+ afile <- Fields.getField Fields.associatedFile
+ ok <- maybe (a $ const noop)
+ (\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a)
+ =<< Fields.getField Fields.remoteUUID
+ liftIO $ exitBool ok
diff --git a/Command/Status.hs b/Command/Status.hs
new file mode 100644
index 000000000..cd6c25983
--- /dev/null
+++ b/Command/Status.hs
@@ -0,0 +1,90 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Status where
+
+import Common.Annex
+import Command
+import Annex.CatFile
+import Annex.Content.Direct
+import Config
+import qualified Git.LsFiles as LsFiles
+import qualified Git.Ref
+import qualified Git
+
+def :: [Command]
+def = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $
+ command "status" paramPaths seek SectionCommon
+ "show the working tree status"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [FilePath] -> CommandStart
+start [] = do
+ -- Like git status, when run without a directory, behave as if
+ -- given the path to the top of the repository.
+ cwd <- liftIO getCurrentDirectory
+ top <- fromRepo Git.repoPath
+ start' [relPathDirToFile cwd top]
+start locs = start' locs
+
+start' :: [FilePath] -> CommandStart
+start' locs = do
+ (l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs
+ getstatus <- ifM isDirect
+ ( return statusDirect
+ , return $ Just <$$> statusIndirect
+ )
+ forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f
+ void $ liftIO cleanup
+ stop
+
+data Status
+ = NewFile
+ | DeletedFile
+ | ModifiedFile
+
+showStatus :: Status -> String
+showStatus NewFile = "?"
+showStatus DeletedFile = "D"
+showStatus ModifiedFile = "M"
+
+showFileStatus :: FilePath -> Status -> Annex ()
+showFileStatus f s = unlessM (showFullJSON [("status", ss), ("file", f)]) $
+ liftIO $ putStrLn $ ss ++ " " ++ f
+ where
+ ss = showStatus s
+
+statusDirect :: FilePath -> Annex (Maybe Status)
+statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f)
+ where
+ checkstatus Nothing = return $ Just DeletedFile
+ checkstatus (Just s)
+ -- Git thinks that present direct mode files modifed,
+ -- so have to check.
+ | not (isSymbolicLink s) = checkkey s =<< catKeyFile f
+ | otherwise = Just <$> checkNew f
+
+ checkkey s (Just k) = ifM (sameFileStatus k s)
+ ( return Nothing
+ , return $ Just ModifiedFile
+ )
+ checkkey _ Nothing = Just <$> checkNew f
+
+statusIndirect :: FilePath -> Annex Status
+statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f))
+ ( checkNew f
+ , return DeletedFile
+ )
+ where
+
+checkNew :: FilePath -> Annex Status
+checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
+ ( return ModifiedFile
+ , return NewFile
+ )
diff --git a/Command/Sync.hs b/Command/Sync.hs
new file mode 100644
index 000000000..a4004736a
--- /dev/null
+++ b/Command/Sync.hs
@@ -0,0 +1,380 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Sync where
+
+import Common.Annex
+import Command
+import qualified Annex
+import qualified Annex.Branch
+import qualified Remote
+import qualified Types.Remote as Remote
+import Annex.Direct
+import Annex.Hook
+import qualified Git.Command
+import qualified Git.LsFiles as LsFiles
+import qualified Git.Branch
+import qualified Git.Ref
+import qualified Git
+import qualified Types.Remote
+import qualified Remote.Git
+import Config
+import Annex.Wanted
+import Annex.Content
+import Command.Get (getKeyFile')
+import qualified Command.Move
+import Logs.Location
+import Annex.Drop
+import Annex.UUID
+import Annex.AutoMerge
+
+import Control.Concurrent.MVar
+
+def :: [Command]
+def = [withOptions syncOptions $
+ command "sync" (paramOptional (paramRepeating paramRemote))
+ seek SectionCommon "synchronize local repository with remotes"]
+
+syncOptions :: [Option]
+syncOptions = [ contentOption ]
+
+contentOption :: Option
+contentOption = flagOption [] "content" "also transfer file contents"
+
+seek :: CommandSeek
+seek rs = do
+ prepMerge
+
+ -- There may not be a branch checked out until after the commit,
+ -- or perhaps after it gets merged from the remote.
+ -- So only look it up once it's needed, and if once there is a
+ -- branch, cache it.
+ mvar <- liftIO newEmptyMVar
+ let getbranch = ifM (liftIO $ isEmptyMVar mvar)
+ ( do
+ branch <- inRepo Git.Branch.current
+ when (isJust branch) $
+ liftIO $ putMVar mvar branch
+ return branch
+ , liftIO $ readMVar mvar
+ )
+ let withbranch a = a =<< getbranch
+
+ remotes <- syncRemotes rs
+ let gitremotes = filter Remote.gitSyncableRemote remotes
+ let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes
+
+ -- Syncing involves many actions, any of which can independently
+ -- fail, without preventing the others from running.
+ seekActions $ return $ concat
+ [ [ commit ]
+ , [ withbranch mergeLocal ]
+ , map (withbranch . pullRemote) gitremotes
+ , [ mergeAnnex ]
+ ]
+ whenM (Annex.getFlag $ optionName contentOption) $
+ whenM (seekSyncContent dataremotes) $
+ -- Transferring content can take a while,
+ -- and other changes can be pushed to the git-annex
+ -- branch on the remotes in the meantime, so pull
+ -- and merge again to avoid our push overwriting
+ -- those changes.
+ seekActions $ return $ concat
+ [ map (withbranch . pullRemote) gitremotes
+ , [ commitAnnex, mergeAnnex ]
+ ]
+ seekActions $ return $ concat
+ [ [ withbranch pushLocal ]
+ , map (withbranch . pushRemote) gitremotes
+ ]
+
+{- Merging may delete the current directory, so go to the top
+ - of the repo. This also means that sync always acts on all files in the
+ - repository, not just on a subdirectory. -}
+prepMerge :: Annex ()
+prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
+
+syncBranch :: Git.Ref -> Git.Ref
+syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch
+
+remoteBranch :: Remote -> Git.Ref -> Git.Ref
+remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
+
+syncRemotes :: [String] -> Annex [Remote]
+syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
+ where
+ pickfast = (++) <$> listed <*> (filterM good =<< fastest <$> available)
+ wanted
+ | null rs = filterM good =<< concat . Remote.byCost <$> available
+ | otherwise = listed
+ listed = catMaybes <$> mapM (Remote.byName . Just) rs
+ available = filter (remoteAnnexSync . Types.Remote.gitconfig)
+ . filter (not . Remote.isXMPPRemote)
+ <$> Remote.remoteList
+ good r
+ | Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Types.Remote.repo r
+ | otherwise = return True
+ fastest = fromMaybe [] . headMaybe . Remote.byCost
+
+commit :: CommandStart
+commit = next $ next $ ifM isDirect
+ ( do
+ showStart "commit" ""
+ void stageDirect
+ void preCommitDirect
+ commitStaged commitmessage
+ , do
+ showStart "commit" ""
+ Annex.Branch.commit "update"
+ -- Commit will fail when the tree is clean, so ignore failure.
+ _ <- inRepo $ tryIO . Git.Command.runQuiet
+ [ Param "commit"
+ , Param "-a"
+ , Param "-m"
+ , Param commitmessage
+ ]
+ return True
+ )
+ where
+ commitmessage = "git-annex automatic sync"
+
+commitStaged :: String -> Annex Bool
+commitStaged commitmessage = go =<< inRepo Git.Branch.currentUnsafe
+ where
+ go Nothing = return False
+ go (Just branch) = do
+ runAnnexHook preCommitAnnexHook
+ parent <- inRepo $ Git.Ref.sha branch
+ void $ inRepo $ Git.Branch.commit False commitmessage branch
+ (maybeToList parent)
+ return True
+
+mergeLocal :: Maybe Git.Ref -> CommandStart
+mergeLocal Nothing = stop
+mergeLocal (Just branch) = go =<< needmerge
+ where
+ syncbranch = syncBranch branch
+ needmerge = ifM isBareRepo
+ ( return False
+ , do
+ unlessM (inRepo $ Git.Ref.exists syncbranch) $
+ inRepo $ updateBranch syncbranch
+ inRepo $ Git.Branch.changed branch syncbranch
+ )
+ go False = stop
+ go True = do
+ showStart "merge" $ Git.Ref.describe syncbranch
+ next $ next $ autoMergeFrom syncbranch (Just branch)
+
+pushLocal :: Maybe Git.Ref -> CommandStart
+pushLocal Nothing = stop
+pushLocal (Just branch) = do
+ -- Update the sync branch to match the new state of the branch
+ inRepo $ updateBranch $ syncBranch branch
+ -- In direct mode, we're operating on some special direct mode
+ -- branch, rather than the intended branch, so update the indended
+ -- branch.
+ whenM isDirect $
+ inRepo $ updateBranch $ fromDirectBranch branch
+ stop
+
+updateBranch :: Git.Ref -> Git.Repo -> IO ()
+updateBranch syncbranch g =
+ unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
+ where
+ go = Git.Command.runBool
+ [ Param "branch"
+ , Param "-f"
+ , Param $ Git.fromRef $ Git.Ref.base syncbranch
+ ] g
+
+pullRemote :: Remote -> Maybe Git.Ref -> CommandStart
+pullRemote remote branch = do
+ showStart "pull" (Remote.name remote)
+ next $ do
+ showOutput
+ stopUnless fetch $
+ next $ mergeRemote remote branch
+ where
+ fetch = inRepo $ Git.Command.runBool
+ [Param "fetch", Param $ Remote.name remote]
+
+{- The remote probably has both a master and a synced/master branch.
+ - Which to merge from? Well, the master has whatever latest changes
+ - were committed (or pushed changes, if this is a bare remote),
+ - while the synced/master may have changes that some
+ - other remote synced to this remote. So, merge them both. -}
+mergeRemote :: Remote -> Maybe Git.Ref -> CommandCleanup
+mergeRemote remote b = case b of
+ Nothing -> do
+ branch <- inRepo Git.Branch.currentUnsafe
+ and <$> mapM (merge Nothing) (branchlist branch)
+ Just thisbranch ->
+ and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b))
+ where
+ merge thisbranch = flip autoMergeFrom thisbranch . remoteBranch remote
+ tomerge = filterM (changed remote)
+ branchlist Nothing = []
+ branchlist (Just branch) = [branch, syncBranch branch]
+
+pushRemote :: Remote -> Maybe Git.Ref -> CommandStart
+pushRemote _remote Nothing = stop
+pushRemote remote (Just branch) = go =<< needpush
+ where
+ needpush
+ | remoteAnnexReadOnly (Types.Remote.gitconfig remote) = return False
+ | otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
+ go False = stop
+ go True = do
+ showStart "push" (Remote.name remote)
+ next $ next $ do
+ showOutput
+ ok <- inRepo $ pushBranch remote branch
+ unless ok $ do
+ warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
+ showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
+ return ok
+
+{- Pushes a regular branch like master to a remote. Also pushes the git-annex
+ - branch.
+ -
+ - If the remote is a bare git repository, it's best to push the regular
+ - branch directly to it, so that cloning/pulling will get it.
+ - On the other hand, if it's not bare, pushing to the checked out branch
+ - will fail, and this is why we push to its syncBranch.
+ -
+ - Git offers no way to tell if a remote is bare or not, so both methods
+ - are tried.
+ -
+ - The direct push is likely to spew an ugly error message, so stderr is
+ - elided. Since git progress display goes to stderr too, the sync push
+ - is done first, and actually sends the data. Then the direct push is
+ - tried, with stderr discarded, to update the branch ref on the remote.
+ -
+ - The sync push forces the update of the remote synced/git-annex branch.
+ - This is necessary if a transition has rewritten the git-annex branch.
+ - Normally any changes to the git-annex branch get pulled and merged before
+ - this push, so this forcing is unlikely to overwrite new data pushed
+ - in from another repository that is also syncing.
+ -
+ - But overwriting of data on synced/git-annex can happen, in a race.
+ - The only difference caused by using a forced push in that case is that
+ - the last repository to push wins the race, rather than the first to push.
+ -
+ - The sync push will fail to overwrite if receive.denyNonFastforwards is
+ - set on the remote.
+ -}
+pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
+pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
+ where
+ syncpush = Git.Command.runBool $ pushparams
+ [ Git.Branch.forcePush $ refspec Annex.Branch.name
+ , refspec branch
+ ]
+ directpush = Git.Command.runQuiet $ pushparams
+ [Git.fromRef $ Git.Ref.base $ fromDirectBranch branch]
+ pushparams branches =
+ [ Param "push"
+ , Param $ Remote.name remote
+ ] ++ map Param branches
+ refspec b = concat
+ [ Git.fromRef $ Git.Ref.base b
+ , ":"
+ , Git.fromRef $ Git.Ref.base $ syncBranch b
+ ]
+
+commitAnnex :: CommandStart
+commitAnnex = do
+ Annex.Branch.commit "update"
+ stop
+
+mergeAnnex :: CommandStart
+mergeAnnex = do
+ void Annex.Branch.forceUpdate
+ stop
+
+changed :: Remote -> Git.Ref -> Annex Bool
+changed remote b = do
+ let r = remoteBranch remote b
+ ifM (inRepo $ Git.Ref.exists r)
+ ( inRepo $ Git.Branch.changed b r
+ , return False
+ )
+
+newer :: Remote -> Git.Ref -> Annex Bool
+newer remote b = do
+ let r = remoteBranch remote b
+ ifM (inRepo $ Git.Ref.exists r)
+ ( inRepo $ Git.Branch.changed r b
+ , return True
+ )
+
+{- If it's preferred content, and we don't have it, get it from one of the
+ - listed remotes (preferring the cheaper earlier ones).
+ -
+ - Send it to each remote that doesn't have it, and for which it's
+ - preferred content.
+ -
+ - Drop it locally if it's not preferred content (honoring numcopies).
+ -
+ - Drop it from each remote that has it, where it's not preferred content
+ - (honoring numcopies).
+ -
+ - If any file movements were generated, returns true.
+ -}
+seekSyncContent :: [Remote] -> Annex Bool
+seekSyncContent rs = do
+ mvar <- liftIO newEmptyMVar
+ mapM_ (go mvar) =<< seekHelper LsFiles.inRepo []
+ liftIO $ not <$> isEmptyMVar mvar
+ where
+ go mvar f = ifAnnexed f
+ (\v -> void (liftIO (tryPutMVar mvar ())) >> syncFile rs f v)
+ noop
+
+syncFile :: [Remote] -> FilePath -> (Key, Backend) -> Annex ()
+syncFile rs f (k, _) = do
+ locs <- loggedLocations k
+ let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
+
+ got <- anyM id =<< handleget have
+ putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack)
+
+ u <- getUUID
+ let locs' = concat [[u | got], putrs, locs]
+
+ -- Using callCommandAction rather than commandAction for drops,
+ -- because a failure to drop does not mean the sync failed.
+ handleDropsFrom locs' rs "unwanted" True k (Just f)
+ Nothing callCommandAction
+ where
+ wantget have = allM id
+ [ pure (not $ null have)
+ , not <$> inAnnex k
+ , wantGet True (Just k) (Just f)
+ ]
+ handleget have = ifM (wantget have)
+ ( return [ get have ]
+ , return []
+ )
+ get have = commandAction $ do
+ showStart "get" f
+ next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have
+
+ wantput r
+ | Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
+ | otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
+ handleput lack = ifM (inAnnex k)
+ ( map put <$> filterM wantput lack
+ , return []
+ )
+ put dest = do
+ ok <- commandAction $ do
+ showStart "copy" f
+ Command.Move.toStart' dest False (Just f) k
+ return (ok, if ok then Just (Remote.uuid dest) else Nothing)
diff --git a/Command/Test.hs b/Command/Test.hs
new file mode 100644
index 000000000..ee7220142
--- /dev/null
+++ b/Command/Test.hs
@@ -0,0 +1,37 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Test where
+
+import Common
+import Command
+import Messages
+
+def :: [Command]
+def = [ noRepo startIO $ dontCheck repoExists $
+ command "test" paramNothing seek SectionPlumbing
+ "run built-in test suite"]
+
+seek :: CommandSeek
+seek = withWords start
+
+{- We don't actually run the test suite here because of a dependency loop.
+ - The main program notices when the command is test and runs it; this
+ - function is never run if that works.
+ -
+ - However, if git-annex is built without the test suite, just print a
+ - warning, and do not exit nonzero. This is so git-annex test can be run
+ - in debian/rules despite some architectures not being able to build the
+ - test suite.
+ -}
+start :: [String] -> CommandStart
+start ps = do
+ liftIO $ startIO ps
+ stop
+
+startIO :: CmdParams -> IO ()
+startIO _ = warningIO "git-annex was built without its test suite; not testing"
diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs
new file mode 100644
index 000000000..8ab577a81
--- /dev/null
+++ b/Command/TransferInfo.hs
@@ -0,0 +1,64 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TransferInfo where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Logs.Transfer
+import Types.Key
+import qualified CmdLine.GitAnnexShell.Fields as Fields
+import Utility.Metered
+
+def :: [Command]
+def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing
+ "updates sender on number of bytes of content received"]
+
+seek :: CommandSeek
+seek = withWords start
+
+{- Security:
+ -
+ - The transfer info file contains the user-supplied key, but
+ - the built-in guards prevent slashes in it from showing up in the filename.
+ - It also contains the UUID of the remote. But slashes are also filtered
+ - out of that when generating the filename.
+ -
+ - Checks that the key being transferred is inAnnex, to prevent
+ - malicious spamming of bogus keys. Does not check that a transfer
+ - of the key is actually in progress, because this could be started
+ - concurrently with sendkey, and win the race.
+ -}
+start :: [String] -> CommandStart
+start (k:[]) = do
+ case file2key k of
+ Nothing -> error "bad key"
+ (Just key) -> whenM (inAnnex key) $ do
+ file <- Fields.getField Fields.associatedFile
+ u <- maybe (error "missing remoteuuid") toUUID
+ <$> Fields.getField Fields.remoteUUID
+ let t = Transfer
+ { transferDirection = Upload
+ , transferUUID = u
+ , transferKey = key
+ }
+ info <- liftIO $ startTransferInfo file
+ (update, tfile, _) <- mkProgressUpdater t info
+ liftIO $ mapM_ void
+ [ tryIO $ forever $ do
+ bytes <- readUpdate
+ maybe (error "transferinfo protocol error")
+ (update . toBytesProcessed) bytes
+ , tryIO $ removeFile tfile
+ , exitSuccess
+ ]
+ stop
+start _ = error "wrong number of parameters"
+
+readUpdate :: IO (Maybe Integer)
+readUpdate = readish <$> getLine
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
new file mode 100644
index 000000000..13bfd825e
--- /dev/null
+++ b/Command/TransferKey.hs
@@ -0,0 +1,57 @@
+{- git-annex plumbing command (for use by old assistant, and users)
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TransferKey where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Logs.Location
+import Annex.Transfer
+import qualified Remote
+import Types.Remote
+
+def :: [Command]
+def = [withOptions transferKeyOptions $
+ noCommit $ command "transferkey" paramKey seek SectionPlumbing
+ "transfers a key from or to a remote"]
+
+transferKeyOptions :: [Option]
+transferKeyOptions = fileOption : fromToOptions
+
+fileOption :: Option
+fileOption = fieldOption [] "file" paramFile "the associated file"
+
+seek :: CommandSeek
+seek ps = do
+ to <- getOptionField toOption Remote.byNameWithUUID
+ from <- getOptionField fromOption Remote.byNameWithUUID
+ file <- getOptionField fileOption return
+ withKeys (start to from file) ps
+
+start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart
+start to from file key =
+ case (from, to) of
+ (Nothing, Just dest) -> next $ toPerform dest key file
+ (Just src, Nothing) -> next $ fromPerform src key file
+ _ -> error "specify either --from or --to"
+
+toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
+toPerform remote key file = go Upload file $
+ upload (uuid remote) key file forwardRetry $ \p -> do
+ ok <- Remote.storeKey remote key file p
+ when ok $
+ Remote.logStatus remote key InfoPresent
+ return ok
+
+fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
+fromPerform remote key file = go Upload file $
+ download (uuid remote) key file forwardRetry $ \p ->
+ getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
+
+go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
+go direction file a = notifyTransfer direction file a >>= liftIO . exitBool
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
new file mode 100644
index 000000000..8f4498eb1
--- /dev/null
+++ b/Command/TransferKeys.hs
@@ -0,0 +1,140 @@
+{- git-annex command, used internally by assistant
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+module Command.TransferKeys where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Logs.Location
+import Annex.Transfer
+import qualified Remote
+import Types.Key
+
+import GHC.IO.Handle
+
+data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
+
+def :: [Command]
+def = [command "transferkeys" paramNothing seek
+ SectionPlumbing "transfers keys"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = withHandles $ \(readh, writeh) -> do
+ runRequests readh writeh runner
+ stop
+ where
+ runner (TransferRequest direction remote key file)
+ | direction == Upload = notifyTransfer direction file $
+ upload (Remote.uuid remote) key file forwardRetry $ \p -> do
+ ok <- Remote.storeKey remote key file p
+ when ok $
+ Remote.logStatus remote key InfoPresent
+ return ok
+ | otherwise = notifyTransfer direction file $
+ download (Remote.uuid remote) key file forwardRetry $ \p ->
+ getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
+
+{- stdin and stdout are connected with the caller, to be used for
+ - communication with it. But doing a transfer might involve something
+ - that tries to read from stdin, or write to stdout. To avoid that, close
+ - stdin, and duplicate stderr to stdout. Return two new handles
+ - that are duplicates of the original (stdin, stdout). -}
+withHandles :: ((Handle, Handle) -> Annex a) -> Annex a
+withHandles a = do
+ readh <- liftIO $ hDuplicate stdin
+ writeh <- liftIO $ hDuplicate stdout
+ liftIO $ do
+ nullh <- openFile devNull ReadMode
+ nullh `hDuplicateTo` stdin
+ stderr `hDuplicateTo` stdout
+ a (readh, writeh)
+
+runRequests
+ :: Handle
+ -> Handle
+ -> (TransferRequest -> Annex Bool)
+ -> Annex ()
+runRequests readh writeh a = do
+ liftIO $ do
+ hSetBuffering readh NoBuffering
+ fileEncoding readh
+ fileEncoding writeh
+ go =<< readrequests
+ where
+ go (d:u:k:f:rest) = do
+ case (deserialize d, deserialize u, deserialize k, deserialize f) of
+ (Just direction, Just uuid, Just key, Just file) -> do
+ mremote <- Remote.remoteFromUUID uuid
+ case mremote of
+ Nothing -> sendresult False
+ Just remote -> sendresult =<< a
+ (TransferRequest direction remote key file)
+ _ -> sendresult False
+ go rest
+ go [] = noop
+ go [""] = noop
+ go v = error $ "transferkeys protocol error: " ++ show v
+
+ readrequests = liftIO $ split fieldSep <$> hGetContents readh
+ sendresult b = liftIO $ do
+ hPutStrLn writeh $ serialize b
+ hFlush writeh
+
+sendRequest :: Transfer -> AssociatedFile -> Handle -> IO ()
+sendRequest t f h = do
+ hPutStr h $ intercalate fieldSep
+ [ serialize (transferDirection t)
+ , serialize (transferUUID t)
+ , serialize (transferKey t)
+ , serialize f
+ , "" -- adds a trailing null
+ ]
+ hFlush h
+
+readResponse :: Handle -> IO Bool
+readResponse h = fromMaybe False . deserialize <$> hGetLine h
+
+fieldSep :: String
+fieldSep = "\0"
+
+class TCSerialized a where
+ serialize :: a -> String
+ deserialize :: String -> Maybe a
+
+instance TCSerialized Bool where
+ serialize True = "1"
+ serialize False = "0"
+ deserialize "1" = Just True
+ deserialize "0" = Just False
+ deserialize _ = Nothing
+
+instance TCSerialized Direction where
+ serialize Upload = "u"
+ serialize Download = "d"
+ deserialize "u" = Just Upload
+ deserialize "d" = Just Download
+ deserialize _ = Nothing
+
+instance TCSerialized AssociatedFile where
+ serialize (Just f) = f
+ serialize Nothing = ""
+ deserialize "" = Just Nothing
+ deserialize f = Just $ Just f
+
+instance TCSerialized UUID where
+ serialize = fromUUID
+ deserialize = Just . toUUID
+
+instance TCSerialized Key where
+ serialize = key2file
+ deserialize = file2key
diff --git a/Command/Trust.hs b/Command/Trust.hs
new file mode 100644
index 000000000..c0f013699
--- /dev/null
+++ b/Command/Trust.hs
@@ -0,0 +1,41 @@
+{- git-annex command
+ -
+ - Copyright 2010, 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Trust where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Types.TrustLevel
+import Logs.Trust
+import Logs.Group
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "trust" (paramRepeating paramRemote) seek
+ SectionSetup "trust a repository"]
+
+seek :: CommandSeek
+seek = trustCommand "trust" Trusted
+
+trustCommand :: String -> TrustLevel -> CommandSeek
+trustCommand cmd level = withWords start
+ where
+ start ws = do
+ let name = unwords ws
+ showStart cmd name
+ u <- Remote.nameToUUID name
+ next $ perform u
+ perform uuid = do
+ trustSet uuid level
+ when (level == DeadTrusted) $
+ groupSet uuid S.empty
+ l <- lookupTrust uuid
+ when (l /= level) $
+ warning $ "This remote's trust level is locally overridden to " ++ showTrustLevel l ++ " via git config."
+ next $ return True
diff --git a/Command/Unannex.hs b/Command/Unannex.hs
new file mode 100644
index 000000000..3da7c2a41
--- /dev/null
+++ b/Command/Unannex.hs
@@ -0,0 +1,111 @@
+{- git-annex command
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.Unannex where
+
+import Common.Annex
+import Command
+import Config
+import qualified Annex
+import Annex.Content
+import Annex.Content.Direct
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.DiffTree as DiffTree
+import Utility.CopyFile
+import Command.PreCommit (lockPreCommitHook)
+
+def :: [Command]
+def = [command "unannex" paramPaths seek SectionUtility
+ "undo accidential add command"]
+
+seek :: CommandSeek
+seek = wrapUnannex . (withFilesInGit $ whenAnnexed start)
+
+wrapUnannex :: Annex a -> Annex a
+wrapUnannex a = ifM isDirect
+ ( a
+ {- Run with the pre-commit hook disabled, to avoid confusing
+ - behavior if an unannexed file is added back to git as
+ - a normal, non-annexed file and then committed.
+ - Otherwise, the pre-commit hook would think that the file
+ - has been unlocked and needs to be re-annexed.
+ -
+ - At the end, make a commit removing the unannexed files.
+ -}
+ , ifM cleanindex
+ ( lockPreCommitHook $ commit `after` a
+ , error "Cannot proceed with uncommitted changes staged in the index. Recommend you: git commit"
+ )
+ )
+ where
+ commit = inRepo $ Git.Command.run
+ [ Param "commit"
+ , Param "-q"
+ , Param "--allow-empty"
+ , Param "--no-verify"
+ , Param "-m", Param "content removed from git annex"
+ ]
+ cleanindex = do
+ (diff, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+ if null diff
+ then void (liftIO cleanup) >> return True
+ else void (liftIO cleanup) >> return False
+
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, _) = stopUnless (inAnnex key) $ do
+ showStart "unannex" file
+ next $ ifM isDirect
+ ( performDirect file key
+ , performIndirect file key)
+
+performIndirect :: FilePath -> Key -> CommandPerform
+performIndirect file key = do
+ liftIO $ removeFile file
+ inRepo $ Git.Command.run [Params "rm --cached --force --quiet --", File file]
+ next $ cleanupIndirect file key
+
+cleanupIndirect :: FilePath -> Key -> CommandCleanup
+cleanupIndirect file key = do
+ src <- calcRepo $ gitAnnexLocation key
+ ifM (Annex.getState Annex.fast)
+ ( hardlinkfrom src
+ , copyfrom src
+ )
+ where
+ copyfrom src =
+ thawContent file `after` liftIO (copyFileExternal src file)
+ hardlinkfrom src =
+#ifndef mingw32_HOST_OS
+ -- creating a hard link could fall; fall back to copying
+ ifM (liftIO $ catchBoolIO $ createLink src file >> return True)
+ ( return True
+ , copyfrom src
+ )
+#else
+ copyfrom src
+#endif
+
+performDirect :: FilePath -> Key -> CommandPerform
+performDirect file key = do
+ -- --force is needed when the file is not committed
+ inRepo $ Git.Command.run [Params "rm --cached --force --quiet --", File file]
+ next $ cleanupDirect file key
+
+{- The direct mode file is not touched during unannex, so the content
+ - is already where it needs to be, so this does not need to do anything
+ - except remove it from the associated file map (which also updates
+ - the location log if this was the last copy), and, if this was the last
+ - associated file, remove the inode cache. -}
+cleanupDirect :: FilePath -> Key -> CommandCleanup
+cleanupDirect file key = do
+ fs <- removeAssociatedFile key file
+ when (null fs) $
+ removeInodeCache key
+ return True
diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs
new file mode 100644
index 000000000..a88e3f7c8
--- /dev/null
+++ b/Command/Ungroup.hs
@@ -0,0 +1,35 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Ungroup where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.Group
+import Types.Group
+
+import qualified Data.Set as S
+
+def :: [Command]
+def = [command "ungroup" (paramPair paramRemote paramDesc) seek
+ SectionSetup "remove a repository from a group"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start (name:g:[]) = do
+ showStart "ungroup" name
+ u <- Remote.nameToUUID name
+ next $ perform u g
+start _ = error "Specify a repository and a group."
+
+perform :: UUID -> Group -> CommandPerform
+perform uuid g = do
+ groupChange uuid (S.delete g)
+ next $ return True
diff --git a/Command/Uninit.hs b/Command/Uninit.hs
new file mode 100644
index 000000000..5b2adf0bd
--- /dev/null
+++ b/Command/Uninit.hs
@@ -0,0 +1,99 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Uninit where
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Command.Unannex
+import qualified Annex.Branch
+import Annex.Content
+import Annex.Init
+
+def :: [Command]
+def = [addCheck check $ command "uninit" paramPaths seek
+ SectionUtility "de-initialize git-annex and clean out repository"]
+
+check :: Annex ()
+check = do
+ b <- current_branch
+ when (b == Annex.Branch.name) $ error $
+ "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
+ top <- fromRepo Git.repoPath
+ cwd <- liftIO getCurrentDirectory
+ whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $
+ error "can only run uninit from the top of the git repository"
+ where
+ current_branch = Git.Ref . Prelude.head . lines <$> revhead
+ revhead = inRepo $ Git.Command.pipeReadStrict
+ [Params "rev-parse --abbrev-ref HEAD"]
+
+seek :: CommandSeek
+seek ps = do
+ withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps
+ withFilesInGit (whenAnnexed Command.Unannex.start) ps
+ finish
+
+{- git annex symlinks that are not checked into git could be left by an
+ - interrupted add. -}
+startCheckIncomplete :: FilePath -> (Key, Backend) -> CommandStart
+startCheckIncomplete file _ = error $ unlines
+ [ file ++ " points to annexed content, but is not checked into git."
+ , "Perhaps this was left behind by an interrupted git annex add?"
+ , "Not continuing with uninit; either delete or git annex add the file and retry."
+ ]
+
+finish :: Annex ()
+finish = do
+ annexdir <- fromRepo gitAnnexDir
+ annexobjectdir <- fromRepo gitAnnexObjectDir
+ leftovers <- removeUnannexed =<< getKeysPresent InAnnex
+ if null leftovers
+ then liftIO $ removeDirectoryRecursive annexdir
+ else error $ unlines
+ [ "Not fully uninitialized"
+ , "Some annexed data is still left in " ++ annexobjectdir
+ , "This may include deleted files, or old versions of modified files."
+ , ""
+ , "If you don't care about preserving the data, just delete the"
+ , "directory."
+ , ""
+ , "Or, you can move it to another location, in case it turns out"
+ , "something in there is important."
+ , ""
+ , "Or, you can run `git annex unused` followed by `git annex dropunused`"
+ , "to remove data that is not used by any tag or branch, which might"
+ , "take care of all the data."
+ , ""
+ , "Then run `git annex uninit` again to finish."
+ ]
+ uninitialize
+ -- avoid normal shutdown
+ saveState False
+ inRepo $ Git.Command.run
+ [Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
+ liftIO exitSuccess
+
+{- Keys that were moved out of the annex have a hard link still in the
+ - annex, with > 1 link count, and those can be removed.
+ -
+ - Returns keys that cannot be removed. -}
+removeUnannexed :: [Key] -> Annex [Key]
+removeUnannexed = go []
+ where
+ go c [] = return c
+ go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks)
+ ( do
+ removeAnnex k
+ go c ks
+ , go (k:c) ks
+ )
+ enoughlinks f = catchBoolIO $ do
+ s <- getFileStatus f
+ return $ linkCount s > 1
diff --git a/Command/Unlock.hs b/Command/Unlock.hs
new file mode 100644
index 000000000..4cfe39307
--- /dev/null
+++ b/Command/Unlock.hs
@@ -0,0 +1,50 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Unlock where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Utility.CopyFile
+
+def :: [Command]
+def =
+ [ c "unlock" "unlock files for modification"
+ , c "edit" "same as unlock"
+ ]
+ where
+ c n = notDirect . command n paramPaths seek SectionCommon
+
+seek :: CommandSeek
+seek = withFilesInGit $ whenAnnexed start
+
+{- The unlock subcommand replaces the symlink with a copy of the file's
+ - content. -}
+start :: FilePath -> (Key, Backend) -> CommandStart
+start file (key, _) = do
+ showStart "unlock" file
+ next $ perform file key
+
+perform :: FilePath -> Key -> CommandPerform
+perform dest key = do
+ unlessM (inAnnex key) $ error "content not present"
+ unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock"
+
+ src <- calcRepo $ gitAnnexLocation key
+ tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key
+ liftIO $ createDirectoryIfMissing True (parentDir tmpdest)
+ showAction "copying"
+ ifM (liftIO $ copyFileExternal src tmpdest)
+ ( do
+ liftIO $ do
+ removeFile dest
+ moveFile tmpdest dest
+ thawContent dest
+ next $ return True
+ , error "copy failed!"
+ )
diff --git a/Command/Untrust.hs b/Command/Untrust.hs
new file mode 100644
index 000000000..4c1035dcd
--- /dev/null
+++ b/Command/Untrust.hs
@@ -0,0 +1,19 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Untrust where
+
+import Command
+import Types.TrustLevel
+import Command.Trust (trustCommand)
+
+def :: [Command]
+def = [command "untrust" (paramRepeating paramRemote) seek
+ SectionSetup "do not trust a repository"]
+
+seek :: CommandSeek
+seek = trustCommand "untrust" UnTrusted
diff --git a/Command/Unused.hs b/Command/Unused.hs
new file mode 100644
index 000000000..3e844e5a8
--- /dev/null
+++ b/Command/Unused.hs
@@ -0,0 +1,371 @@
+{- git-annex command
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Command.Unused where
+
+import qualified Data.Set as S
+import Data.BloomFilter
+import Data.BloomFilter.Easy
+import Data.BloomFilter.Hash
+import Control.Monad.ST
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import Logs.Unused
+import Annex.Content
+import Logs.Location
+import Logs.Transfer
+import qualified Annex
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.Branch
+import qualified Git.LsFiles as LsFiles
+import qualified Git.DiffTree as DiffTree
+import qualified Backend
+import qualified Remote
+import qualified Annex.Branch
+import Annex.CatFile
+import Types.Key
+import Git.FilePath
+
+def :: [Command]
+def = [withOptions [unusedFromOption] $ command "unused" paramNothing seek
+ SectionMaintenance "look for unused file content"]
+
+unusedFromOption :: Option
+unusedFromOption = fieldOption ['f'] "from" paramRemote "remote to check for unused content"
+
+seek :: CommandSeek
+seek = withNothing start
+
+{- Finds unused content in the annex. -}
+start :: CommandStart
+start = do
+ from <- Annex.getField $ optionName unusedFromOption
+ let (name, action) = case from of
+ Nothing -> (".", checkUnused)
+ Just "." -> (".", checkUnused)
+ Just "here" -> (".", checkUnused)
+ Just n -> (n, checkRemoteUnused n)
+ showStart "unused" name
+ next action
+
+checkUnused :: CommandPerform
+checkUnused = chain 0
+ [ check "" unusedMsg $ findunused =<< Annex.getState Annex.fast
+ , check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir False
+ , check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpObjectDir True
+ ]
+ where
+ findunused True = do
+ showNote "fast mode enabled; only finding stale files"
+ return []
+ findunused False = do
+ showAction "checking for unused data"
+ -- InAnnex, not InRepository because if a direct mode
+ -- file exists, it is obviously not unused.
+ excludeReferenced =<< getKeysPresent InAnnex
+ chain _ [] = next $ return True
+ chain v (a:as) = do
+ v' <- a v
+ chain v' as
+
+checkRemoteUnused :: String -> CommandPerform
+checkRemoteUnused name = go =<< fromJust <$> Remote.byNameWithUUID (Just name)
+ where
+ go r = do
+ showAction "checking for unused data"
+ _ <- check "" (remoteUnusedMsg r) (remoteunused r) 0
+ next $ return True
+ remoteunused r = excludeReferenced <=< loggedKeysFor $ Remote.uuid r
+
+check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int
+check file msg a c = do
+ l <- a
+ let unusedlist = number c l
+ unless (null l) $ showLongNote $ msg unusedlist
+ updateUnusedLog file $ M.fromList unusedlist
+ return $ c + length l
+
+number :: Int -> [a] -> [(Int, a)]
+number _ [] = []
+number n (x:xs) = (n+1, x) : number (n+1) xs
+
+table :: [(Int, Key)] -> [String]
+table l = " NUMBER KEY" : map cols l
+ where
+ cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k
+ pad n s = s ++ replicate (n - length s) ' '
+
+staleTmpMsg :: [(Int, Key)] -> String
+staleTmpMsg t = unlines $
+ ["Some partially transferred data exists in temporary files:"]
+ ++ table t ++ [dropMsg Nothing]
+
+staleBadMsg :: [(Int, Key)] -> String
+staleBadMsg t = unlines $
+ ["Some corrupted files have been preserved by fsck, just in case:"]
+ ++ table t ++ [dropMsg Nothing]
+
+unusedMsg :: [(Int, Key)] -> String
+unusedMsg u = unusedMsg' u
+ ["Some annexed data is no longer used by any files:"]
+ [dropMsg Nothing]
+unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String
+unusedMsg' u header trailer = unlines $
+ header ++
+ table u ++
+ ["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
+ trailer
+
+remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
+remoteUnusedMsg r u = unusedMsg' u
+ ["Some annexed data on " ++ name ++ " is not used by any files:"]
+ [dropMsg $ Just r]
+ where
+ name = Remote.name r
+
+dropMsg :: Maybe Remote -> String
+dropMsg Nothing = dropMsg' ""
+dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
+dropMsg' :: String -> String
+dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\n"
+
+{- Finds keys in the list that are not referenced in the git repository.
+ -
+ - Strategy:
+ -
+ - * Build a bloom filter of all keys referenced by symlinks. This
+ - is the fastest one to build and will filter out most keys.
+ - * If keys remain, build a second bloom filter of keys referenced by
+ - all branches.
+ - * The list is streamed through these bloom filters lazily, so both will
+ - exist at the same time. This means that twice the memory is used,
+ - but they're relatively small, so the added complexity of using a
+ - mutable bloom filter does not seem worthwhile.
+ - * Generating the second bloom filter can take quite a while, since
+ - it needs enumerating all keys in all git branches. But, the common
+ - case, if the second filter is needed, is for some keys to be globally
+ - unused, and in that case, no short-circuit is possible.
+ - Short-circuiting if the first filter filters all the keys handles the
+ - other common case.
+ -}
+excludeReferenced :: [Key] -> Annex [Key]
+excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel
+ where
+ runfilter _ [] = return [] -- optimisation
+ runfilter a l = bloomFilter show l <$> genBloomFilter show a
+ firstlevel = withKeysReferencedM
+ secondlevel = withKeysReferencedInGit
+
+{- Finds items in the first, smaller list, that are not
+ - present in the second, larger list.
+ -
+ - Constructing a single set, of the list that tends to be
+ - smaller, appears more efficient in both memory and CPU
+ - than constructing and taking the S.difference of two sets. -}
+exclude :: Ord a => [a] -> [a] -> [a]
+exclude [] _ = [] -- optimisation
+exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
+ where
+ remove a b = foldl (flip S.delete) b a
+
+{- A bloom filter capable of holding half a million keys with a
+ - false positive rate of 1 in 1000 uses around 8 mb of memory,
+ - so will easily fit on even my lowest memory systems.
+ -}
+bloomCapacity :: Annex Int
+bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig
+bloomAccuracy :: Annex Int
+bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getGitConfig
+bloomBitsHashes :: Annex (Int, Int)
+bloomBitsHashes = do
+ capacity <- bloomCapacity
+ accuracy <- bloomAccuracy
+ return $ suggestSizing capacity (1/ fromIntegral accuracy)
+
+{- Creates a bloom filter, and runs an action, such as withKeysReferenced,
+ - to populate it.
+ -
+ - The action is passed a callback that it can use to feed values into the
+ - bloom filter.
+ -
+ - Once the action completes, the mutable filter is frozen
+ - for later use.
+ -}
+genBloomFilter :: Hashable t => (v -> t) -> ((v -> Annex ()) -> Annex b) -> Annex (Bloom t)
+genBloomFilter convert populate = do
+ (numbits, numhashes) <- bloomBitsHashes
+ bloom <- lift $ newMB (cheapHashes numhashes) numbits
+ _ <- populate $ \v -> lift $ insertMB bloom (convert v)
+ lift $ unsafeFreezeMB bloom
+ where
+ lift = liftIO . stToIO
+
+bloomFilter :: Hashable t => (v -> t) -> [v] -> Bloom t -> [v]
+bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l
+
+{- Given an initial value, folds it with each key referenced by
+ - symlinks in the git repo. -}
+withKeysReferenced :: v -> (Key -> v -> v) -> Annex v
+withKeysReferenced initial a = withKeysReferenced' Nothing initial folda
+ where
+ folda k _ v = return $ a k v
+
+{- Runs an action on each referenced key in the git repo. -}
+withKeysReferencedM :: (Key -> Annex ()) -> Annex ()
+withKeysReferencedM a = withKeysReferenced' Nothing () calla
+ where
+ calla k _ _ = a k
+
+{- Folds an action over keys and files referenced in a particular directory. -}
+withKeysFilesReferencedIn :: FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v
+withKeysFilesReferencedIn = withKeysReferenced' . Just
+
+withKeysReferenced' :: Maybe FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v
+withKeysReferenced' mdir initial a = do
+ (files, clean) <- getfiles
+ r <- go initial files
+ liftIO $ void clean
+ return r
+ where
+ getfiles = case mdir of
+ Nothing -> ifM isBareRepo
+ ( return ([], return True)
+ , do
+ top <- fromRepo Git.repoPath
+ inRepo $ LsFiles.allFiles [top]
+ )
+ Just dir -> inRepo $ LsFiles.inRepo [dir]
+ go v [] = return v
+ go v (f:fs) = do
+ x <- Backend.lookupFile f
+ case x of
+ Nothing -> go v fs
+ Just (k, _) -> do
+ !v' <- a k f v
+ go v' fs
+
+withKeysReferencedInGit :: (Key -> Annex ()) -> Annex ()
+withKeysReferencedInGit a = do
+ current <- inRepo Git.Branch.currentUnsafe
+ shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) current
+ showref >>= mapM_ (withKeysReferencedInGitRef a) .
+ relevantrefs (shaHead, current)
+ where
+ showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"]
+ relevantrefs headRef = addHead headRef .
+ filter ourbranches .
+ map (separate (== ' ')) .
+ lines
+ nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y)
+ ourbranchend = '/' : Git.fromRef Annex.Branch.name
+ ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
+ && not ("refs/synced/" `isPrefixOf` b)
+ addHead headRef refs = case headRef of
+ -- if HEAD diverges from all branches (except the branch it
+ -- points to), run the actions on staged keys (and keys
+ -- that are only present in the work tree if the repo is
+ -- non bare)
+ (Just (Git.Ref x), Just (Git.Ref b))
+ | all (\(x',b') -> x /= x' || b == b') refs ->
+ Git.Ref.headRef
+ : nubRefs (filter ((/= x) . fst) refs)
+ _ -> nubRefs refs
+
+{- Runs an action on keys referenced in the given Git reference which
+ - differ from those referenced in the index. -}
+withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
+withKeysReferencedInGitRef a ref = do
+ showAction $ "checking " ++ Git.Ref.describe ref
+ bare <- isBareRepo
+ (ts,clean) <- inRepo $ if bare
+ then DiffTree.diffIndex ref
+ else DiffTree.diffWorkTree ref
+ let lookAtWorkingTree = not bare && ref == Git.Ref.headRef
+ forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a
+ liftIO $ void clean
+ where
+ tKey True = fmap fst <$$> Backend.lookupFile . getTopFilePath . DiffTree.file
+ tKey False = fileKey . takeFileName . decodeBS <$$>
+ catFile ref . getTopFilePath . DiffTree.file
+
+{- Looks in the specified directory for bad/tmp keys, and returns a list
+ - of those that might still have value, or might be stale and removable.
+ -
+ - Also, stale keys that can be proven to have no value are deleted.
+ -}
+staleKeysPrune :: (Git.Repo -> FilePath) -> Bool -> Annex [Key]
+staleKeysPrune dirspec nottransferred = do
+ contents <- dirKeys dirspec
+
+ dups <- filterM inAnnex contents
+ let stale = contents `exclude` dups
+
+ dir <- fromRepo dirspec
+ liftIO $ forM_ dups $ \t -> removeFile $ dir </> keyFile t
+
+ if nottransferred
+ then do
+ inprogress <- S.fromList . map (transferKey . fst)
+ <$> getTransfers
+ return $ filter (`S.notMember` inprogress) stale
+ else return stale
+
+data UnusedMaps = UnusedMaps
+ { unusedMap :: UnusedMap
+ , unusedBadMap :: UnusedMap
+ , unusedTmpMap :: UnusedMap
+ }
+
+withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek
+withUnusedMaps a params = do
+ unused <- readUnusedMap ""
+ unusedbad <- readUnusedMap "bad"
+ unusedtmp <- readUnusedMap "tmp"
+ let m = unused `M.union` unusedbad `M.union` unusedtmp
+ let unusedmaps = UnusedMaps unused unusedbad unusedtmp
+ seekActions $ return $ map (a unusedmaps) $
+ concatMap (unusedSpec m) params
+
+unusedSpec :: UnusedMap -> String -> [Int]
+unusedSpec m spec
+ | spec == "all" = if M.null m
+ then []
+ else [fst (M.findMin m)..fst (M.findMax m)]
+ | "-" `isInfixOf` spec = range $ separate (== '-') spec
+ | otherwise = maybe badspec (: []) (readish spec)
+ where
+ range (a, b) = case (readish a, readish b) of
+ (Just x, Just y) -> [x..y]
+ _ -> badspec
+ badspec = error $ "Expected number or range, not \"" ++ spec ++ "\""
+
+{- Seek action for unused content. Finds the number in the maps, and
+ - calls one of 3 actions, depending on the type of unused file. -}
+startUnused :: String
+ -> (Key -> CommandPerform)
+ -> (Key -> CommandPerform)
+ -> (Key -> CommandPerform)
+ -> UnusedMaps -> Int -> CommandStart
+startUnused message unused badunused tmpunused maps n = search
+ [ (unusedMap maps, unused)
+ , (unusedBadMap maps, badunused)
+ , (unusedTmpMap maps, tmpunused)
+ ]
+ where
+ search [] = error $ show n ++ " not valid (run git annex unused for list)"
+ search ((m, a):rest) =
+ case M.lookup n m of
+ Nothing -> search rest
+ Just key -> do
+ showStart message (show n)
+ next $ a key
diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs
new file mode 100644
index 000000000..80876290a
--- /dev/null
+++ b/Command/Upgrade.hs
@@ -0,0 +1,26 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Upgrade where
+
+import Common.Annex
+import Command
+import Upgrade
+
+def :: [Command]
+def = [dontCheck repoExists $ -- because an old version may not seem to exist
+ command "upgrade" paramNothing seek
+ SectionMaintenance "upgrade repository layout"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = do
+ showStart "upgrade" "."
+ r <- upgrade False
+ next $ next $ return r
diff --git a/Command/VAdd.hs b/Command/VAdd.hs
new file mode 100644
index 000000000..e3726a051
--- /dev/null
+++ b/Command/VAdd.hs
@@ -0,0 +1,36 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VAdd where
+
+import Common.Annex
+import Command
+import Annex.View
+import Command.View (checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $ command "vadd" (paramRepeating "FIELD=GLOB")
+ seek SectionMetaData "add subdirs to current view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start params = do
+ showStart "vadd" ""
+ withCurrentView $ \view -> do
+ let (view', change) = refineView view $
+ map parseViewParam $ reverse params
+ case change of
+ Unchanged -> do
+ showNote "unchanged"
+ next $ next $ return True
+ Narrowing -> next $ next $ do
+ if visibleViewSize view' == visibleViewSize view
+ then error "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
+ else checkoutViewBranch view' narrowView
+ Widening -> error "Widening view to match more files is not currently supported."
diff --git a/Command/VCycle.hs b/Command/VCycle.hs
new file mode 100644
index 000000000..f7da47fa2
--- /dev/null
+++ b/Command/VCycle.hs
@@ -0,0 +1,41 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VCycle where
+
+import Common.Annex
+import Command
+import Annex.View
+import Types.View
+import Logs.View
+import Command.View (checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+ command "vcycle" paramNothing seek SectionUtility
+ "switch view to next layout"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start ::CommandStart
+start = go =<< currentView
+ where
+ go Nothing = error "Not in a view."
+ go (Just v) = do
+ showStart "vcycle" ""
+ let v' = v { viewComponents = vcycle [] (viewComponents v) }
+ if v == v'
+ then do
+ showNote "unchanged"
+ next $ next $ return True
+ else next $ next $ checkoutViewBranch v' narrowView
+
+ vcycle rest (c:cs)
+ | viewVisible c = rest ++ cs ++ [c]
+ | otherwise = vcycle (c:rest) cs
+ vcycle rest c = rest ++ c
diff --git a/Command/VFilter.hs b/Command/VFilter.hs
new file mode 100644
index 000000000..bd17aca45
--- /dev/null
+++ b/Command/VFilter.hs
@@ -0,0 +1,30 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VFilter where
+
+import Common.Annex
+import Command
+import Annex.View
+import Command.View (paramView, checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+ command "vfilter" paramView seek SectionMetaData "filter current view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start params = do
+ showStart "vfilter" ""
+ withCurrentView $ \view -> do
+ let view' = filterView view $
+ map parseViewParam $ reverse params
+ next $ next $ if visibleViewSize view' > visibleViewSize view
+ then error "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
+ else checkoutViewBranch view' narrowView
diff --git a/Command/VPop.hs b/Command/VPop.hs
new file mode 100644
index 000000000..706a522f8
--- /dev/null
+++ b/Command/VPop.hs
@@ -0,0 +1,50 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.VPop where
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import Types.View
+import Logs.View
+import Command.View (checkoutViewBranch)
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+ command "vpop" (paramOptional paramNumber) seek SectionMetaData
+ "switch back to previous view"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start ps = go =<< currentView
+ where
+ go Nothing = error "Not in a view."
+ go (Just v) = do
+ showStart "vpop" (show num)
+ removeView v
+ (oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
+ <$> recentViews
+ mapM_ removeView oldvs
+ case vs of
+ (oldv:_) -> next $ next $ do
+ showOutput
+ checkoutViewBranch oldv (return . branchView)
+ _ -> next $ next $ do
+ showOutput
+ inRepo $ Git.Command.runBool
+ [ Param "checkout"
+ , Param $ Git.fromRef $ Git.Ref.base $
+ viewParentBranch v
+ ]
+ sameparentbranch a b = viewParentBranch a == viewParentBranch b
+
+ num = fromMaybe 1 $ readish =<< headMaybe ps
diff --git a/Command/Version.hs b/Command/Version.hs
new file mode 100644
index 000000000..526b752f0
--- /dev/null
+++ b/Command/Version.hs
@@ -0,0 +1,49 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Version where
+
+import Common.Annex
+import Command
+import qualified Build.SysConfig as SysConfig
+import Annex.Version
+import BuildFlags
+import qualified Types.Backend as B
+import qualified Types.Remote as R
+import qualified Remote
+import qualified Backend
+
+def :: [Command]
+def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
+ command "version" paramNothing seek SectionQuery "show version info"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = do
+ v <- getVersion
+ liftIO $ do
+ showPackageVersion
+ info "local repository version" $ fromMaybe "unknown" v
+ info "supported repository version" supportedVersion
+ info "upgrade supported from repository versions" $
+ unwords upgradableVersions
+ stop
+
+startNoRepo :: CmdParams -> IO ()
+startNoRepo _ = showPackageVersion
+
+showPackageVersion :: IO ()
+showPackageVersion = do
+ info "git-annex version" SysConfig.packageversion
+ info "build flags" $ unwords buildFlags
+ info "key/value backends" $ unwords $ map B.name Backend.list
+ info "remote types" $ unwords $ map R.typename Remote.remoteTypes
+
+info :: String -> String -> IO ()
+info k v = putStrLn $ k ++ ": " ++ v
diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs
new file mode 100644
index 000000000..d7d5229da
--- /dev/null
+++ b/Command/Vicfg.hs
@@ -0,0 +1,278 @@
+{- git-annex command
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Vicfg where
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import System.Environment (getEnv)
+import Data.Tuple (swap)
+import Data.Char (isSpace)
+
+import Common.Annex
+import Command
+import Annex.Perms
+import Types.TrustLevel
+import Types.Group
+import Logs.Trust
+import Logs.Group
+import Logs.PreferredContent
+import Logs.Schedule
+import Types.StandardGroups
+import Types.ScheduledActivity
+import Remote
+
+def :: [Command]
+def = [command "vicfg" paramNothing seek
+ SectionSetup "edit git-annex's configuration"]
+
+seek :: CommandSeek
+seek = withNothing start
+
+start :: CommandStart
+start = do
+ f <- fromRepo gitAnnexTmpCfgFile
+ createAnnexDirectory $ parentDir f
+ cfg <- getCfg
+ descs <- uuidDescriptions
+ liftIO $ writeFile f $ genCfg cfg descs
+ vicfg cfg f
+ stop
+
+vicfg :: Cfg -> FilePath -> Annex ()
+vicfg curcfg f = do
+ vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR"
+ -- Allow EDITOR to be processed by the shell, so it can contain options.
+ unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
+ error $ vi ++ " exited nonzero; aborting"
+ r <- parseCfg curcfg <$> liftIO (readFileStrict f)
+ liftIO $ nukeFile f
+ case r of
+ Left s -> do
+ liftIO $ writeFile f s
+ vicfg curcfg f
+ Right newcfg -> setCfg curcfg newcfg
+
+data Cfg = Cfg
+ { cfgTrustMap :: TrustMap
+ , cfgGroupMap :: M.Map UUID (S.Set Group)
+ , cfgPreferredContentMap :: M.Map UUID PreferredContentExpression
+ , cfgRequiredContentMap :: M.Map UUID PreferredContentExpression
+ , cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression
+ , cfgScheduleMap :: M.Map UUID [ScheduledActivity]
+ }
+
+getCfg :: Annex Cfg
+getCfg = Cfg
+ <$> trustMapRaw -- without local trust overrides
+ <*> (groupsByUUID <$> groupMap)
+ <*> preferredContentMapRaw
+ <*> requiredContentMapRaw
+ <*> groupPreferredContentMapRaw
+ <*> scheduleMap
+
+setCfg :: Cfg -> Cfg -> Annex ()
+setCfg curcfg newcfg = do
+ let diff = diffCfg curcfg newcfg
+ mapM_ (uncurry trustSet) $ M.toList $ cfgTrustMap diff
+ mapM_ (uncurry groupSet) $ M.toList $ cfgGroupMap diff
+ mapM_ (uncurry preferredContentSet) $ M.toList $ cfgPreferredContentMap diff
+ mapM_ (uncurry requiredContentSet) $ M.toList $ cfgRequiredContentMap diff
+ mapM_ (uncurry groupPreferredContentSet) $ M.toList $ cfgGroupPreferredContentMap diff
+ mapM_ (uncurry scheduleSet) $ M.toList $ cfgScheduleMap diff
+
+diffCfg :: Cfg -> Cfg -> Cfg
+diffCfg curcfg newcfg = Cfg
+ { cfgTrustMap = diff cfgTrustMap
+ , cfgGroupMap = diff cfgGroupMap
+ , cfgPreferredContentMap = diff cfgPreferredContentMap
+ , cfgRequiredContentMap = diff cfgRequiredContentMap
+ , cfgGroupPreferredContentMap = diff cfgGroupPreferredContentMap
+ , cfgScheduleMap = diff cfgScheduleMap
+ }
+ where
+ diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
+ (f newcfg) (f curcfg)
+
+genCfg :: Cfg -> M.Map UUID String -> String
+genCfg cfg descs = unlines $ intercalate [""]
+ [ intro
+ , trust
+ , groups
+ , preferredcontent
+ , grouppreferredcontent
+ , standardgroups
+ , requiredcontent
+ , schedule
+ ]
+ where
+ intro =
+ [ com "git-annex configuration"
+ , com ""
+ , com "Changes saved to this file will be recorded in the git-annex branch."
+ , com ""
+ , com "Lines in this file have the format:"
+ , com " setting field = value"
+ ]
+
+ trust = settings cfg descs cfgTrustMap
+ [ com "Repository trust configuration"
+ , com "(Valid trust levels: " ++ trustlevels ++ ")"
+ ]
+ (\(t, u) -> line "trust" u $ showTrustLevel t)
+ (\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted)
+ where
+ trustlevels = unwords $ map showTrustLevel [Trusted .. DeadTrusted]
+
+ groups = settings cfg descs cfgGroupMap
+ [ com "Repository groups"
+ , com $ "(Standard groups: " ++ grouplist ++ ")"
+ , com "(Separate group names with spaces)"
+ ]
+ (\(s, u) -> line "group" u $ unwords $ S.toList s)
+ (\u -> lcom $ line "group" u "")
+ where
+ grouplist = unwords $ map fromStandardGroup [minBound..]
+
+ preferredcontent = settings cfg descs cfgPreferredContentMap
+ [ com "Repository preferred contents" ]
+ (\(s, u) -> line "wanted" u s)
+ (\u -> line "wanted" u "standard")
+
+ requiredcontent = settings cfg descs cfgRequiredContentMap
+ [ com "Repository required contents" ]
+ (\(s, u) -> line "required" u s)
+ (\u -> line "required" u "")
+
+ grouppreferredcontent = settings' cfg allgroups cfgGroupPreferredContentMap
+ [ com "Group preferred contents"
+ , com "(Used by repositories with \"groupwanted\" in their preferred contents)"
+ ]
+ (\(s, g) -> gline g s)
+ (\g -> gline g "standard")
+ where
+ gline g value = [ unwords ["groupwanted", g, "=", value] ]
+ allgroups = S.unions $ stdgroups : M.elems (cfgGroupMap cfg)
+ stdgroups = S.fromList $ map fromStandardGroup [minBound..maxBound]
+
+ standardgroups =
+ [ com "Standard preferred contents"
+ , com "(Used by wanted or groupwanted expressions containing \"standard\")"
+ , com "(For reference only; built-in and cannot be changed!)"
+ ]
+ ++ map gline [minBound..maxBound]
+ where
+ gline g = com $ unwords
+ [ "standard"
+ , fromStandardGroup g, "=", standardPreferredContent g
+ ]
+
+ schedule = settings cfg descs cfgScheduleMap
+ [ com "Scheduled activities"
+ , com "(Separate multiple activities with \"; \")"
+ ]
+ (\(l, u) -> line "schedule" u $ fromScheduledActivities l)
+ (\u -> line "schedule" u "")
+
+ line setting u value =
+ [ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")"
+ , unwords [setting, fromUUID u, "=", value]
+ ]
+
+settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String]
+settings cfg descs = settings' cfg (M.keysSet descs)
+
+settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String]
+settings' cfg s field desc showvals showdefaults = concat
+ [ desc
+ , concatMap showvals $ sort $ map swap $ M.toList $ field cfg
+ , concatMap (lcom . showdefaults) missing
+ ]
+ where
+ missing = S.toList $ s `S.difference` M.keysSet (field cfg)
+
+lcom :: [String] -> [String]
+lcom = map (\l -> if "#" `isPrefixOf` l then l else '#' : l)
+
+{- If there's a parse error, returns a new version of the file,
+ - with the problem lines noted. -}
+parseCfg :: Cfg -> String -> Either String Cfg
+parseCfg curcfg = go [] curcfg . lines
+ where
+ go c cfg []
+ | null (mapMaybe fst c) = Right cfg
+ | otherwise = Left $ unlines $
+ badheader ++ concatMap showerr (reverse c)
+ go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of
+ Left msg -> go ((Just msg, l):c) cfg ls
+ Right cfg' -> go ((Nothing, l):c) cfg' ls
+
+ parse l cfg
+ | null l = Right cfg
+ | "#" `isPrefixOf` l = Right cfg
+ | null setting || null f = Left "missing field"
+ | otherwise = handle cfg f setting value'
+ where
+ (setting, rest) = separate isSpace l
+ (r, value) = separate (== '=') rest
+ value' = trimspace value
+ f = reverse $ trimspace $ reverse $ trimspace r
+ trimspace = dropWhile isSpace
+
+ handle cfg f setting value
+ | setting == "trust" = case readTrustLevel value of
+ Nothing -> badval "trust value" value
+ Just t ->
+ let m = M.insert u t (cfgTrustMap cfg)
+ in Right $ cfg { cfgTrustMap = m }
+ | setting == "group" =
+ let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)
+ in Right $ cfg { cfgGroupMap = m }
+ | setting == "wanted" =
+ case checkPreferredContentExpression value of
+ Just e -> Left e
+ Nothing ->
+ let m = M.insert u value (cfgPreferredContentMap cfg)
+ in Right $ cfg { cfgPreferredContentMap = m }
+ | setting == "required" =
+ case checkPreferredContentExpression value of
+ Just e -> Left e
+ Nothing ->
+ let m = M.insert u value (cfgRequiredContentMap cfg)
+ in Right $ cfg { cfgRequiredContentMap = m }
+ | setting == "groupwanted" =
+ case checkPreferredContentExpression value of
+ Just e -> Left e
+ Nothing ->
+ let m = M.insert f value (cfgGroupPreferredContentMap cfg)
+ in Right $ cfg { cfgGroupPreferredContentMap = m }
+ | setting == "schedule" = case parseScheduledActivities value of
+ Left e -> Left e
+ Right l ->
+ let m = M.insert u l (cfgScheduleMap cfg)
+ in Right $ cfg { cfgScheduleMap = m }
+ | otherwise = badval "setting" setting
+ where
+ u = toUUID f
+
+ showerr (Just msg, l) = [parseerr ++ msg, l]
+ showerr (Nothing, l)
+ -- filter out the header and parse error lines
+ -- from any previous parse failure
+ | any (`isPrefixOf` l) (parseerr:badheader) = []
+ | otherwise = [l]
+
+ badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\""
+ badheader =
+ [ com "** There was a problem parsing your input!"
+ , com "** Search for \"Parse error\" to find the bad lines."
+ , com "** Either fix the bad lines, or delete them (to discard your changes)."
+ ]
+ parseerr = com "** Parse error in next line: "
+
+com :: String -> String
+com s = "# " ++ s
diff --git a/Command/View.hs b/Command/View.hs
new file mode 100644
index 000000000..93b045c39
--- /dev/null
+++ b/Command/View.hs
@@ -0,0 +1,82 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.View where
+
+import Common.Annex
+import Command
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.Branch
+import Types.View
+import Annex.View
+import Logs.View
+
+def :: [Command]
+def = [notBareRepo $ notDirect $
+ command "view" paramView seek SectionMetaData "enter a view branch"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start [] = error "Specify metadata to include in view"
+start params = do
+ showStart "view" ""
+ view <- mkView params
+ go view =<< currentView
+ where
+ go view Nothing = next $ perform view
+ go view (Just v)
+ | v == view = stop
+ | otherwise = error "Already in a view. Use the vfilter and vadd commands to further refine this view."
+
+perform :: View -> CommandPerform
+perform view = do
+ showSideAction "searching"
+ next $ checkoutViewBranch view applyView
+
+paramView :: String
+paramView = paramPair (paramRepeating "TAG") (paramRepeating "FIELD=VALUE")
+
+mkView :: [String] -> Annex View
+mkView params = go =<< inRepo Git.Branch.current
+ where
+ go Nothing = error "not on any branch!"
+ go (Just b) = return $ fst $ refineView (View b []) $
+ map parseViewParam $ reverse params
+
+checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup
+checkoutViewBranch view mkbranch = do
+ oldcwd <- liftIO getCurrentDirectory
+
+ {- Change to top of repository before creating view branch. -}
+ liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
+ branch <- mkbranch view
+
+ showOutput
+ ok <- inRepo $ Git.Command.runBool
+ [ Param "checkout"
+ , Param (Git.fromRef $ Git.Ref.base branch)
+ ]
+ when ok $ do
+ setView view
+ {- A git repo can easily have empty directories in it,
+ - and this pollutes the view, so remove them. -}
+ liftIO $ removeemptydirs "."
+ unlessM (liftIO $ doesDirectoryExist oldcwd) $ do
+ top <- fromRepo Git.repoPath
+ showLongNote (cwdmissing top)
+ return ok
+ where
+ removeemptydirs top = mapM_ (tryIO . removeDirectory)
+ =<< dirTreeRecursiveSkipping (".git" `isSuffixOf`) top
+ cwdmissing top = unlines
+ [ "This view does not include the subdirectory you are currently in."
+ , "Perhaps you should: cd " ++ top
+ ]
diff --git a/Command/Wanted.hs b/Command/Wanted.hs
new file mode 100644
index 000000000..bae450d26
--- /dev/null
+++ b/Command/Wanted.hs
@@ -0,0 +1,51 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Wanted where
+
+import Common.Annex
+import qualified Annex
+import Command
+import qualified Remote
+import Logs.PreferredContent
+import Types.Messages
+
+import qualified Data.Map as M
+
+def :: [Command]
+def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek
+ SectionSetup "get or set preferred content expression"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start = parse
+ where
+ parse (name:[]) = go name performGet
+ parse (name:expr:[]) = go name $ \uuid -> do
+ showStart "wanted" name
+ performSet expr uuid
+ parse _ = error "Specify a repository."
+
+ go name a = do
+ u <- Remote.nameToUUID name
+ next $ a u
+
+performGet :: UUID -> CommandPerform
+performGet uuid = do
+ Annex.setOutput QuietOutput
+ m <- preferredContentMapRaw
+ liftIO $ putStrLn $ fromMaybe "" $ M.lookup uuid m
+ next $ return True
+
+performSet :: String -> UUID -> CommandPerform
+performSet expr uuid = case checkPreferredContentExpression expr of
+ Just e -> error $ "Parse error: " ++ e
+ Nothing -> do
+ preferredContentSet uuid expr
+ next $ return True
diff --git a/Command/Watch.hs b/Command/Watch.hs
new file mode 100644
index 000000000..79079337c
--- /dev/null
+++ b/Command/Watch.hs
@@ -0,0 +1,36 @@
+{- git-annex watch command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Watch where
+
+import Common.Annex
+import Assistant
+import Command
+import Utility.HumanTime
+
+def :: [Command]
+def = [notBareRepo $ withOptions [foregroundOption, stopOption] $
+ command "watch" paramNothing seek SectionCommon "watch for changes"]
+
+seek :: CommandSeek
+seek ps = do
+ stopdaemon <- getOptionFlag stopOption
+ foreground <- getOptionFlag foregroundOption
+ withNothing (start False foreground stopdaemon Nothing) ps
+
+foregroundOption :: Option
+foregroundOption = flagOption [] "foreground" "do not daemonize"
+
+stopOption :: Option
+stopOption = flagOption [] "stop" "stop daemon"
+
+start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
+start assistant foreground stopdaemon startdelay = do
+ if stopdaemon
+ then stopDaemon
+ else startDaemon assistant foreground startdelay Nothing Nothing Nothing -- does not return
+ stop
diff --git a/Command/WebApp.hs b/Command/WebApp.hs
new file mode 100644
index 000000000..91c9afcd0
--- /dev/null
+++ b/Command/WebApp.hs
@@ -0,0 +1,237 @@
+{- git-annex webapp launcher
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.WebApp where
+
+import Common.Annex
+import Command
+import Assistant
+import Assistant.Common
+import Assistant.NamedThread
+import Assistant.Threads.WebApp
+import Assistant.WebApp
+import Assistant.Install
+import Annex.Environment
+import Utility.WebApp
+import Utility.Daemon (checkDaemon)
+#ifdef __ANDROID__
+import Utility.Env
+#endif
+import Annex.Init
+import qualified Git
+import qualified Git.Config
+import qualified Git.CurrentRepo
+import qualified Annex
+import Config.Files
+import Upgrade
+import Annex.Version
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.Process (env, std_out, std_err)
+import Network.Socket (HostName)
+import System.Environment (getArgs)
+
+def :: [Command]
+def = [ withOptions [listenOption] $
+ noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $
+ command "webapp" paramNothing seek SectionCommon "launch webapp"]
+
+listenOption :: Option
+listenOption = fieldOption [] "listen" paramAddress
+ "accept connections to this address"
+
+seek :: CommandSeek
+seek ps = do
+ listenhost <- getOptionField listenOption return
+ withNothing (start listenhost) ps
+
+start :: Maybe HostName -> CommandStart
+start = start' True
+
+start' :: Bool -> Maybe HostName -> CommandStart
+start' allowauto listenhost = do
+ liftIO ensureInstalled
+ ifM isInitialized
+ ( go
+ , auto
+ )
+ stop
+ where
+ go = do
+ cannotrun <- needsUpgrade . fromMaybe (error "no version") =<< getVersion
+ browser <- fromRepo webBrowser
+ f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
+ listenhost' <- if isJust listenhost
+ then pure listenhost
+ else annexListen <$> Annex.getGitConfig
+ ifM (checkpid <&&> checkshim f)
+ ( if isJust listenhost
+ then error "The assistant is already running, so --listen cannot be used."
+ else do
+ url <- liftIO . readFile
+ =<< fromRepo gitAnnexUrlFile
+ liftIO $ if isJust listenhost'
+ then putStrLn url
+ else liftIO $ openBrowser browser f url Nothing Nothing
+ , do
+ startDaemon True True Nothing cannotrun listenhost' $ Just $
+ \origout origerr url htmlshim ->
+ if isJust listenhost'
+ then maybe noop (`hPutStrLn` url) origout
+ else openBrowser browser htmlshim url origout origerr
+ )
+ auto
+ | allowauto = liftIO $ startNoRepo []
+ | otherwise = do
+ d <- liftIO getCurrentDirectory
+ error $ "no git repository in " ++ d
+ checkpid = do
+ pidfile <- fromRepo gitAnnexPidFile
+ liftIO $ isJust <$> checkDaemon pidfile
+ checkshim f = liftIO $ doesFileExist f
+
+{- When run without a repo, start the first available listed repository in
+ - the autostart file. If not, it's our first time being run! -}
+startNoRepo :: CmdParams -> IO ()
+startNoRepo _ = do
+ -- FIXME should be able to reuse regular getopt, but
+ -- it currently runs in the Annex monad.
+ args <- getArgs
+ let listenhost = headMaybe $ map (snd . separate (== '=')) $
+ filter ("--listen=" `isPrefixOf`) args
+
+ dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile
+ case dirs of
+ [] -> firstRun listenhost
+ (d:_) -> do
+ setCurrentDirectory d
+ state <- Annex.new =<< Git.CurrentRepo.get
+ void $ Annex.eval state $ do
+ whenM (fromRepo Git.repoIsLocalBare) $
+ error $ d ++ " is a bare git repository, cannot run the webapp in it"
+ callCommandAction $
+ start' False listenhost
+
+{- Run the webapp without a repository, which prompts the user, makes one,
+ - changes to it, starts the regular assistant, and redirects the
+ - browser to its url.
+ -
+ - This is a very tricky dance -- The first webapp calls the signaler,
+ - which signals the main thread when it's ok to continue by writing to a
+ - MVar. The main thread starts the second webapp, and uses its callback
+ - to write its url back to the MVar, from where the signaler retrieves it,
+ - returning it to the first webapp, which does the redirect.
+ -
+ - Note that it's important that mainthread never terminates! Much
+ - of this complication is due to needing to keep the mainthread running.
+ -}
+firstRun :: Maybe HostName -> IO ()
+firstRun listenhost = do
+ checkEnvironmentIO
+ {- Without a repository, we cannot have an Annex monad, so cannot
+ - get a ThreadState. Using undefined is only safe because the
+ - webapp checks its noAnnex field before accessing the
+ - threadstate. -}
+ let st = undefined
+ {- Get a DaemonStatus without running in the Annex monad. -}
+ dstatus <- atomically . newTMVar =<< newDaemonStatus
+ d <- newAssistantData st dstatus
+ urlrenderer <- newUrlRenderer
+ v <- newEmptyMVar
+ let callback a = Just $ a v
+ runAssistant d $ do
+ startNamedThread urlrenderer $
+ webAppThread d urlrenderer True Nothing
+ (callback signaler)
+ listenhost
+ (callback mainthread)
+ waitNamedThreads
+ where
+ signaler v = do
+ putMVar v ""
+ takeMVar v
+ mainthread v url htmlshim
+ | isJust listenhost = do
+ putStrLn url
+ hFlush stdout
+ go
+ | otherwise = do
+ browser <- maybe Nothing webBrowser
+ <$> catchDefaultIO Nothing Git.Config.global
+ openBrowser browser htmlshim url Nothing Nothing
+ go
+ where
+ go = do
+ _wait <- takeMVar v
+ state <- Annex.new =<< Git.CurrentRepo.get
+ Annex.eval state $
+ startDaemon True True Nothing Nothing listenhost $ Just $
+ sendurlback v
+ sendurlback v _origout _origerr url _htmlshim = do
+ recordUrl url
+ putMVar v url
+
+recordUrl :: String -> IO ()
+#ifdef __ANDROID__
+{- The Android app has a menu item that opens the url recorded
+ - in this file. -}
+recordUrl url = writeFile "/sdcard/git-annex.home/.git-annex-url" url
+#else
+recordUrl _ = noop
+#endif
+
+openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
+#ifndef __ANDROID__
+openBrowser mcmd htmlshim _realurl outh errh = runbrowser
+#else
+openBrowser mcmd htmlshim realurl outh errh = do
+ recordUrl url
+ {- 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
+ Just f -> void $ forkIO $ do
+ fd <- openFd f WriteOnly Nothing defaultFileFlags
+ void $ fdWrite fd url
+ closeFd fd
+#endif
+ where
+ p = case mcmd of
+ Just cmd -> proc cmd [htmlshim]
+ Nothing -> browserProc url
+#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
+#else
+ url = fileUrl htmlshim
+#endif
+ runbrowser = do
+ hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
+ hFlush stdout
+ environ <- cleanEnvironment
+ (_, _, _, pid) <- createProcess p
+ { env = environ
+ , std_out = maybe Inherit UseHandle outh
+ , std_err = maybe Inherit UseHandle errh
+ }
+ exitcode <- waitForProcess pid
+ unless (exitcode == ExitSuccess) $
+ hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
+
+{- web.browser is a generic git config setting for a web browser program -}
+webBrowser :: Git.Repo -> Maybe FilePath
+webBrowser = Git.Config.getMaybe "web.browser"
+
+fileUrl :: FilePath -> String
+fileUrl file = "file://" ++ file
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
new file mode 100644
index 000000000..387ffebc9
--- /dev/null
+++ b/Command/Whereis.hs
@@ -0,0 +1,65 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Whereis where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Command
+import Remote
+import Logs.Trust
+
+def :: [Command]
+def = [noCommit $ withOptions (jsonOption : keyOptions) $
+ command "whereis" paramPaths seek SectionQuery
+ "lists repositories that have file content"]
+
+seek :: CommandSeek
+seek ps = do
+ m <- remoteMap id
+ withKeyOptions
+ (startKeys m)
+ (withFilesInGit $ whenAnnexed $ start m)
+ ps
+
+start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart
+start remotemap file (key, _) = start' remotemap key (Just file)
+
+startKeys :: M.Map UUID Remote -> Key -> CommandStart
+startKeys remotemap key = start' remotemap key Nothing
+
+start' :: M.Map UUID Remote -> Key -> AssociatedFile -> CommandStart
+start' remotemap key afile = do
+ showStart' "whereis" key afile
+ next $ perform remotemap key
+
+perform :: M.Map UUID Remote -> Key -> CommandPerform
+perform remotemap key = do
+ locations <- keyLocations key
+ (untrustedlocations, safelocations) <- trustPartition UnTrusted locations
+ let num = length safelocations
+ showNote $ show num ++ " " ++ copiesplural num
+ pp <- prettyPrintUUIDs "whereis" safelocations
+ unless (null safelocations) $ showLongNote pp
+ pp' <- prettyPrintUUIDs "untrusted" untrustedlocations
+ unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'
+ forM_ (mapMaybe (`M.lookup` remotemap) locations) $
+ performRemote key
+ if null safelocations then stop else next $ return True
+ where
+ copiesplural 1 = "copy"
+ copiesplural _ = "copies"
+ untrustedheader = "The following untrusted locations may also have copies:\n"
+
+performRemote :: Key -> Remote -> Annex ()
+performRemote key remote = maybe noop go $ whereisKey remote
+ where
+ go a = do
+ ls <- a key
+ unless (null ls) $ showLongNote $ unlines $
+ map (\l -> name remote ++ ": " ++ l) ls
diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs
new file mode 100644
index 000000000..47c2d7ff2
--- /dev/null
+++ b/Command/XMPPGit.hs
@@ -0,0 +1,46 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.XMPPGit where
+
+import Common.Annex
+import Command
+import Assistant.XMPP.Git
+
+def :: [Command]
+def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
+ command "xmppgit" paramNothing seek
+ SectionPlumbing "git to XMPP relay"]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start _ = do
+ liftIO gitRemoteHelper
+ liftIO xmppGitRelay
+ stop
+
+startNoRepo :: CmdParams -> IO ()
+startNoRepo _ = xmppGitRelay
+
+{- A basic implementation of the git-remote-helpers protocol. -}
+gitRemoteHelper :: IO ()
+gitRemoteHelper = do
+ expect "capabilities"
+ respond ["connect"]
+ expect "connect git-receive-pack"
+ respond []
+ where
+ expect s = do
+ cmd <- getLine
+ unless (cmd == s) $
+ error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ cmd
+ respond l = do
+ mapM_ putStrLn l
+ putStrLn ""
+ hFlush stdout