Merge branch 'master' into no-xmpp
This commit is contained in:
commit
ab66bbfeb6
377 changed files with 7442 additions and 875 deletions
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
130
Command/EnableTor.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)"
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
302
Command/P2P.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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) }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue