code:
{- git-annex assistant daemon status
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE BangPatterns #-}

module Assistant.DaemonStatus where

import Assistant.Common
import Assistant.Alert.Utility
import Utility.Tmp
import Assistant.Types.NetMessager
import Utility.NotificationBroadcaster
import Logs.Transfer
import Logs.Trust
import qualified Remote
import qualified Types.Remote as Remote
import qualified Git

import Control.Concurrent.STM
import System.Posix.Types
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

getDaemonStatus :: Assistant DaemonStatus
getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle

modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())

modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
modifyDaemonStatus a = do
	dstatus <- getAssistant daemonStatusHandle
	liftIO $ do
		(s, b) <- atomically $ do
			r@(!s, _) <- a <$> takeTMVar dstatus
			putTMVar dstatus s
			return r
		sendNotification $ changeNotifier s
		return b

{- Returns a function that updates the lists of syncable remotes
 - and other associated information. -}
calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
calcSyncRemotes = do
	rs <- filter (remoteAnnexSync . Remote.gitconfig) .
		concat . Remote.byCost <$> Remote.remoteList
	alive <- trustExclude DeadTrusted (map Remote.uuid rs)
	let good r = Remote.uuid r `elem` alive
	let syncable = filter good rs
	let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $
		filter (not . Remote.isXMPPRemote) syncable

	return $ \dstatus -> dstatus
		{ syncRemotes = syncable
		, syncGitRemotes = filter Remote.gitSyncableRemote syncable
		, syncDataRemotes = syncdata
		, syncingToCloudRemote = any iscloud syncdata
		}
  where
  	iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable

{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant ()
updateSyncRemotes = do
	modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
	status <- getDaemonStatus
	liftIO $ sendNotification $ syncRemotesNotifier status

	when (syncingToCloudRemote status) $
		updateAlertMap $
			M.filter $ \alert ->
				alertName alert /= Just CloudRepoNeededAlert

changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant ()
changeCurrentlyConnected sm = do
	modifyDaemonStatus_ $ \ds -> ds
		{ currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds)
		}
	v <- currentlyConnectedRemotes <$> getDaemonStatus
	debug [show v]
	liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus

updateScheduleLog :: Assistant ()
updateScheduleLog =
	liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus

{- Load any previous daemon status file, and store it in a MVar for this
 - process to use as its DaemonStatus. Also gets current transfer status. -}
startDaemonStatus :: Annex DaemonStatusHandle
startDaemonStatus = do
	file <- fromRepo gitAnnexDaemonStatusFile
	status <- liftIO $
		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
	transfers <- M.fromList <$> getTransfers
	addsync <- calcSyncRemotes
	liftIO $ atomically $ newTMVar $ addsync $ status
		{ scanComplete = False
		, sanityCheckRunning = False
		, currentTransfers = transfers
		}

{- Don't just dump out the structure, because it will change over time,
 - and parts of it are not relevant. -}
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
writeDaemonStatusFile file status =
	viaTmp writeFile file =<< serialized <$> getPOSIXTime
  where
	serialized now = unlines
		[ "lastRunning:" ++ show now
		, "scanComplete:" ++ show (scanComplete status)
		, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
		, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
		]

readDaemonStatusFile :: FilePath -> IO DaemonStatus
readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
  where
	parse status = foldr parseline status . lines
	parseline line status
		| key == "lastRunning" = parseval readtime $ \v ->
			status { lastRunning = Just v }
		| key == "scanComplete" = parseval readish $ \v ->
			status { scanComplete = v }
		| key == "sanityCheckRunning" = parseval readish $ \v ->
			status { sanityCheckRunning = v }
		| key == "lastSanityCheck" = parseval readtime $ \v ->
			status { lastSanityCheck = Just v }
		| otherwise = status -- unparsable line
	  where
		(key, value) = separate (== ':') line
		parseval parser a = maybe status a (parser value)
		readtime s = do
			d <- parseTime defaultTimeLocale "%s%Qs" s
			Just $ utcTimeToPOSIXSeconds d

{- Checks if a time stamp was made after the daemon was lastRunning.
 -
 - Some slop is built in; this really checks if the time stamp was made
 - at least ten minutes after the daemon was lastRunning. This is to
 - ensure the daemon shut down cleanly, and deal with minor clock skew.
 -
 - If the daemon has never ran before, this always returns False.
 -}
afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
  where
	t = realToFrac (timestamp + slop) :: POSIXTime
	slop = fromIntegral tenMinutes

tenMinutes :: Int
tenMinutes = 10 * 60

{- Mutates the transfer map. Runs in STM so that the transfer map can
 - be modified in the same transaction that modifies the transfer queue.
 - Note that this does not send a notification of the change; that's left
 - to the caller. -}
adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
adjustTransfersSTM dstatus a = do
	s <- takeTMVar dstatus
	let !v = a (currentTransfers s)
	putTMVar dstatus $ s { currentTransfers = v }

{- Checks if a transfer is currently running. -}
checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
checkRunningTransferSTM dstatus t = M.member t . currentTransfers
	<$> readTMVar dstatus

{- Alters a transfer's info, if the transfer is in the map. -}
alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
alterTransferInfo t a = updateTransferInfo' $ M.adjust a t

{- Updates a transfer's info. Adds the transfer to the map if necessary,
 - or if already present, updates it while preserving the old transferTid,
 - transferPaused, and bytesComplete values, which are not written to disk. -}
updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
  where
	merge new old = new
		{ transferTid = maybe (transferTid new) Just (transferTid old)
		, transferPaused = transferPaused new || transferPaused old
		, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
		}

updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
  where
	update s = s { currentTransfers = a (currentTransfers s) }

{- Removes a transfer from the map, and returns its info. -}
removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
  where
	remove s =
		let (info, ts) = M.updateLookupWithKey
			(\_k _v -> Nothing)
			t (currentTransfers s)
		in (s { currentTransfers = ts }, info)

{- Send a notification when a transfer is changed. -}
notifyTransfer :: Assistant ()
notifyTransfer = do
	dstatus <- getAssistant daemonStatusHandle
	liftIO $ sendNotification
		=<< transferNotifier <$> atomically (readTMVar dstatus)

{- Send a notification when alerts are changed. -}
notifyAlert :: Assistant ()
notifyAlert = do
	dstatus <- getAssistant daemonStatusHandle
	liftIO $ sendNotification
		=<< alertNotifier <$> atomically (readTMVar dstatus)

{- Returns the alert's identifier, which can be used to remove it. -}
addAlert :: Alert -> Assistant AlertId
addAlert alert = do
	notice [showAlert alert]
	notifyAlert `after` modifyDaemonStatus add
  where
	add s = (s { lastAlertId = i, alertMap = m }, i)
	  where
		!i = nextAlertId $ lastAlertId s
		!m = mergeAlert i alert (alertMap s)

removeAlert :: AlertId -> Assistant ()
removeAlert i = updateAlert i (const Nothing)

updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
updateAlert i a = updateAlertMap $ \m -> M.update a i m

updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
  where
	update s =
		let !m = a (alertMap s)
		in s { alertMap = m }

{- Displays an alert while performing an activity that returns True on
 - success.
 -
 - The alert is left visible afterwards, as filler.
 - Old filler is pruned, to prevent the map growing too large. -}
alertWhile :: Alert -> Assistant Bool -> Assistant Bool
alertWhile alert a = alertWhile' alert $ do
	r <- a
	return (r, r)

{- Like alertWhile, but allows the activity to return a value too. -}
alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
alertWhile' alert a = do
	let alert' = alert { alertClass = Activity }
	i <- addAlert alert'
	(ok, r) <- a
	updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
	return r

{- Displays an alert while performing an activity, then removes it. -}
alertDuring :: Alert -> Assistant a -> Assistant a
alertDuring alert a = do
	i <- addAlert $ alert { alertClass = Activity }
	removeAlert  i `after` a

getXMPPClientID :: Remote -> ClientID
getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))


code:
{- git-annex assistant remote deletion utilities
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.DeleteRemote where

import Assistant.Common
import Assistant.Types.UrlRenderer
import Assistant.TransferQueue
import Logs.Transfer
import Logs.Location
import Assistant.DaemonStatus
import qualified Remote
import Remote.List
import qualified Git.Remote
import Logs.Trust
import qualified Annex

#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import Assistant.Alert
import qualified Data.Text as T
#endif

{- Removes a remote (but leave the repository as-is), and returns the old
 - Remote data. -}
disableRemote :: UUID -> Assistant Remote
disableRemote uuid = do
	remote <- fromMaybe (error "unknown remote")
		<$> liftAnnex (Remote.remoteFromUUID uuid)
	liftAnnex $ do
		inRepo $ Git.Remote.remove (Remote.name remote)
		void $ remoteListRefresh
	updateSyncRemotes
	return remote

{- Removes a remote, marking it dead .-}
removeRemote :: UUID -> Assistant Remote
removeRemote uuid = do
	liftAnnex $ trustSet uuid DeadTrusted
	disableRemote uuid

{- Called when a Remote is probably empty, to remove it.
 -
 - This does one last check for any objects remaining in the Remote,
 - and if there are any, queues Downloads of them, and defers removing
 - the remote for later. This is to catch any objects not referred to
 - in keys in the current branch.
 -}
removableRemote :: UrlRenderer -> UUID -> Assistant ()
removableRemote urlrenderer uuid = do
	keys <- getkeys
	if null keys
		then finishRemovingRemote urlrenderer uuid
		else do
			r <- fromMaybe (error "unknown remote")
				<$> liftAnnex (Remote.remoteFromUUID uuid)
			mapM_ (queueremaining r) keys
  where
  	queueremaining r k =
		queueTransferWhenSmall "remaining object in unwanted remote"
			Nothing (Transfer Download uuid k) r
	{- Scanning for keys can take a long time; do not tie up
	 - the Annex monad while doing it, so other threads continue to
	 - run. -}
	getkeys = do
		a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid
		liftIO a

{- With the webapp, this asks the user to click on a button to finish
 - removing the remote.
 -
 - Without the webapp, just do the removal now.
 -}
finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
#ifdef WITH_WEBAPP
finishRemovingRemote urlrenderer uuid = do
	desc <- liftAnnex $ Remote.prettyUUID uuid
	button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
		FinishDeleteRepositoryR uuid
	void $ addAlert $ remoteRemovalAlert desc button
#else
finishRemovingRemote _ uuid = void $ removeRemote uuid
#endif

repo_name: kakafarm/git

license: unknown


code:
{- git-annex assistant dropping of unwanted content
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Drop (
	handleDrops,
	handleDropsFrom,
) where

import Assistant.Common
import Assistant.DaemonStatus
import Annex.Drop (handleDropsFrom, Reason)
import Logs.Location
import CmdLine.Action

{- Drop from local and/or remote when allowed by the preferred content and
 - numcopies settings. -}
handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
handleDrops reason fromhere key f knownpresentremote = do
	syncrs <- syncDataRemotes <$> getDaemonStatus
	locs <- liftAnnex $ loggedLocations key
	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction


code:
{- git-annex assistant fscking
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module Assistant.Fsck where

import Assistant.Common
import Types.ScheduledActivity
import qualified Types.Remote as Remote
import Annex.UUID
import Assistant.Alert
import Assistant.Types.UrlRenderer
import Logs.Schedule
import qualified Annex

import qualified Data.Set as S

{- Displays a nudge in the webapp if a fsck is not configured for
 - the specified remote, or for the local repository. -}
fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
fsckNudge urlrenderer mr
	| maybe True fsckableRemote mr =
		whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $
			unlessM (liftAnnex $ checkFscked mr) $
				notFsckedNudge urlrenderer mr
	| otherwise = noop

fsckableRemote :: Remote -> Bool
fsckableRemote = isJust . Remote.remoteFsck

{- Checks if the remote, or the local repository, has a fsck scheduled.
 - Only looks at fscks configured to run via the local repository, not
 - other repositories. -}
checkFscked :: Maybe Remote -> Annex Bool
checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID)
  where
	wanted = case mr of
		Nothing -> isSelfFsck
		Just r -> flip isFsckOf (Remote.uuid r)

isSelfFsck :: ScheduledActivity -> Bool
isSelfFsck (ScheduledSelfFsck _ _) = True
isSelfFsck _ = False

isFsckOf :: ScheduledActivity -> UUID -> Bool
isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u'
isFsckOf _ _ = False


code:
{- git-annex assistant gpg stuff
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}

module Assistant.Gpg where

import Utility.Gpg
import Utility.UserInfo
import Types.Remote (RemoteConfigKey)

import qualified Data.Map as M

{- Generates a gpg user id that is not used by any existing secret key -}
newUserId :: IO UserId
newUserId = do
	oldkeys <- secretKeys
	username <- myUserName
  	let basekeyname = username ++ "'s git-annex encryption key"
	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
		( basekeyname
		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
		)

data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
	deriving (Eq)

{- Generates Remote configuration for encryption. -}
configureEncryption :: EnableEncryption -> (RemoteConfigKey, String)
configureEncryption SharedEncryption = ("encryption", "shared")
configureEncryption NoEncryption = ("encryption", "none")
configureEncryption HybridEncryption = ("encryption", "hybrid")


code:
{- Assistant installation
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Install where

import Assistant.Common
import Assistant.Install.AutoStart
import Config.Files
import Utility.FileMode
import Utility.Shell
import Utility.Tmp
import Utility.Env
import Utility.SshConfig

#ifdef darwin_HOST_OS
import Utility.OSX
#else
import Utility.FreeDesktop
import Utility.UserInfo
import Assistant.Install.Menu
#endif

standaloneAppBase :: IO (Maybe FilePath)
standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"

{- The standalone app does not have an installation process.
 - So when it's run, it needs to set up autostarting of the assistant
 - daemon, as well as writing the programFile, and putting the
 - git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh
 -
 - Note that this is done every time it's started, so if the user moves
 - it around, the paths this sets up won't break.
 -
 - File manager hook script installation is done even for
 - packaged apps, since it has to go into the user's home directory.
 -}
ensureInstalled :: IO ()
ensureInstalled = go =<< standaloneAppBase
  where
	go Nothing = installFileManagerHooks "git-annex"
	go (Just base) = do
		let program = base </> "git-annex"
		programfile <- programFile
		createDirectoryIfMissing True (parentDir programfile)
		writeFile programfile program

#ifdef darwin_HOST_OS
		autostartfile <- userAutoStart osxAutoStartLabel
#else
		menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
		icondir <- iconDir <$> userDataDir
		installMenu program menufile base icondir
		autostartfile <- autoStartPath "git-annex" <$> userConfigDir
#endif
		installAutoStart program autostartfile

		sshdir <- sshDir
		let runshell var = "exec " ++ base </> "runshell " ++ var
		let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""

		installWrapper (sshdir </> "git-annex-shell") $ unlines
			[ shebang_local
			, "set -e"
			, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
			,   rungitannexshell "$SSH_ORIGINAL_COMMAND"
			, "else"
			,   rungitannexshell "$@"
			, "fi"
			]
		installWrapper (sshdir </> "git-annex-wrapper") $ unlines
			[ shebang_local
			, "set -e"
			, runshell "\"$@\""
			]

		installFileManagerHooks program

installWrapper :: FilePath -> String -> IO ()
installWrapper file content = do
	curr <- catchDefaultIO "" $ readFileStrict file
	when (curr /= content) $ do
		createDirectoryIfMissing True (parentDir file)
		viaTmp writeFile file content
		modifyFileMode file $ addModes [ownerExecuteMode]

installFileManagerHooks :: FilePath -> IO ()
#ifdef linux_HOST_OS
installFileManagerHooks program = do
	-- Gnome
	nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
	createDirectoryIfMissing True nautilusScriptdir
	genNautilusScript nautilusScriptdir "get"
	genNautilusScript nautilusScriptdir "drop"

	-- KDE
	home <- myHomeDir
	let kdeServiceMenusdir = home </> ".kde" </> "share" </> "kde4" </> "services" </> "ServiceMenus"
	createDirectoryIfMissing True kdeServiceMenusdir
	writeFile (kdeServiceMenusdir </> "git-annex.desktop")
		(kdeDesktopFile ["get", "drop"])
  where
	genNautilusScript scriptdir action =
		installscript (scriptdir </> scriptname action) $ unlines
			[ shebang_local
			, autoaddedcomment
			, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
			]
	scriptname action = "git-annex " ++ action
	installscript f c = whenM (safetoinstallscript f) $ do
		writeFile f c
		modifyFileMode f $ addModes [ownerExecuteMode]
	safetoinstallscript f = catchDefaultIO True $
		elem autoaddedcomment . lines <$> readFileStrict f
	autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
	autoaddedmsg = "Automatically added by git-annex, do not edit."

	kdeDesktopFile actions = unlines $ concat $
		kdeDesktopHeader actions : map kdeDesktopAction actions
	kdeDesktopHeader actions =
		[ "# " ++ autoaddedmsg
		, "[Desktop Entry]"
		, "Type=Service"
		, "ServiceTypes=all/allfiles"
		, "MimeType=all/all;"
		, "Actions=" ++ intercalate ";" (map kdeDesktopSection actions)
		, "X-KDE-Priority=TopLevel"
		, "X-KDE-Submenu=Git-Annex"
		, "X-KDE-Icon=git-annex"
		, "X-KDE-ServiceTypes=KonqPopupMenu/Plugin"
		]
	kdeDesktopSection command = "GitAnnex" ++ command
	kdeDesktopAction command =
		[ ""
		, "[Desktop Action " ++ kdeDesktopSection command ++ "]"
		, "Name=" ++ command
		, "Icon=git-annex"
		, unwords
			[ "Exec=sh -c 'cd \"$(dirname '%U')\" &&"
			, program
			, command
			, "--notify-start --notify-finish -- %U'"
			]
		]
#else
installFileManagerHooks _ = noop
#endif

{- Returns a cleaned up environment that lacks settings used to make the
 - standalone builds use their bundled libraries and programs.
 - Useful when calling programs not included in the standalone builds.
 -
 - For a non-standalone build, returns Nothing.
 -}
cleanEnvironment :: IO (Maybe [(String, String)])
cleanEnvironment = clean <$> getEnvironment
  where
	clean environ
		| null vars = Nothing
		| otherwise = Just $ catMaybes $ map (restoreorig environ) environ
		| otherwise = Nothing
	  where
		vars = words $ fromMaybe "" $
			lookup "GIT_ANNEX_STANDLONE_ENV" environ
		restoreorig oldenviron p@(k, _v)
			| k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
				(Just v')
					| not (null v') -> Just (k, v')
				_ -> Nothing
			| otherwise = Just p


code:
{- Assistant autostart file installation
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Install.AutoStart where

import Utility.FreeDesktop
#ifdef darwin_HOST_OS
import Utility.OSX
import Utility.Path
import System.Directory
#endif

installAutoStart :: FilePath -> FilePath -> IO ()
installAutoStart command file = do
#ifdef darwin_HOST_OS
	createDirectoryIfMissing True (parentDir file)
	writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
		["assistant", "--autostart"]
#else
	writeDesktopMenuFile (fdoAutostart command) file
#endif

osxAutoStartLabel :: String
osxAutoStartLabel = "com.branchable.git-annex.assistant"

fdoAutostart :: FilePath -> DesktopEntry
fdoAutostart command = genDesktopEntry
	"Git Annex Assistant"
	"Autostart"
	False
	(command ++ " assistant --autostart")
	Nothing
	[]


code:
{- Assistant menu installation.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Install.Menu where

import Common

import Utility.FreeDesktop

installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
#ifdef darwin_HOST_OS
installMenu _command _menufile _iconsrcdir _icondir = return ()
#else
installMenu command menufile iconsrcdir icondir = do
	writeDesktopMenuFile (fdoDesktopMenu command) menufile
	installIcon (iconsrcdir </> "logo.svg") $
		iconFilePath (iconBaseName ++ ".svg") "scalable" icondir
	installIcon (iconsrcdir </> "logo_16x16.png") $
		iconFilePath (iconBaseName ++ ".png") "16x16" icondir
#endif

{- The command can be either just "git-annex", or the full path to use
 - to run it. -}
fdoDesktopMenu :: FilePath -> DesktopEntry
fdoDesktopMenu command = genDesktopEntry
	"Git Annex"
	"Track and sync the files in your Git Annex"
	False
	(command ++ " webapp")
	(Just iconBaseName)
	["Network", "FileTransfer"]

installIcon :: FilePath -> FilePath -> IO ()
installIcon src dest = do
	createDirectoryIfMissing True (parentDir dest)
	withBinaryFile src ReadMode $ \hin ->
		withBinaryFile dest WriteMode $ \hout ->
			hGetContents hin >>= hPutStr hout

iconBaseName :: String
iconBaseName = "git-annex"


code:
{- git-annex assistant remote creation utilities
 -
 - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.MakeRemote where

import Assistant.Common
import Assistant.Ssh
import qualified Types.Remote as R
import qualified Remote
import Remote.List
import qualified Remote.Rsync as Rsync
import qualified Remote.GCrypt as GCrypt
import qualified Git
import qualified Git.Command
import qualified Command.InitRemote
import Logs.UUID
import Logs.Remote
import Git.Remote
import Git.Types (RemoteName)
import Creds
import Assistant.Gpg
import Utility.Gpg (KeyId)

import qualified Data.Map as M

{- Sets up a new git or rsync remote, accessed over ssh. -}
makeSshRemote :: SshData -> Annex RemoteName
makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata)
  where
	maker
		| onlyCapability sshdata RsyncCapable = makeRsyncRemote
		| otherwise = makeGitRemote

{- Runs an action that returns a name of the remote, and finishes adding it. -}
addRemote :: Annex RemoteName -> Annex Remote
addRemote a = do
	name <- a
	void remoteListRefresh
	maybe (error "failed to add remote") return
		=<< Remote.byName (Just name)

{- Inits a rsync special remote, and returns its name. -}
makeRsyncRemote :: RemoteName -> String -> Annex String
makeRsyncRemote name location = makeRemote name location $ const $ void $
	go =<< Command.InitRemote.findExisting name
  where
  	go Nothing = setupSpecialRemote name Rsync.remote config Nothing
		(Nothing, Command.InitRemote.newConfig name)
	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
		(Just u, c)
	config = M.fromList
		[ ("encryption", "shared")
		, ("rsyncurl", location)
		, ("type", "rsync")
		]

{- Inits a gcrypt special remote, and returns its name. -}
makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
makeGCryptRemote remotename location keyid =
	initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
		[ ("type", "gcrypt")
		, ("gitrepo", location)
		, configureEncryption HybridEncryption
		, ("keyid", keyid)
		]

type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName

{- Inits a new special remote. The name is used as a suggestion, but
 - will be changed if there is already a special remote with that name. -}
initSpecialRemote :: SpecialRemoteMaker
initSpecialRemote name remotetype mcreds config = go 0
  where
	go :: Int -> Annex RemoteName
	go n = do
		let fullname = if n == 0  then name else name ++ show n
		r <- Command.InitRemote.findExisting fullname
		case r of
			Nothing -> setupSpecialRemote fullname remotetype config mcreds
				(Nothing, Command.InitRemote.newConfig fullname)
			Just _ -> go (n + 1)

{- Enables an existing special remote. -}
enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype mcreds config = do
	r <- Command.InitRemote.findExisting name
	case r of
		Nothing -> error $ "Cannot find a special remote named " ++ name
		Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, c)

setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote = setupSpecialRemote' True

setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do
	{- Currently, only 'weak' ciphers can be generated from the
	 - assistant, because otherwise GnuPG may block once the entropy
	 - pool is drained, and as of now there's no way to tell the user
	 - to perform IO actions to refill the pool. -}
	(c', u) <- R.setup remotetype mu mcreds $
		M.insert "highRandomQuality" "false" $ M.union config c
	configSet u c'
	when setdesc $
		whenM (isNothing . M.lookup u <$> uuidMap) $
			describeUUID u name
	return name

{- Returns the name of the git remote it created. If there's already a
 - remote at the location, returns its name. -}
makeGitRemote :: String -> String -> Annex RemoteName
makeGitRemote basename location = makeRemote basename location $ \name ->
	void $ inRepo $ Git.Command.runBool
		[Param "remote", Param "add", Param name, Param location]

{- If there's not already a remote at the location, adds it using the
 - action, which is passed the name of the remote to make.
 -
 - Returns the name of the remote. -}
makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
makeRemote basename location a = do
	g <- gitRepo
	if not (any samelocation $ Git.remotes g)
		then do
			let name = uniqueRemoteName basename 0 g
			a name
			return name
		else return basename
  where
	samelocation x = Git.repoLocation x == location

{- Generate an unused name for a remote, adding a number if
 - necessary.
 -
 - Ensures that the returned name is a legal git remote name. -}
uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
uniqueRemoteName basename n r
	| null namecollision = name
	| otherwise = uniqueRemoteName legalbasename (succ n) r
  where
	namecollision = filter samename (Git.remotes r)
	samename x = Git.remoteName x == Just name
	name
		| n == 0 = legalbasename
		| otherwise = legalbasename ++ show n
	legalbasename = makeLegalName basename

{- Finds a CredPair belonging to any Remote that is of a given type
 - and matches some other criteria.
 -
 - This can be used as a default when another repository is being set up
 - using the same service.
 -
 - A function must be provided that returns the CredPairStorage
 - to use for a particular Remote's uuid.
 -}
previouslyUsedCredPair
	:: (UUID -> CredPairStorage)
	-> RemoteType
	-> (Remote -> Bool)
	-> Annex (Maybe CredPair)
previouslyUsedCredPair getstorage remotetype criteria =
	getM fromstorage =<< filter criteria . filter sametype <$> remoteList
  where
	sametype r = R.typename (R.remotetype r) == R.typename remotetype
	fromstorage r = do
		let storage = getstorage (R.uuid r)
		getRemoteCredPair (R.config r) storage


code:
{- git-annex assistant monad
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}

module Assistant.Monad (
	Assistant,
	AssistantData(..),
	newAssistantData,
	runAssistant,
	getAssistant,
	LiftAnnex,
	liftAnnex,
	(<~>),
	(<<~),
	asIO,
	asIO1,
	asIO2,
	ThreadName,
	debug,
	notice
) where

import "mtl" Control.Monad.Reader
import System.Log.Logger

import Common.Annex
import Assistant.Types.ThreadedMonad
import Assistant.Types.DaemonStatus
import Assistant.Types.ScanRemotes
import Assistant.Types.TransferQueue
import Assistant.Types.TransferSlots
import Assistant.Types.TransferrerPool
import Assistant.Types.Pushes
import Assistant.Types.BranchChange
import Assistant.Types.Commits
import Assistant.Types.Changes
import Assistant.Types.RepoProblem
import Assistant.Types.Buddies
import Assistant.Types.NetMessager
import Assistant.Types.ThreadName
import Assistant.Types.RemoteControl
import Assistant.Types.CredPairCache

newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
	deriving (
		Monad,
		MonadIO,
		MonadReader AssistantData,
		Functor,
		Applicative
	)

data AssistantData = AssistantData
	{ threadName :: ThreadName
	, threadState :: ThreadState
	, daemonStatusHandle :: DaemonStatusHandle
	, scanRemoteMap :: ScanRemoteMap
	, transferQueue :: TransferQueue
	, transferSlots :: TransferSlots
	, transferrerPool :: TransferrerPool
	, failedPushMap :: FailedPushMap
	, commitChan :: CommitChan
	, changePool :: ChangePool
	, repoProblemChan :: RepoProblemChan
	, branchChangeHandle :: BranchChangeHandle
	, buddyList :: BuddyList
	, netMessager :: NetMessager
	, remoteControl :: RemoteControl
	, credPairCache :: CredPairCache
	}

newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
newAssistantData st dstatus = AssistantData
	<$> pure (ThreadName "main")
	<*> pure st
	<*> pure dstatus
	<*> newScanRemoteMap
	<*> newTransferQueue
	<*> newTransferSlots
	<*> newTransferrerPool (checkNetworkConnections dstatus)
	<*> newFailedPushMap
	<*> newCommitChan
	<*> newChangePool
	<*> newRepoProblemChan
	<*> newBranchChangeHandle
	<*> newBuddyList
	<*> newNetMessager
	<*> newRemoteControl
	<*> newCredPairCache

runAssistant :: AssistantData -> Assistant a -> IO a
runAssistant d a = runReaderT (mkAssistant a) d

getAssistant :: (AssistantData -> a) -> Assistant a
getAssistant = reader

{- Using a type class for lifting into the annex monad allows
 - easily lifting to it from multiple different monads. -}
class LiftAnnex m where
	liftAnnex :: Annex a -> m a

{- Runs an action in the git-annex monad. Note that the same monad state
 - is shared among all assistant threads, so only one of these can run at
 - a time. Therefore, long-duration actions should be avoided. -}
instance LiftAnnex Assistant where
	liftAnnex a = do
		st <- reader threadState
		liftIO $ runThreadState st a

{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
io <~> a = do
	d <- reader id
	liftIO $ io $ runAssistant d a

{- Creates an IO action that will run an Assistant action when run. -}
asIO :: Assistant a -> Assistant (IO a)
asIO a = do
	d <- reader id
	return $ runAssistant d a

asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
asIO1 a = do
	d <- reader id
	return $ \v -> runAssistant d $ a v

asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
asIO2 a = do
	d <- reader id
	return $ \v1 v2 -> runAssistant d (a v1 v2)

{- Runs an IO action on a selected field of the AssistantData. -}
(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
io <<~ v = reader v >>= liftIO . io

debug :: [String] -> Assistant ()
debug = logaction debugM

notice :: [String] -> Assistant ()
notice = logaction noticeM

logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
logaction a ws = do
	ThreadName name <- getAssistant threadName
	liftIO $ a name $ unwords $ (name ++ ":") : ws


code:
{- git-annex assistant named threads.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.NamedThread where

import Common.Annex
import Assistant.Types.NamedThread
import Assistant.Types.ThreadName
import Assistant.Types.DaemonStatus
import Assistant.Types.UrlRenderer
import Assistant.DaemonStatus
import Assistant.Monad
import Utility.NotificationBroadcaster

import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Map as M
import qualified Control.Exception as E

#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import Assistant.Types.Alert
import Assistant.Alert
import qualified Data.Text as T
#endif

{- Starts a named thread, if it's not already running.
 -
 - Named threads are run by a management thread, so if they crash
 - an alert is displayed, allowing the thread to be restarted. -}
startNamedThread :: UrlRenderer -> NamedThread -> Assistant ()
startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do
	m <- startedThreads <$> getDaemonStatus
	case M.lookup name m of
		Nothing -> start
		Just (aid, _) -> do
			r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ()))))
			case r of
				Right Nothing -> noop
				_ -> start
  where
	start
		| afterstartupsanitycheck = do
			status <- getDaemonStatus
			h <- liftIO $ newNotificationHandle False $
				startupSanityCheckNotifier status
			startwith $ runmanaged $
				liftIO $ waitNotification h
		| otherwise = startwith $ runmanaged noop
	startwith runner = do
		d <- getAssistant id
		aid <- liftIO $ runner $ d { threadName = name }
		restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a)
		modifyDaemonStatus_ $ \s -> s
			{ startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) }
	runmanaged first d = do
		aid <- async $ runAssistant d $ do
			void first
			a
		void $ forkIO $ manager d aid
		return aid
	manager d aid = do
		r <- E.try (wait aid) :: IO (Either E.SomeException ())
		case r of
			Right _ -> noop
			Left e -> do
				let msg = unwords
					[ fromThreadName $ threadName d
					, "crashed:", show e
					]
				hPutStrLn stderr msg
#ifdef WITH_WEBAPP
				button <- runAssistant d $ mkAlertButton True
					(T.pack "Restart Thread")
					urlrenderer
					(RestartThreadR name)
				runAssistant d $ void $ addAlert $
					(warningAlert (fromThreadName name) msg)
						{ alertButtons = [button] }
#endif

namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
namedThreadId (NamedThread _ name _) = do
	m <- startedThreads <$> getDaemonStatus
	return $ asyncThreadId . fst <$> M.lookup name m

{- Waits for all named threads that have been started to finish.
 -
 - Note that if a named thread crashes, it will probably
 - cause this to crash as well. Also, named threads that are started
 - after this is called will not be waited on. -}
waitNamedThreads :: Assistant ()
waitNamedThreads = do
	m <- startedThreads <$> getDaemonStatus
	liftIO $ mapM_ (wait . fst) $ M.elems m


code:
{- git-annex assistant out of band network messager interface
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE BangPatterns #-}

module Assistant.NetMessager where

import Assistant.Common
import Assistant.Types.NetMessager

import Control.Concurrent.STM
import Control.Concurrent.MSampleVar
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.DList as D

sendNetMessage :: NetMessage -> Assistant ()
sendNetMessage m =
	(atomically . flip writeTChan m) <<~ (netMessages . netMessager)

waitNetMessage :: Assistant (NetMessage)
waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager)

notifyNetMessagerRestart :: Assistant ()
notifyNetMessagerRestart =
	flip writeSV () <<~ (netMessagerRestart . netMessager)

{- This can be used to get an early indication if the network has
 - changed, to immediately restart a connection. However, that is not
 - available on all systems, so clients also need to deal with
 - restarting dropped connections in the usual way. -}
waitNetMessagerRestart :: Assistant ()
waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)

{- Store a new important NetMessage for a client, and if an equivilant
 - older message is already stored, remove it from both importantNetMessages
 - and sentImportantNetMessages. -}
storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()
storeImportantNetMessage m client matchingclient = go <<~ netMessager
  where
	go nm = atomically $ do
		q <- takeTMVar $ importantNetMessages nm
		sent <- takeTMVar $ sentImportantNetMessages nm
		putTMVar (importantNetMessages nm) $
			M.alter (Just . maybe (S.singleton m) (S.insert m)) client $
				M.mapWithKey removematching q
		putTMVar (sentImportantNetMessages nm) $
			M.mapWithKey removematching sent
	removematching someclient s
		| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s
		| otherwise = s

{- Indicates that an important NetMessage has been sent to a client. -}
sentImportantNetMessage :: NetMessage -> ClientID -> Assistant ()
sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager)
  where
	go v = atomically $ do
		sent <- takeTMVar v
		putTMVar v $
			M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent

{- Checks for important NetMessages that have been stored for a client, and
 - sent to a client. Typically the same client for both, although
 - a modified or more specific client may need to be used. -}
checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage)
checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
  where
	go nm = atomically $ do
		stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm)
		sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)
		return (fromMaybe S.empty stored, fromMaybe S.empty sent)

{- Queues a push initiation message in the queue for the appropriate
 - side of the push but only if there is not already an initiation message
 - from the same client in the queue. -}
queuePushInitiation :: NetMessage -> Assistant ()
queuePushInitiation msg@(Pushing clientid stage) = do
	tv <- getPushInitiationQueue side
  	liftIO $ atomically $ do
		r <- tryTakeTMVar tv
		case r of
			Nothing -> putTMVar tv [msg]
			Just l -> do
				let !l' = msg : filter differentclient l
				putTMVar tv l'
  where
  	side = pushDestinationSide stage
	differentclient (Pushing cid _) = cid /= clientid
	differentclient _ = True
queuePushInitiation _ = noop

{- Waits for a push inititation message to be received, and runs
 - function to select a message from the queue. -}
waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage
waitPushInitiation side selector = do
	tv <- getPushInitiationQueue side
	liftIO $ atomically $ do
		q <- takeTMVar tv
		if null q
			then retry
			else do
				let (msg, !q') = selector q
				unless (null q') $
					putTMVar tv q'
				return msg

{- Stores messages for a push into the appropriate inbox.
 -
 - To avoid overflow, only 1000 messages max are stored in any
 - inbox, which should be far more than necessary.
 -
 - TODO: If we have more than 100 inboxes for different clients,
 - discard old ones that are not currently being used by any push.
 -}
storeInbox :: NetMessage -> Assistant ()
storeInbox msg@(Pushing clientid stage) = do
	inboxes <- getInboxes side
	stored <- liftIO $ atomically $ do
		m <- readTVar inboxes
		let update = \v -> do
			writeTVar inboxes $
				M.insertWith' const clientid v m
			return True
		case M.lookup clientid m of
			Nothing -> update (1, tostore)
			Just (sz, l)
				| sz > 1000 -> return False
				| otherwise ->
					let !sz' = sz + 1
					    !l' = D.append l tostore
					in update (sz', l')
	if stored
		then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]
		else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]
  where
	side = pushDestinationSide stage
	tostore = D.singleton msg
storeInbox _ = noop

{- Gets the new message for a push from its inbox.
 - Blocks until a message has been received. -}
waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)
waitInbox clientid side = do
	inboxes <- getInboxes side
	liftIO $ atomically $ do
		m <- readTVar inboxes
		case M.lookup clientid m of
			Nothing -> retry
			Just (sz, dl)
				| sz < 1 -> retry
				| otherwise -> do
					let msg = D.head dl
					let dl' = D.tail dl
					let !sz' = sz - 1
					writeTVar inboxes $
						M.insertWith' const clientid (sz', dl') m
					return msg

emptyInbox :: ClientID -> PushSide -> Assistant ()
emptyInbox clientid side = do
	inboxes <- getInboxes side
	liftIO $ atomically $
		modifyTVar' inboxes $
			M.delete clientid

getInboxes :: PushSide -> Assistant Inboxes
getInboxes side =
	getSide side . netMessagerInboxes <$> getAssistant netMessager

getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])
getPushInitiationQueue side =
	getSide side . netMessagerPushInitiations <$> getAssistant netMessager

netMessagerDebug :: ClientID -> [String] -> Assistant ()
netMessagerDebug clientid l = debug $
	"NetMessager" : l ++ [show $ logClientID clientid]


code:
{- git-annex assistant repo pairing, core data types
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Pairing where

import Common.Annex
import Utility.Verifiable
import Assistant.Ssh

import Control.Concurrent
import Network.Socket
import Data.Char
import qualified Data.Text as T

data PairStage
	{- "I'll pair with anybody who shares the secret that can be used
	 - to verify this request." -}
	 = PairReq
	{- "I've verified your request, and you can verify this to see
	 - that I know the secret. I set up your ssh key already.
	 - Here's mine for you to set up." -}
	| PairAck
	{- "I saw your PairAck; you can stop sending them." -}
	| PairDone
	deriving (Eq, Read, Show, Ord, Enum)

newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
	deriving (Eq, Read, Show)

verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip

fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
fromPairMsg (PairMsg m) = m

pairMsgStage :: PairMsg -> PairStage
pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s

pairMsgData :: PairMsg -> PairData
pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d

pairMsgAddr :: PairMsg -> SomeAddr
pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a

data PairData = PairData
	-- uname -n output, not a full domain name
	{ remoteHostName :: Maybe HostName
	, remoteUserName :: UserName
	, remoteDirectory :: FilePath
	, remoteSshPubKey :: SshPubKey
	, pairUUID :: UUID
	}
	deriving (Eq, Read, Show)

type UserName = String

{- A pairing that is in progress has a secret, a thread that is
 - broadcasting pairing messages, and a SshKeyPair that has not yet been
 - set up on disk. -}
data PairingInProgress = PairingInProgress
	{ inProgressSecret :: Secret
	, inProgressThreadId :: Maybe ThreadId
	, inProgressSshKeyPair :: SshKeyPair
	, inProgressPairData :: PairData
	, inProgressPairStage :: PairStage
	}
	deriving (Show)

data SomeAddr = IPv4Addr HostAddress
{- My Android build of the Network library does not currently have IPV6
 - support. -}
#ifndef __ANDROID__
	| IPv6Addr HostAddress6
#endif
	deriving (Ord, Eq, Read, Show)

{- This contains the whole secret, just lightly obfuscated to make it not
 - too obvious. It's only displayed in the user's web browser. -}
newtype SecretReminder = SecretReminder [Int]
	deriving (Show, Eq, Ord, Read)

toSecretReminder :: T.Text -> SecretReminder
toSecretReminder = SecretReminder . map ord . T.unpack

fromSecretReminder :: SecretReminder -> T.Text
fromSecretReminder (SecretReminder s) = T.pack $ map chr s


code:
{- git-annex assistant pairing remote creation
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Pairing.MakeRemote where

import Assistant.Common
import Assistant.Ssh
import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.MakeRemote
import Assistant.Sync
import Config.Cost
import Config
import qualified Types.Remote as Remote

import Network.Socket
import qualified Data.Text as T

{- Authorized keys are set up before pairing is complete, so that the other
 - side can immediately begin syncing. -}
setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = do
	validateSshPubKey pubkey
	unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
		error "failed setting up ssh authorized keys"
  where
	pubkey = remoteSshPubKey $ pairMsgData msg

{- When local pairing is complete, this is used to set up the remote for
 - the host we paired with. -}
finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
finishedLocalPairing msg keypair = do
	sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
	{- Ensure that we know the ssh host key for the host we paired with.
	 - If we don't, ssh over to get it. -}
	liftIO $ unlessM (knownHost $ sshHostName sshdata) $
		void $ sshTranscript
			[ sshOpt "StrictHostKeyChecking" "no"
			, sshOpt "NumberOfPasswordPrompts" "0"
			, "-n"
			, genSshHost (sshHostName sshdata) (sshUserName sshdata)
			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
			]
			Nothing
	r <- liftAnnex $ addRemote $ makeSshRemote sshdata
	liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost
	syncRemote r

{- Mostly a straightforward conversion.  Except:
 -  * Determine the best hostname to use to contact the host.
 -  * Strip leading ~/ from the directory name.
 -}
pairMsgToSshData :: PairMsg -> IO SshData
pairMsgToSshData msg = do
	let d = pairMsgData msg
	hostname <- liftIO $ bestHostName msg
	let dir = case remoteDirectory d of
		('~':'/':v) -> v
		v -> v
	return SshData
		{ sshHostName = T.pack hostname
		, sshUserName = Just (T.pack $ remoteUserName d)
		, sshDirectory = T.pack dir
		, sshRepoName = genSshRepoName hostname dir
		, sshPort = 22
		, needsPubKey = True
		, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
		}

{- Finds the best hostname to use for the host that sent the PairMsg.
 -
 - If remoteHostName is set, tries to use a .local address based on it.
 - That's the most robust, if this system supports .local.
 - Otherwise, looks up the hostname in the DNS for the remoteAddress,
 - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
bestHostName :: PairMsg -> IO HostName
bestHostName msg = case remoteHostName $ pairMsgData msg of
	Just h -> do
		let localname = h ++ ".local"
		addrs <- catchDefaultIO [] $
			getAddrInfo Nothing (Just localname) Nothing
		maybe fallback (const $ return localname) (headMaybe addrs)
	Nothing -> fallback
  where
	fallback = do
		let a = pairMsgAddr msg
		let sockaddr = case a of
			IPv4Addr addr -> SockAddrInet (PortNum 0) addr
			IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
		fromMaybe (showAddr a)
			<$> catchDefaultIO Nothing
				(fst <$> getNameInfo [] True False sockaddr)


code:
{- git-annex assistant pairing network code
 -
 - All network traffic is sent over multicast UDP. For reliability,
 - each message is repeated until acknowledged. This is done using a
 - thread, that gets stopped before the next message is sent.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Pairing.Network where

import Assistant.Common
import Assistant.Pairing
import Assistant.DaemonStatus
import Utility.ThreadScheduler
import Utility.Verifiable

import Network.Multicast
import Network.Info
import Network.Socket
import Control.Exception (bracket)
import qualified Data.Map as M
import Control.Concurrent

{- This is an arbitrary port in the dynamic port range, that could
 - conceivably be used for some other broadcast messages.
 - If so, hope they ignore the garbage from us; we'll certianly
 - ignore garbage from them. Wild wild west. -}
pairingPort :: PortNumber
pairingPort = 55556

{- Goal: Reach all hosts on the same network segment.
 - Method: Use same address that avahi uses. Other broadcast addresses seem
 - to not be let through some routers. -}
multicastAddress :: SomeAddr -> HostName
multicastAddress (IPv4Addr _) = "224.0.0.251"
multicastAddress (IPv6Addr _) = "ff02::fb"

{- Multicasts a message repeatedly on all interfaces, with a 2 second
 - delay between each transmission. The message is repeated forever
 - unless a number of repeats is specified.
 -
 - The remoteHostAddress is set to the interface's IP address.
 -
 - Note that new sockets are opened each time. This is hardly efficient,
 - but it allows new network interfaces to be used as they come up.
 - On the other hand, the expensive DNS lookups are cached.
 -}
multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()
multicastPairMsg repeats secret pairdata stage = go M.empty repeats
  where
	go _ (Just 0) = noop
	go cache n = do
		addrs <- activeNetworkAddresses
		let cache' = updatecache cache addrs
		mapM_ (sendinterface cache') addrs
		threadDelaySeconds (Seconds 2)
		go cache' $ pred <$> n
	{- The multicast library currently chokes on ipv6 addresses. -}
	sendinterface _ (IPv6Addr _) = noop
	sendinterface cache i = void $ tryIO $
		withSocketsDo $ bracket setup cleanup use
	  where
		setup = multicastSender (multicastAddress i) pairingPort
		cleanup (sock, _) = sClose sock -- FIXME does not work
		use (sock, addr) = do
			setInterface sock (showAddr i)
			maybe noop (\s -> void $ sendTo sock s addr)
				(M.lookup i cache)
	updatecache cache [] = cache
	updatecache cache (i:is)
		| M.member i cache = updatecache cache is
		| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
	mkmsg addr = PairMsg $
		mkVerifiable (stage, pairdata, addr) secret

startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()
startSending pip stage sender = do
	a <- asIO start
	void $ liftIO $ forkIO a
  where
	start = do
		tid <- liftIO myThreadId
		let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
		oldpip <- modifyDaemonStatus $
			\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
		maybe noop stopold oldpip
		liftIO $ sender stage
	stopold = maybe noop (liftIO . killThread) . inProgressThreadId

stopSending :: PairingInProgress -> Assistant ()
stopSending pip = do
	maybe noop (liftIO . killThread) $ inProgressThreadId pip
	modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing }

class ToSomeAddr a where
	toSomeAddr :: a -> SomeAddr

instance ToSomeAddr IPv4 where
	toSomeAddr (IPv4 a) = IPv4Addr a

instance ToSomeAddr IPv6 where
	toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)

showAddr :: SomeAddr -> HostName
showAddr (IPv4Addr a) = show $ IPv4 a
showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4

activeNetworkAddresses :: IO [SomeAddr]
activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
	. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
	<$> getNetworkInterfaces

{- A human-visible description of the repository being paired with.
 - Note that the repository's description is not shown to the user, because
 - it could be something like "my repo", which is confusing when pairing
 - with someone else's repo. However, this has the same format as the
 - default decription of a repo. -}
pairRepo :: PairMsg -> String
pairRepo msg = concat
	[ remoteUserName d
	, "@"
	, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
	, ":"
	, remoteDirectory d
	]
  where
	d = pairMsgData msg


code:
{- git-annex assistant push tracking
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Pushes where

import Assistant.Common
import Assistant.Types.Pushes

import Control.Concurrent.STM
import Data.Time.Clock
import qualified Data.Map as M

{- Blocks until there are failed pushes.
 - Returns Remotes whose pushes failed a given time duration or more ago.
 - (This may be an empty list.) -}
getFailedPushesBefore :: NominalDiffTime -> Assistant [Remote]
getFailedPushesBefore duration = do
	v <- getAssistant failedPushMap
	liftIO $ do
		m <- atomically $ readTMVar v
		now <- getCurrentTime
		return $ M.keys $ M.filter (not . toorecent now) m
  where
	toorecent now time = now `diffUTCTime` time < duration

{- Modifies the map. -}
changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()
changeFailedPushMap a = do
	v <- getAssistant failedPushMap
	liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
  where
	{- tryTakeTMVar empties the TMVar; refill it only if
	 - the modified map is not itself empty -}
	store v m
		| m == M.empty = noop
		| otherwise = putTMVar v $! m


code:
{- git-annex assistant RemoteDaemon control
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.RemoteControl (
	sendRemoteControl,
	RemoteDaemon.Consumed(..)
) where

import Assistant.Common
import qualified RemoteDaemon.Types as RemoteDaemon

import Control.Concurrent

sendRemoteControl :: RemoteDaemon.Consumed -> Assistant ()
sendRemoteControl msg = do
	clicker <- getAssistant remoteControl
	liftIO $ writeChan clicker msg


code:
{- git-annex assistant repository repair
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Repair where

import Assistant.Common
import Command.Repair (repairAnnexBranch, trackingOrSyncBranch)
import Git.Fsck (FsckResults, foundBroken)
import Git.Repair (runRepairOf)
import qualified Git
import qualified Remote
import qualified Types.Remote as Remote
import Logs.FsckResults
import Annex.UUID
import Utility.Batch
import Config.Files
import Assistant.Sync
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.Types.UrlRenderer
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import qualified Data.Text as T
#endif
import qualified Utility.Lsof as Lsof
import Utility.ThreadScheduler

import Control.Concurrent.Async

{- When the FsckResults require a repair, tries to do a non-destructive
 - repair. If that fails, pops up an alert. -}
repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant Bool
repairWhenNecessary urlrenderer u mrmt fsckresults
	| foundBroken fsckresults = do
		liftAnnex $ writeFsckResults u fsckresults
		repodesc <- liftAnnex $ Remote.prettyUUID u
		ok <- alertWhile (repairingAlert repodesc)
			(runRepair u mrmt False)
#ifdef WITH_WEBAPP
		unless ok $ do
			button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
				RepairRepositoryR u
			void $ addAlert $ brokenRepositoryAlert [button]
#endif
		return ok
	| otherwise = return False

runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool
runRepair u mrmt destructiverepair = do
	fsckresults <- liftAnnex $ readFsckResults u
	myu <- liftAnnex getUUID
	ok <- if u == myu
		then localrepair fsckresults
		else remoterepair fsckresults
	liftAnnex $ clearFsckResults u
	debug [ "Repaired", show u, show ok ]

	return ok
  where
  	localrepair fsckresults = do
		-- Stop the watcher from running while running repairs.
		changeSyncable Nothing False

		-- This intentionally runs the repair inside the Annex
		-- monad, which is not strictly necessary, but keeps
		-- other threads that might be trying to use the Annex
		-- from running until it completes.
		ok <- liftAnnex $ repair fsckresults Nothing

		-- Run a background fast fsck if a destructive repair had
		-- to be done, to ensure that the git-annex branch
		-- reflects the current state of the repo.
		when destructiverepair $
			backgroundfsck [ Param "--fast" ]

		-- Start the watcher running again. This also triggers it to
		-- do a startup scan, which is especially important if the
		-- git repo repair removed files from the index file. Those
		-- files will be seen as new, and re-added to the repository.
		when (ok || destructiverepair) $
			changeSyncable Nothing True

		return ok

	remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
		Nothing -> return False
		Just mkrepair -> do
			thisrepopath <- liftIO . absPath
				=<< liftAnnex (fromRepo Git.repoPath)
			a <- liftAnnex $ mkrepair $
				repair fsckresults (Just thisrepopath)
			liftIO $ catchBoolIO a

	repair fsckresults referencerepo = do
		(ok, modifiedbranches) <- inRepo $
			runRepairOf fsckresults trackingOrSyncBranch destructiverepair referencerepo
		when destructiverepair $
			repairAnnexBranch modifiedbranches
		return ok

	backgroundfsck params = liftIO $ void $ async $ do
		program <- readProgramFile
		batchCommand program (Param "fsck" : params)

{- Detect when a git lock file exists and has no git process currently
 - writing to it. This strongly suggests it is a stale lock file.
 -
 - However, this could be on a network filesystem. Which is not very safe
 - anyway (the assistant relies on being able to check when files have
 - no writers to know when to commit them). Also, a few lock-file-ish
 - things used by git are not kept open, particularly MERGE_HEAD.
 -
 - So, just in case, when the lock file appears stale, we delay for one
 - minute, and check its size. If the size changed, delay for another
 - minute, and so on. This will at work to detect when another machine
 - is writing out a new index file, since git does so by writing the
 - new content to index.lock.
 -
 - Returns true if locks were cleaned up.
 -}
repairStaleGitLocks :: Git.Repo -> Assistant Bool
repairStaleGitLocks r = do
	lockfiles <- liftIO $ filter islock <$> findgitfiles r
	repairStaleLocks lockfiles
	return $ not $ null lockfiles
  where
	findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
	islock f
		| "gc.pid" `isInfixOf` f = False
		| ".lock" `isSuffixOf` f = True
		| takeFileName f == "MERGE_HEAD" = True
		| otherwise = False

repairStaleLocks :: [FilePath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes
  where
  	getsize lf = catchMaybeIO $
		(\s -> (lf, fileSize s)) <$> getFileStatus lf
  	getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
	go [] = return ()
	go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
		( do
			waitforit "to check stale git lock file"
			l' <- getsizes
			if l' == l
				then liftIO $ mapM_ nukeFile (map fst l)
				else go l'
		, do
			waitforit "for git lock file writer"
			go =<< getsizes
		)
	waitforit why = do
		notice ["Waiting for 60 seconds", why]
		liftIO $ threadDelaySeconds $ Seconds 60


code:
{- git-annex assistant remote problem handling
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.RepoProblem where

import Assistant.Common
import Assistant.Types.RepoProblem
import Utility.TList

import Control.Concurrent.STM

{- Gets all repositories that have problems. Blocks until there is at
 - least one. -}
getRepoProblems :: Assistant [RepoProblem]
getRepoProblems = nubBy sameRepoProblem
	<$> (atomically . getTList) <<~ repoProblemChan

{- Indicates that there was a problem with a repository, and the problem
 - appears to not be a transient (eg network connection) problem.
 -
 - If the problem is able to be repaired, the passed action will be run.
 - (However, if multiple problems are reported with a single repository,
 - only a single action will be run.)
 -}
repoHasProblem :: UUID -> Assistant () -> Assistant ()
repoHasProblem u afterrepair = do
	rp <- RepoProblem
		<$> pure u
		<*> asIO afterrepair
	(atomically . flip consTList rp) <<~ repoProblemChan


code:
{- git-annex assistant restarting
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Assistant.Restart where

import Assistant.Common
import Assistant.Threads.Watcher
import Assistant.DaemonStatus
import Assistant.NamedThread
import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
import Utility.Url
import Utility.PID
import qualified Git.Construct
import qualified Git.Config
import Config.Files
import qualified Annex
import qualified Git

import Control.Concurrent
#ifndef mingw32_HOST_OS
import System.Posix (signalProcess, sigTERM)
#else
import Utility.WinProcess
#endif
import Data.Default
import Network.URI

{- Before the assistant can be restarted, have to remove our
 - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also
 - a good idea, to avoid fighting when two assistants are running in the
 - same repo.
 -}
prepRestart :: Assistant ()
prepRestart = do
	liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)

{- To finish a restart, send a global redirect to the new url
 - to any web browsers that are displaying the webapp.
 -
 - Wait for browser to update before terminating this process. -}
postRestart :: URLString -> Assistant ()
postRestart url = do
	modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
	liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
	void $ liftIO $ forkIO $ do
		threadDelaySeconds (Seconds 120)
#ifndef mingw32_HOST_OS
		signalProcess sigTERM =<< getPID
#else
		terminatePID =<< getPID
#endif

runRestart :: Assistant URLString
runRestart = liftIO . newAssistantUrl
	=<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)

{- Starts up the assistant in the repository, and waits for it to create
 - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
 - connections by testing the url. -}
newAssistantUrl :: FilePath -> IO URLString
newAssistantUrl repo = do
	startAssistant repo
	geturl
  where
	geturl = do
		r <- Git.Config.read =<< Git.Construct.fromPath repo
		waiturl $ gitAnnexUrlFile r
	waiturl urlfile = do
		v <- tryIO $ readFile urlfile
		case v of
			Left _ -> delayed $ waiturl urlfile
			Right url -> ifM (assistantListening url)
				( return url
				, delayed $ waiturl urlfile
				)
	delayed a = do
		threadDelay 100000 -- 1/10th of a second
		a

{- Checks if the assistant is listening on an url.
 -
 - Always checks http, because https with self-signed cert is problimatic.
 - warp-tls listens to http, in order to show an error page, so this works.
 -}
assistantListening :: URLString -> IO Bool
assistantListening url = catchBoolIO $ fst <$> exists url' def
  where
	url' = case parseURI url of
		Nothing -> url
		Just uri -> show $ uri
			{ uriScheme = "http:"
			}

{- Does not wait for assistant to be listening for web connections.
 -
 - On windows, the assistant does not daemonize, which is why the forkIO is
 - done.
 -}
startAssistant :: FilePath -> IO ()
startAssistant repo = void $ forkIO $ do
	program <- readProgramFile
	(_, _, _, pid) <-
		createProcess $
			(proc program ["assistant"]) { cwd = Just repo }
	void $ checkSuccessProcess pid


code:
{- git-annex assistant remotes needing scanning
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.ScanRemotes where

import Assistant.Common
import Assistant.Types.ScanRemotes
import qualified Types.Remote as Remote

import Data.Function
import Control.Concurrent.STM
import qualified Data.Map as M

{- Blocks until there is a remote or remotes that need to be scanned.
 -
 - The list has higher priority remotes listed first. -}
getScanRemote :: Assistant [(Remote, ScanInfo)]
getScanRemote = do
	v <- getAssistant scanRemoteMap
	liftIO $ atomically $
		reverse . sortBy (compare `on` scanPriority . snd) . M.toList
			<$> takeTMVar v

{- Adds new remotes that need scanning. -}
addScanRemotes :: Bool -> [Remote] -> Assistant ()
addScanRemotes _ [] = noop
addScanRemotes full rs = do
	v <- getAssistant scanRemoteMap
	liftIO $ atomically $ do
		m <- fromMaybe M.empty <$> tryTakeTMVar v
		putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
  where
	info r = ScanInfo (-1 * Remote.cost r) full
	merge x y = ScanInfo
		{ scanPriority = max (scanPriority x) (scanPriority y)
		, fullScan = fullScan x || fullScan y
		}


code:
{- git-annex assistant ssh utilities
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Ssh where

import Common.Annex
import Utility.Tmp
import Utility.Shell
import Utility.Rsync
import Utility.FileMode
import Utility.SshConfig
import Git.Remote

import Data.Text (Text)
import qualified Data.Text as T
import Data.Char
import Network.URI

data SshData = SshData
	{ sshHostName :: Text
	, sshUserName :: Maybe Text
	, sshDirectory :: Text
	, sshRepoName :: String
	, sshPort :: Int
	, needsPubKey :: Bool
	, sshCapabilities :: [SshServerCapability]
	}
	deriving (Read, Show, Eq)

data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
	deriving (Read, Show, Eq)

hasCapability :: SshData -> SshServerCapability -> Bool
hasCapability d c = c `elem` sshCapabilities d

onlyCapability :: SshData -> SshServerCapability -> Bool
onlyCapability d c = all (== c) (sshCapabilities d)

data SshKeyPair = SshKeyPair
	{ sshPubKey :: String
	, sshPrivKey :: String
	}

instance Show SshKeyPair where
	show = sshPubKey

type SshPubKey = String

{- ssh -ofoo=bar command-line option -}
sshOpt :: String -> String -> String
sshOpt k v = concat ["-o", k, "=", v]

{- user@host or host -}
genSshHost :: Text -> Maybe Text -> String
genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host

{- Generates a ssh or rsync url from a SshData. -}
genSshUrl :: SshData -> String
genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $
	if (onlyCapability sshdata RsyncCapable)
		then [u, h, T.pack ":", sshDirectory sshdata]
		else [T.pack "ssh://", u, h, d]
  where
	u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
	h = sshHostName sshdata
	d
		| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata
		| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]
		| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
	addtrailingslash s
		| "/" `isSuffixOf` s = s
		| otherwise = s ++ "/"

{- Reverses genSshUrl -}
parseSshUrl :: String -> Maybe SshData
parseSshUrl u
	| "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u)
	| otherwise = fromrsync u
  where
	mkdata (userhost, dir) = Just $ SshData
		{ sshHostName = T.pack host
		, sshUserName = if null user then Nothing else Just $ T.pack user
		, sshDirectory = T.pack dir
		, sshRepoName = genSshRepoName host dir
		-- dummy values, cannot determine from url
		, sshPort = 22
		, needsPubKey = True
		, sshCapabilities = []
		}
	  where
	  	(user, host) = if '@' `elem` userhost
			then separate (== '@') userhost
			else ("", userhost)
	fromrsync s
		| not (rsyncUrlIsShell u) = Nothing
		| otherwise = mkdata $ separate (== ':') s
	fromssh = mkdata . break (== '/')

{- Generates a git remote name, like host_dir or host -}
genSshRepoName :: String -> FilePath -> String
genSshRepoName host dir
	| null dir = makeLegalName host
	| otherwise = makeLegalName $ host ++ "_" ++ dir

{- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
sshTranscript opts input = processTranscript "ssh" opts input

{- Ensure that the ssh public key doesn't include any ssh options, like
 - command=foo, or other weirdness -}
validateSshPubKey :: SshPubKey -> IO ()
validateSshPubKey pubkey
	| length (lines pubkey) == 1 =
		either error return $ check $ words pubkey
	| otherwise = error "too many lines in ssh public key"
  where
	check [prefix, _key, comment] = do
		checkprefix prefix
		checkcomment comment
	check [prefix, _key] =
		checkprefix prefix
	check _ = err "wrong number of words in ssh public key"

	ok = Right ()
	err msg = Left $ unwords [msg, pubkey]

	checkprefix prefix
		| ssh == "ssh" && all isAlphaNum keytype = ok
		| otherwise = err "bad ssh public key prefix"
	  where
		(ssh, keytype) = separate (== '-') prefix

	checkcomment comment = case filter (not . safeincomment) comment of
		[] -> ok
		badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")"
	safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'

addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
	[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]

{- Should only be used within the same process that added the line;
 - the layout of the line is not kepy stable across versions. -}
removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
removeAuthorizedKeys gitannexshellonly dir pubkey = do
	let keyline = authorizedKeysLine gitannexshellonly dir pubkey
	sshdir <- sshDir
	let keyfile = sshdir </> "authorized_keys"
	ls <- lines <$> readFileStrict keyfile
	viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls

{- Implemented as a shell command, so it can be run on remote servers over
 - ssh.
 -
 - The ~/.ssh/git-annex-shell wrapper script is created if not already
 - present.
 -}
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
	[ "mkdir -p ~/.ssh"
	, intercalate "; "
		[ "if [ ! -e " ++ wrapper ++ " ]"
		, "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper
		, "fi"
		]
	, "chmod 700 " ++ wrapper
	, "touch ~/.ssh/authorized_keys"
	, "chmod 600 ~/.ssh/authorized_keys"
	, unwords
		[ "echo"
		, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
		, ">>~/.ssh/authorized_keys"
		]
	]
  where
	echoval v = "echo " ++ shellEscape v
	wrapper = "~/.ssh/git-annex-shell"
	script =
		[ shebang_portable
		, "set -e"
		, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
		,   runshell "$SSH_ORIGINAL_COMMAND"
		, "else"
		,   runshell "$@"
		, "fi"
		]
	runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""

authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
authorizedKeysLine gitannexshellonly dir pubkey
	| gitannexshellonly = limitcommand ++ pubkey
	{- TODO: Locking down rsync is difficult, requiring a rather
	 - long perl script. -}
	| otherwise = pubkey
  where
	limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "

{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
	ok <- boolSystem "ssh-keygen"
		[ Param "-P", Param "" -- no password
		, Param "-f", File $ dir </> "key"
		]
	unless ok $
		error "ssh-keygen failed"
	SshKeyPair
		<$> readFile (dir </> "key.pub")
		<*> readFile (dir </> "key")

{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
 - that will enable use of the key. This way we avoid changing the user's
 - regular ssh experience at all. Returns a modified SshData containing the
 - mangled hostname.
 -
 - Note that the key files are put in ~/.ssh/git-annex/, rather than directly
 - in ssh because of an **INSANE** behavior of gnome-keyring: It loads
 - ~/.ssh/ANYTHING.pub, and uses them indiscriminately. But using this key
 - for a normal login to the server will force git-annex-shell to run,
 - and locks the user out. Luckily, it does not recurse into subdirectories.
 -
 - Similarly, IdentitiesOnly is set in the ssh config to prevent the
 - ssh-agent from forcing use of a different key.
 -
 - Force strict host key checking to avoid repeated prompts
 - when git-annex and git try to access the remote, if its
 - host key has changed.
 -}
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
setupSshKeyPair sshkeypair sshdata = do
	sshdir <- sshDir
	createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile

	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
		writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)
	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)

	setSshConfig sshdata
		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
		, ("IdentitiesOnly", "yes")
		, ("StrictHostKeyChecking", "yes")
		]
  where
	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
	sshpubkeyfile = sshprivkeyfile ++ ".pub"

{- Fixes git-annex ssh key pairs configured in .ssh/config
 - by old versions to set IdentitiesOnly.
 -
 - Strategy: Search for IdentityFile lines with key.git-annex
 - in their names. These are for git-annex ssh key pairs.
 - Add the IdentitiesOnly line immediately after them, if not already
 - present.
 -}
fixSshKeyPairIdentitiesOnly :: IO ()
fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
  where
  	go c [] = reverse c
	go c (l:[])
		| all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
		| otherwise = go (l:c) []
	go c (l:next:rest)
		| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) =
			go (fixedline l:l:c) (next:rest)
		| otherwise = go (l:c) (next:rest)
  	indicators = ["IdentityFile", "key.git-annex"]
	fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"

{- Add StrictHostKeyChecking to any ssh config stanzas that were written
 - by git-annex. -}
fixUpSshRemotes :: IO ()
fixUpSshRemotes = modifyUserSshConfig (map go)
  where
	go c@(HostConfig h _)
		| "git-annex-" `isPrefixOf` h = fixupconfig c
		| otherwise = c
	go other = other

	fixupconfig c = case findHostConfigKey c "StrictHostKeyChecking" of
		Nothing -> addToHostConfig c "StrictHostKeyChecking" "yes"
		Just _ -> c

{- Setups up a ssh config with a mangled hostname.
 - Returns a modified SshData containing the mangled hostname. -}
setSshConfig :: SshData -> [(String, String)] -> IO SshData
setSshConfig sshdata config = do
	sshdir <- sshDir
	createDirectoryIfMissing True sshdir
	let configfile = sshdir </> "config"
	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do
		appendFile configfile $ unlines $
			[ ""
			, "# Added automatically by git-annex"
			, "Host " ++ mangledhost
			] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
				(settings ++ config)
		setSshConfigMode configfile

	return $ sshdata { sshHostName = T.pack mangledhost }
  where
	mangledhost = mangleSshHostName sshdata
	settings =
		[ ("Hostname", T.unpack $ sshHostName sshdata)
		, ("Port", show $ sshPort sshdata)
		]

{- This hostname is specific to a given repository on the ssh host,
 - so it is based on the real hostname, the username, and the directory.
 -
 - The mangled hostname has the form "git-annex-realhostname-username-port_dir".
 - The only use of "-" is to separate the parts shown; this is necessary
 - to allow unMangleSshHostName to work. Any unusual characters in the
 - username or directory are url encoded, except using "." rather than "%"
 - (the latter has special meaning to ssh).
 -}
mangleSshHostName :: SshData -> String
mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
	++ "-" ++ escape extra
  where
	extra = intercalate "_" $ map T.unpack $ catMaybes
		[ sshUserName sshdata
		, Just $ T.pack $ show $ sshPort sshdata
		, Just $ sshDirectory sshdata
		]
	safe c
		| isAlphaNum c = True
		| c == '_' = True
		| otherwise = False
	escape s = replace "%" "." $ escapeURIString safe s

{- Extracts the real hostname from a mangled ssh hostname. -}
unMangleSshHostName :: String -> String
unMangleSshHostName h = case split "-" h of
	("git":"annex":rest) -> intercalate "-" (beginning rest)
	_ -> h

{- Does ssh have known_hosts data for a hostname? -}
knownHost :: Text -> IO Bool
knownHost hostname = do
	sshdir <- sshDir
	ifM (doesFileExist $ sshdir </> "known_hosts")
		( not . null <$> checkhost
		, return False
		)
  where
	{- ssh-keygen -F can crash on some old known_hosts file -}
	checkhost = catchDefaultIO "" $
		readProcess "ssh-keygen" ["-F", T.unpack hostname]


code:
{- git-annex assistant repo syncing
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Sync where

import Assistant.Common
import Assistant.Pushes
import Assistant.NetMessager
import Assistant.Types.NetMessager
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.RemoteControl
import qualified Command.Sync
import Utility.Parallel
import qualified Git
import qualified Git.Branch
import qualified Git.Command
import qualified Git.Ref
import qualified Remote
import qualified Types.Remote as Remote
import qualified Remote.List as Remote
import qualified Annex.Branch
import Annex.UUID
import Annex.TaggedPush
import qualified Config
import Git.Config
import Assistant.NamedThread
import Assistant.Threads.Watcher (watchThread, WatcherControl(..))
import Assistant.TransferSlots
import Assistant.TransferQueue
import Assistant.RepoProblem
import Logs.Transfer

import Data.Time.Clock
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Concurrent

{- Syncs with remotes that may have been disconnected for a while.
 -
 - First gets git in sync, and then prepares any necessary file transfers.
 -
 - An expensive full scan is queued when the git-annex branches of some of
 - the remotes have diverged from the local git-annex branch. Otherwise,
 - it's sufficient to requeue failed transfers.
 -
 - XMPP remotes are also signaled that we can push to them, and we request
 - they push to us. Since XMPP pushes run ansynchronously, any scan of the
 - XMPP remotes has to be deferred until they're done pushing to us, so
 - all XMPP remotes are marked as possibly desynced.
 -
 - Also handles signaling any connectRemoteNotifiers, after the syncing is
 - done.
 -}
reconnectRemotes :: Bool -> [Remote] -> Assistant ()
reconnectRemotes _ [] = noop
reconnectRemotes notifypushes rs = void $ do
	rs' <- liftIO $ filterM (Remote.checkAvailable True) rs
	unless (null rs') $ do
		modifyDaemonStatus_ $ \s -> s
			{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
		failedrs <- syncAction rs' (const go)
		forM_ failedrs $ \r ->
			whenM (liftIO $ Remote.checkAvailable False r) $
				repoHasProblem (Remote.uuid r) (syncRemote r)
		mapM_ signal $ filter (`notElem` failedrs) rs'
  where
	gitremotes = filter (notspecialremote . Remote.repo) rs
	(xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
	notspecialremote r
		| Git.repoIsUrl r = True
		| Git.repoIsLocal r = True
		| Git.repoIsLocalUnknown r = True
		| otherwise = False
	sync (Just branch) = do
		(failedpull, diverged) <- manualPull (Just branch) gitremotes
		now <- liftIO getCurrentTime
		failedpush <- pushToRemotes' now notifypushes gitremotes
		return (nub $ failedpull ++ failedpush, diverged)
	{- No local branch exists yet, but we can try pulling. -}
	sync Nothing = manualPull Nothing gitremotes
	go = do
		(failed, diverged) <- sync
			=<< liftAnnex (inRepo Git.Branch.current)
		addScanRemotes diverged $
			filter (not . remoteAnnexIgnore . Remote.gitconfig)
				nonxmppremotes
		return failed
	signal r = liftIO . mapM_ (flip tryPutMVar ())
		=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
			<$> getDaemonStatus

{- Pushes the local sync branch to all remotes, in
 - parallel, along with the git-annex branch. This is the same
 - as "git annex sync", except in parallel, and will co-exist with use of
 - "git annex sync".
 -
 - After the pushes to normal git remotes, also signals XMPP clients that
 - they can request an XMPP push.
 -
 - Avoids running possibly long-duration commands in the Annex monad, so
 - as not to block other threads.
 -
 - This can fail, when the remote's sync branch (or git-annex branch) has
 - been updated by some other remote pushing into it, or by the remote
 - itself. To handle failure, a manual pull and merge is done, and the push
 - is retried.
 -
 - When there's a lot of activity, we may fail more than once.
 - On the other hand, we may fail because the remote is not available.
 - Rather than retrying indefinitely, after the first retry we enter a
 - fallback mode, where our push is guarenteed to succeed if the remote is
 - reachable. If the fallback fails, the push is queued to be retried
 - later.
 -
 - Returns any remotes that it failed to push to.
 -}
pushToRemotes :: Bool -> [Remote] -> Assistant [Remote]
pushToRemotes notifypushes remotes = do
	now <- liftIO getCurrentTime
	let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes
	syncAction remotes' (pushToRemotes' now notifypushes)
pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
pushToRemotes' now notifypushes remotes = do
	(g, branch, u) <- liftAnnex $ do
		Annex.Branch.commit "update"
		(,,)
			<$> gitRepo
			<*> inRepo Git.Branch.current
			<*> getUUID
	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
	ret <- go True branch g u normalremotes
	unless (null xmppremotes) $ do
		shas <- liftAnnex $ map fst <$>
			inRepo (Git.Ref.matchingWithHEAD
				[Annex.Branch.fullname, Git.Ref.headRef])
		forM_ xmppremotes $ \r -> sendNetMessage $
			Pushing (getXMPPClientID r) (CanPush u shas)
	return ret
  where
	go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
	go _ _ _ _ [] = return [] -- no remotes, so nothing to do
	go shouldretry (Just branch) g u rs =  do
		debug ["pushing to", show rs]
		(succeeded, failed) <- liftIO $ inParallel (push g branch) rs
		updatemap succeeded []
		if null failed
			then do
				when notifypushes $
					sendNetMessage $ NotifyPush $
						map Remote.uuid succeeded
				return failed
			else if shouldretry
				then retry branch g u failed
				else fallback branch g u failed

	updatemap succeeded failed = changeFailedPushMap $ \m ->
		M.union (makemap failed) $
			M.difference m (makemap succeeded)
	makemap l = M.fromList $ zip l (repeat now)

	retry branch g u rs = do
		debug ["trying manual pull to resolve failed pushes"]
		void $ manualPull (Just branch) rs
		go False (Just branch) g u rs

	fallback branch g u rs = do
		debug ["fallback pushing to", show rs]
		(succeeded, failed) <- liftIO $
			inParallel (\r -> taggedPush u Nothing branch r g) rs
		updatemap succeeded failed
		when (notifypushes && (not $ null succeeded)) $
			sendNetMessage $ NotifyPush $
				map Remote.uuid succeeded
		return failed

	push g branch remote = Command.Sync.pushBranch remote branch g

{- Displays an alert while running an action that syncs with some remotes,
 - and returns any remotes that it failed to sync with.
 -
 - XMPP remotes are handled specially; since the action can only start
 - an async process for them, they are not included in the alert, but are
 - still passed to the action.
 -
 - Readonly remotes are also hidden (to hide the web special remote).
 -}
syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
syncAction rs a
	| null visibleremotes = a rs
	| otherwise = do
		i <- addAlert $ syncAlert visibleremotes
		failed <- a rs
		let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed
		let succeeded = filter (`notElem` failed) visibleremotes
		if null succeeded && null failed'
			then removeAlert i
			else updateAlertMap $ mergeAlert i $
				syncResultAlert succeeded failed'
		return failed
  where
	visibleremotes = filter (not . Remote.readonly) $
		filter (not . Remote.isXMPPRemote) rs

{- Manually pull from remotes and merge their branches. Returns any
 - remotes that it failed to pull from, and a Bool indicating
 - whether the git-annex branches of the remotes and local had
 - diverged before the pull.
 -
 - After pulling from the normal git remotes, requests pushes from any
 - XMPP remotes. However, those pushes will run asynchronously, so their
 - results are not included in the return data.
 -}
manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
	g <- liftAnnex gitRepo
	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
	failed <- liftIO $ forM normalremotes $ \r ->
		ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g)
			( return Nothing
			, return $ Just r
			)
	haddiverged <- liftAnnex Annex.Branch.forceUpdate
	forM_ normalremotes $ \r ->
		liftAnnex $ Command.Sync.mergeRemote r currentbranch
	u <- liftAnnex getUUID
	forM_ xmppremotes $ \r ->
		sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
	return (catMaybes failed, haddiverged)

{- Start syncing a remote, using a background thread. -}
syncRemote :: Remote -> Assistant ()
syncRemote remote = do
	updateSyncRemotes
	thread <- asIO $ do
		reconnectRemotes False [remote]
		addScanRemotes True [remote]
	void $ liftIO $ forkIO $ thread

{- Use Nothing to change autocommit setting; or a remote to change
 - its sync setting. -}
changeSyncable :: Maybe Remote -> Bool -> Assistant ()
changeSyncable Nothing enable = do
	liftAnnex $ Config.setConfig key (boolConfig enable)
	liftIO . maybe noop (`throwTo` signal)
		=<< namedThreadId watchThread
  where
	key = Config.annexConfig "autocommit"
	signal
		| enable = ResumeWatcher
		| otherwise = PauseWatcher
changeSyncable (Just r) True = do
	liftAnnex $ changeSyncFlag r True
	syncRemote r
	sendRemoteControl RELOAD
changeSyncable (Just r) False = do
	liftAnnex $ changeSyncFlag r False
	updateSyncRemotes
	{- Stop all transfers to or from this remote.
	 - XXX Can't stop any ongoing scan, or git syncs. -}
	void $ dequeueTransfers tofrom
	mapM_ (cancelTransfer False) =<<
		filter tofrom . M.keys . currentTransfers <$> getDaemonStatus
  where
	tofrom t = transferUUID t == Remote.uuid r

changeSyncFlag :: Remote -> Bool -> Annex ()
changeSyncFlag r enabled = do
	Config.setConfig key (boolConfig enabled)
	void Remote.remoteListRefresh
  where
	key = Config.remoteConfig (Remote.repo r) "sync"