Merge branch 'master' into no-xmpp
This commit is contained in:
Joey Hess
commit
ab66bbfeb6
377 changed files with 7442 additions and 875 deletions
|
|
@ -596,7 +596,7 @@ checkAdjustedClone = ifM isBareRepo
|
|||
aps <- fmap commitParent <$> findAdjustingCommit (AdjBranch currbranch)
|
||||
case aps of
|
||||
Just [p] -> setBasisBranch basis p
|
||||
_ -> error $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
|
||||
_ -> giveup $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
|
||||
ifM versionSupportsUnlockedPointers
|
||||
( return InAdjustedClone
|
||||
, return NeedUpgradeForAdjustedClone
|
||||
|
|
@ -610,6 +610,6 @@ isGitVersionSupported = not <$> Git.Version.older "2.2.0"
|
|||
checkVersionSupported :: Annex ()
|
||||
checkVersionSupported = do
|
||||
unlessM versionSupportsAdjustedBranch $
|
||||
error "Adjusted branches are only supported in v6 or newer repositories."
|
||||
giveup "Adjusted branches are only supported in v6 or newer repositories."
|
||||
unlessM (liftIO isGitVersionSupported) $
|
||||
error "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."
|
||||
giveup "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."
|
||||
|
|
|
|||
|
|
@ -61,6 +61,7 @@ import qualified Annex.Queue
|
|||
import Annex.Branch.Transitions
|
||||
import qualified Annex
|
||||
import Annex.Hook
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
{- Name of the branch that is used to store git-annex's information. -}
|
||||
name :: Git.Ref
|
||||
|
|
@ -225,7 +226,7 @@ getHistorical date file =
|
|||
-- This check avoids some ugly error messages when the reflog
|
||||
-- is empty.
|
||||
ifM (null <$> inRepo (Git.RefLog.get' [Param (fromRef fullname), Param "-n1"]))
|
||||
( error ("No reflog for " ++ fromRef fullname)
|
||||
( giveup ("No reflog for " ++ fromRef fullname)
|
||||
, getRef (Git.Ref.dateRef fullname date) file
|
||||
)
|
||||
|
||||
|
|
@ -436,7 +437,6 @@ stageJournal jl = withIndex $ do
|
|||
g <- gitRepo
|
||||
let dir = gitAnnexJournalDir g
|
||||
(jlogf, jlogh) <- openjlog
|
||||
liftIO $ fileEncoding jlogh
|
||||
h <- hashObjectHandle
|
||||
withJournalHandle $ \jh ->
|
||||
Git.UpdateIndex.streamUpdateIndex g
|
||||
|
|
@ -574,7 +574,7 @@ checkBranchDifferences ref = do
|
|||
<$> catFile ref differenceLog
|
||||
mydiffs <- annexDifferences <$> Annex.getGitConfig
|
||||
when (theirdiffs /= mydiffs) $
|
||||
error "Remote repository is tuned in incompatable way; cannot be merged with local repository."
|
||||
giveup "Remote repository is tuned in incompatable way; cannot be merged with local repository."
|
||||
|
||||
ignoreRefs :: [Git.Sha] -> Annex ()
|
||||
ignoreRefs rs = do
|
||||
|
|
|
|||
|
|
@ -33,6 +33,7 @@ import Git.FilePath
|
|||
import Git.Index
|
||||
import qualified Git.Ref
|
||||
import Annex.Link
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
catFile :: Git.Branch -> FilePath -> Annex L.ByteString
|
||||
catFile branch file = do
|
||||
|
|
|
|||
108
Annex/ChangedRefs.hs
Normal file
108
Annex/ChangedRefs.hs
Normal file
|
|
@ -0,0 +1,108 @@
|
|||
{- Waiting for changed git refs
|
||||
-
|
||||
- Copyright 2014-216 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Annex.ChangedRefs
|
||||
( ChangedRefs(..)
|
||||
, ChangedRefsHandle
|
||||
, waitChangedRefs
|
||||
, drainChangedRefs
|
||||
, stopWatchingChangedRefs
|
||||
, watchChangedRefs
|
||||
) where
|
||||
|
||||
import Annex.Common
|
||||
import Utility.DirWatcher
|
||||
import Utility.DirWatcher.Types
|
||||
import qualified Git
|
||||
import Git.Sha
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TBMChan
|
||||
|
||||
newtype ChangedRefs = ChangedRefs [Git.Ref]
|
||||
deriving (Show)
|
||||
|
||||
instance Proto.Serializable ChangedRefs where
|
||||
serialize (ChangedRefs l) = unwords $ map Git.fromRef l
|
||||
deserialize = Just . ChangedRefs . map Git.Ref . words
|
||||
|
||||
data ChangedRefsHandle = ChangedRefsHandle DirWatcherHandle (TBMChan Git.Sha)
|
||||
|
||||
-- | Wait for one or more git refs to change.
|
||||
--
|
||||
-- When possible, coalesce ref writes that occur closely together
|
||||
-- in time. Delay up to 0.05 seconds to get more ref writes.
|
||||
waitChangedRefs :: ChangedRefsHandle -> IO ChangedRefs
|
||||
waitChangedRefs (ChangedRefsHandle _ chan) = do
|
||||
v <- atomically $ readTBMChan chan
|
||||
case v of
|
||||
Nothing -> return $ ChangedRefs []
|
||||
Just r -> do
|
||||
threadDelay 50000
|
||||
rs <- atomically $ loop []
|
||||
return $ ChangedRefs (r:rs)
|
||||
where
|
||||
loop rs = do
|
||||
v <- tryReadTBMChan chan
|
||||
case v of
|
||||
Just (Just r) -> loop (r:rs)
|
||||
_ -> return rs
|
||||
|
||||
-- | Remove any changes that might be buffered in the channel,
|
||||
-- without waiting for any new changes.
|
||||
drainChangedRefs :: ChangedRefsHandle -> IO ()
|
||||
drainChangedRefs (ChangedRefsHandle _ chan) = atomically go
|
||||
where
|
||||
go = do
|
||||
v <- tryReadTBMChan chan
|
||||
case v of
|
||||
Just (Just _) -> go
|
||||
_ -> return ()
|
||||
|
||||
stopWatchingChangedRefs :: ChangedRefsHandle -> IO ()
|
||||
stopWatchingChangedRefs h@(ChangedRefsHandle wh chan) = do
|
||||
stopWatchDir wh
|
||||
atomically $ closeTBMChan chan
|
||||
drainChangedRefs h
|
||||
|
||||
watchChangedRefs :: Annex (Maybe ChangedRefsHandle)
|
||||
watchChangedRefs = do
|
||||
-- This channel is used to accumulate notifications,
|
||||
-- because the DirWatcher might have multiple threads that find
|
||||
-- changes at the same time. It is bounded to allow a watcher
|
||||
-- to be started once and reused, without too many changes being
|
||||
-- buffered in memory.
|
||||
chan <- liftIO $ newTBMChanIO 100
|
||||
|
||||
g <- gitRepo
|
||||
let refdir = Git.localGitDir g </> "refs"
|
||||
liftIO $ createDirectoryIfMissing True refdir
|
||||
|
||||
let notifyhook = Just $ notifyHook chan
|
||||
let hooks = mkWatchHooks
|
||||
{ addHook = notifyhook
|
||||
, modifyHook = notifyhook
|
||||
}
|
||||
|
||||
if canWatch
|
||||
then do
|
||||
h <- liftIO $ watchDir refdir (const False) True hooks id
|
||||
return $ Just $ ChangedRefsHandle h chan
|
||||
else return Nothing
|
||||
|
||||
notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
|
||||
notifyHook chan reffile _
|
||||
| ".lock" `isSuffixOf` reffile = noop
|
||||
| otherwise = void $ do
|
||||
sha <- catchDefaultIO Nothing $
|
||||
extractSha <$> readFile reffile
|
||||
-- When the channel is full, there is probably no reader
|
||||
-- running, or ref changes have been occuring very fast,
|
||||
-- so it's ok to not write the change to it.
|
||||
maybe noop (void . atomically . tryWriteTBMChan chan) sha
|
||||
|
|
@ -268,8 +268,8 @@ lockContentUsing locker key a = do
|
|||
(unlock lockfile)
|
||||
(const a)
|
||||
where
|
||||
alreadylocked = error "content is locked"
|
||||
failedtolock e = error $ "failed to lock content: " ++ show e
|
||||
alreadylocked = giveup "content is locked"
|
||||
failedtolock e = giveup $ "failed to lock content: " ++ show e
|
||||
|
||||
lock contentfile lockfile =
|
||||
(maybe alreadylocked return
|
||||
|
|
|
|||
|
|
@ -52,8 +52,7 @@ associatedFiles key = do
|
|||
associatedFilesRelative :: Key -> Annex [FilePath]
|
||||
associatedFilesRelative key = do
|
||||
mapping <- calcRepo $ gitAnnexMapping key
|
||||
liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do
|
||||
fileEncoding h
|
||||
liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
|
||||
-- Read strictly to ensure the file is closed
|
||||
-- before changeAssociatedFiles tries to write to it.
|
||||
-- (Especially needed on Windows.)
|
||||
|
|
@ -68,8 +67,7 @@ changeAssociatedFiles key transform = do
|
|||
let files' = transform files
|
||||
when (files /= files') $
|
||||
modifyContent mapping $
|
||||
liftIO $ viaTmp writeFileAnyEncoding mapping $
|
||||
unlines files'
|
||||
liftIO $ viaTmp writeFile mapping $ unlines files'
|
||||
top <- fromRepo Git.repoPath
|
||||
return $ map (top </>) files'
|
||||
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ import Common
|
|||
import Types.Key
|
||||
import Types.GitConfig
|
||||
import Types.Difference
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
type Hasher = Key -> FilePath
|
||||
|
||||
|
|
|
|||
|
|
@ -165,7 +165,7 @@ largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
|
|||
mkmatcher expr = do
|
||||
parser <- mkLargeFilesParser
|
||||
either badexpr return $ parsedToMatcher $ parser expr
|
||||
badexpr e = error $ "bad annex.largefiles configuration: " ++ e
|
||||
badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e
|
||||
|
||||
simply :: MatchFiles Annex -> ParseResult
|
||||
simply = Right . Operation
|
||||
|
|
|
|||
|
|
@ -129,7 +129,7 @@ ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
|
|||
where
|
||||
needsinit = ifM Annex.Branch.hasSibling
|
||||
( initialize Nothing Nothing
|
||||
, error "First run: git-annex init"
|
||||
, giveup "First run: git-annex init"
|
||||
)
|
||||
|
||||
{- Checks if a repository is initialized. Does not check version for ugrade. -}
|
||||
|
|
|
|||
|
|
@ -37,7 +37,6 @@ setJournalFile _jl file content = do
|
|||
let tmpfile = tmp </> takeFileName jfile
|
||||
liftIO $ do
|
||||
withFile tmpfile WriteMode $ \h -> do
|
||||
fileEncoding h
|
||||
#ifdef mingw32_HOST_OS
|
||||
hSetNewlineMode h noNewlineTranslation
|
||||
#endif
|
||||
|
|
@ -53,7 +52,7 @@ getJournalFile _jl = getJournalFileStale
|
|||
- changes. -}
|
||||
getJournalFileStale :: FilePath -> Annex (Maybe String)
|
||||
getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
|
||||
readFileStrictAnyEncoding $ journalFile file g
|
||||
readFileStrict $ journalFile file g
|
||||
|
||||
{- List of files that have updated content in the journal. -}
|
||||
getJournalledFiles :: JournalLocked -> Annex [FilePath]
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import Git.Types
|
|||
import Git.FilePath
|
||||
import Annex.HashObject
|
||||
import Utility.FileMode
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
|
|
@ -63,7 +64,6 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
|
|||
Nothing -> fallback
|
||||
|
||||
probefilecontent f = withFile f ReadMode $ \h -> do
|
||||
fileEncoding h
|
||||
-- The first 8k is more than enough to read; link
|
||||
-- files are small.
|
||||
s <- take 8192 <$> hGetContents h
|
||||
|
|
|
|||
|
|
@ -63,7 +63,6 @@ module Annex.Locations (
|
|||
gitAnnexUrlFile,
|
||||
gitAnnexTmpCfgFile,
|
||||
gitAnnexSshDir,
|
||||
gitAnnexSshConfig,
|
||||
gitAnnexRemotesDir,
|
||||
gitAnnexAssistantDefaultDir,
|
||||
HashLevels(..),
|
||||
|
|
@ -403,10 +402,6 @@ gitAnnexTmpCfgFile r = gitAnnexDir r </> "config.tmp"
|
|||
gitAnnexSshDir :: Git.Repo -> FilePath
|
||||
gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"
|
||||
|
||||
{- .git/annex/ssh.config is used to configure ssh. -}
|
||||
gitAnnexSshConfig :: Git.Repo -> FilePath
|
||||
gitAnnexSshConfig r = gitAnnexDir r </> "ssh.config"
|
||||
|
||||
{- .git/annex/remotes/ is used for remote-specific state. -}
|
||||
gitAnnexRemotesDir :: Git.Repo -> FilePath
|
||||
gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where
|
||||
module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where
|
||||
|
||||
import Annex.Common
|
||||
import Types.Transfer
|
||||
|
|
@ -21,6 +21,10 @@ import qualified DBus.Client
|
|||
-- Witness that notification has happened.
|
||||
data NotifyWitness = NotifyWitness
|
||||
|
||||
-- Only use when no notification should be done.
|
||||
noNotification :: NotifyWitness
|
||||
noNotification = NotifyWitness
|
||||
|
||||
{- Wrap around an action that performs a transfer, which may run multiple
|
||||
- attempts. Displays notification when supported and when the user asked
|
||||
- for it. -}
|
||||
|
|
|
|||
|
|
@ -13,12 +13,11 @@ import Types.Remote (RemoteConfig, RemoteConfigKey, typename, setup)
|
|||
import Logs.Remote
|
||||
import Logs.Trust
|
||||
import qualified Git.Config
|
||||
import Git.Types (RemoteName)
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Data.Ord
|
||||
|
||||
type RemoteName = String
|
||||
|
||||
{- See if there's an existing special remote with this name.
|
||||
-
|
||||
- Prefer remotes that are not dead when a name appears multiple times. -}
|
||||
|
|
|
|||
40
Annex/Ssh.hs
40
Annex/Ssh.hs
|
|
@ -33,7 +33,7 @@ import qualified Git.Url
|
|||
import Config
|
||||
import Annex.Path
|
||||
import Utility.Env
|
||||
import Utility.Tmp
|
||||
import Utility.FileSystemEncoding
|
||||
import Types.CleanupActions
|
||||
import Git.Env
|
||||
#ifndef mingw32_HOST_OS
|
||||
|
|
@ -50,37 +50,13 @@ sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port)
|
|||
go (Just socketfile, params) = do
|
||||
prepSocket socketfile
|
||||
ret params
|
||||
ret ps = do
|
||||
overideconfigfile <- fromRepo gitAnnexSshConfig
|
||||
-- We assume that the file content does not change.
|
||||
-- If it did, a more expensive test would be needed.
|
||||
liftIO $ unlessM (doesFileExist overideconfigfile) $
|
||||
viaTmp writeFile overideconfigfile $ unlines
|
||||
-- Make old version of ssh that does
|
||||
-- not know about Include ignore those
|
||||
-- entries.
|
||||
[ "IgnoreUnknown Include"
|
||||
-- ssh expands "~"
|
||||
, "Include ~/.ssh/config"
|
||||
-- ssh will silently skip the file
|
||||
-- if it does not exist
|
||||
, "Include /etc/ssh/ssh_config"
|
||||
-- Everything below this point is only
|
||||
-- used if there's no setting for it in
|
||||
-- the above files.
|
||||
--
|
||||
-- Make sure that ssh detects stalled
|
||||
-- connections.
|
||||
, "ServerAliveInterval 60"
|
||||
]
|
||||
return $ concat
|
||||
[ ps
|
||||
, [Param "-F", File overideconfigfile]
|
||||
, map Param (remoteAnnexSshOptions gc)
|
||||
, opts
|
||||
, portParams port
|
||||
, [Param "-T"]
|
||||
]
|
||||
ret ps = return $ concat
|
||||
[ ps
|
||||
, map Param (remoteAnnexSshOptions gc)
|
||||
, opts
|
||||
, portParams port
|
||||
, [Param "-T"]
|
||||
]
|
||||
|
||||
{- Returns a filename to use for a ssh connection caching socket, and
|
||||
- parameters to enable ssh connection caching. -}
|
||||
|
|
|
|||
|
|
@ -45,6 +45,11 @@ instance Observable (Bool, Verification) where
|
|||
observeBool = fst
|
||||
observeFailure = (False, UnVerified)
|
||||
|
||||
instance Observable (Either e Bool) where
|
||||
observeBool (Left _) = False
|
||||
observeBool (Right b) = b
|
||||
observeFailure = Right False
|
||||
|
||||
upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
|
||||
upload u key f d a _witness = guardHaveUUID u $
|
||||
runTransfer (Transfer Upload u key) f d a
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
module Annex.VariantFile where
|
||||
|
||||
import Annex.Common
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
import Data.Hash.MD5
|
||||
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ refineView origview = checksize . calc Unchanged origview
|
|||
in (view', Narrowing)
|
||||
|
||||
checksize r@(v, _)
|
||||
| viewTooLarge v = error $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
|
||||
| viewTooLarge v = giveup $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
|
||||
| otherwise = r
|
||||
|
||||
updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent
|
||||
|
|
@ -424,4 +424,4 @@ genViewBranch view = withViewIndex $ do
|
|||
return branch
|
||||
|
||||
withCurrentView :: (View -> Annex a) -> Annex a
|
||||
withCurrentView a = maybe (error "Not in a view.") a =<< currentView
|
||||
withCurrentView a = maybe (giveup "Not in a view.") a =<< currentView
|
||||
|
|
|
|||
|
|
@ -26,7 +26,6 @@ import qualified Control.Exception as E
|
|||
import Assistant.DaemonStatus
|
||||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp (renderUrl)
|
||||
import Yesod
|
||||
#endif
|
||||
import Assistant.Monad
|
||||
import Assistant.Types.UrlRenderer
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Fsck where
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Gpg where
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ import Utility.Parallel
|
|||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Git.Merge
|
||||
import qualified Git.Ref
|
||||
import qualified Remote
|
||||
import qualified Types.Remote as Remote
|
||||
import qualified Remote.List as Remote
|
||||
|
|
@ -204,16 +205,9 @@ manualPull currentbranch remotes = do
|
|||
)
|
||||
haddiverged <- liftAnnex Annex.Branch.forceUpdate
|
||||
forM_ normalremotes $ \r ->
|
||||
liftAnnex $ Command.Sync.mergeRemote r currentbranch mergeConfig
|
||||
liftAnnex $ Command.Sync.mergeRemote r currentbranch Command.Sync.mergeConfig
|
||||
return (catMaybes failed, haddiverged)
|
||||
|
||||
mergeConfig :: [Git.Merge.MergeConfig]
|
||||
mergeConfig =
|
||||
[ Git.Merge.MergeNonInteractive
|
||||
-- Pairing involves merging unrelated histories
|
||||
, Git.Merge.MergeUnrelatedHistories
|
||||
]
|
||||
|
||||
{- Start syncing a remote, using a background thread. -}
|
||||
syncRemote :: Remote -> Assistant ()
|
||||
syncRemote remote = do
|
||||
|
|
|
|||
|
|
@ -11,6 +11,8 @@ import Assistant.Common
|
|||
import Assistant.TransferQueue
|
||||
import Assistant.BranchChange
|
||||
import Assistant.Sync
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Utility.DirWatcher
|
||||
import Utility.DirWatcher.Types
|
||||
import qualified Annex.Branch
|
||||
|
|
@ -78,7 +80,7 @@ onChange file
|
|||
, "into", Git.fromRef b
|
||||
]
|
||||
void $ liftAnnex $ Command.Sync.merge
|
||||
currbranch mergeConfig
|
||||
currbranch Command.Sync.mergeConfig
|
||||
Git.Branch.AutomaticCommit
|
||||
changedbranch
|
||||
mergecurrent _ = noop
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ remoteControlThread :: NamedThread
|
|||
remoteControlThread = namedThread "RemoteControl" $ do
|
||||
program <- liftIO programPath
|
||||
(cmd, params) <- liftIO $ toBatchCommand
|
||||
(program, [Param "remotedaemon"])
|
||||
(program, [Param "remotedaemon", Param "--foreground"])
|
||||
let p = proc cmd (toCommand params)
|
||||
(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
|
||||
{ std_in = CreatePipe
|
||||
|
|
|
|||
|
|
@ -65,10 +65,10 @@ checkCanWatch
|
|||
#else
|
||||
noop
|
||||
#endif
|
||||
| otherwise = error "watch mode is not available on this system"
|
||||
| otherwise = giveup "watch mode is not available on this system"
|
||||
|
||||
needLsof :: Annex ()
|
||||
needLsof = error $ unlines
|
||||
needLsof = giveup $ unlines
|
||||
[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
|
||||
, "To override lsof checks to ensure that files are not open for writing"
|
||||
, "when added to the annex, you can use --force"
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ import Assistant.WebApp.OtherRepos
|
|||
import Assistant.WebApp.Repair
|
||||
import Assistant.Types.ThreadedMonad
|
||||
import Utility.WebApp
|
||||
import Utility.AuthToken
|
||||
import Utility.Tmp
|
||||
import Utility.FileMode
|
||||
import Git
|
||||
|
|
@ -70,11 +71,11 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
|
|||
#ifdef __ANDROID__
|
||||
when (isJust listenhost') $
|
||||
-- See Utility.WebApp
|
||||
error "Sorry, --listen is not currently supported on Android"
|
||||
giveup "Sorry, --listen is not currently supported on Android"
|
||||
#endif
|
||||
webapp <- WebApp
|
||||
<$> pure assistantdata
|
||||
<*> genAuthToken
|
||||
<*> genAuthToken 128
|
||||
<*> getreldir
|
||||
<*> pure staticRoutes
|
||||
<*> pure postfirstrun
|
||||
|
|
|
|||
|
|
@ -74,8 +74,6 @@ mkTransferrer program batchmaker = do
|
|||
, std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
}
|
||||
fileEncoding readh
|
||||
fileEncoding writeh
|
||||
return $ Transferrer
|
||||
{ transferrerRead = readh
|
||||
, transferrerWrite = writeh
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
|
@ -153,7 +153,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
|
|||
where
|
||||
changeprogram program = liftIO $ do
|
||||
unlessM (boolSystem program [Param "version"]) $
|
||||
error "New git-annex program failed to run! Not using."
|
||||
giveup "New git-annex program failed to run! Not using."
|
||||
pf <- programFile
|
||||
liftIO $ writeFile pf program
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ import Assistant.WebApp.Types
|
|||
import Assistant.Common
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
import Utility.WebApp
|
||||
import Utility.AuthToken
|
||||
|
||||
import Data.Text (Text)
|
||||
import Control.Concurrent
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ postAddS3R = awsConfigurator $ do
|
|||
]
|
||||
_ -> $(widgetFile "configurators/adds3")
|
||||
#else
|
||||
postAddS3R = error "S3 not supported by this build"
|
||||
postAddS3R = giveup "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getAddGlacierR :: Handler Html
|
||||
|
|
@ -161,7 +161,7 @@ postAddGlacierR = glacierConfigurator $ do
|
|||
]
|
||||
_ -> $(widgetFile "configurators/addglacier")
|
||||
#else
|
||||
postAddGlacierR = error "S3 not supported by this build"
|
||||
postAddGlacierR = giveup "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableS3R :: UUID -> Handler Html
|
||||
|
|
@ -179,7 +179,7 @@ postEnableS3R :: UUID -> Handler Html
|
|||
#ifdef WITH_S3
|
||||
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
|
||||
#else
|
||||
postEnableS3R _ = error "S3 not supported by this build"
|
||||
postEnableS3R _ = giveup "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableGlacierR :: UUID -> Handler Html
|
||||
|
|
@ -205,7 +205,7 @@ enableAWSRemote remotetype uuid = do
|
|||
T.pack <$> Remote.prettyUUID uuid
|
||||
$(widgetFile "configurators/enableaws")
|
||||
#else
|
||||
enableAWSRemote _ _ = error "S3 not supported by this build"
|
||||
enableAWSRemote _ _ = giveup "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
|
||||
|
|
|
|||
|
|
@ -147,7 +147,7 @@ postAddIAR = iaConfigurator $ do
|
|||
]
|
||||
_ -> $(widgetFile "configurators/addia")
|
||||
#else
|
||||
postAddIAR = error "S3 not supported by this build"
|
||||
postAddIAR = giveup "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableIAR :: UUID -> Handler Html
|
||||
|
|
@ -157,7 +157,7 @@ postEnableIAR :: UUID -> Handler Html
|
|||
#ifdef WITH_S3
|
||||
postEnableIAR = iaConfigurator . enableIARemote
|
||||
#else
|
||||
postEnableIAR _ = error "S3 not supported by this build"
|
||||
postEnableIAR _ = giveup "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
#ifdef WITH_S3
|
||||
|
|
|
|||
|
|
@ -151,7 +151,7 @@ getFirstRepositoryR = postFirstRepositoryR
|
|||
postFirstRepositoryR :: Handler Html
|
||||
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
|
||||
unlessM (liftIO $ inPath "git") $
|
||||
error "You need to install git in order to use git-annex!"
|
||||
giveup "You need to install git in order to use git-annex!"
|
||||
#ifdef __ANDROID__
|
||||
androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
|
||||
let path = "/sdcard/annex"
|
||||
|
|
@ -309,7 +309,7 @@ getFinishAddDriveR drive = go
|
|||
mu <- liftAnnex $ probeGCryptRemoteUUID dir
|
||||
case mu of
|
||||
Just u -> enableexistinggcryptremote u
|
||||
Nothing -> error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||
Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||
enableexistinggcryptremote u = do
|
||||
remotename' <- liftAnnex $ getGCryptRemoteName u dir
|
||||
makewith $ const $ do
|
||||
|
|
|
|||
|
|
@ -196,7 +196,7 @@ postEnableSshGCryptR u = whenGcryptInstalled $
|
|||
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
|
||||
sshConfigurator $
|
||||
checkExistingGCrypt sshdata' $
|
||||
error "Expected to find an encrypted git repository, but did not."
|
||||
giveup "Expected to find an encrypted git repository, but did not."
|
||||
getsshinput = parseSshUrl <=< M.lookup "gitrepo"
|
||||
|
||||
getEnableSshGitRemoteR :: UUID -> Handler Html
|
||||
|
|
@ -475,7 +475,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
|
|||
case mu of
|
||||
Just u -> void $ liftH $
|
||||
combineExistingGCrypt sshdata u
|
||||
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||
Nothing -> giveup "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||||
where
|
||||
repourl = genSshUrl sshdata
|
||||
|
||||
|
|
@ -641,7 +641,7 @@ enableRsyncNetGCrypt sshinput reponame =
|
|||
checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
|
||||
enableGCrypt sshdata reponame
|
||||
where
|
||||
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
|
||||
notencrypted = giveup "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
|
||||
notinstalled = error "internal"
|
||||
|
||||
{- Prepares rsync.net ssh key and creates the directory that will be
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ postAddBoxComR = boxConfigurator $ do
|
|||
]
|
||||
_ -> $(widgetFile "configurators/addbox.com")
|
||||
#else
|
||||
postAddBoxComR = error "WebDAV not supported by this build"
|
||||
postAddBoxComR = giveup "WebDAV not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableWebDAVR :: UUID -> Handler Html
|
||||
|
|
@ -120,7 +120,7 @@ postEnableWebDAVR uuid = do
|
|||
T.pack <$> Remote.prettyUUID uuid
|
||||
$(widgetFile "configurators/enablewebdav")
|
||||
#else
|
||||
postEnableWebDAVR _ = error "WebDAV not supported by this build"
|
||||
postEnableWebDAVR _ = giveup "WebDAV not supported by this build"
|
||||
#endif
|
||||
|
||||
#ifdef WITH_WEBDAV
|
||||
|
|
|
|||
|
|
@ -74,5 +74,5 @@ getLogR :: Handler Html
|
|||
getLogR = page "Logs" Nothing $ do
|
||||
logfile <- liftAnnex $ fromRepo gitAnnexLogFile
|
||||
logs <- liftIO $ listLogs logfile
|
||||
logcontent <- liftIO $ concat <$> mapM readFileStrictAnyEncoding logs
|
||||
logcontent <- liftIO $ concat <$> mapM readFile logs
|
||||
$(widgetFile "control/log")
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ withNewSecretKey use = do
|
|||
liftIO $ genSecretKey cmd RSA "" userid maxRecommendedKeySize
|
||||
results <- M.keys . M.filter (== userid) <$> liftIO (secretKeys cmd)
|
||||
case results of
|
||||
[] -> error "Failed to generate gpg key!"
|
||||
[] -> giveup "Failed to generate gpg key!"
|
||||
(key:_) -> use key
|
||||
|
||||
{- Tries to find the name used in remote.log for a gcrypt repository
|
||||
|
|
@ -85,7 +85,7 @@ getGCryptRemoteName u repoloc = do
|
|||
void $ inRepo $ Git.Remote.Remove.remove tmpremote
|
||||
maybe missing return mname
|
||||
where
|
||||
missing = error $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
|
||||
missing = giveup $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
|
||||
|
||||
{- Checks to see if a repo is encrypted with gcrypt, and runs one action if
|
||||
- it's not an another if it is.
|
||||
|
|
@ -103,7 +103,7 @@ checkGCryptRepoEncryption location notencrypted notinstalled encrypted =
|
|||
dispatch Git.GCrypt.Decryptable = encrypted
|
||||
dispatch Git.GCrypt.NotEncrypted = notencrypted
|
||||
dispatch Git.GCrypt.NotDecryptable =
|
||||
error "This git repository is encrypted with a GnuPG key that you do not have."
|
||||
giveup "This git repository is encrypted with a GnuPG key that you do not have."
|
||||
|
||||
{- Gets the UUID of the gcrypt repo at a location, which may not exist.
|
||||
- Only works if the gcrypt repo was created as a git-annex remote. -}
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import Assistant.WebApp.Types
|
|||
import Assistant.DaemonStatus
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
import Utility.WebApp
|
||||
import Utility.AuthToken
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
|
|
|||
|
|
@ -10,12 +10,16 @@
|
|||
{-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Assistant.WebApp.Types where
|
||||
module Assistant.WebApp.Types (
|
||||
module Assistant.WebApp.Types,
|
||||
Route
|
||||
) where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.Ssh
|
||||
import Assistant.Pairing
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.AuthToken
|
||||
import Utility.WebApp
|
||||
import Utility.Yesod
|
||||
import Types.Transfer
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ module Backend.Utilities where
|
|||
import Data.Hash.MD5
|
||||
|
||||
import Annex.Common
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
{- Generates a keyName from an input string. Takes care of sanitizing it.
|
||||
- If it's not too long, the full string is used as the keyName.
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import Build.Version (getChangelogVersion, Version)
|
|||
import Utility.UserInfo
|
||||
import Utility.Url
|
||||
import Utility.Tmp
|
||||
import Utility.FileSystemEncoding
|
||||
import qualified Git.Construct
|
||||
import qualified Annex
|
||||
import Annex.Content
|
||||
|
|
@ -50,6 +51,7 @@ autobuilds =
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
useFileSystemEncoding
|
||||
version <- liftIO getChangelogVersion
|
||||
repodir <- getRepoDir
|
||||
changeWorkingDirectory repodir
|
||||
|
|
|
|||
|
|
@ -210,7 +210,6 @@ applySplices destdir imports splices@(first:_) = do
|
|||
when (oldcontent /= Just newcontent) $ do
|
||||
putStrLn $ "splicing " ++ f
|
||||
withFile dest WriteMode $ \h -> do
|
||||
fileEncoding h
|
||||
hPutStr h newcontent
|
||||
hClose h
|
||||
where
|
||||
|
|
@ -474,7 +473,7 @@ mangleCode = flip_colon
|
|||
-
|
||||
- To fix, we could just put a semicolon at the start of every line
|
||||
- containing " -> " ... Except that lambdas also contain that.
|
||||
- But we can get around that: GHC outputs lambas like this:
|
||||
- But we can get around that: GHC outputs lambdas like this:
|
||||
-
|
||||
- \ foo
|
||||
- -> bar
|
||||
|
|
@ -487,7 +486,7 @@ mangleCode = flip_colon
|
|||
- containing " -> " unless there's a "\ " first, or it's
|
||||
- all whitespace up until it.
|
||||
-}
|
||||
case_layout = parsecAndReplace $ do
|
||||
case_layout = skipfree $ parsecAndReplace $ do
|
||||
void newline
|
||||
indent1 <- many1 $ char ' '
|
||||
prefix <- manyTill (noneOf "\n") (try (string "-> "))
|
||||
|
|
@ -508,7 +507,7 @@ mangleCode = flip_colon
|
|||
- var var
|
||||
- -> foo
|
||||
-}
|
||||
case_layout_multiline = parsecAndReplace $ do
|
||||
case_layout_multiline = skipfree $ parsecAndReplace $ do
|
||||
void newline
|
||||
indent1 <- many1 $ char ' '
|
||||
firstline <- restofline
|
||||
|
|
@ -521,6 +520,11 @@ mangleCode = flip_colon
|
|||
else return $ "\n" ++ indent1 ++ "; " ++ firstline ++ "\n"
|
||||
++ indent1 ++ indent2 ++ "-> "
|
||||
|
||||
{- Type definitions for free monads triggers the case_* hacks, avoid. -}
|
||||
skipfree f s
|
||||
| "MonadFree" `isInfixOf` s = s
|
||||
| otherwise = f s
|
||||
|
||||
{- (foo, \ -> bar) is not valid haskell, GHC.
|
||||
- Change to (foo, bar)
|
||||
-
|
||||
|
|
@ -716,7 +720,9 @@ parsecAndReplace p s = case parse find "" s of
|
|||
find = many $ try (Right <$> p) <|> (Left <$> anyChar)
|
||||
|
||||
main :: IO ()
|
||||
main = go =<< getArgs
|
||||
main = do
|
||||
useFileSystemEncoding
|
||||
go =<< getArgs
|
||||
where
|
||||
go (destdir:log:header:[]) = run destdir log (Just header)
|
||||
go (destdir:log:[]) = run destdir log Nothing
|
||||
|
|
|
|||
|
|
@ -70,7 +70,6 @@ installLinkerShim top linker exe = do
|
|||
-- Assume that for a symlink, the destination
|
||||
-- will also be shimmed.
|
||||
let sl' = ".." </> takeFileName sl </> takeFileName sl
|
||||
print (sl', exedest)
|
||||
createSymbolicLink sl' exedest
|
||||
, renameFile exe exedest
|
||||
)
|
||||
|
|
|
|||
|
|
@ -50,8 +50,11 @@ buildMans = do
|
|||
else return (Just dest)
|
||||
|
||||
isManSrc :: FilePath -> Bool
|
||||
isManSrc s = "git-annex" `isPrefixOf` (takeFileName s)
|
||||
&& takeExtension s == ".mdwn"
|
||||
isManSrc s
|
||||
| not (takeExtension s == ".mdwn") = False
|
||||
| otherwise = "git-annex" `isPrefixOf` f || "git-remote-" `isPrefixOf` f
|
||||
where
|
||||
f = takeFileName s
|
||||
|
||||
srcToDest :: FilePath -> FilePath
|
||||
srcToDest s = "man" </> progName s ++ ".1"
|
||||
|
|
|
|||
88
CHANGELOG
88
CHANGELOG
|
|
@ -1,3 +1,91 @@
|
|||
git-annex (6.20161211) UNRELEASED; urgency=medium
|
||||
|
||||
* p2p --pair makes it easy to pair repositories over P2P, using
|
||||
Magic Wormhole codes to find the other repository.
|
||||
* metadata --batch: Fix bug when conflicting metadata changes were
|
||||
made in the same batch run.
|
||||
* Pass annex.web-options to wget and curl after other options, so that
|
||||
eg --no-show-progress can be set by the user to disable the default
|
||||
--show-progress.
|
||||
* Revert ServerAliveInterval change in 6.20161111, which caused problems
|
||||
with too many old versions of ssh and unusual ssh configurations.
|
||||
It should have not been needed anyway since ssh is supposted to
|
||||
have TCPKeepAlive enabled by default.
|
||||
* Make all --batch input, as well as fromkey and registerurl stdin
|
||||
be processed without requiring it to be in the current encoding.
|
||||
* p2p: --link no longer takes a remote name, instead the --name
|
||||
option can be used.
|
||||
* Linux standalone: Improve generation of locale definition files,
|
||||
supporting locales such as, en_GB.UTF-8.
|
||||
* rekey --force: Incorrectly marked the new key's content as being
|
||||
present in the local repo even when it was not.
|
||||
* enable-tor: Put tor sockets in /var/lib/tor-annex/, rather
|
||||
than in /etc/tor/hidden_service/.
|
||||
* enable-tor: No longer needs to be run as root.
|
||||
* enable-tor: When run as a regular user, test a connection back to
|
||||
the hidden service over tor.
|
||||
* Always use filesystem encoding for all file and handle reads and
|
||||
writes.
|
||||
* Fix build with directory-1.3.
|
||||
* Debian: Suggest tor and magic-wormhole.
|
||||
* Debian: Build webapp on armel.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Sun, 11 Dec 2016 21:29:51 -0400
|
||||
|
||||
git-annex (6.20161210) unstable; urgency=medium
|
||||
|
||||
* Linux standalone: Updated ghc to fix its "unable to decommit memory"
|
||||
bug, which may have resulted in data loss when these builds were used
|
||||
with Linux kernels older than 4.5.
|
||||
* enable-tor: New command, enables tor hidden service for P2P syncing.
|
||||
* p2p: New command, allows linking repositories using a P2P network.
|
||||
* remotedaemon: Serve tor hidden service.
|
||||
* Added git-remote-tor-annex, which allows git pull and push to the tor
|
||||
hidden service.
|
||||
* remotedaemon: Fork to background by default. Added --foreground switch
|
||||
to enable old behavior.
|
||||
* addurl: Fix bug in checking annex.largefiles expressions using
|
||||
largerthan, mimetype, and smallerthan; the first two always failed
|
||||
to match, and the latter always matched.
|
||||
* Relicense 5 source files that are not part of the webapp from AGPL to GPL.
|
||||
* map: Run xdot if it's available in PATH. On OSX, the dot command
|
||||
does not support graphical display, while xdot does.
|
||||
* Debian: xdot is a better interactive viewer than dot, so Suggest
|
||||
xdot, rather than graphviz.
|
||||
* rmurl: Multiple pairs of files and urls can be provided on the
|
||||
command line.
|
||||
* rmurl: Added --batch mode.
|
||||
* fromkey: Accept multiple pairs of files and keys.
|
||||
Thanks, Daniel Brooks.
|
||||
* rekey: Added --batch mode.
|
||||
* add: Stage modified non-large files when running in indirect mode.
|
||||
(This was already done in v6 mode and direct mode.)
|
||||
* git-annex-shell, remotedaemon, git remote: Fix some memory DOS attacks.
|
||||
* Fix build with http-client 0.5.
|
||||
Thanks, Alper Nebi Yasak.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Sat, 10 Dec 2016 11:56:25 -0400
|
||||
|
||||
git-annex (6.20161118) unstable; urgency=medium
|
||||
|
||||
* git-annex.cabal: Loosen bounds on persistent to allow 2.5, which
|
||||
on Debian has been patched to work with esqueleto.
|
||||
This may break cabal's resolver on non-Debian systems;
|
||||
if so, either use stack to build, or run cabal with
|
||||
--constraint='persistent ==2.2.4.1'
|
||||
Hopefully this mess with esqueleto will be resolved soon.
|
||||
* sync: Pass --allow-unrelated-histories to git merge when used with git
|
||||
git 2.9.0 or newer. This makes merging a remote into a freshly created
|
||||
direct mode repository work the same as it works in indirect mode.
|
||||
* Avoid backtraces on expected failures when built with ghc 8;
|
||||
only use backtraces for unexpected errors.
|
||||
* fsck --all --from was checking the existence and content of files
|
||||
in the local repository, rather than on the special remote. Oops.
|
||||
* Linux arm standalone: Build with a 32kb page size, which is needed
|
||||
on several ARM NAS devices, including Drobo 5N, and WD NAS.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Fri, 18 Nov 2016 11:43:14 -0400
|
||||
|
||||
git-annex (6.20161111) unstable; urgency=medium
|
||||
|
||||
* Restarting a crashing git process could result in filename encoding
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -101,15 +101,15 @@ repoExists = CommandCheck 0 ensureInitialized
|
|||
|
||||
notDirect :: Command -> Command
|
||||
notDirect = addCheck $ whenM isDirect $
|
||||
error "You cannot run this command in a direct mode repository."
|
||||
giveup "You cannot run this command in a direct mode repository."
|
||||
|
||||
notBareRepo :: Command -> Command
|
||||
notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $
|
||||
error "You cannot run this command in a bare repository."
|
||||
giveup "You cannot run this command in a bare repository."
|
||||
|
||||
noDaemonRunning :: Command -> Command
|
||||
noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
|
||||
error "You cannot run this command while git-annex watch or git-annex assistant is running."
|
||||
giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
|
||||
where
|
||||
daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Reference in a new issue