Merge branch 'master' into no-xmpp
This commit is contained in:
commit
ab66bbfeb6
377 changed files with 7442 additions and 875 deletions
|
@ -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,
|
||||
|
|
|
@ -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.
|
||||
--
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ...]"
|
||||
|
|
|
@ -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."
|
||||
|
|
66
CmdLine/GitRemoteTorAnnex.hs
Normal file
66
CmdLine/GitRemoteTorAnnex.hs
Normal 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
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue