mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Merge commit '3.20110906' into debian-stable

Browse source 
Conflicts:
	Command/Add.hs
	debian/control
	doc/install/Fedora.mdwn
	doc/install/OSX.mdwn
	git-annex.cabal
This commit is contained in:
Joey Hess 2011-09-17 09:27:50 -04:00
commit 3e96e69ce6
131 changed files with 1635 additions and 752 deletions
Download patch file Download diff file Expand all files Collapse all files

6
.gitignore vendored
View file

@ -2,7 +2,7 @@
*.o
test
configure
SysConfig.hs
Build/SysConfig.hs
git-annex
git-annex-shell
git-union-merge
@ -13,7 +13,7 @@ doc/.ikiwiki
html
*.tix
.hpc
Touch.hs
StatFS.hs
Utility/Touch.hs
Utility/StatFS.hs
Remote/S3.hs
dist

27
Annex.hs
View file

@ -5,9 +5,12 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Annex (
Annex,
AnnexState(..),
OutputType(..),
new,
run,
eval,
@ -17,6 +20,8 @@ module Annex (
) where
import Control.Monad.State
import Control.Monad.IO.Control
import Control.Applicative hiding (empty)
import qualified Git
import Git.Queue
@ -28,7 +33,15 @@ import Types.TrustLevel
import Types.UUID
-- git-annex's monad
type Annex = StateT AnnexState IO
newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
deriving (
Monad,
MonadIO,
MonadControlIO,
MonadState AnnexState,
Functor,
Applicative
)
-- internal state storage
data AnnexState = AnnexState
@ -36,7 +49,7 @@ data AnnexState = AnnexState
, backends :: [Backend Annex]
, remotes :: [Remote Annex]
, repoqueue :: Queue
, quiet :: Bool
, output :: OutputType
, force :: Bool
, fast :: Bool
, branchstate :: BranchState
@ -51,13 +64,15 @@ data AnnexState = AnnexState
, cipher :: Maybe Cipher
}
data OutputType = NormalOutput | QuietOutput | JSONOutput
newState :: Git.Repo -> AnnexState
newState gitrepo = AnnexState
{ repo = gitrepo
, backends = []
, remotes = []
, repoqueue = empty
, quiet = False
, output = NormalOutput
, force = False
, fast = False
, branchstate = startBranchState
@ -74,13 +89,13 @@ newState gitrepo = AnnexState
{- Create and returns an Annex state object for the specified git repo. -}
new :: Git.Repo -> IO AnnexState
new gitrepo = newState `liftM` (liftIO . Git.configRead) gitrepo
new gitrepo = newState <$> Git.configRead gitrepo
{- performs an action in the Annex monad -}
run :: AnnexState -> Annex a -> IO (a, AnnexState)
run = flip runStateT
run s a = runStateT (runAnnex a) s
eval :: AnnexState -> Annex a -> IO a
eval = flip evalStateT
eval s a = evalStateT (runAnnex a) s
{- Gets a value from the internal state, selected by the passed value
- constructor. -}

5
AnnexQueue.hs
View file

@ -17,10 +17,9 @@ import Control.Monad (when, unless)
import Annex
import Messages
import qualified Git.Queue
import Utility
import Utility.SafeCommand
{- Adds a git command to the queue, possibly running previously queued
- actions if enough have accumulated. -}
{- Adds a git command to the queue. -}
add :: String -> [CommandParam] -> [FilePath] -> Annex ()
add command params files = do
q <- getState repoqueue

12
Backend.hs
View file

@ -32,9 +32,10 @@ import Messages
-- When adding a new backend, import it here and add it to the list.
import qualified Backend.WORM
import qualified Backend.SHA
import qualified Backend.URL
list :: [Backend Annex]
list = Backend.WORM.backends ++ Backend.SHA.backends
list = Backend.WORM.backends ++ Backend.SHA.backends ++ Backend.URL.backends
{- List of backends in the order to try them when storing a new key. -}
orderedList :: Annex [Backend Annex]
@ -65,7 +66,7 @@ orderedList = do
genKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
genKey file trybackend = do
bs <- orderedList
let bs' = maybe bs (:bs) trybackend
let bs' = maybe bs (: bs) trybackend
genKey' bs' file
genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
genKey' [] _ = return Nothing
@ -121,8 +122,7 @@ lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
where
unknown = error $ "unknown backend " ++ s
maybeLookupBackendName :: String -> Maybe (Backend Annex)
maybeLookupBackendName s =
if 1 /= length matches
then Nothing
else Just $ head matches
maybeLookupBackendName s
| length matches == 1 = Just $ head matches
| otherwise = Nothing
where matches = filter (\b -> s == B.name b) list

8
Backend/SHA.hs
View file

@ -23,8 +23,8 @@ import Content
import Types
import Types.Backend
import Types.Key
import Utility
import qualified SysConfig
import Utility.SafeCommand
import qualified Build.SysConfig as SysConfig
type SHASize = Int
@ -32,7 +32,7 @@ sizes :: [Int]
sizes = [1, 256, 512, 224, 384]
backends :: [Backend Annex]
-- order is slightly significant; want sha1 first ,and more general
-- order is slightly significant; want sha1 first, and more general
-- sizes earlier
backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes
@ -107,7 +107,7 @@ keyValueE size file = keyValue size file >>= maybe (return Nothing) addE
then "" -- probably not really an extension
else naiveextension
-- A key's checksum is checked during fsck.
{- A key's checksum is checked during fsck. -}
checkKeyChecksum :: SHASize -> Key -> Annex Bool
checkKeyChecksum size key = do
g <- Annex.gitRepo

28
Backend/URL.hs Normal file
View file

@ -0,0 +1,28 @@
{- git-annex "URL" backend -- keys whose content is available from urls.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Backend.URL (
backends,
fromUrl
) where
import Types.Backend
import Types.Key
import Types
backends :: [Backend Annex]
backends = [backend]
backend :: Backend Annex
backend = Types.Backend.Backend {
name = "URL",
getKey = const (return Nothing),
fsckKey = const (return True)
}
fromUrl :: String -> Key
fromUrl url = stubKey { keyName = url, keyBackendName = "URL" }

37
Branch.hs
View file

@ -14,11 +14,13 @@ module Branch (
files,
refExists,
hasOrigin,
hasSomeBranch,
name
) where
import Control.Monad (when, unless, liftM)
import Control.Monad.State (liftIO)
import Control.Applicative ((<$>))
import System.FilePath
import System.Directory
import Data.String.Utils
@ -36,6 +38,8 @@ import qualified Git
import qualified Git.UnionMerge
import qualified Annex
import Utility
import Utility.Conditional
import Utility.SafeCommand
import Types
import Messages
import Locations
@ -124,7 +128,7 @@ getCache file = getState >>= handle
{- Creates the branch, if it does not already exist. -}
create :: Annex ()
create = unlessM (refExists fullname) $ do
create = unlessM hasBranch $ do
g <- Annex.gitRepo
e <- hasOrigin
if e
@ -154,19 +158,14 @@ update = do
-}
staged <- stageJournalFiles
refs <- siblingBranches
updated <- catMaybes <$> mapM updateRef refs
g <- Annex.gitRepo
r <- liftIO $ Git.pipeRead g [Param "show-ref", Param name]
let refs = map (last . words) (lines r)
updated <- catMaybes `liftM` mapM updateRef refs
unless (null updated && not staged) $ liftIO $
Git.commit g "update" fullname (fullname:updated)
Annex.changeState $ \s -> s { Annex.branchstate = state { branchUpdated = True } }
invalidateCache
{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
hasOrigin = refExists originname
{- Checks if a git ref exists. -}
refExists :: GitRef -> Annex Bool
refExists ref = do
@ -174,6 +173,26 @@ refExists ref = do
liftIO $ Git.runBool g "show-ref"
[Param "--verify", Param "-q", Param ref]
{- Does the main git-annex branch exist? -}
hasBranch :: Annex Bool
hasBranch = refExists fullname
{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
hasOrigin = refExists originname
{- Does the git-annex branch or a foo/git-annex branch exist? -}
hasSomeBranch :: Annex Bool
hasSomeBranch = not . null <$> siblingBranches
{- List of all git-annex branches, including the main one and any
- from remotes. -}
siblingBranches :: Annex [String]
siblingBranches = do
g <- Annex.gitRepo
r <- liftIO $ Git.pipeRead g [Param "show-ref", Param name]
return $ map (last . words) (lines r)
{- Ensures that a given ref has been merged into the index. -}
updateRef :: GitRef -> Annex (Maybe String)
updateRef ref
@ -305,7 +324,7 @@ getJournalFile file = do
{- List of journal files. -}
getJournalFiles :: Annex [FilePath]
getJournalFiles = fmap (map fileJournal) getJournalFilesRaw
getJournalFiles = map fileJournal <$> getJournalFilesRaw
getJournalFilesRaw :: Annex [FilePath]
getJournalFilesRaw = do

8
TestConfig.hs → Build/TestConfig.hs
View file

@ -1,6 +1,6 @@
{- Tests the system and generates SysConfig.hs. -}
{- Tests the system and generates Build.SysConfig.hs. -}
module TestConfig where
module Build.TestConfig where
import System.IO
import System.Cmd
@ -33,12 +33,12 @@ instance Show Config where
valuetype (MaybeStringConfig _) = "Maybe String"
writeSysConfig :: [Config] -> IO ()
writeSysConfig config = writeFile "SysConfig.hs" body
writeSysConfig config = writeFile "Build/SysConfig.hs" body
where
body = unlines $ header ++ map show config ++ footer
header = [
"{- Automatically generated. -}"
, "module SysConfig where"
, "module Build.SysConfig where"
, ""
]
footer = []

15
CmdLine.hs
View file

@ -22,10 +22,9 @@ import qualified Git
import Content
import Types
import Command
import Version
import Options
import Messages
import UUID
import Init
{- Runs the passed command line. -}
dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
@ -45,7 +44,7 @@ parseCmd argv header cmds options = do
[] -> error $ "unknown command" ++ usagemsg
[command] -> do
_ <- sequence flags
when (cmdusesrepo command) checkVersion
checkCmdEnviron command
prepCommand command (drop 1 params)
_ -> error "internal error: multiple matching commands"
where
@ -57,6 +56,10 @@ parseCmd argv header cmds options = do
lookupCmd cmd = filter (\c -> cmd == cmdname c) cmds
usagemsg = "\n\n" ++ usage header cmds options
{- Checks that the command can be run in the current environment. -}
checkCmdEnviron :: Command -> Annex ()
checkCmdEnviron command = when (cmdusesrepo command) ensureInitialized
{- Usage message with lists of commands and options. -}
usage :: String -> [Command] -> [Option] -> String
usage header cmds options =
@ -86,8 +89,8 @@ tryRun' errnum state (a:as) = do
case result of
Left err -> do
Annex.eval state $ do
showEndFail
showErr err
showEndFail
tryRun' (errnum + 1) state as
Right (True,state') -> tryRun' errnum state' as
Right (False,state') -> tryRun' (errnum + 1) state' as
@ -95,9 +98,7 @@ tryRun' errnum _ [] = when (errnum > 0) $ error $ show errnum ++ " failed"
{- Actions to perform each time ran. -}
startup :: Annex Bool
startup = do
prepUUID
return True
startup = return True
{- Cleanup actions. -}
shutdown :: Annex Bool

10
Command.hs
View file

@ -11,6 +11,7 @@ import Control.Monad.State (liftIO)
import System.Directory
import System.Posix.Files
import Control.Monad (filterM, liftM, when)
import Control.Applicative
import System.Path.WildMatch
import Text.Regex.PCRE.Light.Char8
import Data.List
@ -102,7 +103,6 @@ doCommand = start
stage a b = b >>= a
success = return True
failure = do
showOutput -- avoid clutter around error message
showEndFail
return False
@ -178,14 +178,12 @@ withKeys :: CommandSeekKeys
withKeys a params = return $ map (a . parse) params
where
parse p = fromMaybe (error "bad key") $ readKey p
withTempFile :: CommandSeekStrings
withTempFile a params = return $ map a params
withNothing :: CommandSeekNothing
withNothing a [] = return [a]
withNothing _ _ = error "This command takes no parameters."
backendPairs :: CommandSeekBackendFiles
backendPairs a files = liftM (map a) $ Backend.chooseBackends files
backendPairs a files = map a <$> Backend.chooseBackends files
{- Filter out files those matching the exclude glob pattern,
- if it was specified. -}
@ -206,7 +204,7 @@ wildsRegex ws = compile regex []
{- filter out symlinks -}
notSymlink :: FilePath -> IO Bool
notSymlink f = liftM (not . isSymbolicLink) $ liftIO $ getSymbolicLinkStatus f
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
{- Descriptions of params used in usage messages. -}
paramRepeating :: String -> String
@ -273,4 +271,4 @@ preserveOrder orig new = collect orig new
- of git file list commands, that assumption tends to hold.
-}
runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
runPreserveOrder a files = liftM (preserveOrder files) (a files)
runPreserveOrder a files = preserveOrder files <$> a files

7
Command/Add.hs
View file

@ -8,6 +8,7 @@
module Command.Add where
import Control.Monad.State (liftIO)
import Control.Monad (when)
import System.Posix.Files
import Command
@ -18,8 +19,10 @@ import LocationLog
import Types
import Content
import Messages
import Utility
import Touch
import Utility.Conditional
import Utility.Touch
import Utility.SafeCommand
import Locations
command :: [Command]
command = [repoCommand "add" paramPath seek "add files to annex"]

32
Command/AddUrl.hs
View file

@ -14,15 +14,16 @@ import System.Directory
import Command
import qualified Backend
import qualified Utility.Url as Url
import qualified Remote.Web
import qualified Command.Add
import qualified Annex
import qualified Backend.URL
import Messages
import Content
import PresenceLog
import Types.Key
import Locations
import Utility
import Utility.Path
command :: [Command]
command = [repoCommand "addurl" paramPath seek "add urls to annex"]
@ -42,12 +43,17 @@ start s = do
perform :: String -> FilePath -> CommandPerform
perform url file = do
fast <- Annex.getState Annex.fast
if fast then nodownload url file else download url file
download :: String -> FilePath -> CommandPerform
download url file = do
g <- Annex.gitRepo
showAction $ "downloading " ++ url ++ " "
let dummykey = stubKey { keyName = url, keyBackendName = "URL" }
let dummykey = Backend.URL.fromUrl url
let tmp = gitAnnexTmpLocation g dummykey
liftIO $ createDirectoryIfMissing True (parentDir tmp)
ok <- Remote.Web.download [url] tmp
ok <- Url.download url tmp
if ok
then do
[(_, backend)] <- Backend.chooseBackends [file]
@ -57,9 +63,16 @@ perform url file = do
Just (key, _) -> do
moveAnnex key tmp
Remote.Web.setUrl key url InfoPresent
next $ Command.Add.cleanup file key
next $ Command.Add.cleanup file key True
else stop
nodownload :: String -> FilePath -> CommandPerform
nodownload url file = do
let key = Backend.URL.fromUrl url
Remote.Web.setUrl key url InfoPresent
next $ Command.Add.cleanup file key False
url2file :: URI -> IO FilePath
url2file url = do
let parts = filter safe $ split "/" $ uriPath url
@ -75,8 +88,7 @@ url2file url = do
e <- doesFileExist file
when e $ error "already have this url"
return file
safe s
| null s = False
| s == "." = False
| s == ".." = False
| otherwise = True
safe "" = False
safe "." = False
safe ".." = False
safe _ = True

2
Command/ConfigList.hs
View file

@ -14,7 +14,7 @@ import Command
import UUID
command :: [Command]
command = [standaloneCommand "configlist" paramNothing seek
command = [repoCommand "configlist" paramNothing seek
"outputs relevant git configuration"]
seek :: [CommandSeek]

1
Command/Drop.hs
View file

@ -15,6 +15,7 @@ import Types
import Content
import Messages
import Utility
import Utility.Conditional
import Trust
import Config

2
Command/DropUnused.hs
View file

@ -22,7 +22,7 @@ import qualified Command.Move
import qualified Remote
import qualified Git
import Types.Key
import Utility
import Utility.Conditional
type UnusedMap = M.Map String Key

2
Command/Find.hs
View file

@ -11,7 +11,7 @@ import Control.Monad.State (liftIO)
import Command
import Content
import Utility
import Utility.Conditional
command :: [Command]
command = [repoCommand "find" (paramOptional $ paramRepeating paramPath) seek

3
Command/Fix.hs
View file

@ -13,7 +13,8 @@ import System.Directory
import Command
import qualified AnnexQueue
import Utility
import Utility.Path
import Utility.SafeCommand
import Content
import Messages

3
Command/FromKey.hs
View file

@ -14,10 +14,11 @@ import Control.Monad (unless)
import Command
import qualified AnnexQueue
import Utility
import Utility.SafeCommand
import Content
import Messages
import Types.Key
import Utility.Path
command :: [Command]
command = [repoCommand "fromkey" paramPath seek

3
Command/Fsck.hs
View file

@ -27,6 +27,7 @@ import LocationLog
import Locations
import Trust
import Utility.DataUnits
import Utility.Path
import Config
command :: [Command]
@ -130,7 +131,7 @@ checkKeyNumCopies key file numcopies = do
let present = length safelocations
if present < needed
then do
ppuuids <- Remote.prettyPrintUUIDs untrustedlocations
ppuuids <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
warning $ missingNote (filename file key) present needed ppuuids
return False
else return True

42
Command/Init.hs
View file

@ -7,31 +7,21 @@
module Command.Init where
import Control.Monad.State (liftIO)
import Control.Monad (when, unless)
import System.Directory
import Command
import qualified Annex
import qualified Git
import qualified Branch
import UUID
import Version
import Messages
import Types
import Utility
import Init
command :: [Command]
command = [standaloneCommand "init" paramDesc seek
"initialize git-annex with repository description"]
"initialize git-annex"]
seek :: [CommandSeek]
seek = [withWords start]
start :: CommandStartWords
start ws = do
when (null description) $
error "please specify a description of this repository\n"
showStart "init" description
next $ perform description
where
@ -39,34 +29,8 @@ start ws = do
perform :: String -> CommandPerform
perform description = do
Branch.create
initialize
g <- Annex.gitRepo
u <- getUUID g
setVersion
describeUUID u description
unless (Git.repoIsLocalBare g) $
gitPreCommitHookWrite g
next $ return True
{- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHookWrite :: Git.Repo -> Annex ()
gitPreCommitHookWrite repo = do
exists <- liftIO $ doesFileExist hook
if exists
then warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
else liftIO $ do
viaTmp writeFile hook preCommitScript
p <- getPermissions hook
setPermissions hook $ p {executable = True}
where
hook = preCommitHook repo
preCommitHook :: Git.Repo -> FilePath
preCommitHook repo =
Git.workTree repo ++ "/" ++ Git.gitDir repo ++ "/hooks/pre-commit"
preCommitScript :: String
preCommitScript =
"#!/bin/sh\n" ++
"# automatically configured by git-annex\n" ++
"git annex pre-commit .\n"

2
Command/Lock.hs
View file

@ -13,7 +13,7 @@ import System.Directory
import Command
import Messages
import qualified AnnexQueue
import Utility
import Utility.SafeCommand
command :: [Command]
command = [repoCommand "lock" paramPath seek "undo unlock command"]

4
Command/Map.hs
View file

@ -19,10 +19,10 @@ import qualified Annex
import qualified Git
import Messages
import Types
import Utility
import Utility.SafeCommand
import UUID
import Trust
import Remote.Ssh
import Utility.Ssh
import qualified Utility.Dot as Dot
-- a link from the first repository to the second (its remote)

7
Command/Migrate.hs
View file

@ -8,6 +8,7 @@
module Command.Migrate where
import Control.Monad.State (liftIO)
import Control.Applicative
import System.Posix.Files
import System.Directory
import System.FilePath
@ -20,7 +21,7 @@ import Locations
import Types
import Content
import Messages
import Utility
import Utility.Conditional
import qualified Command.Add
command :: [Command]
@ -39,7 +40,7 @@ start (file, b) = isAnnexed file $ \(key, oldbackend) -> do
next $ perform file key newbackend
else stop
where
choosebackend Nothing = return . head =<< Backend.orderedList
choosebackend Nothing = head <$> Backend.orderedList
choosebackend (Just backend) = return backend
{- Checks if a key is upgradable to a newer representation. -}
@ -72,7 +73,7 @@ perform file oldkey newbackend = do
then do
-- Update symlink to use the new key.
liftIO $ removeFile file
next $ Command.Add.cleanup file newkey
next $ Command.Add.cleanup file newkey True
else stop
where
cleantmp t = whenM (doesFileExist t) $ removeFile t

2
Command/RecvKey.hs
View file

@ -13,8 +13,8 @@ import System.Exit
import Command
import CmdLine
import Content
import Utility
import Utility.RsyncFile
import Utility.Conditional
command :: [Command]
command = [repoCommand "recvkey" paramKey seek

2
Command/SendKey.hs
View file

@ -14,8 +14,8 @@ import Locations
import qualified Annex
import Command
import Content
import Utility
import Utility.RsyncFile
import Utility.Conditional
import Messages
command :: [Command]

4
Command/SetKey.hs
View file

@ -10,7 +10,7 @@ module Command.SetKey where
import Control.Monad.State (liftIO)
import Command
import Utility
import Utility.SafeCommand
import LocationLog
import Content
import Messages
@ -20,7 +20,7 @@ command = [repoCommand "setkey" paramPath seek
"sets annexed content for a key using a temp file"]
seek :: [CommandSeek]
seek = [withTempFile start]
seek = [withStrings start]
{- Sets cached content for a key. -}
start :: CommandStartString

10
Command/Status.hs
View file

@ -8,6 +8,7 @@
module Command.Status where
import Control.Monad.State
import Control.Applicative
import Data.Maybe
import System.IO
import Data.List
@ -112,12 +113,10 @@ total_annex_size = stat "total annex size" $
cachedKeysReferenced >>= keySizeSum
local_annex_keys :: Stat
local_annex_keys = stat "local annex keys" $
return . show . snd =<< cachedKeysPresent
local_annex_keys = stat "local annex keys" $ show . snd <$> cachedKeysPresent
total_annex_keys :: Stat
total_annex_keys = stat "total annex keys" $
return . show . snd =<< cachedKeysReferenced
total_annex_keys = stat "total annex keys" $ show . snd <$> cachedKeysReferenced
tmp_size :: Stat
tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
@ -126,8 +125,7 @@ bad_data_size :: Stat
bad_data_size = staleSize "bad keys size" gitAnnexBadDir
backend_usage :: Stat
backend_usage = stat "backend usage" $
return . usage =<< cachedKeysReferenced
backend_usage = stat "backend usage" $ usage <$> cachedKeysReferenced
where
usage (ks, _) = pp "" $ sort $ map swap $ splits ks
splits :: [Key] -> [(String, Integer)]

3
Command/Unannex.hs
View file

@ -16,7 +16,8 @@ import Command
import qualified Command.Drop
import qualified Annex
import qualified AnnexQueue
import Utility
import Utility.SafeCommand
import Utility.Path
import LocationLog
import Types
import Content

19
Command/Uninit.hs
View file

@ -12,13 +12,11 @@ import System.Directory
import System.Exit
import Command
import Messages
import Types
import Utility
import Utility.SafeCommand
import qualified Git
import qualified Annex
import qualified Command.Unannex
import qualified Command.Init
import Init
import qualified Branch
import Content
import Locations
@ -47,7 +45,7 @@ perform = next cleanup
cleanup :: CommandCleanup
cleanup = do
g <- Annex.gitRepo
gitPreCommitHookUnWrite g
uninitialize
mapM_ removeAnnex =<< getKeysPresent
liftIO $ removeDirectoryRecursive (gitAnnexDir g)
-- avoid normal shutdown
@ -55,14 +53,3 @@ cleanup = do
liftIO $ do
Git.run g "branch" [Param "-D", Param Branch.name]
exitSuccess
gitPreCommitHookUnWrite :: Git.Repo -> Annex ()
gitPreCommitHookUnWrite repo = do
let hook = Command.Init.preCommitHook repo
whenM (liftIO $ doesFileExist hook) $ do
c <- liftIO $ readFile hook
if c == Command.Init.preCommitScript
then liftIO $ removeFile hook
else warning $ "pre-commit hook (" ++ hook ++
") contents modified; not deleting." ++
" Edit it to remove call to git annex."

3
Command/Unlock.hs
View file

@ -16,8 +16,9 @@ import Types
import Messages
import Locations
import Content
import Utility.Conditional
import Utility.CopyFile
import Utility
import Utility.Path
command :: [Command]
command =

7
Command/Unused.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Command.Unused where
import Control.Monad (filterM, unless, forM_)
@ -78,9 +80,12 @@ checkRemoteUnused' r = do
showLongNote $ remoteUnusedMsg r list
showLongNote "\n"
where
{- This should run strictly to avoid the filterM
- building many thunks containing keyLocations data. -}
isthere k = do
us <- keyLocations k
return $ uuid `elem` us
let !there = uuid `elem` us
return there
uuid = Remote.uuid r
writeUnusedFile :: FilePath -> [(Int, Key)] -> Annex ()

2
Command/Version.hs
View file

@ -12,7 +12,7 @@ import Data.String.Utils
import Data.Maybe
import Command
import qualified SysConfig
import qualified Build.SysConfig as SysConfig
import Version
command :: [Command]

2
Command/Whereis.hs
View file

@ -33,7 +33,7 @@ perform key = do
if null uuids
then stop
else do
pp <- prettyPrintUUIDs uuids
pp <- prettyPrintUUIDs "whereis" uuids
showLongNote pp
showOutput
next $ return True

24
Config.hs
View file

@ -9,11 +9,14 @@ module Config where
import Data.Maybe
import Control.Monad.State (liftIO)
import Control.Applicative
import System.Cmd.Utils
import qualified Git
import qualified Annex
import Types
import Utility
import Utility.SafeCommand
type ConfigKey = String
@ -37,17 +40,22 @@ getConfig r key def = do
remoteConfig :: Git.Repo -> ConfigKey -> String
remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key
{- Calculates cost for a remote.
-
- The default cost is 100 for local repositories, and 200 for remote
- repositories; it can also be configured by remote.<name>.annex-cost
{- Calculates cost for a remote. Either the default, or as configured
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
- is set and prints a number, that is used.
-}
remoteCost :: Git.Repo -> Int -> Annex Int
remoteCost r def = do
c <- getConfig r "cost" ""
if not $ null c
then return $ read c
else return def
cmd <- getConfig r "cost-command" ""
safeparse <$> if not $ null cmd
then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd]
else getConfig r "cost" ""
where
safeparse v
| null ws = def
| otherwise = fromMaybe def $ readMaybe $ head ws
where
ws = words v
cheapRemoteCost :: Int
cheapRemoteCost = 100

16
Content.hs
View file

@ -23,11 +23,10 @@ module Content (
saveState
) where
import System.IO.Error (try)
import System.Directory
import Control.Monad.State (liftIO)
import System.Path
import Control.Monad (when, filterM)
import Control.Monad
import System.Posix.Files
import System.FilePath
import Data.Maybe
@ -41,7 +40,9 @@ import qualified Annex
import qualified AnnexQueue
import qualified Branch
import Utility
import StatFS
import Utility.Conditional
import Utility.StatFS
import Utility.Path
import Types.Key
import Utility.DataUnits
import Config
@ -252,15 +253,8 @@ getKeysPresent' dir = do
levela <- dirContents dir
levelb <- mapM dirContents levela
contents <- mapM dirContents (concat levelb)
files <- filterM present (concat contents)
let files = concat contents
return $ mapMaybe (fileKey . takeFileName) files
where
present d = do
result <- try $
getFileStatus $ d </> takeFileName d
case result of
Right s -> return $ isRegularFile s
Left _ -> return False
{- Things to do to record changes to content. -}
saveState :: Annex ()

4
Crypto.hs
View file

@ -38,6 +38,7 @@ import System.IO
import System.Posix.IO
import System.Posix.Types
import System.Posix.Process
import Control.Applicative
import Control.Concurrent
import Control.Exception (finally)
import System.Exit
@ -48,6 +49,7 @@ import Types.Key
import Types.Remote
import Utility
import Utility.Base64
import Utility.SafeCommand
import Types.Crypto
{- The first half of a Cipher is used for HMAC; the remainder
@ -135,7 +137,7 @@ encryptCipher (Cipher c) (KeyIds ks) = do
{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
decryptCipher :: RemoteConfig -> EncryptedCipher -> IO Cipher
decryptCipher _ (EncryptedCipher encipher _) =
return . Cipher =<< gpgPipeStrict decrypt encipher
Cipher <$> gpgPipeStrict decrypt encipher
where
decrypt = [ Param "--decrypt" ]

26
Git.hs
View file

@ -17,6 +17,7 @@ module Git (
localToUrl,
repoIsUrl,
repoIsSsh,
repoIsHttp,
repoIsLocalBare,
repoDescribe,
repoLocation,
@ -62,6 +63,7 @@ module Git (
) where
import Control.Monad (unless, when)
import Control.Applicative
import System.Directory
import System.FilePath
import System.Posix.Directory
@ -84,6 +86,9 @@ import System.Exit
import System.Posix.Env (setEnv, unsetEnv, getEnv)
import Utility
import Utility.Path
import Utility.Conditional
import Utility.SafeCommand
{- There are two types of repositories; those on local disk and those
- accessed via an URL. -}
@ -206,6 +211,13 @@ repoIsSsh Repo { location = Url url }
| otherwise = False
repoIsSsh _ = False
repoIsHttp :: Repo -> Bool
repoIsHttp Repo { location = Url url }
| uriScheme url == "http:" = True
| uriScheme url == "https:" = True
| otherwise = False
repoIsHttp _ = False
configAvail ::Repo -> Bool
configAvail Repo { config = c } = c /= M.empty
@ -239,11 +251,11 @@ attributes repo
| configBare repo = workTree repo ++ "/info/.gitattributes"
| otherwise = workTree repo ++ "/.gitattributes"
{- Path to a repository's .git directory, relative to its workTree. -}
{- Path to a repository's .git directory. -}
gitDir :: Repo -> String
gitDir repo
| configBare repo = ""
| otherwise = ".git"
| configBare repo = workTree repo
| otherwise = workTree repo </> ".git"
{- Path to a repository's --work-tree, that is, its top.
-
@ -337,10 +349,10 @@ urlAuthPart _ repo = assertUrl repo $ error "internal"
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: Repo -> [CommandParam] -> [CommandParam]
gitCommandLine repo@(Repo { location = Dir d} ) params =
gitCommandLine repo@(Repo { location = Dir _ } ) params =
-- force use of specified repo via --git-dir and --work-tree
[ Param ("--git-dir=" ++ d ++ "/" ++ gitDir repo)
, Param ("--work-tree=" ++ d)
[ Param ("--git-dir=" ++ gitDir repo)
, Param ("--work-tree=" ++ workTree repo)
] ++ params
gitCommandLine repo _ = assertLocal repo $ error "internal"
@ -435,7 +447,7 @@ commit g message newref parentrefs = do
pipeWriteRead g (map Param $ ["commit-tree", tree] ++ ps) message
run g "update-ref" [Param newref, Param sha]
where
ignorehandle a = return . snd =<< a
ignorehandle a = snd <$> a
ps = concatMap (\r -> ["-p", r]) parentrefs
{- Reads null terminated output of a git command (as enabled by the -z

2
Git/LsFiles.hs
View file

@ -16,7 +16,7 @@ module Git.LsFiles (
) where
import Git
import Utility
import Utility.SafeCommand
{- Scans for files that are checked into git at the specified locations. -}
inRepo :: Repo -> [FilePath] -> IO [FilePath]

8
Git/Queue.hs
View file

@ -19,15 +19,15 @@ import System.IO
import System.Cmd.Utils
import Data.String.Utils
import Control.Monad (forM_)
import Utility
import Utility.SafeCommand
import Git
{- An action to perform in a git repository. The file to act on
- is not included, and must be able to be appended after the params. -}
data Action = Action {
getSubcommand :: String,
getParams :: [CommandParam]
data Action = Action
{ getSubcommand :: String
, getParams :: [CommandParam]
} deriving (Show, Eq, Ord)
{- A queue of actions to perform (in any order) on a git repository,

2
Git/UnionMerge.hs
View file

@ -18,7 +18,7 @@ import Data.Maybe
import Data.String.Utils
import Git
import Utility
import Utility.SafeCommand
{- Performs a union merge between two branches, staging it in the index.
- Any previously staged changes in the index will be lost.

89
Init.hs Normal file
View file

@ -0,0 +1,89 @@
{- git-annex repository initialization
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Init (
ensureInitialized,
initialize,
uninitialize
) where
import Control.Monad.State (liftIO)
import Control.Monad (unless)
import System.Directory
import qualified Annex
import qualified Git
import qualified Branch
import Version
import Messages
import Types
import Utility
import Utility.Conditional
import UUID
initialize :: Annex ()
initialize = do
prepUUID
Branch.create
setVersion
gitPreCommitHookWrite
uninitialize :: Annex ()
uninitialize = do
gitPreCommitHookUnWrite
{- Will automatically initialize if there is already a git-annex
branch from somewhere. Otherwise, require a manual init
to avoid git-annex accidentially being run in git
repos that did not intend to use it. -}
ensureInitialized :: Annex ()
ensureInitialized = getVersion >>= maybe needsinit checkVersion
where
needsinit = do
annexed <- Branch.hasSomeBranch
if annexed
then initialize
else error "First run: git-annex init"
{- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHookWrite :: Annex ()
gitPreCommitHookWrite = unlessBare $ do
hook <- preCommitHook
exists <- liftIO $ doesFileExist hook
if exists
then warning $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
else liftIO $ do
viaTmp writeFile hook preCommitScript
p <- getPermissions hook
setPermissions hook $ p {executable = True}
gitPreCommitHookUnWrite :: Annex ()
gitPreCommitHookUnWrite = unlessBare $ do
hook <- preCommitHook
whenM (liftIO $ doesFileExist hook) $ do
c <- liftIO $ readFile hook
if c == preCommitScript
then liftIO $ removeFile hook
else warning $ "pre-commit hook (" ++ hook ++
") contents modified; not deleting." ++
" Edit it to remove call to git annex."
unlessBare :: Annex () -> Annex ()
unlessBare a = do
g <- Annex.gitRepo
unless (Git.repoIsLocalBare g) a
preCommitHook :: Annex FilePath
preCommitHook = do
g <- Annex.gitRepo
return $ Git.gitDir g ++ "/hooks/pre-commit"
preCommitScript :: String
preCommitScript =
"#!/bin/sh\n" ++
"# automatically configured by git-annex\n" ++
"git annex pre-commit .\n"

3
LocationLog.hs
View file

@ -24,6 +24,7 @@ module LocationLog (
import System.FilePath
import Control.Monad (when)
import Control.Applicative
import Data.Maybe
import qualified Git
@ -49,7 +50,7 @@ keyLocations key = currentLog $ logFile key
{- Finds all keys that have location log information.
- (There may be duplicate keys in the list.) -}
loggedKeys :: Annex [Key]
loggedKeys = return . mapMaybe (logFileKey . takeFileName) =<< Branch.files
loggedKeys = mapMaybe (logFileKey . takeFileName) <$> Branch.files
{- The filename of the log file for a given key. -}
logFile :: Key -> String

16
Makefile
View file

@ -8,12 +8,11 @@ GHCMAKE=ghc $(GHCFLAGS) --make
bins=git-annex git-annex-shell git-union-merge
mans=git-annex.1 git-annex-shell.1 git-union-merge.1
sources=Build/SysConfig.hs Utility/StatFS.hs Utility/Touch.hs Remote/S3.hs
all: $(bins) $(mans) docs
sources: SysConfig.hs StatFS.hs Touch.hs Remote/S3.hs
SysConfig.hs: configure.hs TestConfig.hs
Build/SysConfig.hs: configure.hs Build/TestConfig.hs
$(GHCMAKE) configure
./configure
@ -30,7 +29,9 @@ Remote/S3.o: Remote/S3.hs
echo "** building without S3 support"; \
fi
$(bins): SysConfig.hs Touch.hs StatFS.hs Remote/S3.o
sources: $(sources)
$(bins): sources
$(GHCMAKE) $@
git-annex.1: doc/git-annex.mdwn
@ -54,7 +55,9 @@ test: $(bins)
@if ! $(GHCMAKE) -O0 test; then \
echo "** not running test suite" >&2; \
else \
./test; \
if ! ./test; then \
echo "** test suite failed!" >&2; \
fi; \
fi
testcoverage: $(bins)
@ -82,8 +85,7 @@ docs: $(mans)
--exclude='news/.*'
clean:
rm -rf build $(bins) $(mans) test configure *.tix .hpc \
StatFS.hs Touch.hs SysConfig.hs Remote/S3.hs
rm -rf build $(bins) $(mans) test configure *.tix .hpc $(sources)
rm -rf doc/.ikiwiki html dist
find . \( -name \*.o -or -name \*.hi \) -exec rm {} \;

77
Messages.hs
View file

@ -5,28 +5,40 @@
- Licensed under the GNU GPL version 3 or higher.
-}
module Messages where
module Messages (
showStart,
showNote,
showAction,
showProgress,
showSideAction,
showOutput,
showLongNote,
showEndOk,
showEndFail,
showEndResult,
showErr,
warning,
indent,
maybeShowJSON,
setupConsole
) where
import Control.Monad.State (liftIO)
import System.IO
import Control.Monad (unless)
import Data.String.Utils
import Text.JSON
import Types
import qualified Annex
verbose :: Annex () -> Annex ()
verbose a = do
q <- Annex.getState Annex.quiet
unless q a
import qualified Messages.JSON as JSON
showStart :: String -> String -> Annex ()
showStart command file = verbose $ liftIO $ do
showStart command file = handle (JSON.start command file) $ do
putStr $ command ++ " " ++ file ++ " "
hFlush stdout
showNote :: String -> Annex ()
showNote s = verbose $ liftIO $ do
showNote s = handle (JSON.note s) $ do
putStr $ "(" ++ s ++ ") "
hFlush stdout
@ -34,40 +46,44 @@ showAction :: String -> Annex ()
showAction s = showNote $ s ++ "..."
showProgress :: Annex ()
showProgress = verbose $ liftIO $ do
showProgress = handle q $ do
putStr "."
hFlush stdout
showSideAction :: String -> Annex ()
showSideAction s = verbose $ liftIO $ putStrLn $ "(" ++ s ++ "...)"
showSideAction s = handle q $ putStrLn $ "(" ++ s ++ "...)"
showOutput :: Annex ()
showOutput = verbose $ liftIO $ putStr "\n"
showOutput = handle q $ putStr "\n"
showLongNote :: String -> Annex ()
showLongNote s = verbose $ liftIO $ putStr $ '\n' : indent s
showLongNote s = handle (JSON.note s) $ putStr $ '\n' : indent s
showEndOk :: Annex ()
showEndOk = verbose $ liftIO $ putStrLn "ok"
showEndOk = showEndResult True
showEndFail :: Annex ()
showEndFail = verbose $ liftIO $ putStrLn "failed"
showEndFail = showEndResult False
showEndResult :: Bool -> Annex ()
showEndResult True = showEndOk
showEndResult False = showEndFail
showEndResult b = handle (JSON.end b) $ putStrLn msg
where
msg
| b = "ok"
| otherwise = "failed"
showErr :: (Show a) => a -> Annex ()
showErr e = liftIO $ do
hFlush stdout
hPutStrLn stderr $ "git-annex: " ++ show e
showErr e = warning' $ "git-annex: " ++ show e
warning :: String -> Annex ()
warning w = do
verbose $ liftIO $ putStr "\n"
warning w = warning' (indent w)
warning' :: String -> Annex ()
warning' w = do
handle q $ putStr "\n"
liftIO $ do
hFlush stdout
hPutStrLn stderr $ indent w
hPutStrLn stderr w
indent :: String -> String
indent s = join "\n" $ map (\l -> " " ++ l) $ lines s
@ -84,3 +100,18 @@ setupConsole :: IO ()
setupConsole = do
hSetBinaryMode stdout True
hSetBinaryMode stderr True
handle :: IO () -> IO () -> Annex ()
handle json normal = do
output <- Annex.getState Annex.output
case output of
Annex.NormalOutput -> liftIO normal
Annex.QuietOutput -> q
Annex.JSONOutput -> liftIO json
{- Shows a JSON value only when in json mode. -}
maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
maybeShowJSON v = handle (JSON.add v) q
q :: Monad m => m ()
q = return ()

29
Messages/JSON.hs Normal file
View file

@ -0,0 +1,29 @@
{- git-annex JSON output
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Messages.JSON (
start,
end,
note,
add
) where
import Text.JSON
import qualified Utility.JSONStream as Stream
start :: String -> String -> IO ()
start command file = putStr $ Stream.start [("command", command), ("file", file)]
end :: Bool -> IO ()
end b = putStr $ Stream.add [("success", b)] ++ Stream.end
note :: String -> IO ()
note s = add [("note", s)]
add :: JSON a => [(String, a)] -> IO ()
add v = putStr $ Stream.add v

8
Options.hs
View file

@ -26,10 +26,12 @@ commonOptions =
"allow actions that may lose annexed data"
, Option ['F'] ["fast"] (NoArg (setfast True))
"avoid slow operations"
, Option ['q'] ["quiet"] (NoArg (setquiet True))
, Option ['q'] ["quiet"] (NoArg (setoutput Annex.QuietOutput))
"avoid verbose output"
, Option ['v'] ["verbose"] (NoArg (setquiet False))
, Option ['v'] ["verbose"] (NoArg (setoutput Annex.NormalOutput))
"allow verbose output (default)"
, Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput))
"enable JSON output"
, Option ['d'] ["debug"] (NoArg (setdebug))
"show debug messages"
, Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
@ -38,7 +40,7 @@ commonOptions =
where
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
setquiet v = Annex.changeState $ \s -> s { Annex.quiet = v }
setoutput v = Annex.changeState $ \s -> s { Annex.output = v }
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
setdebug = liftIO $ updateGlobalLogger rootLoggerName $
setLevel DEBUG

7
PresenceLog.hs
View file

@ -15,10 +15,12 @@ module PresenceLog (
LogStatus(..),
addLog,
readLog,
parseLog,
writeLog,
logNow,
compactLog,
currentLog
currentLog,
LogLine
) where
import Data.Time.Clock.POSIX
@ -26,6 +28,7 @@ import Data.Time
import System.Locale
import qualified Data.Map as Map
import Control.Monad.State (liftIO)
import Control.Applicative
import qualified Branch
import Types
@ -79,7 +82,7 @@ addLog file line = do
{- Reads a log file.
- Note that the LogLines returned may be in any order. -}
readLog :: FilePath -> Annex [LogLine]
readLog file = return . parseLog =<< Branch.get file
readLog file = parseLog <$> Branch.get file
parseLog :: String -> [LogLine]
parseLog s = filter parsable $ map read $ lines s

45
Remote.hs
View file

@ -29,11 +29,14 @@ module Remote (
forceTrust
) where
import Control.Monad (filterM, liftM2)
import Control.Monad (filterM)
import Data.List
import qualified Data.Map as M
import Data.String.Utils
import Data.Maybe
import Control.Applicative
import Text.JSON
import Text.JSON.Generic
import Types
import Types.Remote
@ -111,30 +114,40 @@ nameToUUID "." = getUUID =<< Annex.gitRepo -- special case for current repo
nameToUUID n = do
res <- byName' n
case res of
Left e -> return . fromMaybe (error e) =<< byDescription
Left e -> fromMaybe (error e) <$> byDescription
Right r -> return $ uuid r
where
byDescription = return . M.lookup n . invertMap =<< uuidMap
byDescription = M.lookup n . invertMap <$> uuidMap
invertMap = M.fromList . map swap . M.toList
swap (a, b) = (b, a)
{- Pretty-prints a list of UUIDs of remotes. -}
prettyPrintUUIDs :: [UUID] -> Annex String
prettyPrintUUIDs uuids = do
{- Pretty-prints a list of UUIDs of remotes, for human display.
-
- Shows descriptions from the uuid log, falling back to remote names,
- as some remotes may not be in the uuid log.
-
- When JSON is enabled, also generates a machine-readable description
- of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs desc uuids = do
here <- getUUID =<< Annex.gitRepo
-- Show descriptions from the uuid log, falling back to remote names,
-- as some remotes may not be in the uuid log
m <- liftM2 M.union uuidMap $
return . M.fromList . map (\r -> (uuid r, name r)) =<< genList
return $ unwords $ map (\u -> "\t" ++ prettify m u here ++ "\n") uuids
m <- M.union <$> uuidMap <*> availMap
maybeShowJSON [(desc, map (jsonify m here) uuids)]
return $ unwords $ map (\u -> "\t" ++ prettify m here u ++ "\n") uuids
where
prettify m u here = base ++ ishere
availMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList
findlog m u = M.findWithDefault "" u m
prettify m here u = base ++ ishere
where
base = if not $ null $ findlog m u
then u ++ " -- " ++ findlog m u
else u
ishere = if here == u then " <-- here" else ""
findlog m u = M.findWithDefault "" u m
jsonify m here u = toJSObject
[ ("uuid", toJSON u)
, ("description", toJSON $ findlog m u)
, ("here", toJSON $ here == u)
]
{- Filters a list of remotes to ones that have the listed uuids. -}
remotesWithUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
@ -147,7 +160,7 @@ remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
-}
keyPossibilities :: Key -> Annex [Remote Annex]
keyPossibilities key = return . fst =<< keyPossibilities' False key
keyPossibilities key = fst <$> keyPossibilities' False key
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
-
@ -185,8 +198,8 @@ showLocations key exclude = do
untrusteduuids <- trustGet UnTrusted
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
ppuuidswanted <- Remote.prettyPrintUUIDs uuidswanted
ppuuidsskipped <- Remote.prettyPrintUUIDs uuidsskipped
ppuuidswanted <- Remote.prettyPrintUUIDs "wanted" uuidswanted
ppuuidsskipped <- Remote.prettyPrintUUIDs "skipped" uuidsskipped
showLongNote $ message ppuuidswanted ppuuidsskipped
where
filteruuids l x = filter (`notElem` x) l

8
Remote/Bup.hs
View file

@ -29,10 +29,12 @@ import UUID
import Locations
import Config
import Utility
import Utility.Conditional
import Utility.SafeCommand
import Messages
import Remote.Ssh
import Remote.Special
import Remote.Encryptable
import Utility.Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
type BupRepo = String

6
Remote/Directory.hs
View file

@ -27,8 +27,10 @@ import Utility.CopyFile
import Config
import Content
import Utility
import Remote.Special
import Remote.Encryptable
import Utility.Conditional
import Utility.Path
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
remote :: RemoteType Annex

68
Remote/Git.hs
View file

@ -12,6 +12,7 @@ import Control.Monad.State (liftIO)
import qualified Data.Map as M
import System.Cmd.Utils
import System.Posix.Files
import System.IO
import Types
import Types.Remote
@ -24,8 +25,12 @@ import qualified Content
import Messages
import Utility.CopyFile
import Utility.RsyncFile
import Remote.Ssh
import Utility.Ssh
import Utility.SafeCommand
import Utility.Path
import qualified Utility.Url as Url
import Config
import Init
remote :: RemoteType Annex
remote = RemoteType {
@ -75,8 +80,11 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r
| not $ M.null $ Git.configMap r = return r -- already read
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
| Git.repoIsHttp r = store $ safely $ geturlconfig
| Git.repoIsUrl r = return r
| otherwise = store $ safely $ Git.configRead r
| otherwise = store $ safely $ do
onLocal r ensureInitialized
Git.configRead r
where
-- Reading config can fail due to IO error or
-- for other reasons; catch all possible exceptions.
@ -85,9 +93,19 @@ tryGitConfigRead r
case result of
Left _ -> return r
Right r' -> return r'
pipedconfig cmd params = safely $
pOpen ReadFromPipe cmd (toCommand params) $
Git.hConfigRead r
geturlconfig = do
s <- Url.get (Git.repoLocation r ++ "/config")
withTempFile "git-annex.tmp" $ \tmpfile -> \h -> do
hPutStr h s
hClose h
pOpen ReadFromPipe "git" ["config", "--list", "--file", tmpfile] $
Git.hConfigRead r
store a = do
r' <- a
g <- Annex.gitRepo
@ -95,6 +113,7 @@ tryGitConfigRead r
let g' = Git.remotesAdd g $ exchange l r'
Annex.changeState $ \s -> s { Annex.repo = g' }
return r'
exchange [] _ = []
exchange (old:ls) new =
if Git.repoRemoteName old == Git.repoRemoteName new
@ -105,24 +124,34 @@ tryGitConfigRead r
- If the remote cannot be accessed, returns a Left error.
-}
inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool)
inAnnex r key = if Git.repoIsUrl r
then checkremote
else liftIO (try checklocal ::IO (Either IOException Bool))
inAnnex r key
| Git.repoIsHttp r = safely checkhttp
| Git.repoIsUrl r = checkremote
| otherwise = safely checklocal
where
checklocal = do
-- run a local check inexpensively,
-- by making an Annex monad using the remote
a <- Annex.new r
Annex.eval a (Content.inAnnex key)
checklocal = onLocal r (Content.inAnnex key)
checkremote = do
showAction $ "checking " ++ Git.repoDescribe r
inannex <- onRemote r (boolSystem, False) "inannex"
[Param (show key)]
return $ Right inannex
checkhttp = Url.exists $ keyUrl r key
safely a = liftIO (try a ::IO (Either IOException Bool))
{- Runs an action on a local repository inexpensively, by making an annex
- monad using that repository. -}
onLocal :: Git.Repo -> Annex a -> IO a
onLocal r a = do
annex <- Annex.new r
Annex.eval annex a
keyUrl :: Git.Repo -> Key -> String
keyUrl r key = Git.repoLocation r ++ "/" ++ annexLocation key
dropKey :: Git.Repo -> Key -> Annex Bool
dropKey r key =
onRemote r (boolSystem, False) "dropkey"
dropKey r key
| Git.repoIsHttp r = error "dropping from http repo not supported"
| otherwise = onRemote r (boolSystem, False) "dropkey"
[ Params "--quiet --force"
, Param $ show key
]
@ -132,7 +161,8 @@ copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
copyFromRemote r key file
| not $ Git.repoIsUrl r = rsyncOrCopyFile r (gitAnnexLocation r key) file
| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file
| otherwise = error "copying from non-ssh repo not supported"
| Git.repoIsHttp r = Url.download (keyUrl r key) file
| otherwise = error "copying from non-ssh, non-http repo not supported"
{- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Git.Repo -> Key -> Annex Bool
@ -141,13 +171,11 @@ copyToRemote r key
g <- Annex.gitRepo
let keysrc = gitAnnexLocation g key
-- run copy from perspective of remote
liftIO $ do
a <- Annex.new r
Annex.eval a $ do
ok <- Content.getViaTmp key $
rsyncOrCopyFile r keysrc
Content.saveState
return ok
liftIO $ onLocal r $ do
ok <- Content.getViaTmp key $
rsyncOrCopyFile r keysrc
Content.saveState
return ok
| Git.repoIsSsh r = do
g <- Annex.gitRepo
let keysrc = gitAnnexLocation g key

2
Remote/Encryptable.hs → Remote/Helper/Encryptable.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Encryptable where
module Remote.Helper.Encryptable where
import qualified Data.Map as M
import Control.Monad.State (liftIO)

4
Remote/Special.hs → Remote/Helper/Special.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Special where
module Remote.Helper.Special where
import qualified Data.Map as M
import Data.Maybe
@ -17,7 +17,7 @@ import Types.Remote
import qualified Git
import qualified Annex
import UUID
import Utility
import Utility.SafeCommand
{- Special remotes don't have a configured url, so Git.Repo does not
- automatically generate remotes for them. This looks for a different

5
Remote/Hook.hs
View file

@ -28,8 +28,9 @@ import Locations
import Config
import Content
import Utility
import Remote.Special
import Remote.Encryptable
import Utility.SafeCommand
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Messages

17
Remote/Rsync.hs
View file

@ -26,11 +26,14 @@ import Locations
import Config
import Content
import Utility
import Remote.Special
import Remote.Encryptable
import Utility.Conditional
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Messages
import Utility.RsyncFile
import Utility.SafeCommand
import Utility.Path
type RsyncUrl = String
@ -93,10 +96,13 @@ rsyncSetup u c = do
return c'
rsyncKey :: RsyncOpts -> Key -> String
rsyncKey o k = rsyncUrl o </> hashDirMixed k </> f </> f
rsyncKey o k = rsyncUrl o </> hashDirMixed k </> shellEscape (f </> f)
where
f = keyFile k
rsyncKeyDir :: RsyncOpts -> Key -> String
rsyncKeyDir o k = rsyncUrl o </> hashDirMixed k </> shellEscape (keyFile k)
store :: RsyncOpts -> Key -> Annex Bool
store o k = do
g <- Annex.gitRepo
@ -136,7 +142,7 @@ remove o k = withRsyncScratchDir $ \tmp -> do
[ Params "--delete --recursive"
, partialParams
, Param $ addTrailingPathSeparator dummy
, Param $ parentDir $ rsyncKey o k
, Param $ rsyncKeyDir o k
]
checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either IOException Bool)
@ -147,8 +153,7 @@ checkPresent r o k = do
res <- liftIO $ boolSystem "sh" [Param "-c", Param cmd]
return $ Right res
where
cmd = "rsync --quiet " ++ testfile ++ " 2>/dev/null"
testfile = shellEscape $ rsyncKey o k
cmd = "rsync --quiet " ++ shellEscape (rsyncKey o k) ++ " 2>/dev/null"
{- Rsync params to enable resumes of sending files safely,
- ensure that files are only moved into place once complete

4
Remote/S3real.hs
View file

@ -33,8 +33,8 @@ import UUID
import Messages
import Locations
import Config
import Remote.Special
import Remote.Encryptable
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Content
import Utility.Base64

54
Remote/Web.hs
View file

@ -7,28 +7,25 @@
module Remote.Web (
remote,
setUrl,
download
setUrl
) where
import Control.Monad.State (liftIO)
import Control.Exception
import System.FilePath
import Network.Browser
import Network.HTTP
import Network.URI
import Types
import Types.Remote
import qualified Git
import qualified Annex
import Messages
import Utility
import UUID
import Config
import PresenceLog
import LocationLog
import Locations
import Utility
import qualified Utility.Url as Url
type URLString = String
@ -67,10 +64,17 @@ gen r _ _ =
{- The urls for a key are stored in remote/web/hash/key.log
- in the git-annex branch. -}
urlLog :: Key -> FilePath
urlLog key = "remote/web" </> hashDirLower key </> show key ++ ".log"
urlLog key = "remote/web" </> hashDirLower key </> keyFile key ++ ".log"
oldurlLog :: Key -> FilePath
{- A bug used to store the urls elsewhere. -}
oldurlLog key = "remote/web" </> hashDirLower key </> show key ++ ".log"
getUrls :: Key -> Annex [URLString]
getUrls key = currentLog (urlLog key)
getUrls key = do
us <- currentLog (urlLog key)
if null us
then currentLog (oldurlLog key)
else return us
{- Records a change in an url for a key. -}
setUrl :: Key -> URLString -> LogStatus -> Annex ()
@ -83,9 +87,12 @@ setUrl key url status = do
logChange g key webUUID (if null us then InfoMissing else InfoPresent)
downloadKey :: Key -> FilePath -> Annex Bool
downloadKey key file = do
us <- getUrls key
download us file
downloadKey key file = get =<< getUrls key
where
get [] = do
warning "no known url"
return False
get urls = anyM (`Url.download` file) urls
uploadKey :: Key -> Annex Bool
uploadKey _ = do
@ -107,28 +114,5 @@ checkKey' :: [URLString] -> Annex Bool
checkKey' [] = return False
checkKey' (u:us) = do
showAction $ "checking " ++ u
e <- liftIO $ urlexists u
e <- liftIO $ Url.exists u
if e then return e else checkKey' us
urlexists :: URLString -> IO Bool
urlexists url =
case parseURI url of
Nothing -> return False
Just u -> do
(_, r) <- Network.Browser.browse $ do
setErrHandler ignore
setOutHandler ignore
setAllowRedirects True
request (mkRequest HEAD u :: Request_String)
case rspCode r of
(2,_,_) -> return True
_ -> return False
where
ignore = const $ return ()
download :: [URLString] -> FilePath -> Annex Bool
download [] _ = return False
download (url:us) file = do
showOutput -- make way for curl progress bar
ok <- liftIO $ boolSystem "curl" [Params "-L -C - -# -o", File file, File url]
if ok then return ok else download us file

3
RemoteLog.hs
View file

@ -19,6 +19,7 @@ import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Char
import Control.Applicative
import qualified Branch
import Types
@ -40,7 +41,7 @@ configSet u c = do
{- Map of remotes by uuid containing key/value config maps. -}
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
readRemoteLog = return . remoteLogParse =<< Branch.get remoteLog
readRemoteLog = remoteLogParse <$> Branch.get remoteLog
remoteLogParse :: String -> M.Map UUID RemoteConfig
remoteLogParse s =

2
UUID.hs
View file

@ -33,7 +33,7 @@ import qualified Branch
import Types
import Types.UUID
import qualified Annex
import qualified SysConfig
import qualified Build.SysConfig as SysConfig
import Config
configkey :: String

38
Upgrade/V1.hs
View file

@ -11,6 +11,7 @@ import System.IO.Error (try)
import System.Directory
import Control.Monad.State (liftIO)
import Control.Monad (filterM, forM_, unless)
import Control.Applicative
import System.Posix.Files
import System.FilePath
import Data.String.Utils
@ -22,7 +23,7 @@ import Types.Key
import Content
import Types
import Locations
import LocationLog
import PresenceLog
import qualified Annex
import qualified AnnexQueue
import qualified Git
@ -31,6 +32,8 @@ import Backend
import Messages
import Version
import Utility
import Utility.SafeCommand
import Utility.Path
import qualified Upgrade.V2
-- v2 adds hashing of filenames of content and location log files.
@ -123,7 +126,7 @@ moveLocationLogs = do
else return []
move (l, k) = do
g <- Annex.gitRepo
let dest = logFile k
let dest = logFile2 g k
let dir = Upgrade.V2.gitStateDir g
let f = dir </> l
liftIO $ createDirectoryIfMissing True (parentDir dest)
@ -131,9 +134,9 @@ moveLocationLogs = do
-- log files that are not checked into git,
-- as well as merging with already upgraded
-- logs that have been pulled from elsewhere
old <- readLog f
new <- readLog dest
writeLog dest (old++new)
old <- liftIO $ readLog1 f
new <- liftIO $ readLog1 dest
liftIO $ writeLog1 dest (old++new)
AnnexQueue.add "add" [Param "--"] [dest]
AnnexQueue.add "add" [Param "--"] [f]
AnnexQueue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f]
@ -186,8 +189,11 @@ fileKey1 :: FilePath -> Key
fileKey1 file = readKey1 $
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
logFile1 :: Git.Repo -> Key -> String
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
writeLog1 :: FilePath -> [LogLine] -> IO ()
writeLog1 file ls = viaTmp writeFile file (unlines $ map show ls)
readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catch (parseLog <$> readFileStrict file) (const $ return [])
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile1 file = do
@ -196,7 +202,7 @@ lookupFile1 file = do
Left _ -> return Nothing
Right l -> makekey l
where
getsymlink = return . takeFileName =<< readSymbolicLink file
getsymlink = takeFileName <$> readSymbolicLink file
makekey l = case maybeLookupBackendName bname of
Nothing -> do
unless (null kname || null bname ||
@ -230,3 +236,19 @@ getKeyFilesPresent1' dir = do
case result of
Right s -> return $ isRegularFile s
Left _ -> return False
logFile1 :: Git.Repo -> Key -> String
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
logFile2 :: Git.Repo -> Key -> String
logFile2 = logFile' hashDirLower
logFile' :: (Key -> FilePath) -> Git.Repo -> Key -> String
logFile' hasher repo key =
gitStateDir repo ++ hasher key ++ keyFile key ++ ".log"
stateDir :: FilePath
stateDir = addTrailingPathSeparator $ ".git-annex"
gitStateDir :: Git.Repo -> FilePath
gitStateDir repo = addTrailingPathSeparator $ Git.workTree repo </> stateDir

2
Upgrade/V2.hs
View file

@ -20,6 +20,8 @@ import qualified Git
import qualified Branch
import Messages
import Utility
import Utility.Conditional
import Utility.SafeCommand
import LocationLog
import Content

245
Utility.hs
View file

@ -6,144 +6,33 @@
-}
module Utility (
CommandParam(..),
toCommand,
hGetContentsStrict,
readFileStrict,
parentDir,
absPath,
absPathFrom,
relPathCwdToFile,
relPathDirToFile,
boolSystem,
boolSystemEnv,
executeFile,
shellEscape,
shellUnEscape,
unsetFileMode,
readMaybe,
viaTmp,
withTempFile,
dirContains,
dirContents,
myHomeDir,
catchBool,
whenM,
(>>?),
unlessM,
(>>!),
prop_idempotent_shellEscape,
prop_idempotent_shellEscape_multiword,
prop_parentDir_basics,
prop_relPathDirToFile_basics
inPath,
firstM,
anyM
) where
import IO (bracket)
import System.IO
import System.Exit
import qualified System.Posix.Process
import System.Posix.Process hiding (executeFile)
import System.Posix.Signals
import System.Posix.Files
import System.Posix.Types
import System.Posix.User
import Data.String.Utils
import System.Path
import System.FilePath
import System.Directory
import Foreign (complement)
import Data.List
import Utility.Path
import Data.Maybe
import Control.Monad (liftM2, when, unless)
import System.Log.Logger
{- A type for parameters passed to a shell command. A command can
- be passed either some Params (multiple parameters can be included,
- whitespace-separated, or a single Param (for when parameters contain
- whitespace), or a File.
-}
data CommandParam = Params String | Param String | File FilePath
deriving (Eq, Show, Ord)
{- Used to pass a list of CommandParams to a function that runs
- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
toCommand = (>>= unwrap)
where
unwrap (Param s) = [s]
unwrap (Params s) = filter (not . null) (split " " s)
-- Files that start with a dash are modified to avoid
-- the command interpreting them as options.
unwrap (File ('-':s)) = ["./-" ++ s]
unwrap (File s) = [s]
{- Run a system command, and returns True or False
- if it succeeded or failed.
-
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
-}
boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystemEnv command params Nothing
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params env = do
-- Going low-level because all the high-level system functions
-- block SIGINT etc. We need to block SIGCHLD, but allow
-- SIGINT to do its default program termination.
let sigset = addSignal sigCHLD emptySignalSet
oldint <- installHandler sigINT Default Nothing
oldset <- getSignalMask
blockSignals sigset
childpid <- forkProcess $ childaction oldint oldset
mps <- getProcessStatus True False childpid
restoresignals oldint oldset
case mps of
Just (Exited ExitSuccess) -> return True
_ -> return False
where
restoresignals oldint oldset = do
_ <- installHandler sigINT oldint Nothing
setSignalMask oldset
childaction oldint oldset = do
restoresignals oldint oldset
executeFile command True (toCommand params) env
{- executeFile with debug logging -}
executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
executeFile c path p e = do
debugM "Utility.executeFile" $
"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
System.Posix.Process.executeFile c path p e
{- Escapes a filename or other parameter to be safely able to be exposed to
- the shell. -}
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
escaped = join "'\"'\"'" $ split "'" f
{- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
where
(word, rest) = findword "" s
findword w [] = (w, "")
findword w (c:cs)
| c == ' ' = (w, cs)
| c == '\'' = inquote c w cs
| c == '"' = inquote c w cs
| otherwise = findword (w++[c]) cs
inquote _ w [] = (w, "")
inquote q w (c:cs)
| c == q = findword w cs
| otherwise = inquote q (w++[c]) cs
{- For quickcheck. -}
prop_idempotent_shellEscape :: String -> Bool
prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
prop_idempotent_shellEscape_multiword :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
import Control.Monad (liftM)
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}
@ -154,82 +43,6 @@ hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s
readFileStrict :: FilePath -> IO String
readFileStrict f = readFile f >>= \s -> length s `seq` return s
{- Returns the parent directory of a path. Parent of / is "" -}
parentDir :: FilePath -> FilePath
parentDir dir =
if not $ null dirs
then slash ++ join s (take (length dirs - 1) dirs)
else ""
where
dirs = filter (not . null) $ split s dir
slash = if isAbsolute dir then s else ""
s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
| null dir = True
| dir == "/" = parentDir dir == ""
| otherwise = p /= dir
where
p = parentDir dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
where
norm p = fromMaybe "" $ absNormPath p "."
a' = norm a
b' = norm b
{- Converts a filename into a normalized, absolute path. -}
absPath :: FilePath -> IO FilePath
absPath file = do
cwd <- getCurrentDirectory
return $ absPathFrom cwd file
{- Converts a filename into a normalized, absolute path
- from the specified cwd. -}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
where
bad = error $ "unable to normalize " ++ file
{- Constructs a relative path from the CWD to a file.
-
- For example, assuming CWD is /tmp/foo/bar:
- relPathCwdToFile "/tmp/foo" == ".."
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = liftM2 relPathDirToFile getCurrentDirectory (absPath f)
{- Constructs a relative path from a directory to a file.
-
- Both must be absolute, and normalized (eg with absNormpath).
-}
relPathDirToFile :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = path
where
s = [pathSeparator]
pfrom = split s from
pto = split s to
common = map fst $ filter same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
path = join s $ dotdots ++ uncommon
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
| from == to = null r
| otherwise = not (null r)
where
r = relPathDirToFile from to
{- Removes a FileMode from a file.
- For example, call with otherWriteMode to chmod o-w -}
unsetFileMode :: FilePath -> FileMode -> IO ()
@ -253,6 +66,18 @@ viaTmp a file content = do
a tmpfile content
renameFile tmpfile file
{- Runs an action with a temp file, then removes the file. -}
withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a
withTempFile template a = bracket create remove use
where
create = do
tmpdir <- catch getTemporaryDirectory (const $ return ".")
openTempFile tmpdir template
remove (name, handle) = do
hClose handle
catchBool (removeFile name >> return True)
use (name, handle) = a name handle
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath]
@ -275,19 +100,23 @@ myHomeDir = do
catchBool :: IO Bool -> IO Bool
catchBool = flip catch (const $ return False)
{- when with a monadic conditional -}
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = c >>= flip when a
{- Return the first value from a list, if any, satisfying the given
- predicate -}
firstM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing
firstM p (x:xs) = do
q <- p x
if q
then return (Just x)
else firstM p xs
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= flip unless a
{- Returns true if any value in the list satisfies the preducate,
- stopping once one is found. -}
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyM p = liftM isJust . firstM p
(>>?) :: Monad m => m Bool -> m () -> m ()
(>>?) = whenM
(>>!) :: Monad m => m Bool -> m () -> m ()
(>>!) = unlessM
-- low fixity allows eg, foo bar >>! error $ "failed " ++ meep
infixr 0 >>?
infixr 0 >>!
{- Checks if a command is available in PATH. -}
inPath :: String -> IO Bool
inPath command = getSearchPath >>= anyM indir
where
indir d = doesFileExist $ d </> command

26
Utility/Conditional.hs Normal file
View file

@ -0,0 +1,26 @@
{- monadic conditional operators
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Conditional where
import Control.Monad (when, unless)
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = c >>= flip when a
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= flip unless a
(>>?) :: Monad m => m Bool -> m () -> m ()
(>>?) = whenM
(>>!) :: Monad m => m Bool -> m () -> m ()
(>>!) = unlessM
-- low fixity allows eg, foo bar >>! error $ "failed " ++ meep
infixr 0 >>?
infixr 0 >>!

5
Utility/CopyFile.hs
View file

@ -9,8 +9,9 @@ module Utility.CopyFile (copyFile) where
import System.Directory (doesFileExist, removeFile)
import Utility
import qualified SysConfig
import Utility.Conditional
import Utility.SafeCommand
import qualified Build.SysConfig as SysConfig
{- The cp command is used, because I hate reinventing the wheel,
- and because this allows easy access to features like cp --reflink. -}

3
Utility/DataUnits.hs
View file

@ -137,8 +137,7 @@ compareSizes units abbrev old new
{- Parses strings like "10 kilobytes" or "0.5tb". -}
readSize :: [Unit] -> String -> Maybe ByteSize
readSize units input
| null parsednum = Nothing
| null parsedunit = Nothing
| null parsednum || null parsedunit = Nothing
| otherwise = Just $ round $ number * fromIntegral multiplier
where
(number, rest) = head parsednum

44
Utility/JSONStream.hs Normal file
View file

@ -0,0 +1,44 @@
{- Streaming JSON output.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.JSONStream (
start,
add,
end
) where
import Text.JSON
{- Text.JSON does not support building up a larger JSON document piece by
piece as a stream. To support streaming, a hack. The JSObject is converted
to a string with its final "}" is left off, allowing it to be added to
later. -}
start :: JSON a => [(String, a)] -> String
start l
| last s == endchar = take (length s - 1) s
| otherwise = bad s
where
s = encodeStrict $ toJSObject l
add :: JSON a => [(String, a)] -> String
add l
| head s == startchar = ',' : drop 1 s
| otherwise = bad s
where
s = start l
end :: String
end = [endchar, '\n']
startchar :: Char
startchar = '{'
endchar :: Char
endchar = '}'
bad :: String -> a
bad s = error $ "Text.JSON returned unexpected string: " ++ s

92
Utility/Path.hs Normal file
View file

@ -0,0 +1,92 @@
{- path manipulation
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Path where
import Data.String.Utils
import System.Path
import System.FilePath
import System.Directory
import Data.List
import Data.Maybe
import Control.Applicative
{- Returns the parent directory of a path. Parent of / is "" -}
parentDir :: FilePath -> FilePath
parentDir dir =
if not $ null dirs
then slash ++ join s (take (length dirs - 1) dirs)
else ""
where
dirs = filter (not . null) $ split s dir
slash = if isAbsolute dir then s else ""
s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
| null dir = True
| dir == "/" = parentDir dir == ""
| otherwise = p /= dir
where
p = parentDir dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
where
norm p = fromMaybe "" $ absNormPath p "."
a' = norm a
b' = norm b
{- Converts a filename into a normalized, absolute path. -}
absPath :: FilePath -> IO FilePath
absPath file = do
cwd <- getCurrentDirectory
return $ absPathFrom cwd file
{- Converts a filename into a normalized, absolute path
- from the specified cwd. -}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
where
bad = error $ "unable to normalize " ++ file
{- Constructs a relative path from the CWD to a file.
-
- For example, assuming CWD is /tmp/foo/bar:
- relPathCwdToFile "/tmp/foo" == ".."
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
{- Constructs a relative path from a directory to a file.
-
- Both must be absolute, and normalized (eg with absNormpath).
-}
relPathDirToFile :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = path
where
s = [pathSeparator]
pfrom = split s from
pto = split s to
common = map fst $ filter same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
path = join s $ dotdots ++ uncommon
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
| from == to = null r
| otherwise = not (null r)
where
r = relPathDirToFile from to

2
Utility/RsyncFile.hs
View file

@ -9,7 +9,7 @@ module Utility.RsyncFile where
import Data.String.Utils
import Utility
import Utility.SafeCommand
{- Generates parameters to make rsync use a specified command as its remote
- shell. -}

104
Utility/SafeCommand.hs Normal file
View file

@ -0,0 +1,104 @@
{- safely running shell commands
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.SafeCommand where
import System.Exit
import qualified System.Posix.Process
import System.Posix.Process hiding (executeFile)
import System.Posix.Signals
import Data.String.Utils
import System.Log.Logger
{- A type for parameters passed to a shell command. A command can
- be passed either some Params (multiple parameters can be included,
- whitespace-separated, or a single Param (for when parameters contain
- whitespace), or a File.
-}
data CommandParam = Params String | Param String | File FilePath
deriving (Eq, Show, Ord)
{- Used to pass a list of CommandParams to a function that runs
- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
toCommand = (>>= unwrap)
where
unwrap (Param s) = [s]
unwrap (Params s) = filter (not . null) (split " " s)
-- Files that start with a dash are modified to avoid
-- the command interpreting them as options.
unwrap (File s@('-':_)) = ["./" ++ s]
unwrap (File s) = [s]
{- Run a system command, and returns True or False
- if it succeeded or failed.
-
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
-}
boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystemEnv command params Nothing
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params env = do
-- Going low-level because all the high-level system functions
-- block SIGINT etc. We need to block SIGCHLD, but allow
-- SIGINT to do its default program termination.
let sigset = addSignal sigCHLD emptySignalSet
oldint <- installHandler sigINT Default Nothing
oldset <- getSignalMask
blockSignals sigset
childpid <- forkProcess $ childaction oldint oldset
mps <- getProcessStatus True False childpid
restoresignals oldint oldset
case mps of
Just (Exited ExitSuccess) -> return True
_ -> return False
where
restoresignals oldint oldset = do
_ <- installHandler sigINT oldint Nothing
setSignalMask oldset
childaction oldint oldset = do
restoresignals oldint oldset
executeFile command True (toCommand params) env
{- executeFile with debug logging -}
executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
executeFile c path p e = do
debugM "Utility.SafeCommand.executeFile" $
"Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e
System.Posix.Process.executeFile c path p e
{- Escapes a filename or other parameter to be safely able to be exposed to
- the shell. -}
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
escaped = join "'\"'\"'" $ split "'" f
{- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
where
(word, rest) = findword "" s
findword w [] = (w, "")
findword w (c:cs)
| c == ' ' = (w, cs)
| c == '\'' = inquote c w cs
| c == '"' = inquote c w cs
| otherwise = findword (w++[c]) cs
inquote _ w [] = (w, "")
inquote q w (c:cs)
| c == q = findword w cs
| otherwise = inquote q (w++[c]) cs
{- For quickcheck. -}
prop_idempotent_shellEscape :: String -> Bool
prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
prop_idempotent_shellEscape_multiword :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s

4
Remote/Ssh.hs → Utility/Ssh.hs
View file

@ -5,12 +5,12 @@
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Ssh where
module Utility.Ssh where
import Control.Monad.State (liftIO)
import qualified Git
import Utility
import Utility.SafeCommand
import Types
import Config

2
StatFS.hsc → Utility/StatFS.hsc
View file

@ -45,7 +45,7 @@
{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}
module StatFS ( FileSystemStats(..), getFileSystemStats ) where
module Utility.StatFS ( FileSystemStats(..), getFileSystemStats ) where
import Foreign
import Foreign.C.Types

2
Touch.hsc → Utility/Touch.hsc
View file

@ -7,7 +7,7 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Touch (
module Utility.Touch (
TimeSpec(..),
touchBoth,
touch

79
Utility/Url.hs Normal file
View file

@ -0,0 +1,79 @@
{- Url downloading.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Url (
exists,
download,
get
) where
import Control.Applicative
import Control.Monad.State (liftIO)
import qualified Network.Browser as Browser
import Network.HTTP
import Network.URI
import Types
import Messages
import Utility.SafeCommand
import Utility
type URLString = String
{- Checks that an url exists and could be successfully downloaded. -}
exists :: URLString -> IO Bool
exists url =
case parseURI url of
Nothing -> return False
Just u -> do
r <- request u HEAD
case rspCode r of
(2,_,_) -> return True
_ -> return False
{- Used to download large files, such as the contents of keys.
- Uses wget or curl program for its progress bar. (Wget has a better one,
- so is preferred.) -}
download :: URLString -> FilePath -> Annex Bool
download url file = do
showOutput -- make way for program's progress bar
e <- liftIO $ inPath "wget"
if e
then
liftIO $ boolSystem "wget"
[Params "-c -O", File file, File url]
else
-- Uses the -# progress display, because the normal
-- one is very confusing when resuming, showing
-- the remainder to download as the whole file,
-- and not indicating how much percent was
-- downloaded before the resume.
liftIO $ boolSystem "curl"
[Params "-L -C - -# -o", File file, File url]
{- Downloads a small file. -}
get :: URLString -> IO String
get url =
case parseURI url of
Nothing -> error "url parse error"
Just u -> do
r <- request u GET
case rspCode r of
(2,_,_) -> return $ rspBody r
_ -> error $ rspReason r
{- Makes a http request of an url. For example, HEAD can be used to
- check if the url exists, or GET used to get the url content (best for
- small urls). -}
request :: URI -> RequestMethod -> IO (Response String)
request url requesttype = Browser.browse $ do
Browser.setErrHandler ignore
Browser.setOutHandler ignore
Browser.setAllowRedirects True
snd <$> Browser.request (mkRequest requesttype url :: Request_String)
where
ignore = const $ return ()

19
Version.hs
View file

@ -7,8 +7,6 @@
module Version where
import Control.Monad (unless)
import Types
import qualified Annex
import qualified Git
@ -39,14 +37,11 @@ getVersion = do
setVersion :: Annex ()
setVersion = setConfig versionField defaultVersion
checkVersion :: Annex ()
checkVersion = getVersion >>= handle
checkVersion :: Version -> Annex ()
checkVersion v
| v `elem` supportedVersions = return ()
| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
| otherwise = err "Upgrade git-annex."
where
handle Nothing = error "First run: git-annex init"
handle (Just v) = unless (v `elem` supportedVersions) $
error $ "Repository version " ++ v ++
" is not supported. " ++
msg v
msg v
| v `elem` upgradableVersions = "Upgrade this repository: git-annex upgrade"
| otherwise = "Upgrade git-annex."
err msg = error $ "Repository version " ++ v ++
" is not supported. " ++ msg

2
configure.hs
View file

@ -3,7 +3,7 @@
import System.Directory
import Data.List
import TestConfig
import Build.TestConfig
tests :: [TestCase]
tests =

40
debian/changelog vendored
View file

@ -1,3 +1,43 @@
git-annex (3.20110906) unstable; urgency=low
* Improve display of newlines around error and warning messages.
* Fix Makefile to work with cabal again.
-- Joey Hess <joeyh@debian.org> Tue, 06 Sep 2011 13:45:16 -0400
git-annex (3.20110902) unstable; urgency=low
* Set EMAIL when running test suite so that git does not need to be
configured first. Closes: #638998
* The wget command will now be used in preference to curl, if available.
* init: Make description an optional parameter.
* unused, status: Sped up by avoiding unnecessary stats of annexed files.
* unused --remote: Reduced memory use to 1/4th what was used before.
* Add --json switch, to produce machine-consumable output.
-- Joey Hess <joeyh@debian.org> Fri, 02 Sep 2011 21:20:37 -0400
git-annex (3.20110819) unstable; urgency=low
* Now "git annex init" only has to be run once, when a git repository
is first being created. Clones will automatically notice that git-annex
is in use and automatically perform a basic initalization. It's
still recommended to run "git annex init" in any clones, to describe them.
* Added annex-cost-command configuration, which can be used to vary the
cost of a remote based on the output of a shell command.
* Fix broken upgrade from V1 repository. Closes: #638584
-- Joey Hess <joeyh@debian.org> Fri, 19 Aug 2011 20:34:09 -0400
git-annex (3.20110817) unstable; urgency=low
* Fix shell escaping in rsync special remote.
* addurl: --fast can be used to avoid immediately downloading the url.
* Added support for getting content from git remotes using http (and https).
* Added curl to Debian package dependencies.
-- Joey Hess <joeyh@debian.org> Wed, 17 Aug 2011 01:29:02 -0400
git-annex (3.20110719~bpo60+1) squeeze-backports; urgency=low
* Bugfix: Make add ../ work.

2
debian/control vendored
View file

@ -12,6 +12,7 @@ Build-Depends:
libghc6-http-dev,
libghc6-utf8-string-dev,
libghc6-testpack-dev [any-i386 any-amd64],
libghc6-json-dev,
ikiwiki,
perlmagick,
git | git-core,
@ -29,6 +30,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
git | git-core,
uuid,
rsync,
wget | curl,
openssh-client
Suggests: graphviz, bup, gnupg
Description: manage files with git, without checking their contents into git

2
debian/copyright vendored
View file

@ -8,7 +8,7 @@ License: GPL-3+
this package's source, or in /usr/share/common-licenses/GPL-3 on
Debian systems.
Files: StatFS.hsc
Files: Utility/StatFS.hsc
Copyright: Jose A Ortega Ruiz <jao@gnu.org>
License: BSD-3-clause
-- All rights reserved.

26
doc/backends.mdwn
View file

@ -1,24 +1,16 @@
git-annex uses a key-value abstraction layer to allow file contents to be
stored in different ways. In theory, any key-value storage system could be
used to store file contents.
When a file is annexed, a key is generated from its content and/or metadata.
The file checked into git symlinks to the key. This key can later be used
to retrieve the file's content (its value).
Multiple pluggable backends are supported, and a single repository
can use different backends for different files.
Multiple pluggable key-value backends are supported, and a single repository
can use different ones for different files.
These backends can transfer file contents between configured git remotes.
It's also possible to use [[special_remotes]], such as Amazon S3 with
these backends.
* `WORM` ("Write Once, Read Many") This backend assumes that any file with
the same basename, size, and modification time has the same content. So with
this backend, files can be moved around, but should never be added to
or changed. This is the default, and the least expensive backend.
* `SHA1` -- This backend uses a key based on a sha1 checksum. This backend
allows modifications of files to be tracked. Its need to generate checksums
* `WORM` ("Write Once, Read Many") This assumes that any file with
the same basename, size, and modification time has the same content.
This is the default, and the least expensive backend.
* `SHA1` -- This uses a key based on a sha1 checksum. This allows
verifying that the file content is right, and can avoid duplicates of
files with the same content. Its need to generate checksums
can make it slower for large files.
* `SHA512`, `SHA384`, `SHA256`, `SHA224` -- Like SHA1, but larger
checksums. Mostly useful for the very paranoid, or anyone who is
@ -36,7 +28,7 @@ files, the `.gitattributes` file can be used. The `annex.backend`
attribute can be set to the name of the backend to use for matching files.
For example, to use the SHA1 backend for sound files, which tend to be
smallish and might be modified over time, you could set in
smallish and might be modified or copied over time, you could set in
`.gitattributes`:
*.mp3 annex.backend=SHA1

29
doc/bugs/--git-dir_and_--work-tree_options.mdwn Normal file
View file

@ -0,0 +1,29 @@
git-annex does not take into account the --git-dir and --work-tree command line options (while they can be useful when scripting).
> mkdir /tmp/test
> cd /tmp/test
> git init
Initialized empty Git repository in /tmp/test/.git/
> git annex init test
init test ok
> touch foo
> cd
> git --git-dir=/tmp/test/.git --work-tree=/tmp/test annex add foo
git-annex: Not in a git repository.
regular git add works:
> git --git-dir=/tmp/test/.git --work-tree=/tmp/test add foo
> git --git-dir=/tmp/test/.git --work-tree=/tmp/test status
# On branch master
#
# Initial commit
#
# Changes to be committed:
# (use "git rm --cached <file>..." to unstage)
#
# new file: foo
#
git-annex version: 3.20110702

11
doc/bugs/Build_error_on_Mac_OSX_10.6.mdwn Normal file
View file

@ -0,0 +1,11 @@
While following the instructions given at the OSX build page , I get this error:
$ make
ghc -O2 -Wall -ignore-package monads-fd -fspec-constr-count=5 --make git-annex
Utility/JSONStream.hs:14:8:
Could not find module `Text.JSON':
Use -v to see a list of the files searched for.
make: *** [git-annex] Error 1
> Updated the instructions. [[done]] --[[Joey]]

14
doc/bugs/Cabal_dependency_monadIO_missing.mdwn Normal file
View file

@ -0,0 +1,14 @@
Just issuing the command `cabal install` results in the following error message.
Command/Add.hs:54:3:
No instance for (Control.Monad.IO.Control.MonadControlIO
(Control.Monad.State.Lazy.StateT Annex.AnnexState IO))
arising from a use of `handle' at Command/Add.hs:54:3-24
Adding the dependency for `monadIO` to `git-annex.cabal` should fix this?
-- Thomas
> No, it's already satisfied by `monad-control` being listed as a
> dependency in the cabal file. Your system might be old/new/or broken,
> perhaps it's time to provide some details about the version of haskell
> and of `monad-control` you have installed? --[[Joey]]

75
doc/bugs/Cabal_dependency_monadIO_missing/comment_1_14be660aa57fadec0d81b32a8b52c66f._comment Normal file
View file

@ -0,0 +1,75 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawmFgsNxmnGznb5bbmcoWhoQOoxZZ-io61s"
nickname="Thomas"
subject="comment 1"
date="2011-08-08T09:04:20Z"
content="""
I use Debian Squeeze, I have the Debian package cabal-install 0.8.0-1 installed.
$ git clone git://git-annex.branchable.com/
$ cd git-annex.branchable.com
$ cabal update
$ cabal install cabal-install
This installed: Cabal-1.10.2.0, zlib-0.5.3.1, cabal-install 0.10.2.
No version of monad-control or monadIO installed.
$ ~/.cabal/bin/cabal install
Registering QuickCheck-2.4.1.1...
Registering Crypto-4.2.3...
Registering base-unicode-symbols-0.2.2.1...
Registering deepseq-1.1.0.2...
Registering hxt-charproperties-9.1.0...
Registering hxt-regex-xmlschema-9.0.0...
Registering hxt-unicode-9.0.1...
Registering hxt-9.1.2...
Registering stm-2.2.0.1...
Registering hS3-0.5.6...
Registering transformers-0.2.2.0...
Registering monad-control-0.2.0.1...
[1 of 1] Compiling Main ( Setup.hs, dist/setup/Main.o )
Linking ./dist/setup/setup ...
ghc -O2 -Wall -ignore-package monads-fd -fspec-constr-count=5 --make configure
[1 of 2] Compiling TestConfig ( TestConfig.hs, TestConfig.o )
[2 of 2] Compiling Main ( configure.hs, configure.o )
Linking configure ...
./configure
checking version... 3.20110720
checking cp -a... yes
checking cp -p... yes
checking cp --reflink=auto... yes
checking uuid generator... uuid
checking xargs -0... yes
checking rsync... yes
checking curl... yes
checking bup... yes
checking gpg... yes
checking sha1... sha1sum
checking sha256... sha256sum
checking sha512... sha512sum
checking sha224... sha224sum
checking sha384... sha384sum
...
Command/Add.hs:54:3:
No instance for (Control.Monad.IO.Control.MonadControlIO
(Control.Monad.State.Lazy.StateT Annex.AnnexState IO))
arising from a use of `handle' at Command/Add.hs:54:3-24
Possible fix:
add an instance declaration for
(Control.Monad.IO.Control.MonadControlIO
(Control.Monad.State.Lazy.StateT Annex.AnnexState IO))
In the first argument of `($)', namely `handle (undo file key)'
In a stmt of a 'do' expression:
handle (undo file key) $ moveAnnex key file
In the expression:
do { handle (undo file key) $ moveAnnex key file;
next $ cleanup file key }
cabal: Error: some packages failed to install:
git-annex-3.20110719 failed during the building phase. The exception was:
ExitFailure 1
After I added a depencency for monadIO to the git-annex.cabal file, it installed correctly.
-- Thomas
"""]]

8
doc/bugs/Cabal_dependency_monadIO_missing/comment_2_4f4d8e1e00a2a4f7e8a8ab082e16adac._comment Normal file
View file

@ -0,0 +1,8 @@
[[!comment format=mdwn
username="http://joey.kitenet.net/"
nickname="joey"
subject="comment 2"
date="2011-08-17T04:56:30Z"
content="""
Finally got a chance to try to reproduce this. I followed your recipe exactly in a clean squeeze chroot. monadIO was not installed, but git-annex built ok, using monad-control.
"""]]

14
doc/bugs/Prevent_accidental_merges.mdwn Normal file
View file

@ -0,0 +1,14 @@
With the storage layout v3, pulling the git-annex branch into the master branch is... less than ideal.
The fact that the two branches contain totally different data make an accidental merge worse, arguably.
Adding a tiny binary file called .gitnomerge to both branches would solve that without any noticeable overhead.
Yes, there is an argument to be made that this is too much hand-holding, but I still think it's worth it.
-- Richard
> It should be as easy to undo such an accidential merge
> as it is to undo any other git commit, right? I quite like that git-annex
> no longer adds any clutter to the master branch, and would be reluctant
> to change that. --[[Joey]]

19
doc/bugs/add_script-friendly_output_options.mdwn Normal file
View file

@ -0,0 +1,19 @@
I have a need to use git-annex from a larger program. It'd be great if the information output by some of the commands that is descriptive (for example, whereis) could be sent to stdout in a machine-readable format like (preferably) JSON, or XML. That way I can simply read in the output of the command and use the data directly instead of having to parse it via regexes or other such string manipulation.
This could perhaps be triggered by a --json or --xml flag to the relevant commands.
> This is [[done]], --json is supported by all commands, more or less.
>
> Caveats:
>
> * the version, status, and find commands produce custom output and so
> no json. This could change for version and status; find needs to just
> be a simple list of files, I think
> * The "note" fields may repeat multiple times per object with different
> notes and are of course not machine readable, and subject to change.
> * Output of helper commands like rsync is not diverted away, and
> could clutter up the json output badly. Should only affect commands
> that transfer data. And AFAICS, wget and rsync both output their
> progress displays to stderr, so shouldn't be a problem.
>
> --[[Joey]]

10
doc/bugs/fsck_output.mdwn
View file

@ -34,3 +34,13 @@ The newline is in the wrong place and confuses the user. It should be printed _a
> failed
>
> --[[Joey]]
>> Well, I fixed this in all cases except a thrown non-IO error (last
>> example aboce), which output is printed by haskell's runtime. I'd
>> have to add a second error handler to handle those, and it's not
>> clear what it would do. Often an error will occur before anything
>> else is printed, and then the current behavior is right; if something
>> has been printed it would be nice to have a newline before the error,
>> but by the time the error is caught we'd be out of the annex monad
>> and not really have any way to know if something has been printed.
>> I think my fix is good enough [[done]] --[[Joey]]

50
doc/bugs/rsync_special_remote_fails_to___96__get__96___files_which_have_names_containing_spaces.mdwn Normal file
View file

@ -0,0 +1,50 @@
~$ mkdir test annex
~$ cd test
~$ git init
Initialized empty Git repository in /home/user/test/.git/
~$ git annex init test
init test ok
~$ git annex initremote localrsync encryption=none type=rsync rsyncurl=localhost:annex/
initremote localrsync ok
~$ cp /home/user/Music/Charming\ Hostess/Eat/03\ Mi\ Nuera.ogg ./
~$ git annex add 03\ Mi\ Nuera.ogg
add 03 Mi Nuera.ogg ok
(Recording state in git...)
~$ git commit -m "add ogg"
fatal: No HEAD commit to compare with (yet)
fatal: No HEAD commit to compare with (yet)
[master (root-commit) 12608af] add ogg
1 files changed, 1 insertions(+), 0 deletions(-)
create mode 120000 03 Mi Nuera.ogg
~$ git annex move 03\ Mi\ Nuera.ogg --to localrsync
move 03 Mi Nuera.ogg (checking localrsync...) (to localrsync...)
sending incremental file list
1X/
1X/39/
1X/39/WORM-s6296772-m1311874383--03 Mi Nuera.ogg/
1X/39/WORM-s6296772-m1311874383--03 Mi Nuera.ogg/WORM-s6296772-m1311874383--03 Mi Nuera.ogg
6296772 100% 42.98MB/s 0:00:00 (xfer#1, to-check=0/5)
sent 6297754 bytes received 43 bytes 4198531.33 bytes/sec
total size is 6296772 speedup is 1.00
ok
~$ git annex get 03\ Mi\ Nuera.ogg
get 03 Mi Nuera.ogg (from localrsync...)
rsync: link_stat "/home/user/annex/1X/39/WORM-s6296772-m1311874383--03" failed: No such file or directory (2)
rsync: link_stat "/home/user/Mi" failed: No such file or directory (2)
rsync: change_dir "/home/user/Nuera.ogg" failed: No such file or directory (2)
rsync: link_stat "/home/user/Mi" failed: No such file or directory (2)
rsync: link_stat "/home/user/Nuera.ogg" failed: No such file or directory (2)
sent 8 bytes received 12 bytes 13.33 bytes/sec
total size is 0 speedup is 0.00
rsync error: some files/attrs were not transferred (see previous errors) (code 23) at main.c(1526) [Receiver=3.0.7]
rsync failed -- run git annex again to resume file transfer
Unable to access these remotes: localrsync
Try making some of these repositories available:
b8b1ea7a-b93f-11e0-b712-d7bffb6e61e6 -- localrsync
failed
git-annex: 1 failed
> [[fixed|done]] --[[Joey]]

20
doc/bugs/support_bare_git_repo__44___with_the_annex_directory_exposed_to_http.mdwn Normal file
View file

@ -0,0 +1,20 @@
Let's say that http://people.collabora.com/~alsuren/git/fate-suite.git/ is a bare git repo. It has been 'git update-server-info'd so that it can be served on a dumb http server.
The repo is also a git annex remote, created using the following commands:
* git remote add alsuren git+ssh://people.collabora.co.uk/user/alsuren/public_html/fate-suite.git
* git push alsuren --all
* git annex copy --to=alsuren
so http://people.collabora.com/~alsuren/git/fate-suite.git/annex is a valid git annex (though listing dirs is forbidden, so you need to know the filenames ahead of time).
I would like to be able to use the following commands to get a clone of the repo:
* git clone http://people.collabora.com/~alsuren/git/fate-suite.git/
* cd fate-suite
* git annex get
This would allow contributors to quickly get a copy of our upstream repo and start contributing with minimal bandwidth/effort.
> This is now supported.. I look forward to seeing your project using it!
> --[[Joey]] [[!tag done]]

3
doc/bugs/test_suite_shouldn__39__t_fail_silently.mdwn Normal file
View file

@ -0,0 +1,3 @@
When the test suite cannot be compiled, the build just fails silenty. This means that in automated builds there is no easy way to ensure that the generated binaries have passed the test suite, because it may not even have been run! IMHO, "make test" should fail (i.e. return a non-zero exit code) when it can't succeeed.
> Ok, fixed. --[[Joey]] [[done]]

36
doc/bugs/wishlist:_more_descriptive_commit_messages_in_git-annex_branch.mdwn Normal file
View file

@ -0,0 +1,36 @@
as of git-annex version 3.20110719, all git-annex commits only contain the word "update" as a commit message. given that the contents of the commit are pretty non-descriptive (SHA1 hashes for file names, uuids for repository names), i suggest to have more descriptive commit messages, as shown here:
/mnt/usb_disk/photos/2011$ git annex get
/mnt/usb_disk/photos/2011$ git show git-annex
[...]
usb-disk-photos: get 2011
* 10 files retrieved from 2 sources (9 from local-harddisk, 1 from my-server)
* 120 files were already present
* 2 files could not be retrieved
/mnt/usb_disk/photos/2011$ cd ~/photos/2011/07
~/photos/2011/07$ git copy --to my-server
~/photos/2011/07$ git show git-annex
[...]
local-harddisk: copy 2011/07 to my-server
* 20 files pushed
~/photos/2011/07$
in my opinion, the messages should at least contain
* what command was used
* in which repository they were executed
* which files or directories they affected (not necessarily all files, but what was given on command line or implicitly from the working directory)
--[[chrysn]]
> The implementation of the git-annex branch precludes more descriptive
> commit messages, since a single commit can include changes that were
> previously staged to the branch's index file, or spooled to its journal
> by other git-annex commands (either concurrently running or
> interrupted commands, or even changes needed to automatically merge
> other git-annex branches).
>
> It would be possible to make it *less* verbose, with an empty commit
> message. :) --[[Joey]]

2
doc/cheatsheet.mdwn
View file

@ -1,4 +1,4 @@
A suppliment to the [[walkthrough]].
A supplement to the [[walkthrough]].
[[!toc]]

6
doc/copies.mdwn
View file

@ -1,8 +1,8 @@
The WORM and SHA1 key-value [[backends]] store data inside
your git repository's `.git` directory, not in some external data store.
Annexed data is stored inside your git repository's `.git/annex` directory.
Some [[special_remotes]] can store annexed data elsewhere.
It's important that data not get lost by an ill-considered `git annex drop`
command. So, then using those backends, git-annex can be configured to try
command. So, git-annex can be configured to try
to keep N copies of a file's content available across all repositories.
(Although [[untrusted_repositories|trust]] don't count toward this total.)

15
doc/forum/Wishlist:_Is_it_possible_to___34__unlock__34___files_without_copying_the_file_data__63__/comment_2_f5ebb7f43dcef861ecc13373fb1e263f._comment Normal file
View file

@ -0,0 +1,15 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawmL8pteP2jbYJUn1M3CbeLDvz2SWAA1wtg"
nickname="Kristian"
subject="Solution"
date="2011-07-31T15:24:25Z"
content="""
Yes, it can read id3-tags and guess titles from movie filenames but it sometimes gets confused by the filename metadata provided by the WORM-backend.
I think I have a good enough solution to this problem. It's not efficient when it comes to renames but handles adding and deletion just fine
rsync -vaL --delete source dest
The -L flag looks at symbolic links and copies the actual data they are pointing to. Of course \"source\" must have all data locally for this to work.
"""]]

5
doc/forum/advantages_of_SHA__42___over_WORM.mdwn Normal file
View file

@ -0,0 +1,5 @@
Thanks for creating git-annex.
I am confused about the advantages of the SHA* backends over WORM. The "backends" page in this wiki says that with WORM, files "can be moved around, but should never be added to or changed". But I don't see any difference to SHA* files as long as the premise of WORM that "any file with the same basename, size, and modification time has the same content" is true. Using "git annex unlock", WORM files can be modified in the same way as SHA* files.
If the storage I use is dependable (i.e. I don't need SHA checksums for detection of corruption), and I don't need to optimize for the case that the modification date of a file is changed but the contents stay the same, and if it is unlikely that several files will be identical, is there actually any advantage in using SHA*?

8
doc/forum/advantages_of_SHA__42___over_WORM/comment_1_96c354cac4b5ce5cf6664943bc84db1d._comment Normal file
View file

@ -0,0 +1,8 @@
[[!comment format=mdwn
username="http://joey.kitenet.net/"
nickname="joey"
subject="comment 1"
date="2011-08-29T16:10:38Z"
content="""
You're right -- as long as nothing changes a file without letting the modification time update, editing WORM files is safe.
"""]]

9
doc/forum/version_3_upgrade.mdwn Normal file
View file

@ -0,0 +1,9 @@
after upgrading to git-annex 3, i'm stuck with diverging git-annex branches -- i didn't manage to follow this line in the directions:
> After this upgrade, you should make sure you include the git-annex branch when git pushing and pulling.
could you explain how to do that in a littel more detail? git pull seems to only merge master, although i have these ``.git/config`` settings:
[branch "git-annex"]
remote = origin
merge = git-annex

13
doc/forum/version_3_upgrade/comment_1_05fc9c9cad26c520bebb98c852c71e35._comment Normal file
View file

@ -0,0 +1,13 @@
[[!comment format=mdwn
username="http://joey.kitenet.net/"
nickname="joey"
subject="comment 1"
date="2011-08-17T01:33:08Z"
content="""
It's ok that `git pull` does not merge the git-annex branch. You can merge it with `git annex merge`, or it will be done
automatically when you use other git-annex commands.
If you use `git pull` and `git push` without any options, the defaults will make git pull and push the git-annex branch automatically.
But if you're in the habit of doing `git push origin master`, that won't cause the git-annex branch to be pushed (use `git push origin git-annex` to manually push it then). Similarly, `git pull origin master` won't pull it. And also, the `remote.origin.fetch` setting in `.git/config` can be modified in ways that make `git pull` not automatically pull the git-annex branch. So those are the things to avoid after upgrade to v3, basically.
"""]]

54
doc/git-annex.mdwn
View file

@ -72,15 +72,15 @@ Many git-annex commands will stage changes for later `git commit` by you.
* get [path ...]
Makes the content of annexed files available in this repository. Depending
on the backend used, this will involve copying them from another repository,
or downloading them, or transferring them from some kind of key-value store.
Makes the content of annexed files available in this repository. This
will involve copying them from another repository, or downloading them,
or transferring them from some kind of key-value store.
* drop [path ...]
Drops the content of annexed files from this repository.
git-annex may refuse to drop content if the backend does not think
git-annex may refuse to drop content if it does not think
it is safe to do so, typically because of the setting of annex.numcopies.
* move [path ...]
@ -119,10 +119,14 @@ Many git-annex commands will stage changes for later `git commit` by you.
Use this to undo an unlock command if you don't want to modify
the files, or have made modifications you want to discard.
* init description
* init [description]
Initializes git-annex with a description of the git repository,
and sets up `.gitattributes` and the pre-commit hook.
Until a repository (or one of its remotes) has been initialized,
git-annex will refuse to operate on it, to avoid accidentially
using it in a repository that was not intended to have an annex.
It's useful, but not mandatory, to initialize each new clone
of a repository with its own description.
* describe repository description
@ -201,14 +205,14 @@ Many git-annex commands will stage changes for later `git commit` by you.
* migrate [path ...]
Changes the specified annexed files to store their content in the
default backend (or the one specified with --backend). Only files whose
content is currently available are migrated.
Changes the specified annexed files to use the default key-value backend
(or the one specified with --backend). Only files whose content
is currently available are migrated.
Note that the content is not removed from the backend it was previously in.
Use `git annex unused` to find and remove such content.
Note that the content is also still available using the old key after
migration. Use `git annex unused` to find and remove the old key.
Normally, nothing will be done to files already in the backend.
Normally, nothing will be done to files already using the new backend.
However, if a backend changes the information it uses to construct a key,
this can also be used to migrate files to use the new key format.
@ -282,10 +286,12 @@ Many git-annex commands will stage changes for later `git commit` by you.
Downloads each url to a file, which is added to the annex.
To avoid immediately downloading the url, specify --fast
* fromkey file
This plumbing-level command can be used to manually set up a file
to link to a specified key in the key-value backend.
in the git repository to link to a specified key.
* dropkey [key ...]
@ -331,12 +337,18 @@ Many git-annex commands will stage changes for later `git commit` by you.
* --quiet
Avoid the default verbose logging of what is done; only show errors
Avoid the default verbose display of what is done; only show errors
and progress displays.
* --verbose
Enable verbose logging.
Enable verbose display.
* --json
Rather than the normal output, generate JSON. This is intended to be
parsed by programs that use git-annex. Each line of output is a JSON
object.
* --debug
@ -416,6 +428,12 @@ Here are all the supported configuration settings.
The default cost is 100 for local repositories, and 200 for remote
repositories.
* `remote.<name>.annex-cost-command`
If set, the command is run, and the number it outputs is used as the cost.
This allows varying the cost based on eg, the current network. The
cost-command can be any shell command line.
* `remote.<name>.annex-ignore`
If set to `true`, prevents git-annex
@ -486,8 +504,8 @@ Here are all the supported configuration settings.
# CONFIGURATION VIA .gitattributes
The backend used when adding a new file to the annex can be configured
on a per-file-type basis via `.gitattributes` files. In the file,
The key-value backend used when adding a new file to the annex can be
configured on a per-file-type basis via `.gitattributes` files. In the file,
the `annex.backend` attribute can be set to the name of the backend to
use. For example, this here's how to use the WORM backend by default,
but the SHA1 backend for ogg files:

2
doc/index.mdwn
View file

@ -12,7 +12,7 @@ To get a feel for it, see the [[walkthrough]].
* [[forum]]
* [[comments]]
* [[contact]]
* <a href="http://flattr.com/thing/84843/git-annex"><img src="http://api.flattr.com/button/button-compact-static-100x17.png" alt="Flattr this" title="Flattr this" /></a>
* <a href="http://flattr.com/thing/84843/git-annex"><img src="https://api.flattr.com/button/flattr-badge-large.png" alt="Flattr this" title="Flattr this" /></a>
[[News]]:

Some files were not shown because too many files have changed in this diff Show more