diff options
Diffstat (limited to 'CmdLine')
-rw-r--r-- | CmdLine/Action.hs | 2 | ||||
-rw-r--r-- | CmdLine/Batch.hs | 17 | ||||
-rw-r--r-- | CmdLine/GitAnnex.hs | 8 | ||||
-rw-r--r-- | CmdLine/GitAnnexShell.hs | 8 | ||||
-rw-r--r-- | CmdLine/GitAnnexShell/Checks.hs | 6 | ||||
-rw-r--r-- | CmdLine/GitRemoteTorAnnex.hs | 66 | ||||
-rw-r--r-- | CmdLine/Seek.hs | 16 |
7 files changed, 97 insertions, 26 deletions
diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 7d9dce574..27621e445 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -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, diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index cca93b0b3..82038314c 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -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. -- diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index a5913e9e0..394bd173b 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -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 diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 599d12fec..70c86ec2f 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -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 ...]" diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs index 63d2e594f..47bc11a76 100644 --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -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." diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs new file mode 100644 index 000000000..5208a47ca --- /dev/null +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -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 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 5d20ad0db..7fc64c528 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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 |