Merge branch 'master' into no-xmpp

This commit is contained in:
Joey Hess 2016-12-24 14:48:51 -04:00
commit ab66bbfeb6
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
377 changed files with 7442 additions and 875 deletions

View file

@ -41,9 +41,6 @@ optParser desc = AddOptions
)
<*> parseBatchOption
{- Add acts on both files not checked into git yet, and unlocked files.
-
- In direct mode, it acts on any files that have changed. -}
seek :: AddOptions -> CommandSeek
seek o = allowConcurrentOutput $ do
matcher <- largeFilesMatcher
@ -59,10 +56,9 @@ seek o = allowConcurrentOutput $ do
NoBatch -> do
let go a = a gofile (addThese o)
go (withFilesNotInGit (not $ includeDotFiles o))
ifM (versionSupportsUnlockedPointers <||> isDirect)
( go withFilesMaybeModified
, go withFilesOldUnlocked
)
go withFilesMaybeModified
unlessM (versionSupportsUnlockedPointers <||> isDirect) $
go withFilesOldUnlocked
{- Pass file off to git-add. -}
startSmall :: FilePath -> CommandStart

View file

@ -38,4 +38,4 @@ perform key = next $ do
- it seems better to error out, rather than moving bad/tmp content into
- the annex. -}
performOther :: String -> Key -> CommandPerform
performOther other _ = error $ "cannot addunused " ++ other ++ "content"
performOther other _ = giveup $ "cannot addunused " ++ other ++ "content"

View file

@ -27,6 +27,7 @@ import Types.UrlContents
import Annex.FileMatcher
import Logs.Location
import Utility.Metered
import Utility.FileSystemEncoding
import qualified Annex.Transfer as Transfer
import Annex.Quvi
import qualified Utility.Quvi as Quvi
@ -133,7 +134,7 @@ checkUrl r o u = do
let f' = adjustFile o (deffile </> fromSafeFilePath f)
void $ commandAction $
startRemote r (relaxedOption o) f' u' sz
| otherwise = error $ unwords
| otherwise = giveup $ unwords
[ "That url contains multiple files according to the"
, Remote.name r
, " remote; cannot add it to a single file."
@ -182,7 +183,7 @@ startWeb :: AddUrlOptions -> String -> CommandStart
startWeb o s = go $ fromMaybe bad $ parseURI urlstring
where
(urlstring, downloader) = getDownloader s
bad = fromMaybe (error $ "bad url " ++ urlstring) $
bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
Url.parseURIRelaxed $ urlstring
go url = case downloader of
QuviDownloader -> usequvi
@ -208,7 +209,7 @@ startWeb o s = go $ fromMaybe bad $ parseURI urlstring
)
showStart "addurl" file
next $ performWeb (relaxedOption o) urlstring file urlinfo
badquvi = error $ "quvi does not know how to download url " ++ urlstring
badquvi = giveup $ "quvi does not know how to download url " ++ urlstring
usequvi = do
page <- fromMaybe badquvi
<$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] urlstring
@ -340,13 +341,18 @@ cleanup :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
cleanup u url file key mtmp = case mtmp of
Nothing -> go
Just tmp -> do
-- Move to final location for large file check.
liftIO $ renameFile tmp file
largematcher <- largeFilesMatcher
ifM (checkFileMatcher largematcher file)
( go
, do
liftIO $ renameFile tmp file
void $ Command.Add.addSmall file
)
large <- checkFileMatcher largematcher file
if large
then do
-- Move back to tmp because addAnnexedFile
-- needs the file in a different location
-- than the work tree file.
liftIO $ renameFile file tmp
go
else void $ Command.Add.addSmall file
where
go = do
maybeShowJSON $ JSONChunk [("key", key2file key)]
@ -372,7 +378,7 @@ url2file url pathdepth pathmax = case pathdepth of
| depth >= length urlbits -> frombits id
| depth > 0 -> frombits $ drop depth
| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
| otherwise -> error "bad --pathdepth"
| otherwise -> giveup "bad --pathdepth"
where
fullurl = concat
[ maybe "" uriRegName (uriAuthority url)
@ -385,7 +391,7 @@ url2file url pathdepth pathmax = case pathdepth of
urlString2file :: URLString -> Maybe Int -> Int -> FilePath
urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of
Nothing -> error $ "bad uri " ++ s
Nothing -> giveup $ "bad uri " ++ s
Just u -> url2file u pathdepth pathmax
adjustFile :: AddUrlOptions -> FilePath -> FilePath

View file

@ -66,14 +66,14 @@ startNoRepo :: AssistantOptions -> IO ()
startNoRepo o
| autoStartOption o = autoStart o
| autoStopOption o = autoStop
| otherwise = error "Not in a git repository."
| otherwise = giveup "Not in a git repository."
autoStart :: AssistantOptions -> IO ()
autoStart o = do
dirs <- liftIO readAutoStartFile
when (null dirs) $ do
f <- autoStartFile
error $ "Nothing listed in " ++ f
giveup $ "Nothing listed in " ++ f
program <- programPath
haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
forM_ dirs $ \d -> do

View file

@ -40,7 +40,7 @@ seek o = case batchOption o of
_ -> wrongnumparams
batchInput Right $ checker >=> batchResult
where
wrongnumparams = error "Wrong number of parameters"
wrongnumparams = giveup "Wrong number of parameters"
data Result = Present | NotPresent | CheckFailure String
@ -71,8 +71,8 @@ batchResult Present = liftIO $ putStrLn "1"
batchResult _ = liftIO $ putStrLn "0"
toKey :: String -> Key
toKey = fromMaybe (error "Bad key") . file2key
toKey = fromMaybe (giveup "Bad key") . file2key
toRemote :: String -> Annex Remote
toRemote rn = maybe (error "Unknown remote") return
toRemote rn = maybe (giveup "Unknown remote") return
=<< Remote.byNameWithUUID (Just rn)

View file

@ -19,7 +19,7 @@ cmd = noCommit $ noMessages $
run :: () -> String -> Annex Bool
run _ p = do
let k = fromMaybe (error "bad key") $ file2key p
let k = fromMaybe (giveup "bad key") $ file2key p
maybe (return False) (\f -> liftIO (putStrLn f) >> return True)
=<< inAnnex' (pure True) Nothing check k
where

View file

@ -37,7 +37,7 @@ startKey key = do
ls <- keyLocations key
case ls of
[] -> next $ performKey key
_ -> error "This key is still known to be present in some locations; not marking as dead."
_ -> giveup "This key is still known to be present in some locations; not marking as dead."
performKey :: Key -> CommandPerform
performKey key = do

View file

@ -25,7 +25,7 @@ start (name:description) = do
showStart "describe" name
u <- Remote.nameToUUID name
next $ perform u $ unwords description
start _ = error "Specify a repository and a description."
start _ = giveup "Specify a repository and a description."
perform :: UUID -> String -> CommandPerform
perform u description = do

View file

@ -73,7 +73,7 @@ parseReq opts = case separate (== "--") opts of
mk (unmergedpath:[]) = UnmergedReq { rPath = unmergedpath }
mk _ = badopts
badopts = error $ "Unexpected input: " ++ unwords opts
badopts = giveup $ "Unexpected input: " ++ unwords opts
{- Check if either file is a symlink to a git-annex object,
- which git-diff will leave as a normal file containing the link text.

View file

@ -26,7 +26,7 @@ seek = withNothing start
start :: CommandStart
start = ifM versionSupportsDirectMode
( ifM isDirect ( stop , next perform )
, error "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
, giveup "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
)
perform :: CommandPerform

View file

@ -32,7 +32,7 @@ optParser desc = DropKeyOptions
seek :: DropKeyOptions -> CommandSeek
seek o = do
unlessM (Annex.getState Annex.force) $
error "dropkey can cause data loss; use --force if you're sure you want to do this"
giveup "dropkey can cause data loss; use --force if you're sure you want to do this"
withKeys start (toDrop o)
case batchOption o of
Batch -> batchInput parsekey $ batchCommandAction . start

View file

@ -12,6 +12,7 @@ import qualified Annex
import qualified Logs.Remote
import qualified Types.Remote as R
import qualified Git
import qualified Git.Types as Git
import qualified Annex.SpecialRemote
import qualified Remote
import qualified Types.Remote as Remote
@ -40,9 +41,7 @@ start (name:rest) = go =<< filter matchingname <$> Annex.fromRepo Git.remotes
=<< Annex.SpecialRemote.findExisting name
go (r:_) = startNormalRemote name r
type RemoteName = String
startNormalRemote :: RemoteName -> Git.Repo -> CommandStart
startNormalRemote :: Git.RemoteName -> Git.Repo -> CommandStart
startNormalRemote name r = do
showStart "enableremote" name
next $ next $ do
@ -51,7 +50,7 @@ startNormalRemote name r = do
u <- getRepoUUID r'
return $ u /= NoUUID
startSpecialRemote :: RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart
startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart
startSpecialRemote name config Nothing = do
m <- Annex.SpecialRemote.specialRemoteMap
confm <- Logs.Remote.readRemoteLog
@ -63,7 +62,7 @@ startSpecialRemote name config Nothing = do
_ -> unknownNameError "Unknown remote name."
startSpecialRemote name config (Just (u, c)) = do
let fullconfig = config `M.union` c
t <- either error return (Annex.SpecialRemote.findType fullconfig)
t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
showStart "enableremote" name
gc <- maybe def Remote.gitconfig <$> Remote.byUUID u
next $ performSpecialRemote t u fullconfig gc
@ -94,7 +93,7 @@ unknownNameError prefix = do
disabledremotes <- filterM isdisabled =<< Annex.fromRepo Git.remotes
let remotesmsg = unlines $ map ("\t" ++) $
mapMaybe Git.remoteName disabledremotes
error $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
giveup $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
where
isdisabled r = anyM id
[ (==) NoUUID <$> getRepoUUID r

130
Command/EnableTor.hs Normal file
View file

@ -0,0 +1,130 @@
{- git-annex command
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Command.EnableTor where
import Command
import qualified Annex
import P2P.Address
import Utility.Tor
import Annex.UUID
import Config.Files
import P2P.IO
import qualified P2P.Protocol as P2P
import Utility.ThreadScheduler
import Control.Concurrent.Async
import qualified Network.Socket as S
#ifndef mingw32_HOST_OS
import Utility.Su
import System.Posix.User
#endif
cmd :: Command
cmd = noCommit $ dontCheck repoExists $
command "enable-tor" SectionSetup "enable tor hidden service"
"uid" (withParams seek)
seek :: CmdParams -> CommandSeek
seek = withWords start
-- This runs as root, so avoid making any commits or initializing
-- git-annex, or doing other things that create root-owned files.
start :: [String] -> CommandStart
start os = do
uuid <- getUUID
when (uuid == NoUUID) $
giveup "This can only be run in a git-annex repository."
#ifndef mingw32_HOST_OS
curruserid <- liftIO getEffectiveUserID
if curruserid == 0
then case readish =<< headMaybe os of
Nothing -> giveup "Need user-id parameter."
Just userid -> go uuid userid
else do
showStart "enable-tor" ""
showLongNote "Need root access to enable tor..."
gitannex <- liftIO readProgramFile
let ps = [Param (cmdname cmd), Param (show curruserid)]
ifM (liftIO $ runAsRoot gitannex ps)
( next $ next checkHiddenService
, giveup $ unwords $
[ "Failed to run as root:" , gitannex ] ++ toCommand ps
)
#else
go uuid 0
#endif
where
go uuid userid = do
(onionaddr, onionport) <- liftIO $
addHiddenService torAppName userid (fromUUID uuid)
storeP2PAddress $ TorAnnex onionaddr onionport
stop
checkHiddenService :: CommandCleanup
checkHiddenService = bracket setup cleanup go
where
setup = do
showLongNote "Tor hidden service is configured. Checking connection to it. This may take a few minutes."
startlistener
cleanup = liftIO . cancel
go _ = check (150 :: Int) =<< filter istoraddr <$> loadP2PAddresses
istoraddr (TorAnnex _ _) = True
check 0 _ = giveup "Still unable to connect to hidden service. It might not yet be usable by others. Please check Tor's logs for details."
check _ [] = giveup "Somehow didn't get an onion address."
check n addrs@(addr:_) = do
g <- Annex.gitRepo
-- Connect but don't bother trying to auth,
-- we just want to know if the tor circuit works.
cv <- liftIO $ tryNonAsync $ connectPeer g addr
case cv of
Left e -> do
warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.."
liftIO $ threadDelaySeconds (Seconds 2)
check (n-1) addrs
Right conn -> do
liftIO $ closeConnection conn
showLongNote "Tor hidden service is working."
return True
-- Unless the remotedaemon is already listening on the hidden
-- service's socket, start a listener. This is only run during the
-- check, and it refuses all auth attempts.
startlistener = do
r <- Annex.gitRepo
u <- getUUID
uid <- liftIO getRealUserID
let ident = fromUUID u
v <- liftIO $ getHiddenServiceSocketFile torAppName uid ident
case v of
Just sockfile -> ifM (liftIO $ haslistener sockfile)
( liftIO $ async $ return ()
, liftIO $ async $ runlistener sockfile u r
)
Nothing -> giveup "Could not find socket file in Tor configuration!"
runlistener sockfile u r = serveUnixSocket sockfile $ \h -> do
let conn = P2PConnection
{ connRepo = r
, connCheckAuth = const False
, connIhdl = h
, connOhdl = h
}
void $ runNetProto conn $ P2P.serveAuth u
hClose h
haslistener sockfile = catchBoolIO $ do
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
S.connect soc (S.SockAddrUnix sockfile)
S.close soc
return True

View file

@ -21,6 +21,6 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
run :: Maybe Utility.Format.Format -> String -> Annex Bool
run format p = do
let k = fromMaybe (error "bad key") $ file2key p
let k = fromMaybe (giveup "bad key") $ file2key p
showFormatted format (key2file k) (keyVars k)
return True

View file

@ -92,7 +92,7 @@ start (Expire expire) noact actlog descs u =
data Expire = Expire (M.Map (Maybe UUID) (Maybe POSIXTime))
parseExpire :: [String] -> Annex Expire
parseExpire [] = error "Specify an expire time."
parseExpire [] = giveup "Specify an expire time."
parseExpire ps = do
now <- liftIO getPOSIXTime
Expire . M.fromList <$> mapM (parse now) ps
@ -104,7 +104,7 @@ parseExpire ps = do
return (Just r, parsetime now t)
parsetime _ "never" = Nothing
parsetime now s = case parseDuration s of
Nothing -> error $ "bad expire time: " ++ s
Nothing -> giveup $ "bad expire time: " ++ s
Just d -> Just (now - durationToPOSIXTime d)
parseActivity :: Monad m => String -> m Activity

View file

@ -20,30 +20,32 @@ import Network.URI
cmd :: Command
cmd = notDirect $ notBareRepo $
command "fromkey" SectionPlumbing "adds a file using a specific key"
(paramPair paramKey paramPath)
(paramRepeating (paramPair paramKey paramPath))
(withParams seek)
seek :: CmdParams -> CommandSeek
seek [] = withNothing startMass []
seek ps = do
force <- Annex.getState Annex.force
withWords (start force) ps
withPairs (start force) ps
start :: Bool -> [String] -> CommandStart
start force (keyname:file:[]) = do
start :: Bool -> (String, FilePath) -> CommandStart
start force (keyname, file) = do
let key = mkKey keyname
unless force $ do
inbackend <- inAnnex key
unless inbackend $ error $
unless inbackend $ giveup $
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
showStart "fromkey" file
next $ perform key file
start _ [] = do
startMass :: CommandStart
startMass = do
showStart "fromkey" "stdin"
next massAdd
start _ _ = error "specify a key and a dest file"
massAdd :: CommandPerform
massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
massAdd = go True =<< map (separate (== ' ')) <$> batchLines
where
go status [] = next $ return status
go status ((keyname,f):rest) | not (null keyname) && not (null f) = do
@ -51,7 +53,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
ok <- perform' key f
let !status' = status && ok
go status' rest
go _ _ = error "Expected pairs of key and file on stdin, but got something else."
go _ _ = giveup "Expected pairs of key and file on stdin, but got something else."
-- From user input to a Key.
-- User can input either a serialized key, or an url.
@ -66,7 +68,7 @@ mkKey s = case parseURI s of
Backend.URL.fromUrl s Nothing
_ -> case file2key s of
Just k -> k
Nothing -> error $ "bad key/url " ++ s
Nothing -> giveup $ "bad key/url " ++ s
perform :: Key -> FilePath -> CommandPerform
perform key file = do

View file

@ -89,7 +89,7 @@ seek o = allowConcurrentOutput $ do
checkDeadRepo u
i <- prepIncremental u (incrementalOpt o)
withKeyOptions (keyOptions o) False
(\k ai -> startKey i k ai =<< getNumCopies)
(\k ai -> startKey from i k ai =<< getNumCopies)
(withFilesInGit $ whenAnnexed $ start from i)
(fsckFiles o)
cleanupIncremental i
@ -109,7 +109,7 @@ start from inc file key = do
numcopies <- getFileNumCopies file
case from of
Nothing -> go $ perform key file backend numcopies
Just r -> go $ performRemote key file backend numcopies r
Just r -> go $ performRemote key (Just file) backend numcopies r
where
go = runFsck inc (mkActionItem (Just file)) key
@ -129,8 +129,8 @@ perform key file backend numcopies = do
{- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -}
performRemote :: Key -> FilePath -> Backend -> NumCopies -> Remote -> Annex Bool
performRemote key file backend numcopies remote =
performRemote :: Key -> AssociatedFile -> Backend -> NumCopies -> Remote -> Annex Bool
performRemote key afile backend numcopies remote =
dispatch =<< Remote.hasKey remote key
where
dispatch (Left err) = do
@ -147,10 +147,10 @@ performRemote key file backend numcopies remote =
return False
dispatch (Right False) = go False Nothing
go present localcopy = check
[ verifyLocationLogRemote key file remote present
[ verifyLocationLogRemote key (maybe (key2file key) id afile) remote present
, checkKeySizeRemote key remote localcopy
, checkBackendRemote backend key remote localcopy
, checkKeyNumCopies key (Just file) numcopies
, checkKeyNumCopies key afile numcopies
]
withtmp a = do
pid <- liftIO getPID
@ -161,7 +161,7 @@ performRemote key file backend numcopies remote =
cleanup
cleanup `after` a tmp
getfile tmp = ifM (checkDiskSpace (Just (takeDirectory tmp)) key 0 True)
( ifM (Remote.retrieveKeyFileCheap remote key (Just file) tmp)
( ifM (Remote.retrieveKeyFileCheap remote key afile tmp)
( return (Just True)
, ifM (Annex.getState Annex.fast)
( return Nothing
@ -173,12 +173,14 @@ performRemote key file backend numcopies remote =
)
dummymeter _ = noop
startKey :: Incremental -> Key -> ActionItem -> NumCopies -> CommandStart
startKey inc key ai numcopies =
startKey :: Maybe Remote -> Incremental -> Key -> ActionItem -> NumCopies -> CommandStart
startKey from inc key ai numcopies =
case Backend.maybeLookupBackendName (keyBackendName key) of
Nothing -> stop
Just backend -> runFsck inc ai key $
performKey key backend numcopies
case from of
Nothing -> performKey key backend numcopies
Just r -> performRemote key Nothing backend numcopies r
performKey :: Key -> Backend -> NumCopies -> Annex Bool
performKey key backend numcopies = do
@ -584,7 +586,7 @@ prepIncremental u (Just StartIncrementalO) = do
recordStartTime u
ifM (FsckDb.newPass u)
( StartIncremental <$> openFsckDb u
, error "Cannot start a new --incremental fsck pass; another fsck process is already running."
, giveup "Cannot start a new --incremental fsck pass; another fsck process is already running."
)
prepIncremental u (Just MoreIncrementalO) =
ContIncremental <$> openFsckDb u

View file

@ -39,7 +39,7 @@ start = do
guardTest :: Annex ()
guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
error $ unlines
giveup $ unlines
[ "Running fuzz tests *writes* to and *deletes* files in"
, "this repository, and pushes those changes to other"
, "repositories! This is a developer tool, not something"

View file

@ -25,7 +25,7 @@ start :: String -> CommandStart
start gcryptid = next $ next $ do
u <- getUUID
when (u /= NoUUID) $
error "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
g <- gitRepo
gu <- Remote.GCrypt.getGCryptUUID True g
@ -35,5 +35,5 @@ start gcryptid = next $ next $ do
then do
void $ Remote.GCrypt.setupRepo gcryptid g
return True
else error "cannot use gcrypt in a non-bare repository"
else error "gcryptsetup uuid mismatch"
else giveup "cannot use gcrypt in a non-bare repository"
else giveup "gcryptsetup uuid mismatch"

View file

@ -30,7 +30,7 @@ start (name:[]) = do
u <- Remote.nameToUUID name
showRaw . unwords . S.toList =<< lookupGroups u
stop
start _ = error "Specify a repository and a group."
start _ = giveup "Specify a repository and a group."
setGroup :: UUID -> Group -> CommandPerform
setGroup uuid g = do

View file

@ -25,4 +25,4 @@ start (g:[]) = next $ performGet groupPreferredContentMapRaw g
start (g:expr:[]) = do
showStart "groupwanted" g
next $ performSet groupPreferredContentSet expr g
start _ = error "Specify a group."
start _ = giveup "Specify a group."

View file

@ -62,7 +62,7 @@ seek o = allowConcurrentOutput $ do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
unless (null inrepops) $ do
error $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
largematcher <- largeFilesMatcher
withPathContents (start largematcher (duplicateMode o)) (importFiles o)

View file

@ -138,23 +138,25 @@ findDownloads u = go =<< downloadFeed u
Just $ ToDownload f u i $ Enclosure enclosureurl
Nothing -> mkquvi f i
mkquvi f i = case getItemLink i of
Just link -> ifM (quviSupported link)
( return $ Just $ ToDownload f u i $ QuviLink link
, return Nothing
)
Just link -> do
liftIO $ print ("link", link)
ifM (quviSupported link)
( return $ Just $ ToDownload f u i $ QuviLink link
, return Nothing
)
Nothing -> return Nothing
{- Feeds change, so a feed download cannot be resumed. -}
downloadFeed :: URLString -> Annex (Maybe Feed)
downloadFeed url
| Url.parseURIRelaxed url == Nothing = error "invalid feed url"
| Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"
| otherwise = do
showOutput
uo <- Url.getUrlOptions
liftIO $ withTmpFile "feed" $ \f h -> do
hClose h
ifM (Url.download url f uo)
( parseFeedString <$> readFileStrictAnyEncoding f
( parseFeedString <$> readFileStrict f
, return Nothing
)
@ -336,7 +338,7 @@ noneValue = "none"
- Throws an error if the feed is broken, otherwise shows a warning. -}
feedProblem :: URLString -> String -> Annex ()
feedProblem url message = ifM (checkFeedBroken url)
( error $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
( giveup $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
, warning $ "warning: " ++ message
)

View file

@ -33,9 +33,9 @@ start :: CommandStart
start = ifM isDirect
( do
unlessM (coreSymlinks <$> Annex.getGitConfig) $
error "Git is configured to not use symlinks, so you must use direct mode."
giveup "Git is configured to not use symlinks, so you must use direct mode."
whenM probeCrippledFileSystem $
error "This repository seems to be on a crippled filesystem, you must use direct mode."
giveup "This repository seems to be on a crippled filesystem, you must use direct mode."
next perform
, stop
)

View file

@ -26,16 +26,16 @@ seek :: CmdParams -> CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start [] = error "Specify a name for the remote."
start [] = giveup "Specify a name for the remote."
start (name:ws) = ifM (isJust <$> findExisting name)
( error $ "There is already a special remote named \"" ++ name ++
( giveup $ "There is already a special remote named \"" ++ name ++
"\". (Use enableremote to enable an existing special remote.)"
, do
ifM (isJust <$> Remote.byNameOnly name)
( error $ "There is already a remote named \"" ++ name ++ "\""
( giveup $ "There is already a remote named \"" ++ name ++ "\""
, do
let c = newConfig name
t <- either error return (findType config)
t <- either giveup return (findType config)
showStart "initremote" name
next $ perform t name $ M.union config c

View file

@ -79,7 +79,7 @@ performNew file key = do
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContent obj $ replaceFile obj $ \tmp -> do
unlessM (checkedCopyFile key obj tmp Nothing) $
error "unable to lock file"
giveup "unable to lock file"
Database.Keys.storeInodeCaches key [obj]
-- Try to repopulate obj from an unmodified associated file.
@ -115,4 +115,4 @@ performOld file = do
next $ return True
errorModified :: a
errorModified = error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"
errorModified = giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"

View file

@ -10,6 +10,7 @@ module Command.LockContent where
import Command
import Annex.Content
import Remote.Helper.Ssh (contentLockedMarker)
import Utility.SimpleProtocol
cmd :: Command
cmd = noCommit $
@ -32,13 +33,13 @@ start [ks] = do
then exitSuccess
else exitFailure
where
k = fromMaybe (error "bad key") (file2key ks)
k = fromMaybe (giveup "bad key") (file2key ks)
locksuccess = ifM (inAnnex k)
( liftIO $ do
putStrLn contentLockedMarker
hFlush stdout
_ <- getLine
_ <- getProtocolLine stdin
return True
, return False
)
start _ = error "Specify exactly 1 key."
start _ = giveup "Specify exactly 1 key."

View file

@ -93,7 +93,7 @@ seek o = do
case (logFiles o, allOption o) of
(fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) fs
([], True) -> commandAction (startAll o outputter)
(_, True) -> error "Cannot specify both files and --all"
(_, True) -> giveup "Cannot specify both files and --all"
start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart
start o outputter file key = do

View file

@ -47,15 +47,25 @@ start = do
liftIO $ writeFile file (drawMap rs trustmap umap)
next $ next $
ifM (Annex.getState Annex.fast)
( do
showLongNote $ "left map in " ++ file
return True
, do
showLongNote $ "running: dot -Tx11 " ++ file
showOutput
liftIO $ boolSystem "dot" [Param "-Tx11", File file]
( runViewer file []
, runViewer file
[ ("xdot", [File file])
, ("dot", [Param "-Tx11", File file])
]
)
runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
runViewer file [] = do
showLongNote $ "left map in " ++ file
return True
runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)
( do
showLongNote $ "running: " ++ c ++ unwords (toCommand ps)
showOutput
liftIO $ boolSystem c ps
, runViewer file rest
)
{- Generates a graph for dot(1). Each repository, and any other uuids
- (except for dead ones), are displayed as a node, and each of its
- remotes is represented as an edge pointing at the node for the remote.

View file

@ -20,6 +20,7 @@ import qualified Data.Text as T
import qualified Data.ByteString.Lazy.UTF8 as BU
import Data.Time.Clock.POSIX
import Data.Aeson
import Control.Concurrent
cmd :: Command
cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $
@ -65,23 +66,22 @@ optParser desc = MetaDataOptions
)
seek :: MetaDataOptions -> CommandSeek
seek o = do
now <- liftIO getPOSIXTime
case batchOption o of
NoBatch -> do
let seeker = case getSet o of
Get _ -> withFilesInGit
GetAll -> withFilesInGit
Set _ -> withFilesInGitNonRecursive
"Not recursively setting metadata. Use --force to do that."
withKeyOptions (keyOptions o) False
(startKeys now o)
(seeker $ whenAnnexed $ start now o)
(forFiles o)
Batch -> withMessageState $ \s -> case outputType s of
JSONOutput _ -> batchInput parseJSONInput $
commandAction . startBatch now
_ -> error "--batch is currently only supported in --json mode"
seek o = case batchOption o of
NoBatch -> do
now <- liftIO getPOSIXTime
let seeker = case getSet o of
Get _ -> withFilesInGit
GetAll -> withFilesInGit
Set _ -> withFilesInGitNonRecursive
"Not recursively setting metadata. Use --force to do that."
withKeyOptions (keyOptions o) False
(startKeys now o)
(seeker $ whenAnnexed $ start now o)
(forFiles o)
Batch -> withMessageState $ \s -> case outputType s of
JSONOutput _ -> batchInput parseJSONInput $
commandAction . startBatch
_ -> giveup "--batch is currently only supported in --json mode"
start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart
start now o file k = startKeys now o k (mkActionItem afile)
@ -150,13 +150,13 @@ parseJSONInput i = do
(Nothing, Just f) -> Right (Left f, m)
(Nothing, Nothing) -> Left "JSON input is missing either file or key"
startBatch :: POSIXTime -> (Either FilePath Key, MetaData) -> CommandStart
startBatch now (i, (MetaData m)) = case i of
startBatch :: (Either FilePath Key, MetaData) -> CommandStart
startBatch (i, (MetaData m)) = case i of
Left f -> do
mk <- lookupFile f
case mk of
Just k -> go k (mkActionItem (Just f))
Nothing -> error $ "not an annexed file: " ++ f
Nothing -> giveup $ "not an annexed file: " ++ f
Right k -> go k (mkActionItem k)
where
go k ai = do
@ -169,6 +169,15 @@ startBatch now (i, (MetaData m)) = case i of
, keyOptions = Nothing
, batchOption = NoBatch
}
now <- liftIO getPOSIXTime
-- It would be bad if two batch mode changes used exactly
-- the same timestamp, since the order of adds and removals
-- of the same metadata value would then be indeterminate.
-- To guarantee that never happens, delay 1 microsecond,
-- so the timestamp will always be different. This is
-- probably less expensive than cleaner methods,
-- such as taking from a list of increasing timestamps.
liftIO $ threadDelay 1
next $ perform now o k
mkModMeta (f, s)
| S.null s = DelMeta f Nothing

View file

@ -197,4 +197,4 @@ fromPerform src move key afile = ifM (inAnnex key)
]
ok <- Remote.removeKey src key
next $ Command.Drop.cleanupRemote key src ok
faileddropremote = error "Unable to drop from remote."
faileddropremote = giveup "Unable to drop from remote."

View file

@ -8,15 +8,11 @@
module Command.NotifyChanges where
import Command
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Git
import Git.Sha
import Annex.ChangedRefs
import RemoteDaemon.Transport.Ssh.Types
import Utility.SimpleProtocol
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
cmd :: Command
cmd = noCommit $
@ -28,55 +24,19 @@ seek :: CmdParams -> CommandSeek
seek = withNothing start
start :: CommandStart
start = do
-- This channel is used to accumulate notifcations,
-- because the DirWatcher might have multiple threads that find
-- changes at the same time.
chan <- liftIO newTChanIO
g <- gitRepo
let refdir = Git.localGitDir g </> "refs"
liftIO $ createDirectoryIfMissing True refdir
let notifyhook = Just $ notifyHook chan
let hooks = mkWatchHooks
{ addHook = notifyhook
, modifyHook = notifyhook
}
void $ liftIO $ watchDir refdir (const False) True hooks id
let sender = do
send READY
forever $ send . CHANGED =<< drain chan
-- No messages need to be received from the caller,
-- but when it closes the connection, notice and terminate.
let receiver = forever $ void getLine
void $ liftIO $ concurrently sender receiver
stop
notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
notifyHook chan reffile _
| ".lock" `isSuffixOf` reffile = noop
| otherwise = void $ do
sha <- catchDefaultIO Nothing $
extractSha <$> readFile reffile
maybe noop (atomically . writeTChan chan) sha
-- When possible, coalesce ref writes that occur closely together
-- in time. Delay up to 0.05 seconds to get more ref writes.
drain :: TChan Git.Sha -> IO [Git.Sha]
drain chan = do
r <- atomically $ readTChan chan
threadDelay 50000
rs <- atomically $ drain' chan
return (r:rs)
drain' :: TChan Git.Sha -> STM [Git.Sha]
drain' chan = loop []
start = go =<< watchChangedRefs
where
loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan
go (Just h) = do
-- No messages need to be received from the caller,
-- but when it closes the connection, notice and terminate.
let receiver = forever $ void $ getProtocolLine stdin
let sender = forever $ send . CHANGED =<< waitChangedRefs h
liftIO $ send READY
void $ liftIO $ concurrently sender receiver
liftIO $ stopWatchingChangedRefs h
stop
go Nothing = stop
send :: Notification -> IO ()
send n = do

View file

@ -23,15 +23,15 @@ seek = withWords start
start :: [String] -> CommandStart
start [] = startGet
start [s] = case readish s of
Nothing -> error $ "Bad number: " ++ s
Nothing -> giveup $ "Bad number: " ++ s
Just n
| n > 0 -> startSet n
| n == 0 -> ifM (Annex.getState Annex.force)
( startSet n
, error "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
, giveup "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
)
| otherwise -> error "Number cannot be negative!"
start _ = error "Specify a single number."
| otherwise -> giveup "Number cannot be negative!"
start _ = giveup "Specify a single number."
startGet :: CommandStart
startGet = next $ next $ do

302
Command/P2P.hs Normal file
View file

@ -0,0 +1,302 @@
{- git-annex command
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.P2P where
import Command
import P2P.Address
import P2P.Auth
import P2P.IO
import qualified P2P.Protocol as P2P
import Git.Types
import qualified Git.Remote
import qualified Git.Command
import qualified Annex
import Annex.UUID
import Config
import Utility.AuthToken
import Utility.Tmp
import Utility.FileMode
import Utility.ThreadScheduler
import qualified Utility.MagicWormhole as Wormhole
import Control.Concurrent.Async
import qualified Data.Text as T
cmd :: Command
cmd = command "p2p" SectionSetup
"configure peer-2-peer links between repositories"
paramNothing (seek <$$> optParser)
data P2POpts
= GenAddresses
| LinkRemote
| Pair
optParser :: CmdParamsDesc -> Parser (P2POpts, Maybe RemoteName)
optParser _ = (,)
<$> (pair <|> linkremote <|> genaddresses)
<*> optional name
where
genaddresses = flag' GenAddresses
( long "gen-addresses"
<> help "generate addresses that allow accessing this repository over P2P networks"
)
linkremote = flag' LinkRemote
( long "link"
<> help "set up a P2P link to a git remote"
)
pair = flag' Pair
( long "pair"
<> help "pair with another repository"
)
name = Git.Remote.makeLegalName <$> strOption
( long "name"
<> metavar paramName
<> help "name of remote"
)
seek :: (P2POpts, Maybe RemoteName) -> CommandSeek
seek (GenAddresses, _) = genAddresses =<< loadP2PAddresses
seek (LinkRemote, Just name) = commandAction $
linkRemote name
seek (LinkRemote, Nothing) = commandAction $
linkRemote =<< unusedPeerRemoteName
seek (Pair, Just name) = commandAction $
startPairing name =<< loadP2PAddresses
seek (Pair, Nothing) = commandAction $ do
name <- unusedPeerRemoteName
startPairing name =<< loadP2PAddresses
unusedPeerRemoteName :: Annex RemoteName
unusedPeerRemoteName = go (1 :: Integer) =<< usednames
where
usednames = mapMaybe remoteName . remotes <$> Annex.gitRepo
go n names = do
let name = "peer" ++ show n
if name `elem` names
then go (n+1) names
else return name
-- Only addresses are output to stdout, to allow scripting.
genAddresses :: [P2PAddress] -> Annex ()
genAddresses [] = giveup "No P2P networks are currrently available."
genAddresses addrs = do
authtoken <- liftIO $ genAuthToken 128
storeP2PAuthToken authtoken
earlyWarning "These addresses allow access to this git-annex repository. Only share them with people you trust with that access, using trusted communication channels!"
liftIO $ putStr $ unlines $
map formatP2PAddress $
map (`P2PAddressAuth` authtoken) addrs
-- Address is read from stdin, to avoid leaking it in shell history.
linkRemote :: RemoteName -> CommandStart
linkRemote remotename = do
showStart "p2p link" remotename
next $ next prompt
where
prompt = do
liftIO $ putStrLn ""
liftIO $ putStr "Enter peer address: "
liftIO $ hFlush stdout
s <- liftIO getLine
if null s
then do
liftIO $ hPutStrLn stderr "Nothing entered, giving up."
return False
else case unformatP2PAddress s of
Nothing -> do
liftIO $ hPutStrLn stderr "Unable to parse that address, please check its format and try again."
prompt
Just addr -> do
r <- setupLink remotename addr
case r of
LinkSuccess -> return True
ConnectionError e -> giveup e
AuthenticationError e -> giveup e
startPairing :: RemoteName -> [P2PAddress] -> CommandStart
startPairing _ [] = giveup "No P2P networks are currrently available."
startPairing remotename addrs = do
showStart "p2p pair" remotename
ifM (liftIO Wormhole.isInstalled)
( next $ performPairing remotename addrs
, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
)
performPairing :: RemoteName -> [P2PAddress] -> CommandPerform
performPairing remotename addrs = do
-- This note is displayed mainly so when magic wormhole
-- complains about possible protocol mismatches or other problems,
-- it's clear what's doing the complaining.
showNote "using Magic Wormhole"
next $ do
showOutput
r <- wormholePairing remotename addrs ui
case r of
PairSuccess -> return True
SendFailed -> do
warning "Failed sending data to pair."
return False
ReceiveFailed -> do
warning "Failed receiving data from pair."
return False
LinkFailed e -> do
warning $ "Failed linking to pair: " ++ e
return False
where
ui observer producer = do
ourcode <- Wormhole.waitCode observer
putStrLn ""
putStrLn $ "This repository's pairing code is: " ++
Wormhole.fromCode ourcode
putStrLn ""
theircode <- getcode ourcode
Wormhole.sendCode producer theircode
getcode ourcode = do
putStr "Enter the other repository's pairing code: "
hFlush stdout
l <- getLine
case Wormhole.toCode l of
Just code
| code /= ourcode -> do
putStrLn "Exchanging pairing data..."
return code
| otherwise -> do
putStrLn "Oops -- You entered this repository's pairing code. We need the pairing code of the *other* repository."
getcode ourcode
Nothing -> do
putStrLn "That does not look like a valid code. Try again..."
getcode ourcode
-- We generate half of the authtoken; the pair will provide
-- the other half.
newtype HalfAuthToken = HalfAuthToken T.Text
deriving (Show)
data PairData = PairData HalfAuthToken [P2PAddress]
deriving (Show)
serializePairData :: PairData -> String
serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $
T.unpack ha : map formatP2PAddress addrs
deserializePairData :: String -> Maybe PairData
deserializePairData s = case lines s of
[] -> Nothing
(ha:l) -> do
addrs <- mapM unformatP2PAddress l
return (PairData (HalfAuthToken (T.pack ha)) addrs)
data PairingResult
= PairSuccess
| SendFailed
| ReceiveFailed
| LinkFailed String
wormholePairing
:: RemoteName
-> [P2PAddress]
-> (Wormhole.CodeObserver -> Wormhole.CodeProducer -> IO ())
-> Annex PairingResult
wormholePairing remotename ouraddrs ui = do
ourhalf <- liftIO $ HalfAuthToken . fromAuthToken
<$> genAuthToken 64
let ourpairdata = PairData ourhalf ouraddrs
-- The magic wormhole interface only supports exchanging
-- files. Permissions of received files may allow others
-- to read them. So, set up a temp directory that only
-- we can read.
withTmpDir "pair" $ \tmp -> do
liftIO $ void $ tryIO $ modifyFileMode tmp $
removeModes otherGroupModes
let sendf = tmp </> "send"
let recvf = tmp </> "recv"
liftIO $ writeFileProtected sendf $
serializePairData ourpairdata
observer <- liftIO Wormhole.mkCodeObserver
producer <- liftIO Wormhole.mkCodeProducer
void $ liftIO $ async $ ui observer producer
(sendres, recvres) <- liftIO $
Wormhole.sendFile sendf observer []
`concurrently`
Wormhole.receiveFile recvf producer []
liftIO $ nukeFile sendf
if sendres /= True
then return SendFailed
else if recvres /= True
then return ReceiveFailed
else do
r <- liftIO $ tryIO $
readFileStrict recvf
case r of
Left _e -> return ReceiveFailed
Right s -> maybe
(return ReceiveFailed)
(finishPairing 100 remotename ourhalf)
(deserializePairData s)
-- | Allow the peer we're pairing with to authenticate to us,
-- using an authtoken constructed from the two HalfAuthTokens.
-- Connect to the peer we're pairing with, and try to link to them.
--
-- Multiple addresses may have been received for the peer. This only
-- makes a link to one address.
--
-- Since we're racing the peer as they do the same, the first try is likely
-- to fail to authenticate. Can retry any number of times, to avoid the
-- users needing to redo the whole process.
finishPairing :: Int -> RemoteName -> HalfAuthToken -> PairData -> Annex PairingResult
finishPairing retries remotename (HalfAuthToken ourhalf) (PairData (HalfAuthToken theirhalf) theiraddrs) = do
case (toAuthToken (ourhalf <> theirhalf), toAuthToken (theirhalf <> ourhalf)) of
(Just ourauthtoken, Just theirauthtoken) -> do
liftIO $ putStrLn $ "Successfully exchanged pairing data. Connecting to " ++ remotename ++ "..."
storeP2PAuthToken ourauthtoken
go retries theiraddrs theirauthtoken
_ -> return ReceiveFailed
where
go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."
go n [] theirauthtoken = do
liftIO $ threadDelaySeconds (Seconds 2)
liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..."
go (n-1) theiraddrs theirauthtoken
go n (addr:rest) theirauthtoken = do
r <- setupLink remotename (P2PAddressAuth addr theirauthtoken)
case r of
LinkSuccess -> return PairSuccess
_ -> go n rest theirauthtoken
data LinkResult
= LinkSuccess
| ConnectionError String
| AuthenticationError String
setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult
setupLink remotename (P2PAddressAuth addr authtoken) = do
g <- Annex.gitRepo
cv <- liftIO $ tryNonAsync $ connectPeer g addr
case cv of
Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")"
Right conn -> do
u <- getUUID
go =<< liftIO (runNetProto conn $ P2P.auth u authtoken)
where
go (Right (Just theiruuid)) = do
ok <- inRepo $ Git.Command.runBool
[ Param "remote", Param "add"
, Param remotename
, Param (formatP2PAddress addr)
]
when ok $ do
storeUUIDIn (remoteConfig remotename "uuid") theiruuid
storeP2PRemoteAuthToken addr authtoken
return LinkSuccess
go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again."
go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ e

View file

@ -46,7 +46,7 @@ seek ps = lockPreCommitHook $ ifM isDirect
( do
(fs, cleanup) <- inRepo $ Git.typeChangedStaged ps
whenM (anyM isOldUnlocked fs) $
error "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
void $ liftIO cleanup
, do
-- fix symlinks to files being committed

View file

@ -30,7 +30,7 @@ seek :: CmdParams -> CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start [] = error "Did not specify command to run."
start [] = giveup "Did not specify command to run."
start (c:ps) = liftIO . exitWith =<< ifM isDirect
( do
tmp <- gitAnnexTmpMiscDir <$> gitRepo

View file

@ -25,15 +25,39 @@ cmd = notDirect $
command "rekey" SectionPlumbing
"change keys used for files"
(paramRepeating $ paramPair paramPath paramKey)
(withParams seek)
(seek <$$> optParser)
seek :: CmdParams -> CommandSeek
seek = withPairs start
data ReKeyOptions = ReKeyOptions
{ reKeyThese :: CmdParams
, batchOption :: BatchMode
}
start :: (FilePath, String) -> CommandStart
start (file, keyname) = ifAnnexed file go stop
optParser :: CmdParamsDesc -> Parser ReKeyOptions
optParser desc = ReKeyOptions
<$> cmdParams desc
<*> parseBatchOption
-- Split on the last space, since a FilePath can contain whitespace,
-- but a Key very rarely does.
batchParser :: String -> Either String (FilePath, Key)
batchParser s = case separate (== ' ') (reverse s) of
(rk, rf)
| null rk || null rf -> Left "Expected: \"file key\""
| otherwise -> case file2key (reverse rk) of
Nothing -> Left "bad key"
Just k -> Right (reverse rf, k)
seek :: ReKeyOptions -> CommandSeek
seek o = case batchOption o of
Batch -> batchInput batchParser (batchCommandAction . start)
NoBatch -> withPairs (start . parsekey) (reKeyThese o)
where
parsekey (file, skey) =
(file, fromMaybe (giveup "bad key") (file2key skey))
start :: (FilePath, Key) -> CommandStart
start (file, newkey) = ifAnnexed file go stop
where
newkey = fromMaybe (error "bad key") $ file2key keyname
go oldkey
| oldkey == newkey = stop
| otherwise = do
@ -44,9 +68,9 @@ perform :: FilePath -> Key -> Key -> CommandPerform
perform file oldkey newkey = do
ifM (inAnnex oldkey)
( unlessM (linkKey file oldkey newkey) $
error "failed"
giveup "failed"
, unlessM (Annex.getState Annex.force) $
error $ file ++ " is not available (use --force to override)"
giveup $ file ++ " is not available (use --force to override)"
)
next $ cleanup file oldkey newkey
@ -102,6 +126,6 @@ cleanup file oldkey newkey = do
Database.Keys.removeAssociatedFile oldkey
=<< inRepo (toTopFilePath file)
)
logStatus newkey InfoPresent
whenM (inAnnex newkey) $
logStatus newkey InfoPresent
return True

View file

@ -27,5 +27,5 @@ start (ks:us:[]) = do
then liftIO exitSuccess
else liftIO exitFailure
where
k = fromMaybe (error "bad key") (file2key ks)
start _ = error "Wrong number of parameters"
k = fromMaybe (giveup "bad key") (file2key ks)
start _ = giveup "Wrong number of parameters"

View file

@ -32,10 +32,10 @@ start (keyname:url:[]) = do
start [] = do
showStart "registerurl" "stdin"
next massAdd
start _ = error "specify a key and an url"
start _ = giveup "specify a key and an url"
massAdd :: CommandPerform
massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
massAdd = go True =<< map (separate (== ' ')) <$> batchLines
where
go status [] = next $ return status
go status ((keyname,u):rest) | not (null keyname) && not (null u) = do
@ -43,7 +43,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
ok <- perform' key u
let !status' = status && ok
go status' rest
go _ _ = error "Expected pairs of key and url on stdin, but got something else."
go _ _ = giveup "Expected pairs of key and url on stdin, but got something else."
perform :: Key -> URLString -> CommandPerform
perform key url = do

View file

@ -16,8 +16,7 @@ import Types.KeySource
cmd :: Command
cmd = command "reinject" SectionUtility
"inject content of file back into annex"
(paramRepeating (paramPair "SRC" "DEST")
`paramOr` "--known " ++ paramRepeating "SRC")
(paramRepeating (paramPair "SRC" "DEST"))
(seek <$$> optParser)
data ReinjectOptions = ReinjectOptions
@ -47,7 +46,7 @@ startSrcDest (src:dest:[])
next $ ifAnnexed dest
(\key -> perform src key (verifyKeyContent DefaultVerify UnVerified key src))
stop
startSrcDest _ = error "specify a src file and a dest file"
startSrcDest _ = giveup "specify a src file and a dest file"
startKnown :: FilePath -> CommandStart
startKnown src = notAnnexed src $ do
@ -63,7 +62,8 @@ startKnown src = notAnnexed src $ do
)
notAnnexed :: FilePath -> CommandStart -> CommandStart
notAnnexed src = ifAnnexed src (error $ "cannot used annexed file as src: " ++ src)
notAnnexed src = ifAnnexed src $
giveup $ "cannot used annexed file as src: " ++ src
perform :: FilePath -> Key -> Annex Bool -> CommandPerform
perform src key verify = ifM move

View file

@ -1,25 +1,32 @@
{- git-annex command
-
- Copyright 2014 Joey Hess <id@joeyh.name>
- Copyright 2014-2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Command.RemoteDaemon where
import Command
import RemoteDaemon.Core
import Utility.Daemon
cmd :: Command
cmd = noCommit $
command "remotedaemon" SectionPlumbing
"detects when remotes have changed, and fetches from them"
paramNothing (withParams seek)
cmd = noCommit $
command "remotedaemon" SectionMaintenance
"persistent communication with remotes"
paramNothing (run <$$> const parseDaemonOptions)
seek :: CmdParams -> CommandSeek
seek = withNothing start
start :: CommandStart
start = do
liftIO runForeground
stop
run :: DaemonOptions -> CommandSeek
run o
| stopDaemonOption o = error "--stop not implemented for remotedaemon"
| foregroundDaemonOption o = liftIO runInteractive
| otherwise = do
#ifndef mingw32_HOST_OS
nullfd <- liftIO $ openFd "/dev/null" ReadOnly Nothing defaultFileFlags
liftIO $ daemonize nullfd Nothing False runNonInteractive
#else
liftIO $ foreground Nothing runNonInteractive
#endif

View file

@ -33,8 +33,8 @@ start = do
( do
void $ commitResolvedMerge Git.Branch.ManualCommit
next $ next $ return True
, error "Merge conflict could not be automatically resolved."
, giveup "Merge conflict could not be automatically resolved."
)
where
nobranch = error "No branch is currently checked out."
nomergehead = error "No SHA found in .git/merge_head"
nobranch = giveup "No branch is currently checked out."
nomergehead = giveup "No SHA found in .git/merge_head"

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2013 Joey Hess <id@joeyh.name>
- Copyright 2013-2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -15,13 +15,33 @@ cmd :: Command
cmd = notBareRepo $
command "rmurl" SectionCommon
"record file is not available at url"
(paramPair paramFile paramUrl)
(withParams seek)
(paramRepeating (paramPair paramFile paramUrl))
(seek <$$> optParser)
seek :: CmdParams -> CommandSeek
seek = withPairs start
data RmUrlOptions = RmUrlOptions
{ rmThese :: CmdParams
, batchOption :: BatchMode
}
start :: (FilePath, String) -> CommandStart
optParser :: CmdParamsDesc -> Parser RmUrlOptions
optParser desc = RmUrlOptions
<$> cmdParams desc
<*> parseBatchOption
seek :: RmUrlOptions -> CommandSeek
seek o = case batchOption o of
Batch -> batchInput batchParser (batchCommandAction . start)
NoBatch -> withPairs start (rmThese o)
-- Split on the last space, since a FilePath can contain whitespace,
-- but a url should not.
batchParser :: String -> Either String (FilePath, URLString)
batchParser s = case separate (== ' ') (reverse s) of
(ru, rf)
| null ru || null rf -> Left "Expected: \"file url\""
| otherwise -> Right (reverse rf, reverse ru)
start :: (FilePath, URLString) -> CommandStart
start (file, url) = flip whenAnnexed file $ \_ key -> do
showStart "rmurl" file
next $ next $ cleanup url key

View file

@ -29,9 +29,9 @@ start = parse
where
parse (name:[]) = go name performGet
parse (name:expr:[]) = go name $ \uuid -> do
showStart "schedile" name
showStart "schedule" name
performSet expr uuid
parse _ = error "Specify a repository."
parse _ = giveup "Specify a repository."
go name a = do
u <- Remote.nameToUUID name
@ -47,7 +47,7 @@ performGet uuid = do
performSet :: String -> UUID -> CommandPerform
performSet expr uuid = case parseScheduledActivities expr of
Left e -> error $ "Parse error: " ++ e
Left e -> giveup $ "Parse error: " ++ e
Right l -> do
scheduleSet uuid l
next $ return True

View file

@ -23,10 +23,10 @@ start :: [String] -> CommandStart
start (keyname:file:[]) = do
showStart "setkey" file
next $ perform file (mkKey keyname)
start _ = error "specify a key and a content file"
start _ = giveup "specify a key and a content file"
mkKey :: String -> Key
mkKey = fromMaybe (error "bad key") . file2key
mkKey = fromMaybe (giveup "bad key") . file2key
perform :: FilePath -> Key -> CommandPerform
perform file key = do

View file

@ -26,9 +26,9 @@ start (ks:us:vs:[]) = do
showStart' "setpresentkey" k (mkActionItem k)
next $ perform k (toUUID us) s
where
k = fromMaybe (error "bad key") (file2key ks)
s = fromMaybe (error "bad value") (parseStatus vs)
start _ = error "Wrong number of parameters"
k = fromMaybe (giveup "bad key") (file2key ks)
s = fromMaybe (giveup "bad value") (parseStatus vs)
start _ = giveup "Wrong number of parameters"
perform :: Key -> UUID -> LogStatus -> CommandPerform
perform k u s = next $ do

View file

@ -169,7 +169,15 @@ prepMerge :: Annex ()
prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
mergeConfig :: [Git.Merge.MergeConfig]
mergeConfig = [Git.Merge.MergeNonInteractive]
mergeConfig =
[ Git.Merge.MergeNonInteractive
-- In several situations, unrelated histories should be merged
-- together. This includes pairing in the assistant, and merging
-- from a remote into a newly created direct mode repo.
-- (Once direct mode is removed, this could be changed, so only
-- the assistant uses it.)
, Git.Merge.MergeUnrelatedHistories
]
merge :: CurrBranch -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool
merge (Just b, Just adj) mergeconfig commitmode tomerge =
@ -287,7 +295,7 @@ updateSyncBranch (Just branch, madj) = do
updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO ()
updateBranch syncbranch updateto g =
unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
unlessM go $ giveup $ "failed to update " ++ Git.fromRef syncbranch
where
go = Git.Command.runBool
[ Param "branch"

View file

@ -57,7 +57,7 @@ seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o)
start :: Int -> RemoteName -> CommandStart
start basesz name = do
showStart "testremote" name
r <- either error id <$> Remote.byName' name
r <- either giveup id <$> Remote.byName' name
showAction "generating test keys"
fast <- Annex.getState Annex.fast
ks <- mapM randKey (keySizes basesz fast)

View file

@ -13,6 +13,7 @@ import Types.Transfer
import Logs.Transfer
import qualified CmdLine.GitAnnexShell.Fields as Fields
import Utility.Metered
import Utility.SimpleProtocol
cmd :: Command
cmd = noCommit $
@ -59,7 +60,7 @@ start (k:[]) = do
, exitSuccess
]
stop
start _ = error "wrong number of parameters"
start _ = giveup "wrong number of parameters"
readUpdate :: IO (Maybe Integer)
readUpdate = readish <$> getLine
readUpdate = maybe Nothing readish <$> getProtocolLine stdin

View file

@ -56,10 +56,7 @@ runRequests
-> (TransferRequest -> Annex Bool)
-> Annex ()
runRequests readh writeh a = do
liftIO $ do
hSetBuffering readh NoBuffering
fileEncoding readh
fileEncoding writeh
liftIO $ hSetBuffering readh NoBuffering
go =<< readrequests
where
go (d:rn:k:f:rest) = do

View file

@ -45,7 +45,7 @@ wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
-}
, ifM cleanindex
( lockPreCommitHook $ commit `after` a
, error "Cannot proceed with uncommitted changes staged in the index. Recommend you: git commit"
, giveup "Cannot proceed with uncommitted changes staged in the index. Recommend you: git commit"
)
)
where

View file

@ -32,7 +32,7 @@ seek ps = do
-- in the index.
(fs, cleanup) <- inRepo $ LsFiles.notInRepo False ps
unless (null fs) $
error $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs
giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs
void $ liftIO $ cleanup
-- Committing staged changes before undo allows later

View file

@ -26,7 +26,7 @@ start (name:g:[]) = do
showStart "ungroup" name
u <- Remote.nameToUUID name
next $ perform u g
start _ = error "Specify a repository and a group."
start _ = giveup "Specify a repository and a group."
perform :: UUID -> Group -> CommandPerform
perform uuid g = do

View file

@ -30,12 +30,12 @@ cmd = addCheck check $
check :: Annex ()
check = do
b <- current_branch
when (b == Annex.Branch.name) $ error $
when (b == Annex.Branch.name) $ giveup $
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
top <- fromRepo Git.repoPath
currdir <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
error "can only run uninit from the top of the git repository"
giveup "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . Prelude.head . lines <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
@ -51,7 +51,7 @@ seek ps = do
{- git annex symlinks that are not checked into git could be left by an
- interrupted add. -}
startCheckIncomplete :: FilePath -> Key -> CommandStart
startCheckIncomplete file _ = error $ unlines
startCheckIncomplete file _ = giveup $ unlines
[ file ++ " points to annexed content, but is not checked into git."
, "Perhaps this was left behind by an interrupted git annex add?"
, "Not continuing with uninit; either delete or git annex add the file and retry."
@ -65,7 +65,7 @@ finish = do
prepareRemoveAnnexDir annexdir
if null leftovers
then liftIO $ removeDirectoryRecursive annexdir
else error $ unlines
else giveup $ unlines
[ "Not fully uninitialized"
, "Some annexed data is still left in " ++ annexobjectdir
, "This may include deleted files, or old versions of modified files."

View file

@ -320,7 +320,7 @@ unusedSpec m spec
range (a, b) = case (readish a, readish b) of
(Just x, Just y) -> [x..y]
_ -> badspec
badspec = error $ "Expected number or range, not \"" ++ spec ++ "\""
badspec = giveup $ "Expected number or range, not \"" ++ spec ++ "\""
{- Seek action for unused content. Finds the number in the maps, and
- calls one of 3 actions, depending on the type of unused file. -}
@ -335,7 +335,7 @@ startUnused message unused badunused tmpunused maps n = search
, (unusedTmpMap maps, tmpunused)
]
where
search [] = error $ show n ++ " not valid (run git annex unused for list)"
search [] = giveup $ show n ++ " not valid (run git annex unused for list)"
search ((m, a):rest) =
case M.lookup n m of
Nothing -> search rest

View file

@ -33,6 +33,6 @@ start params = do
next $ next $ return True
Narrowing -> next $ next $ do
if visibleViewSize view' == visibleViewSize view
then error "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
then giveup "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
else checkoutViewBranch view' narrowView
Widening -> error "Widening view to match more files is not currently supported."
Widening -> giveup "Widening view to match more files is not currently supported."

View file

@ -25,7 +25,7 @@ seek = withNothing start
start ::CommandStart
start = go =<< currentView
where
go Nothing = error "Not in a view."
go Nothing = giveup "Not in a view."
go (Just v) = do
showStart "vcycle" ""
let v' = v { viewComponents = vcycle [] (viewComponents v) }

View file

@ -26,5 +26,5 @@ start params = do
let view' = filterView view $
map parseViewParam $ reverse params
next $ next $ if visibleViewSize view' > visibleViewSize view
then error "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
then giveup "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
else checkoutViewBranch view' narrowView

View file

@ -26,7 +26,7 @@ seek = withWords start
start :: [String] -> CommandStart
start ps = go =<< currentView
where
go Nothing = error "Not in a view."
go Nothing = giveup "Not in a view."
go (Just v) = do
showStart "vpop" (show num)
removeView v

View file

@ -41,7 +41,7 @@ start = do
createAnnexDirectory $ parentDir f
cfg <- getCfg
descs <- uuidDescriptions
liftIO $ writeFileAnyEncoding f $ genCfg cfg descs
liftIO $ writeFile f $ genCfg cfg descs
vicfg cfg f
stop
@ -50,12 +50,12 @@ vicfg curcfg f = do
vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR"
-- Allow EDITOR to be processed by the shell, so it can contain options.
unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
error $ vi ++ " exited nonzero; aborting"
r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrictAnyEncoding f)
giveup $ vi ++ " exited nonzero; aborting"
r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f)
liftIO $ nukeFile f
case r of
Left s -> do
liftIO $ writeFileAnyEncoding f s
liftIO $ writeFile f s
vicfg curcfg f
Right newcfg -> setCfg curcfg newcfg

View file

@ -25,7 +25,7 @@ seek :: CmdParams -> CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start [] = error "Specify metadata to include in view"
start [] = giveup "Specify metadata to include in view"
start ps = do
showStart "view" ""
view <- mkView ps
@ -34,7 +34,7 @@ start ps = do
go view Nothing = next $ perform view
go view (Just v)
| v == view = stop
| otherwise = error "Already in a view. Use the vfilter and vadd commands to further refine this view."
| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view."
perform :: View -> CommandPerform
perform view = do
@ -47,7 +47,7 @@ paramView = paramRepeating "FIELD=VALUE"
mkView :: [String] -> Annex View
mkView ps = go =<< inRepo Git.Branch.current
where
go Nothing = error "not on any branch!"
go Nothing = giveup "not on any branch!"
go (Just b) = return $ fst $ refineView (View b []) $
map parseViewParam $ reverse ps

View file

@ -37,7 +37,7 @@ cmd' name desc getter setter = command name SectionSetup desc pdesc (withParams
start (rname:expr:[]) = go rname $ \uuid -> do
showStart name rname
performSet setter expr uuid
start _ = error "Specify a repository."
start _ = giveup "Specify a repository."
go rname a = do
u <- Remote.nameToUUID rname
@ -52,7 +52,7 @@ performGet getter a = do
performSet :: (a -> PreferredContentExpression -> Annex ()) -> String -> a -> CommandPerform
performSet setter expr a = case checkPreferredContentExpression expr of
Just e -> error $ "Parse error: " ++ e
Just e -> giveup $ "Parse error: " ++ e
Nothing -> do
setter a expr
next $ return True

View file

@ -77,7 +77,7 @@ start' allowauto o = do
else annexListen <$> Annex.getGitConfig
ifM (checkpid <&&> checkshim f)
( if isJust (listenAddress o)
then error "The assistant is already running, so --listen cannot be used."
then giveup "The assistant is already running, so --listen cannot be used."
else do
url <- liftIO . readFile
=<< fromRepo gitAnnexUrlFile
@ -125,7 +125,7 @@ startNoRepo o = go =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile)
go ds
Right state -> void $ Annex.eval state $ do
whenM (fromRepo Git.repoIsLocalBare) $
error $ d ++ " is a bare git repository, cannot run the webapp in it"
giveup $ d ++ " is a bare git repository, cannot run the webapp in it"
callCommandAction $
start' False o