git-annex/Remote.hs

373 lines
12 KiB
Haskell
Raw Normal View History

{- git-annex remotes
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote (
Remote,
uuid,
name,
storeKey,
retrieveKeyFile,
retrieveKeyFileCheap,
removeKey,
hasKey,
hasKeyCheap,
whereisKey,
remoteFsck,
2011-03-29 18:55:59 +00:00
remoteTypes,
2011-12-30 23:10:54 +00:00
remoteList,
remoteList',
gitSyncableRemote,
remoteMap,
remoteMap',
uuidDescriptions,
addName,
byName,
byName',
byNameOrGroup,
byNameOnly,
byNameWithUUID,
byUUID,
2012-08-26 18:45:47 +00:00
byCost,
2011-07-06 20:06:10 +00:00
prettyPrintUUIDs,
prettyPrintUUIDsDescs,
prettyPrintUUIDsWith,
2012-07-30 01:54:23 +00:00
prettyListUUIDs,
prettyUUID,
remoteFromUUID,
remotesWithUUID,
2011-03-29 03:22:31 +00:00
remotesWithoutUUID,
keyLocations,
2011-07-06 20:06:10 +00:00
keyPossibilities,
remoteLocations,
2011-07-06 20:06:10 +00:00
nameToUUID,
nameToUUID',
showTriedRemotes,
showLocations,
forceTrust,
logStatus,
checkAvailable,
claimingUrl,
isExportSupported,
) where
import Data.Ord
import qualified Data.Map as M
import qualified Data.Vector as V
import Annex.Common
import Types.Remote
import qualified Annex
import Annex.UUID
2011-10-15 20:21:08 +00:00
import Logs.UUID
import Logs.Trust
2012-12-12 23:20:38 +00:00
import Logs.Location hiding (logStatus)
import Logs.Web
import Remote.List
import Config
import Config.DynamicConfig
import Git.Types (RemoteName)
import Utility.Aeson
{- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
remoteMap mkv = remoteMap' mkv (pure . mkk)
where
mkk r = case uuid r of
NoUUID -> Nothing
u -> Just u
remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Annex (Maybe k)) -> Annex (M.Map k v)
remoteMap' mkv mkk = M.fromList . catMaybes <$> (mapM mk =<< remoteList)
where
mk r = mkk r >>= return . \case
Nothing -> Nothing
Just k -> Just (k, mkv r)
{- Map of UUIDs of repositories and their descriptions.
- The names of Remotes are added to suppliment any description that has
- been set for a repository. -}
uuidDescriptions :: Annex (M.Map UUID String)
uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name
addName :: String -> RemoteName -> String
addName desc n
| desc == n || null desc = "[" ++ n ++ "]"
| otherwise = desc ++ " [" ++ n ++ "]"
byUUID :: UUID -> Annex (Maybe Remote)
byUUID u = headMaybe . filter matching <$> remoteList
where
matching r = uuid r == u
{- When a name is specified, looks up the remote matching that name.
- (Or it can be a UUID.)
-
- Throws an error if a name is specified and no matching remote can be
- found.
-}
byName :: Maybe RemoteName -> Annex (Maybe Remote)
byName Nothing = return Nothing
byName (Just n) = either giveup Just <$> byName' n
{- Like byName, but the remote must have a configured UUID. -}
byNameWithUUID :: Maybe RemoteName -> Annex (Maybe Remote)
byNameWithUUID = checkuuid <=< byName
where
checkuuid Nothing = return Nothing
checkuuid (Just r)
| uuid r == NoUUID = do
repo <- getRepo r
ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore (gitconfig r))
( giveup $ noRemoteUUIDMsg r ++
" (" ++ show (remoteConfig repo "ignore") ++
" is set)"
, giveup $ noRemoteUUIDMsg r
)
| otherwise = return $ Just r
byName' :: RemoteName -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified"
byName' n = go . filter matching <$> remoteList
where
go [] = Left $ "there is no available git remote named \"" ++ n ++ "\""
go (match:_) = Right match
matching r = n == name r || toUUID n == uuid r
{- Finds the remote or remote group matching the name. -}
byNameOrGroup :: RemoteName -> Annex [Remote]
byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." ++ n))
where
go (Just l) = catMaybes <$> mapM (byName . Just) (splitc ' ' l)
2015-01-16 17:14:44 +00:00
go Nothing = maybeToList <$> byName (Just n)
{- Only matches remote name, not UUID -}
byNameOnly :: RemoteName -> Annex (Maybe Remote)
byNameOnly n = headMaybe . filter matching <$> remoteList
where
matching r = n == name r
noRemoteUUIDMsg :: Remote -> String
noRemoteUUIDMsg r = "cannot determine uuid for " ++ name r ++ " (perhaps you need to run \"git annex sync\"?)"
{- Looks up a remote by name (or by UUID, or even by description),
- and returns its UUID. Finds even repositories that are not
- configured in .git/config. -}
nameToUUID :: RemoteName -> Annex UUID
nameToUUID = either giveup return <=< nameToUUID'
nameToUUID' :: RemoteName -> Annex (Either String UUID)
nameToUUID' "." = Right <$> getUUID -- special case for current repo
nameToUUID' "here" = Right <$> getUUID
nameToUUID' n = byName' n >>= go
where
go (Right r) = return $ case uuid r of
NoUUID -> Left $ noRemoteUUIDMsg r
u -> Right u
go (Left e) = do
m <- uuidMap
return $ case M.keys (M.filter (== n) m) of
[u] -> Right u
[] -> let u = toUUID n
in case M.keys (M.filterWithKey (\k _ -> k == u) m) of
[] -> Left e
_ -> Right u
_us -> Left "Found multiple repositories with that description"
{- Pretty-prints a list of UUIDs of remotes, with their descriptions,
- for human display.
-
- When JSON is enabled, also outputs a machine-readable description
- of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs header uuids = do
descm <- uuidDescriptions
prettyPrintUUIDsDescs header descm uuids
prettyPrintUUIDsDescs :: String -> M.Map UUID RemoteName -> [UUID] -> Annex String
prettyPrintUUIDsDescs header descm uuids =
prettyPrintUUIDsWith Nothing header descm
(const Nothing)
(zip uuids (repeat (Nothing :: Maybe String)))
{- An optional field can be included in the list of UUIDs. -}
prettyPrintUUIDsWith
:: ToJSON' v
=> Maybe String
-> String
-> M.Map UUID RemoteName
-> (v -> Maybe String)
-> [(UUID, Maybe v)]
-> Annex String
prettyPrintUUIDsWith optfield header descm showval uuidvals = do
hereu <- getUUID
maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)]
return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals
where
finddescription u = M.findWithDefault "" u descm
prettify hereu (u, optval)
| not (null d) = addoptval $ fromUUID u ++ " -- " ++ d
| otherwise = addoptval $ fromUUID u
where
ishere = hereu == u
n = finddescription u
d
| null n && ishere = "here"
| ishere = addName n "here"
| otherwise = n
addoptval s = case showval =<< optval of
Nothing -> s
Just val -> val ++ ": " ++ s
jsonify hereu (u, optval) = object $ catMaybes
[ Just (packString "uuid", toJSON' $ fromUUID u)
, Just (packString "description", toJSON' $ finddescription u)
, Just (packString "here", toJSON' $ hereu == u)
, case (optfield, optval) of
(Just field, Just val) -> Just (packString field, toJSON' val)
_ -> Nothing
]
2012-07-30 02:11:01 +00:00
{- List of remote names and/or descriptions, for human display. -}
2012-07-30 01:54:23 +00:00
prettyListUUIDs :: [UUID] -> Annex [String]
prettyListUUIDs uuids = do
hereu <- getUUID
m <- uuidDescriptions
2013-04-03 07:52:41 +00:00
return $ map (prettify m hereu) uuids
where
finddescription m u = M.findWithDefault "" u m
prettify m hereu u
| u == hereu = addName n "here"
| otherwise = n
where
n = finddescription m u
2012-07-30 01:54:23 +00:00
{- Nice display of a remote's name and/or description. -}
prettyUUID :: UUID -> Annex String
prettyUUID u = concat <$> prettyListUUIDs [u]
{- Gets the remote associated with a UUID. -}
remoteFromUUID :: UUID -> Annex (Maybe Remote)
remoteFromUUID u = ifM ((==) u <$> getUUID)
( return Nothing
2014-02-11 05:35:11 +00:00
, maybe tryharder (return . Just) =<< findinmap
)
where
findinmap = M.lookup u <$> remoteMap id
{- Re-read remote list in case a new remote has popped up. -}
tryharder = do
void remoteListRefresh
findinmap
{- Filters a list of remotes to ones that have the listed uuids. -}
2011-12-31 08:11:39 +00:00
remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
{- Filters a list of remotes to ones that do not have the listed uuids. -}
2011-12-31 08:11:39 +00:00
remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
{- List of repository UUIDs that the location log indicates may have a key.
- Dead repositories are excluded. -}
keyLocations :: Key -> Annex [UUID]
2012-11-11 04:26:29 +00:00
keyLocations key = trustExclude DeadTrusted =<< loggedLocations key
{- Cost ordered lists of remotes that the location log indicates
- may have a key.
2011-06-23 17:39:04 +00:00
-}
2011-12-31 08:11:39 +00:00
keyPossibilities :: Key -> Annex [Remote]
keyPossibilities key = do
2011-10-11 18:43:45 +00:00
u <- getUUID
-- uuids of all remotes that are recorded to have the key
locations <- filter (/= u) <$> keyLocations key
fst <$> remoteLocations locations []
{- Given a list of locations of a key, and a list of all
- trusted repositories, generates a cost-ordered list of
- remotes that contain the key, and a list of trusted locations of the key.
-}
remoteLocations :: [UUID] -> [UUID] -> Annex ([Remote], [UUID])
remoteLocations locations trusted = do
let validtrustedlocations = nub locations `intersect` trusted
-- remotes that match uuids that have the key
allremotes <- remoteList
>>= filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig)
let validremotes = remotesWithUUID allremotes locations
return (sortBy (comparing cost) validremotes, validtrustedlocations)
{- Displays known locations of a key. -}
showLocations :: Bool -> Key -> [UUID] -> String -> Annex ()
showLocations separateuntrusted key exclude nolocmsg = do
2011-10-11 18:43:45 +00:00
u <- getUUID
uuids <- keyLocations key
untrusteduuids <- if separateuntrusted
then trustGet UnTrusted
else pure []
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
2015-01-16 17:14:44 +00:00
ppuuidswanted <- prettyPrintUUIDs "wanted" uuidswanted
ppuuidsskipped <- prettyPrintUUIDs "skipped" uuidsskipped
2015-04-30 18:10:28 +00:00
let msg = message ppuuidswanted ppuuidsskipped
unless (null msg) $
showLongNote msg
ignored <- remoteList
>>= filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig)
unless (null ignored) $
showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"
where
filteruuids l x = filter (`notElem` x) l
message [] [] = nolocmsg
message rs [] = "Try making some of these repositories available:\n" ++ rs
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
message rs us = message rs [] ++ message [] us
2011-12-31 08:11:39 +00:00
showTriedRemotes :: [Remote] -> Annex ()
2012-04-22 03:32:33 +00:00
showTriedRemotes [] = noop
showTriedRemotes remotes =
showLongNote $ "Unable to access these remotes: " ++
intercalate ", " (map name remotes)
2011-06-02 06:33:31 +00:00
forceTrust :: TrustLevel -> String -> Annex ()
forceTrust level remotename = do
u <- nameToUUID remotename
2011-06-02 06:33:31 +00:00
Annex.changeState $ \s ->
s { Annex.forcetrust = M.insert u level (Annex.forcetrust s) }
{- Used to log a change in a remote's having a key. The change is logged
- in the local repo, not on the remote. The process of transferring the
- key to the remote, or removing the key from it *may* log the change
- on the remote, but this cannot always be relied on. -}
logStatus :: Remote -> Key -> LogStatus -> Annex ()
2012-02-16 04:41:30 +00:00
logStatus remote key = logChange key (uuid remote)
2012-08-26 18:45:47 +00:00
{- Orders remotes by cost, with ones with the lowest cost grouped together. -}
byCost :: [Remote] -> [[Remote]]
byCost = map snd . sortBy (comparing fst) . M.toList . costmap
where
costmap = M.fromListWith (++) . map costpair
costpair r = (cost r, [r])
checkAvailable :: Bool -> Remote -> IO Bool
checkAvailable assumenetworkavailable =
maybe (return assumenetworkavailable) doesDirectoryExist . localpath
hasKey :: Remote -> Key -> Annex (Either String Bool)
hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k)
hasKeyCheap :: Remote -> Bool
hasKeyCheap = checkPresentCheap
{- The web special remote claims urls by default. -}
claimingUrl :: URLString -> Annex Remote
claimingUrl url = do
rs <- remoteList
let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs
fromMaybe web <$> firstM checkclaim rs
where
2015-04-11 04:10:34 +00:00
checkclaim = maybe (pure False) (`id` url) . claimUrl