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