2011-03-27 19:56:43 +00:00
{- Standard git remotes.
-
2015-01-21 16:50:09 +00:00
- Copyright 2011 - 2012 Joey Hess < id @ joeyh . name >
2011-03-27 19:56:43 +00:00
-
- Licensed under the GNU GPL version 3 or higher .
- }
2013-05-11 20:03:00 +00:00
{- # LANGUAGE CPP # -}
2012-07-22 17:48:50 +00:00
module Remote.Git (
remote ,
configRead ,
repoAvail ,
) where
2011-03-27 19:56:43 +00:00
2011-10-05 20:02:51 +00:00
import Common.Annex
2013-05-14 17:53:29 +00:00
import Annex.Ssh
2011-06-02 01:56:04 +00:00
import Types.Remote
2013-01-01 17:52:47 +00:00
import Types.GitConfig
2011-06-30 17:16:57 +00:00
import qualified Git
2011-12-13 19:05:07 +00:00
import qualified Git.Config
import qualified Git.Construct
2012-10-12 17:45:14 +00:00
import qualified Git.Command
2013-09-05 20:02:39 +00:00
import qualified Git.GCrypt
2014-05-22 17:42:17 +00:00
import qualified Git.Types as Git
2011-03-27 19:56:43 +00:00
import qualified Annex
2012-01-28 19:54:42 +00:00
import Logs.Presence
2014-03-22 14:42:38 +00:00
import Annex.Transfer
2011-10-15 21:47:03 +00:00
import Annex.UUID
2011-10-04 04:40:47 +00:00
import qualified Annex.Content
2011-12-12 21:38:46 +00:00
import qualified Annex.BranchState
2012-02-25 22:02:49 +00:00
import qualified Annex.Branch
2013-09-28 18:35:21 +00:00
import qualified Annex.Url as Url
2013-05-12 23:19:28 +00:00
import Utility.Tmp
2011-03-28 01:43:25 +00:00
import Config
2013-03-13 20:16:01 +00:00
import Config.Cost
2014-01-26 20:36:31 +00:00
import Annex.Init
2012-02-10 23:17:41 +00:00
import Types.Key
2014-03-13 23:06:26 +00:00
import Types.CleanupActions
2014-01-26 20:32:55 +00:00
import qualified CmdLine.GitAnnexShell.Fields as Fields
2012-12-12 23:20:38 +00:00
import Logs.Location
2013-03-28 21:03:04 +00:00
import Utility.Metered
2013-08-04 17:12:18 +00:00
# ifndef mingw32_HOST_OS
import Utility.CopyFile
# endif
2013-10-14 19:05:10 +00:00
import Utility.Env
2013-10-11 20:03:18 +00:00
import Utility.Batch
2013-09-07 22:38:00 +00:00
import Remote.Helper.Git
2013-09-24 17:37:41 +00:00
import Remote.Helper.Messages
import qualified Remote.Helper.Ssh as Ssh
2013-09-07 22:38:00 +00:00
import qualified Remote.GCrypt
2015-02-28 21:23:13 +00:00
import Annex.Path
2014-05-22 17:42:17 +00:00
import Creds
2014-08-20 16:01:45 +00:00
import Annex.CatFile
2015-04-10 19:15:01 +00:00
import Messages.Progress
2011-03-27 19:56:43 +00:00
2012-09-20 17:35:53 +00:00
import Control.Concurrent
2012-10-05 21:03:58 +00:00
import Control.Concurrent.MSampleVar
2013-09-07 22:38:00 +00:00
import qualified Data.Map as M
2014-08-10 18:52:58 +00:00
import Network.URI
2012-09-20 17:35:53 +00:00
2011-12-31 08:11:39 +00:00
remote :: RemoteType
2011-03-29 18:55:59 +00:00
remote = RemoteType {
typename = " git " ,
2011-03-29 21:57:20 +00:00
enumerate = list ,
generate = gen ,
2014-05-22 17:42:17 +00:00
setup = gitSetup
2011-03-29 18:55:59 +00:00
}
2011-03-29 03:51:07 +00:00
2011-03-29 21:57:20 +00:00
list :: Annex [ Git . Repo ]
list = do
2011-12-14 19:30:14 +00:00
c <- fromRepo Git . config
2012-06-26 21:15:17 +00:00
rs <- mapM ( tweakurl c ) =<< fromRepo Git . remotes
2012-07-22 17:48:50 +00:00
mapM configRead rs
2012-10-29 01:27:15 +00:00
where
annexurl n = " remote. " ++ n ++ " .annexurl "
tweakurl c r = do
let n = fromJust $ Git . remoteName r
case M . lookup ( annexurl n ) c of
Nothing -> return r
Just url -> inRepo $ \ g ->
Git . Construct . remoteNamed n $
Git . Construct . fromRemoteLocation url g
2012-07-22 17:48:50 +00:00
2014-05-22 17:42:17 +00:00
{- Git remotes are normally set up using standard git command, not
- git - annex initremote and enableremote .
-
- For initremote , the git remote must already be set up , and have a uuid .
- Initremote simply remembers its location .
-
- enableremote simply sets up a git remote using the stored location .
- No attempt is made to make the remote be accessible via ssh key setup ,
- etc .
- }
gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex ( RemoteConfig , UUID )
gitSetup Nothing _ c = do
let location = fromMaybe ( error " Specify location=url " ) $
Url . parseURIRelaxed =<< M . lookup " location " c
g <- Annex . gitRepo
u <- case filter ( \ r -> Git . location r == Git . Url location ) ( Git . remotes g ) of
[ r ] -> getRepoUUID r
[] -> error " could not find existing git remote with specified location "
_ -> error " found multiple git remotes with specified location "
return ( c , u )
gitSetup ( Just u ) _ c = do
inRepo $ Git . Command . run
[ Param " remote "
, Param " add "
, Param $ fromMaybe ( error " no name " ) ( M . lookup " name " c )
, Param $ fromMaybe ( error " no location " ) ( M . lookup " location " c )
]
return ( c , u )
2012-07-22 17:48:50 +00:00
{- It's assumed to be cheap to read the config of non - URL remotes, so this is
- done each time git - annex is run in a way that uses remotes .
-
- Conversely , the config of an URL remote is only read when there is no
- cached UUID value . - }
configRead :: Git . Repo -> Annex Git . Repo
configRead r = do
2014-05-16 20:08:20 +00:00
gc <- Annex . getRemoteGitConfig r
2012-07-22 17:48:50 +00:00
u <- getRepoUUID r
2014-05-16 20:08:20 +00:00
case ( repoCheap r , remoteAnnexIgnore gc , u ) of
2013-01-01 17:52:47 +00:00
( _ , True , _ ) -> return r
2012-07-22 17:48:50 +00:00
( True , _ , _ ) -> tryGitConfigRead r
( False , _ , NoUUID ) -> tryGitConfigRead r
_ -> return r
2011-03-28 01:43:25 +00:00
2013-09-12 19:54:35 +00:00
gen :: Git . Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex ( Maybe Remote )
2013-09-07 22:38:00 +00:00
gen r u c gc
2014-08-04 12:42:04 +00:00
| Git . GCrypt . isEncrypted r = Remote . GCrypt . chainGen r u c gc
2013-09-07 22:38:00 +00:00
| otherwise = go <$> remoteCost gc defcst
2012-10-29 01:27:15 +00:00
where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
2013-09-12 19:54:35 +00:00
go cst = Just new
2013-01-01 17:52:47 +00:00
where
new = Remote
{ uuid = u
, cost = cst
, name = Git . repoDescribe r
, storeKey = copyToRemote new
, retrieveKeyFile = copyFromRemote new
, retrieveKeyFileCheap = copyFromRemoteCheap new
, removeKey = dropKey new
2014-08-06 17:45:19 +00:00
, checkPresent = inAnnex new
, checkPresentCheap = repoCheap r
2013-01-01 17:52:47 +00:00
, whereisKey = Nothing
2013-10-11 20:03:18 +00:00
, remoteFsck = if Git . repoIsUrl r
then Nothing
else Just $ fsckOnRemote r
2013-10-27 19:38:59 +00:00
, repairRepo = if Git . repoIsUrl r
then Nothing
else Just $ repairRemote r
2013-11-02 20:37:28 +00:00
, config = c
2013-09-07 22:38:00 +00:00
, localpath = localpathCalc r
2013-01-01 17:52:47 +00:00
, repo = r
, gitconfig = gc
2013-04-04 19:46:33 +00:00
{ remoteGitConfig = Just $ extractGitConfig r }
2013-01-01 17:52:47 +00:00
, readonly = Git . repoIsHttp r
2014-01-13 18:41:10 +00:00
, availability = availabilityCalc r
2013-01-01 17:52:47 +00:00
, remotetype = remote
2014-08-10 18:52:58 +00:00
, mkUnavailable = unavailable r u c gc
2015-01-13 22:11:03 +00:00
, getInfo = gitRepoInfo new
2014-12-08 17:40:15 +00:00
, claimUrl = Nothing
2014-12-11 19:32:42 +00:00
, checkUrl = Nothing
2013-01-01 17:52:47 +00:00
}
2011-03-27 19:56:43 +00:00
2014-08-10 18:52:58 +00:00
unavailable :: Git . Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex ( Maybe Remote )
unavailable r u c gc = gen r' u c gc
where
r' = case Git . location r of
Git . Local { Git . gitdir = d } ->
r { Git . location = Git . LocalUnknown d }
Git . Url url -> case uriAuthority url of
Just auth ->
let auth' = auth { uriRegName = " !dne! " }
in r { Git . location = Git . Url ( url { uriAuthority = Just auth' } ) }
Nothing -> r { Git . location = Git . Unknown }
_ -> r -- already unavailable
2012-06-27 02:27:30 +00:00
{- Checks relatively inexpensively if a repository is available for use. -}
repoAvail :: Git . Repo -> Annex Bool
repoAvail r
| Git . repoIsHttp r = return True
2013-09-09 13:58:17 +00:00
| Git . GCrypt . isEncrypted r = do
g <- gitRepo
liftIO $ do
2013-09-19 16:53:24 +00:00
er <- Git . GCrypt . encryptedRemote g r
2013-09-09 13:58:17 +00:00
if Git . repoIsLocal er || Git . repoIsLocalUnknown er
then catchBoolIO $
void ( Git . Config . read er ) >> return True
else return True
2012-06-27 02:27:30 +00:00
| Git . repoIsUrl r = return True
| Git . repoIsLocalUnknown r = return False
2014-03-06 21:12:50 +00:00
| otherwise = liftIO $ isJust <$> catchMaybeIO ( Git . Config . read r )
2012-06-27 02:27:30 +00:00
2011-03-28 01:43:25 +00:00
{- Tries to read the config for a specified remote, updates state, and
- returns the updated repo . - }
tryGitConfigRead :: Git . Repo -> Annex Git . Repo
2011-03-27 19:56:43 +00:00
tryGitConfigRead r
2013-04-24 00:06:02 +00:00
| haveconfig r = return r -- already read
2012-10-12 17:45:14 +00:00
| Git . repoIsSsh r = store $ do
2015-04-19 04:38:29 +00:00
v <- Ssh . onRemote r ( pipedconfig , return ( Left $ error " configlist failed " ) ) " configlist " [] []
2013-04-24 00:06:02 +00:00
case v of
Right r'
| haveconfig r' -> return r'
| otherwise -> configlist_failed
Left _ -> configlist_failed
2014-02-25 01:29:37 +00:00
| Git . repoIsHttp r = store geturlconfig
2013-09-08 19:19:14 +00:00
| Git . GCrypt . isEncrypted r = handlegcrypt =<< getConfigMaybe ( remoteConfig r " uuid " )
2011-03-28 01:43:25 +00:00
| Git . repoIsUrl r = return r
2014-07-15 18:45:27 +00:00
| otherwise = store $ liftIO $
readlocalannexconfig ` catchNonAsync ` ( const $ return r )
2012-10-29 01:27:15 +00:00
where
2013-04-24 00:06:02 +00:00
haveconfig = not . M . null . Git . config
2013-09-24 21:51:12 +00:00
pipedconfig cmd params = do
v <- Git . Config . fromPipe r cmd params
case v of
Right ( r' , val ) -> do
when ( getUncachedUUID r' == NoUUID && not ( null val ) ) $ do
warningIO $ " Failed to get annex.uuid configuration of repository " ++ Git . repoDescribe r
warningIO $ " Instead, got: " ++ show val
warningIO $ " This is unexpected; please check the network transport! "
return $ Right r'
Left l -> return $ Left l
2011-08-17 00:48:11 +00:00
2014-02-25 01:29:37 +00:00
geturlconfig = do
2014-02-25 02:00:25 +00:00
uo <- Url . getUrlOptions
2013-05-25 05:47:19 +00:00
v <- liftIO $ withTmpFile " git-annex.tmp " $ \ tmpfile h -> do
2012-10-29 01:27:15 +00:00
hClose h
2015-04-19 04:38:29 +00:00
let url = Git . repoLocation r ++ " /config "
ifM ( Url . downloadQuiet url tmpfile uo )
2013-05-25 05:47:19 +00:00
( pipedconfig " git " [ Param " config " , Param " --null " , Param " --list " , Param " --file " , File tmpfile ]
2015-04-19 04:38:29 +00:00
, return $ Left $ error $ " unable to load config from " ++ url
2013-05-25 05:47:19 +00:00
)
case v of
Left _ -> do
2014-05-16 16:58:50 +00:00
set_ignore " not usable by git-annex " False
2013-05-25 05:47:19 +00:00
return r
2014-01-26 17:03:25 +00:00
Right r' -> do
-- Cache when http remote is not bare for
-- optimisation.
unless ( Git . Config . isBare r' ) $
setremote " annex-bare " ( Git . Config . boolConfig False )
return r'
2011-08-17 00:48:11 +00:00
2012-10-29 01:27:15 +00:00
store = observe $ \ r' -> do
g <- gitRepo
let l = Git . remotes g
let g' = g { Git . remotes = exchange l r' }
Annex . changeState $ \ s -> s { Annex . repo = g' }
2011-08-17 00:48:11 +00:00
2012-10-29 01:27:15 +00:00
exchange [] _ = []
exchange ( old : ls ) new
| Git . remoteName old == Git . remoteName new =
new : exchange ls new
| otherwise =
old : exchange ls new
2011-03-27 19:56:43 +00:00
2013-04-24 00:06:02 +00:00
{- Is this remote just not available, or does
- it not have git - annex - shell ?
- Find out by trying to fetch from the remote . - }
configlist_failed = case Git . remoteName r of
Nothing -> return r
Just n -> do
2014-05-16 16:58:50 +00:00
whenM ( inRepo $ Git . Command . runBool [ Param " fetch " , Param " --quiet " , Param n ] ) $ do
set_ignore " does not have git-annex installed " True
2013-04-24 00:06:02 +00:00
return r
2013-05-25 05:47:19 +00:00
2014-05-16 16:58:50 +00:00
set_ignore msg longmessage = do
2014-01-26 17:03:25 +00:00
let k = " annex-ignore "
case Git . remoteName r of
Nothing -> noop
2014-05-16 16:58:50 +00:00
Just n -> do
warning $ " Remote " ++ n ++ " " ++ msg ++ " ; setting " ++ k
when longmessage $
warning $ " This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git config remote. " ++ n ++ " . " ++ k ++ " false "
2014-01-26 17:03:25 +00:00
setremote k ( Git . Config . boolConfig True )
setremote k v = case Git . remoteName r of
2013-05-25 05:47:19 +00:00
Nothing -> noop
Just n -> do
2014-01-26 17:03:25 +00:00
let k' = " remote. " ++ n ++ " . " ++ k
inRepo $ Git . Command . run [ Param " config " , Param k' , Param v ]
2013-09-08 19:19:14 +00:00
handlegcrypt Nothing = return r
handlegcrypt ( Just _cacheduuid ) = do
-- Generate UUID from the gcrypt-id
g <- gitRepo
case Git . GCrypt . remoteRepoId g ( Git . remoteName r ) of
Nothing -> return r
Just v -> store $ liftIO $ setUUID r $
genUUIDInNameSpace gCryptNameSpace v
2013-04-24 00:06:02 +00:00
2014-07-15 18:45:27 +00:00
{- The local repo may not yet be initialized, so try to initialize
- it if allowed . However , if that fails , still return the read
- git config . - }
2014-07-15 18:27:43 +00:00
readlocalannexconfig = do
s <- Annex . new r
Annex . eval s $ do
Annex . BranchState . disableUpdate
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
void $ tryNonAsync $ ensureInitialized
2014-07-15 18:27:43 +00:00
Annex . getState Annex . repo
2014-08-06 17:45:19 +00:00
{- Checks if a given remote has the content for a key in its annex. -}
inAnnex :: Remote -> Key -> Annex Bool
2014-01-26 17:03:25 +00:00
inAnnex rmt key
2014-02-25 01:29:37 +00:00
| Git . repoIsHttp r = checkhttp
2011-08-17 01:04:23 +00:00
| Git . repoIsUrl r = checkremote
2011-11-09 22:33:15 +00:00
| otherwise = checklocal
2012-10-29 01:27:15 +00:00
where
2014-10-09 18:53:13 +00:00
r = repo rmt
2014-02-25 01:29:37 +00:00
checkhttp = do
2013-09-24 17:37:41 +00:00
showChecking r
2014-02-25 02:00:25 +00:00
ifM ( Url . withUrlOptions $ \ uo -> anyM ( \ u -> Url . checkBoth u ( keySize key ) uo ) ( keyUrls rmt key ) )
2014-08-06 17:45:19 +00:00
( return True
, error " not found "
2013-07-18 18:11:56 +00:00
)
2013-09-24 17:37:41 +00:00
checkremote = Ssh . inAnnex r key
2014-08-06 17:45:19 +00:00
checklocal = guardUsable r ( cantCheck r ) $
2014-08-10 18:52:58 +00:00
maybe ( cantCheck r ) return
=<< onLocal rmt ( Annex . Content . inAnnexSafe key )
2011-08-17 01:04:23 +00:00
2014-01-26 17:03:25 +00:00
keyUrls :: Remote -> Key -> [ String ]
keyUrls r key = map tourl locs'
2012-10-29 01:27:15 +00:00
where
2014-01-26 17:03:25 +00:00
tourl l = Git . repoLocation ( repo r ) ++ " / " ++ l
-- If the remote is known to not be bare, try the hash locations
-- used for non-bare repos first, as an optimisation.
locs
2015-01-28 20:51:40 +00:00
| remoteAnnexBare remoteconfig == Just False = reverse ( annexLocations cfg key )
| otherwise = annexLocations cfg key
2013-08-02 16:27:32 +00:00
# ifndef mingw32_HOST_OS
2014-01-26 17:03:25 +00:00
locs' = locs
2013-07-07 17:35:06 +00:00
# else
2014-02-25 17:47:09 +00:00
locs' = map ( replace " \ \ " " / " ) locs
2013-07-07 17:35:06 +00:00
# endif
2015-01-28 20:51:40 +00:00
remoteconfig = gitconfig r
cfg = fromJust $ remoteGitConfig remoteconfig
2011-08-17 01:04:23 +00:00
2013-01-01 17:52:47 +00:00
dropKey :: Remote -> Key -> Annex Bool
2011-08-17 01:20:14 +00:00
dropKey r key
2013-01-01 17:52:47 +00:00
| not $ Git . repoIsUrl ( repo r ) =
2014-08-08 23:18:08 +00:00
guardUsable ( repo r ) ( return False ) $
commitOnCleanup r $ onLocal r $ do
ensureInitialized
whenM ( Annex . Content . inAnnex key ) $ do
2014-08-21 00:08:45 +00:00
Annex . Content . lockContent key
Annex . Content . removeAnnex
2014-08-08 23:18:08 +00:00
logStatus key InfoMissing
Annex . Content . saveState True
return True
2013-09-24 17:37:41 +00:00
| Git . repoIsHttp ( repo r ) = error " dropping from http remote not supported "
| otherwise = commitOnCleanup r $ Ssh . dropKey ( repo r ) key
2011-03-27 19:56:43 +00:00
{- Tries to copy a key's content from a remote's annex to a file. -}
2013-04-11 21:15:45 +00:00
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
2015-04-14 20:35:10 +00:00
copyFromRemote r key file dest p = parallelMetered ( Just p ) key file $
2015-04-10 19:15:01 +00:00
copyFromRemote' r key file dest
copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
copyFromRemote' r key file dest meterupdate
2014-08-08 23:18:08 +00:00
| not $ Git . repoIsUrl ( repo r ) = guardUsable ( repo r ) ( return False ) $ do
2014-04-17 18:31:42 +00:00
params <- Ssh . rsyncParams r Download
2012-07-01 20:59:54 +00:00
u <- getUUID
2014-12-29 21:25:59 +00:00
# ifndef mingw32_HOST_OS
2014-09-05 17:44:09 +00:00
hardlink <- annexHardLink <$> Annex . getGitConfig
2014-12-29 21:25:59 +00:00
# endif
2012-07-01 20:59:54 +00:00
-- run copy from perspective of remote
2014-03-06 21:12:50 +00:00
onLocal r $ do
2012-07-01 20:59:54 +00:00
ensureInitialized
2013-01-10 15:52:11 +00:00
v <- Annex . Content . prepSendAnnex key
case v of
Nothing -> return False
2014-09-05 17:44:09 +00:00
Just ( object , checksuccess ) -> do
let copier = rsyncOrCopyFile params object dest
# ifndef mingw32_HOST_OS
let linker = createLink object dest >> return True
go <- ifM ( pure hardlink <&&> not <$> isDirect )
( return $ \ m -> liftIO ( catchBoolIO linker )
<||> copier m
, return copier
)
# else
let go = copier
# endif
runTransfer ( Transfer Download u key )
2015-05-12 19:50:03 +00:00
file noRetry noObserver go
2013-01-10 15:52:11 +00:00
<&&> checksuccess
2013-10-01 18:10:45 +00:00
| Git . repoIsSsh ( repo r ) = feedprogressback $ \ feeder -> do
direct <- isDirect
2013-09-24 17:37:41 +00:00
Ssh . rsyncHelper ( Just feeder )
2013-10-01 18:10:45 +00:00
=<< Ssh . rsyncParamsRemote direct r Download key dest file
2014-01-26 17:03:25 +00:00
| Git . repoIsHttp ( repo r ) = Annex . Content . downloadUrl ( keyUrls r key ) dest
2013-09-24 17:37:41 +00:00
| otherwise = error " copying from non-ssh, non-http remote not supported "
2012-10-29 01:27:15 +00:00
where
{- Feed local rsync's progress info back to the remote,
- by forking a feeder thread that runs
- git - annex - shell transferinfo at the same time
- git - annex - shell sendkey is running .
-
2013-05-14 17:51:14 +00:00
- To avoid extra password prompts , this is only done when ssh
- connection caching is supported .
2012-10-29 01:27:15 +00:00
- Note that it actually waits for rsync to indicate
- progress before starting transferinfo , in order
- to ensure ssh connection caching works and reuses
- the connection set up for the sendkey .
-
- Also note that older git - annex - shell does not support
- transferinfo , so stderr is dropped and failure ignored .
- }
2013-05-14 17:51:14 +00:00
feedprogressback a = ifM ( isJust <$> sshCacheDir )
( feedprogressback' a
2013-05-19 22:15:29 +00:00
, a $ const noop
2013-05-14 17:52:30 +00:00
)
2013-05-14 17:51:14 +00:00
feedprogressback' a = do
2012-10-29 01:27:15 +00:00
u <- getUUID
let fields = ( Fields . remoteUUID , fromUUID u )
: maybe [] ( \ f -> [ ( Fields . associatedFile , f ) ] ) file
2013-09-24 17:37:41 +00:00
Just ( cmd , params ) <- Ssh . git_annex_shell ( repo r ) " transferinfo "
2012-10-29 01:27:15 +00:00
[ Param $ key2file key ] fields
2013-09-26 03:19:01 +00:00
v <- liftIO ( newEmptySV :: IO ( MSampleVar Integer ) )
2014-08-04 00:14:20 +00:00
pidv <- liftIO $ newEmptyMVar
2012-10-29 01:27:15 +00:00
tid <- liftIO $ forkIO $ void $ tryIO $ do
bytes <- readSV v
p <- createProcess $
( proc cmd ( toCommand params ) )
{ std_in = CreatePipe
, std_err = CreatePipe
}
2014-08-04 00:14:20 +00:00
putMVar pidv ( processHandle p )
2012-10-29 01:27:15 +00:00
hClose $ stderrHandle p
let h = stdinHandle p
let send b = do
2013-09-26 03:19:01 +00:00
hPrint h b
2012-10-29 01:27:15 +00:00
hFlush h
send bytes
forever $
send =<< readSV v
2015-04-10 19:15:01 +00:00
let feeder = \ n -> do
meterupdate n
writeSV v ( fromBytesProcessed n )
2014-08-04 00:14:20 +00:00
let cleanup = do
void $ tryIO $ killThread tid
tryNonAsync $
maybe noop ( void . waitForProcess )
=<< tryTakeMVar pidv
bracketIO noop ( const cleanup ) ( const $ a feeder )
2011-08-17 01:04:23 +00:00
2015-04-14 20:35:10 +00:00
copyFromRemoteCheap :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
2013-08-02 16:27:32 +00:00
# ifndef mingw32_HOST_OS
2015-04-14 20:35:10 +00:00
copyFromRemoteCheap r key af file
2015-04-18 17:36:12 +00:00
| not $ Git . repoIsUrl ( repo r ) = guardUsable ( repo r ) ( return False ) $ liftIO $ do
loc <- gitAnnexLocation key ( repo r ) $
2013-04-04 19:46:33 +00:00
fromJust $ remoteGitConfig $ gitconfig r
2015-04-18 17:36:12 +00:00
ifM ( doesFileExist loc )
( do
absloc <- absPath loc
catchBoolIO $ do
createSymbolicLink absloc file
return True
, return False
)
2013-01-01 17:52:47 +00:00
| Git . repoIsSsh ( repo r ) =
2012-03-16 00:39:25 +00:00
ifM ( Annex . Content . preseedTmp key file )
2015-04-14 20:35:10 +00:00
( parallelMetered Nothing key af $
copyFromRemote' r key af file
2012-03-16 00:39:25 +00:00
, return False
)
2012-01-20 17:23:11 +00:00
| otherwise = return False
2013-08-04 17:12:18 +00:00
# else
2015-04-14 20:35:10 +00:00
copyFromRemoteCheap _ _ _ _ = return False
2013-08-04 17:12:18 +00:00
# endif
2012-01-20 17:23:11 +00:00
2011-03-27 19:56:43 +00:00
{- Tries to copy a key's content to a remote's annex. -}
2013-01-01 17:52:47 +00:00
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
2015-04-14 20:35:10 +00:00
copyToRemote r key file p = parallelMetered ( Just p ) key file $ copyToRemote' r key file
2015-04-14 20:00:20 +00:00
copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote' r key file p
2013-01-01 17:52:47 +00:00
| not $ Git . repoIsUrl ( repo r ) =
2014-08-08 23:18:08 +00:00
guardUsable ( repo r ) ( return False ) $ commitOnCleanup r $
2013-01-10 15:45:44 +00:00
copylocal =<< Annex . Content . prepSendAnnex key
2013-01-01 17:52:47 +00:00
| Git . repoIsSsh ( repo r ) = commitOnCleanup r $
2013-10-01 18:10:45 +00:00
Annex . Content . sendAnnex key noop $ \ object -> do
direct <- isDirect
2013-09-24 17:37:41 +00:00
Ssh . rsyncHelper ( Just p )
2013-10-01 18:10:45 +00:00
=<< Ssh . rsyncParamsRemote direct r Upload key object file
2012-12-08 21:03:39 +00:00
| otherwise = error " copying to non-ssh repo not supported "
where
2013-01-10 15:45:44 +00:00
copylocal Nothing = return False
copylocal ( Just ( object , checksuccess ) ) = do
2013-03-12 20:41:54 +00:00
-- The checksuccess action is going to be run in
-- the remote's Annex, but it needs access to the current
-- Annex monad's state.
checksuccessio <- Annex . withCurrentState checksuccess
2014-04-17 18:31:42 +00:00
params <- Ssh . rsyncParams r Upload
2012-07-01 20:59:54 +00:00
u <- getUUID
2011-03-27 19:56:43 +00:00
-- run copy from perspective of remote
2014-03-06 21:12:50 +00:00
onLocal r $ ifM ( Annex . Content . inAnnex key )
2013-03-10 21:54:27 +00:00
( return True
2012-09-18 17:59:03 +00:00
, do
ensureInitialized
2015-05-12 19:50:03 +00:00
runTransfer ( Transfer Download u key ) file noRetry noObserver $ const $
2012-09-18 17:59:03 +00:00
Annex . Content . saveState True ` after `
2013-03-12 20:41:54 +00:00
Annex . Content . getViaTmpChecked ( liftIO checksuccessio ) key
2012-12-08 21:03:39 +00:00
( \ d -> rsyncOrCopyFile params object d p )
2012-09-18 17:59:03 +00:00
)
2011-03-27 19:56:43 +00:00
2013-10-11 20:03:18 +00:00
fsckOnRemote :: Git . Repo -> [ CommandParam ] -> Annex ( IO Bool )
fsckOnRemote r params
2013-10-14 16:23:38 +00:00
| Git . repoIsUrl r = do
2013-10-11 20:03:18 +00:00
s <- Ssh . git_annex_shell r " fsck " params []
return $ case s of
Nothing -> return False
Just ( c , ps ) -> batchCommand c ps
2013-10-14 16:23:38 +00:00
| otherwise = return $ do
2015-02-28 21:23:13 +00:00
program <- programPath
2013-10-14 19:05:10 +00:00
r' <- Git . Config . read r
2014-06-10 23:20:14 +00:00
environ <- getEnvironment
let environ' = addEntries
2013-10-14 19:05:10 +00:00
[ ( " GIT_WORK_TREE " , Git . repoPath r' )
, ( " GIT_DIR " , Git . localGitDir r' )
2014-06-10 23:20:14 +00:00
] environ
2015-02-09 18:16:42 +00:00
batchCommandEnv program ( Param " fsck " : params ) ( Just environ' )
2013-10-11 20:03:18 +00:00
2013-10-27 19:38:59 +00:00
{- The passed repair action is run in the Annex monad of the remote. -}
repairRemote :: Git . Repo -> Annex Bool -> Annex ( IO Bool )
2014-03-06 21:12:50 +00:00
repairRemote r a = return $ do
2013-09-07 22:38:00 +00:00
s <- Annex . new r
Annex . eval s $ do
Annex . BranchState . disableUpdate
2014-03-06 21:12:50 +00:00
ensureInitialized
2013-09-07 22:38:00 +00:00
a
2011-03-27 19:56:43 +00:00
2014-03-06 21:12:50 +00:00
{- Runs an action from the perspective of a local remote.
-
- The AnnexState is cached for speed and to avoid resource leaks .
2014-08-20 16:01:45 +00:00
- However , catFileStop is called to avoid git - cat - file processes hanging
- around on removable media .
2014-03-06 21:12:50 +00:00
-
- The repository's git - annex branch is not updated , as an optimisation .
- No caller of onLocal can query data from the branch and be ensured
- it gets a current value . Caller of onLocal can make changes to
- the branch , however .
- }
onLocal :: Remote -> Annex a -> Annex a
onLocal r a = do
m <- Annex . getState Annex . remoteannexstate
case M . lookup ( uuid r ) m of
Nothing -> do
st <- liftIO $ Annex . new ( repo r )
go st $ do
Annex . BranchState . disableUpdate
a
Just st -> go st a
where
cache st = Annex . changeState $ \ s -> s
{ Annex . remoteannexstate = M . insert ( uuid r ) st ( Annex . remoteannexstate s ) }
go st a' = do
2015-04-04 00:08:38 +00:00
curro <- Annex . getState Annex . output
( ret , st' ) <- liftIO $ Annex . run ( st { Annex . output = curro } ) $
2014-08-20 16:01:45 +00:00
catFileStop ` after ` a'
2014-03-06 21:12:50 +00:00
cache st'
return ret
2011-06-14 00:23:47 +00:00
{- Copys a file with rsync unless both locations are on the same
- filesystem . Then cp could be faster . - }
2012-09-21 18:50:14 +00:00
rsyncOrCopyFile :: [ CommandParam ] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool
2012-09-19 20:08:37 +00:00
rsyncOrCopyFile rsyncparams src dest p =
2013-08-02 16:27:32 +00:00
# ifdef mingw32_HOST_OS
2013-05-11 20:03:00 +00:00
dorsync
where
# else
2012-09-22 00:24:08 +00:00
ifM ( sameDeviceIds src dest ) ( docopy , dorsync )
2012-10-29 01:27:15 +00:00
where
2013-09-26 03:19:01 +00:00
sameDeviceIds a b = ( == ) <$> getDeviceId a <*> getDeviceId b
2015-01-09 17:11:56 +00:00
getDeviceId f = deviceID <$> liftIO ( getFileStatus $ parentDir f )
2012-10-29 01:27:15 +00:00
docopy = liftIO $ bracket
2013-03-28 21:03:04 +00:00
( forkIO $ watchfilesize zeroBytesProcessed )
2012-10-29 01:27:15 +00:00
( void . tryIO . killThread )
2014-08-27 00:06:43 +00:00
( const $ copyFileExternal CopyTimeStamps src dest )
2012-10-29 01:27:15 +00:00
watchfilesize oldsz = do
threadDelay 500000 -- 0.5 seconds
2015-01-20 20:58:48 +00:00
v <- catchMaybeIO $ toBytesProcessed <$> getFileSize dest
2012-10-29 01:27:15 +00:00
case v of
Just sz
| sz /= oldsz -> do
p sz
watchfilesize sz
_ -> watchfilesize oldsz
2013-05-11 20:03:00 +00:00
# endif
2013-09-24 17:37:41 +00:00
dorsync = Ssh . rsyncHelper ( Just p ) $
2013-05-14 17:24:15 +00:00
rsyncparams ++ [ File src , File dest ]
2011-06-14 00:23:47 +00:00
2013-01-01 17:52:47 +00:00
commitOnCleanup :: Remote -> Annex a -> Annex a
2012-02-25 22:02:49 +00:00
commitOnCleanup r a = go ` after ` a
2012-10-29 01:27:15 +00:00
where
2014-03-13 23:06:26 +00:00
go = Annex . addCleanup ( RemoteCleanup $ uuid r ) cleanup
2012-10-29 01:27:15 +00:00
cleanup
2014-03-06 21:12:50 +00:00
| not $ Git . repoIsUrl ( repo r ) = onLocal r $
2012-10-29 01:27:15 +00:00
doQuietSideAction $
Annex . Branch . commit " update "
| otherwise = void $ do
Just ( shellcmd , shellparams ) <-
2013-09-24 17:37:41 +00:00
Ssh . git_annex_shell ( repo r ) " commit " [] []
2012-10-29 01:27:15 +00:00
-- Throw away stderr, since the remote may not
-- have a new enough git-annex shell to
-- support committing.
2013-09-26 03:19:01 +00:00
liftIO $ catchMaybeIO $
2012-10-29 01:27:15 +00:00
withQuietOutput createProcessSuccess $
proc shellcmd $
toCommand shellparams