git-annex/Annex/SpecialRemote.hs

{- git-annex special remote configuration
 -
 - Copyright 2011-2015 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.SpecialRemote where

import Annex.Common
import Remote (remoteTypes, remoteMap)
import Types.Remote (RemoteConfig, RemoteConfigKey, SetupStage(..), typename, setup)
import Types.GitConfig
import Logs.Remote
import Logs.Trust
import qualified Git.Config
import Git.Types (RemoteName)

import qualified Data.Map as M
import Data.Ord

{- See if there's an existing special remote with this name.
 -
 - Prefer remotes that are not dead when a name appears multiple times. -}
findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig))
findExisting name = do
	t <- trustMap
	headMaybe
		. sortBy (comparing $ \(u, _c) -> Down $ M.lookup u t)
		. findByName name
		<$> Logs.Remote.readRemoteLog

newConfig :: RemoteName -> RemoteConfig
newConfig = M.singleton nameKey

findByName :: RemoteName ->  M.Map UUID RemoteConfig -> [(UUID, RemoteConfig)]
findByName n = filter (matching . snd) . M.toList
  where
	matching c = case M.lookup nameKey c of
		Nothing -> False
		Just n'
			| n' == n -> True
			| otherwise -> False

specialRemoteMap :: Annex (M.Map UUID RemoteName)
specialRemoteMap = do
	m <- Logs.Remote.readRemoteLog
	return $ M.fromList $ mapMaybe go (M.toList m)
  where
	go (u, c) = case M.lookup nameKey c of
		Nothing -> Nothing
		Just n -> Just (u, n)

{- find the specified remote type -}
findType :: RemoteConfig -> Either String RemoteType
findType config = maybe unspecified specified $ M.lookup typeKey config
  where
	unspecified = Left "Specify the type of remote with type="
	specified s = case filter (findtype s) remoteTypes of
		[] -> Left $ "Unknown remote type " ++ s
		(t:_) -> Right t
	findtype s i = typename i == s

{- The name of a configured remote is stored in its config using this key. -}
nameKey :: RemoteConfigKey
nameKey = "name"

{- The type of a remote is stored in its config using this key. -}
typeKey :: RemoteConfigKey
typeKey = "type"

autoEnableKey :: RemoteConfigKey
autoEnableKey = "autoenable"

autoEnable :: Annex ()
autoEnable = do
	remotemap <- M.filter configured <$> readRemoteLog
	enabled <- remoteMap id
	forM_ (M.toList remotemap) $ \(u, c) -> unless (u `M.member` enabled) $ do
		case (M.lookup nameKey c, findType c) of
			(Just name, Right t) -> whenM (canenable u) $ do
				showSideAction $ "Auto enabling special remote " ++ name
				dummycfg <- liftIO dummyRemoteGitConfig
				tryNonAsync (setup t (Enable c) (Just u) Nothing c dummycfg) >>= \case
					Left e -> warning (show e)
					Right _ -> return ()
			_ -> return ()
  where
	configured rc = fromMaybe False $
		Git.Config.isTrue =<< M.lookup autoEnableKey rc
	canenable u = (/= DeadTrusted) <$> lookupTrust u