91 lines
2.7 KiB
Haskell
91 lines
2.7 KiB
Haskell
{- 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
|
|
matches <- sortBy (comparing $ \(u, _c) -> M.lookup u t)
|
|
. findByName name
|
|
<$> Logs.Remote.readRemoteLog
|
|
return $ headMaybe matches
|
|
|
|
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
|