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

@ -38,7 +38,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
showerrcount =<< Annex.getState Annex.errcounter
where
showerrcount 0 = noop
showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed"
showerrcount cnt = giveup $ name ++ ": " ++ show cnt ++ " failed"
{- Runs one of the actions needed to perform a command.
- Individual actions can fail without stopping the whole command,

View file

@ -48,15 +48,16 @@ batchBadInput Batch = liftIO $ putStrLn ""
-- Reads lines of batch mode input and passes to the action to handle.
batchInput :: (String -> Either String a) -> (a -> Annex ()) -> Annex ()
batchInput parser a = do
mp <- liftIO $ catchMaybeIO getLine
case mp of
Nothing -> return ()
Just v -> do
either parseerr a (parser v)
batchInput parser a
batchInput parser a = go =<< batchLines
where
parseerr s = error $ "Batch input parse failure: " ++ s
go [] = return ()
go (l:rest) = do
either parseerr a (parser l)
go rest
parseerr s = giveup $ "Batch input parse failure: " ++ s
batchLines :: Annex [String]
batchLines = liftIO $ lines <$> getContents
-- Runs a CommandStart in batch mode.
--

View file

@ -52,6 +52,7 @@ import qualified Command.Init
import qualified Command.Describe
import qualified Command.InitRemote
import qualified Command.EnableRemote
import qualified Command.EnableTor
import qualified Command.Expire
import qualified Command.Repair
import qualified Command.Unused
@ -95,18 +96,19 @@ import qualified Command.Direct
import qualified Command.Indirect
import qualified Command.Upgrade
import qualified Command.Forget
import qualified Command.P2P
import qualified Command.Proxy
import qualified Command.DiffDriver
import qualified Command.Smudge
import qualified Command.Undo
import qualified Command.Version
import qualified Command.RemoteDaemon
#ifdef WITH_ASSISTANT
import qualified Command.Watch
import qualified Command.Assistant
#ifdef WITH_WEBAPP
import qualified Command.WebApp
#endif
import qualified Command.RemoteDaemon
#endif
import qualified Command.Test
#ifdef WITH_TESTSUITE
@ -139,6 +141,7 @@ cmds testoptparser testrunner =
, Command.Describe.cmd
, Command.InitRemote.cmd
, Command.EnableRemote.cmd
, Command.EnableTor.cmd
, Command.Reinject.cmd
, Command.Unannex.cmd
, Command.Uninit.cmd
@ -199,18 +202,19 @@ cmds testoptparser testrunner =
, Command.Indirect.cmd
, Command.Upgrade.cmd
, Command.Forget.cmd
, Command.P2P.cmd
, Command.Proxy.cmd
, Command.DiffDriver.cmd
, Command.Smudge.cmd
, Command.Undo.cmd
, Command.Version.cmd
, Command.RemoteDaemon.cmd
#ifdef WITH_ASSISTANT
, Command.Watch.cmd
, Command.Assistant.cmd
#ifdef WITH_WEBAPP
, Command.WebApp.cmd
#endif
, Command.RemoteDaemon.cmd
#endif
, Command.Test.cmd testoptparser testrunner
#ifdef WITH_TESTSUITE

View file

@ -71,7 +71,7 @@ globalOptions =
check Nothing = unexpected expected "uninitialized repository"
check (Just u) = unexpectedUUID expected u
unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
unexpected expected s = error $
unexpected expected s = giveup $
"expected repository UUID " ++ expected ++ " but found " ++ s
run :: [String] -> IO ()
@ -109,7 +109,7 @@ builtin cmd dir params = do
Git.Config.read r
`catchIO` \_ -> do
hn <- fromMaybe "unknown" <$> getHostname
error $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
giveup $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
external :: [String] -> IO ()
external params = do
@ -120,7 +120,7 @@ external params = do
checkDirectory lastparam
checkNotLimited
unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $
error "git-shell failed"
giveup "git-shell failed"
{- Split the input list into 3 groups separated with a double dash --.
- Parameters between two -- markers are field settings, in the form:
@ -150,6 +150,6 @@ checkField (field, val)
| otherwise = False
failure :: IO ()
failure = error $ "bad parameters\n\n" ++ usage h cmds
failure = giveup $ "bad parameters\n\n" ++ usage h cmds
where
h = "git-annex-shell [-c] command [parameters ...] [option ...]"

View file

@ -26,7 +26,7 @@ checkEnv var = do
case v of
Nothing -> noop
Just "" -> noop
Just _ -> error $ "Action blocked by " ++ var
Just _ -> giveup $ "Action blocked by " ++ var
checkDirectory :: Maybe FilePath -> IO ()
checkDirectory mdir = do
@ -44,7 +44,7 @@ checkDirectory mdir = do
then noop
else req d' (Just dir')
where
req d mdir' = error $ unwords
req d mdir' = giveup $ unwords
[ "Only allowed to access"
, d
, maybe "and could not determine directory from command line" ("not " ++) mdir'
@ -64,4 +64,4 @@ gitAnnexShellCheck :: Command -> Command
gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
where
okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
error "Not a git-annex or gcrypt repository."
giveup "Not a git-annex or gcrypt repository."

View file

@ -0,0 +1,66 @@
{- git-remote-tor-annex program
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module CmdLine.GitRemoteTorAnnex where
import Common
import qualified Annex
import qualified Git.CurrentRepo
import P2P.Protocol
import P2P.IO
import Utility.Tor
import Utility.AuthToken
import Annex.UUID
import P2P.Address
import P2P.Auth
run :: [String] -> IO ()
run (_remotename:address:[]) = forever $ do
-- gitremote-helpers protocol
l <- getLine
case l of
"capabilities" -> putStrLn "connect" >> ready
"connect git-upload-pack" -> go UploadPack
"connect git-receive-pack" -> go ReceivePack
_ -> error $ "git-remote-helpers protocol error at " ++ show l
where
(onionaddress, onionport)
| '/' `elem` address = parseAddressPort $
reverse $ takeWhile (/= '/') $ reverse address
| otherwise = parseAddressPort address
go service = do
ready
either giveup exitWith
=<< connectService onionaddress onionport service
ready = do
putStrLn ""
hFlush stdout
run (_remotename:[]) = giveup "remote address not configured"
run _ = giveup "expected remote name and address parameters"
parseAddressPort :: String -> (OnionAddress, OnionPort)
parseAddressPort s =
let (a, sp) = separate (== ':') s
in case readish sp of
Nothing -> giveup "onion address must include port number"
Just p -> (OnionAddress a, p)
connectService :: OnionAddress -> OnionPort -> Service -> IO (Either String ExitCode)
connectService address port service = do
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $ do
authtoken <- fromMaybe nullAuthToken
<$> loadP2PRemoteAuthToken (TorAnnex address port)
myuuid <- getUUID
g <- Annex.gitRepo
conn <- liftIO $ connectPeer g (TorAnnex address port)
liftIO $ runNetProto conn $ do
v <- auth myuuid authtoken
case v of
Just _theiruuid -> connect service stdin stdout
Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv

View file

@ -40,7 +40,7 @@ withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> CmdParams
withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)
( withFilesInGit a params
, if null params
then error needforce
then giveup needforce
else seekActions $ prepFiltered a (getfiles [] params)
)
where
@ -54,7 +54,7 @@ withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)
[] -> do
void $ liftIO $ cleanup
getfiles c ps
_ -> error needforce
_ -> giveup needforce
withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesNotInGit skipdotfiles a params
@ -117,7 +117,7 @@ withPairs a params = seekActions $ return $ map a $ pairs [] params
where
pairs c [] = reverse c
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = error "expected pairs"
pairs _ _ = giveup "expected pairs"
withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesToBeCommitted a params = seekActions $ prepFiltered a $
@ -152,11 +152,11 @@ withFilesMaybeModified a params = seekActions $
withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek
withKeys a params = seekActions $ return $ map (a . parse) params
where
parse p = fromMaybe (error "bad key") $ file2key p
parse p = fromMaybe (giveup "bad key") $ file2key p
withNothing :: CommandStart -> CmdParams -> CommandSeek
withNothing a [] = seekActions $ return [a]
withNothing _ _ = error "This command takes no parameters."
withNothing _ _ = giveup "This command takes no parameters."
{- Handles the --all, --branch, --unused, --failed, --key, and
- --incomplete options, which specify particular keys to run an
@ -191,7 +191,7 @@ withKeyOptions'
withKeyOptions' ko auto mkkeyaction fallbackaction params = do
bare <- fromRepo Git.repoIsLocalBare
when (auto && bare) $
error "Cannot use --auto in a bare repository"
giveup "Cannot use --auto in a bare repository"
case (null params, ko) of
(True, Nothing)
| bare -> noauto $ runkeyaction loggedKeys
@ -203,10 +203,10 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
(True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k])
(True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys
(True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs
(False, Just _) -> error "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"
(False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"
where
noauto a
| auto = error "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"
| auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"
| otherwise = a
incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True
runkeyaction getks = do