1{- git-annex special remote configuration
2 -
3 - Copyright 2011-2019 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9
10module Annex.SpecialRemote (
11	module Annex.SpecialRemote,
12	module Annex.SpecialRemote.Config
13) where
14
15import Annex.Common
16import Annex.SpecialRemote.Config
17import Types.Remote (RemoteConfig, SetupStage(..), typename, setup)
18import Types.GitConfig
19import Types.ProposedAccepted
20import Config
21import Remote.List
22import Logs.Remote
23import Logs.Trust
24import qualified Types.Remote as Remote
25import Git.Types (RemoteName)
26
27import qualified Data.Map as M
28import Data.Ord
29
30{- See if there's an existing special remote with this name.
31 -
32 - Prefer remotes that are not dead when a name appears multiple times. -}
33findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig, Maybe (ConfigFrom UUID)))
34findExisting name = do
35	t <- trustMap
36	headMaybe
37		. sortBy (comparing $ \(u, _, _) -> Down $ M.lookup u t)
38		. findByRemoteConfig (\c -> lookupName c == Just name)
39		<$> Logs.Remote.remoteConfigMap
40
41newConfig
42	:: RemoteName
43	-> Maybe (Sameas UUID)
44	-> RemoteConfig
45	-- ^ configuration provided by the user
46	-> M.Map UUID RemoteConfig
47	-- ^ configuration of other special remotes, to inherit from
48	-- when sameas is used
49	-> RemoteConfig
50newConfig name sameas fromuser m = case sameas of
51	Nothing -> M.insert nameField (Proposed name) fromuser
52	Just (Sameas u) -> addSameasInherited m $ M.fromList
53		[ (sameasNameField, Proposed name)
54		, (sameasUUIDField, Proposed (fromUUID u))
55		] `M.union` fromuser
56
57specialRemoteMap :: Annex (M.Map UUID RemoteName)
58specialRemoteMap = do
59	m <- Logs.Remote.remoteConfigMap
60	return $ M.fromList $ mapMaybe go (M.toList m)
61  where
62	go (u, c) = case lookupName c of
63		Nothing -> Nothing
64		Just n -> Just (u, n)
65
66{- find the remote type -}
67findType :: RemoteConfig -> Either String RemoteType
68findType config = maybe unspecified (specified . fromProposedAccepted) $
69	M.lookup typeField config
70  where
71	unspecified = Left "Specify the type of remote with type="
72	specified s = case filter (findtype s) remoteTypes of
73		[] -> Left $ "Unknown remote type " ++ s
74			++ " (pick from: "
75			++ intercalate " " (map typename remoteTypes)
76			++ ")"
77		(t:_) -> Right t
78	findtype s i = typename i == s
79
80autoEnable :: Annex ()
81autoEnable = do
82	remotemap <- M.filter configured <$> remoteConfigMap
83	enabled <- getenabledremotes
84	forM_ (M.toList remotemap) $ \(cu, c) -> unless (cu `M.member` enabled) $ do
85		let u = case findSameasUUID c of
86			Just (Sameas u') -> u'
87			Nothing -> cu
88		case (lookupName c, findType c) of
89			(Just name, Right t) -> whenM (canenable u) $ do
90				showSideAction $ "Auto enabling special remote " ++ name
91				dummycfg <- liftIO dummyRemoteGitConfig
92				tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case
93					Left e -> warning (show e)
94					Right (_c, _u) ->
95						when (cu /= u) $
96							setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)
97			_ -> return ()
98  where
99	configured rc = fromMaybe False $
100		trueFalseParser' . fromProposedAccepted
101			=<< M.lookup autoEnableField rc
102	canenable u = (/= DeadTrusted) <$> lookupTrust u
103	getenabledremotes = M.fromList
104		. map (\r -> (getcu r, r))
105		<$> remoteList
106	getcu r = fromMaybe
107		(Remote.uuid r)
108		(remoteAnnexConfigUUID (Remote.gitconfig r))
109