git-annex/Remote.hs

257 lines
7.7 KiB
Haskell
Raw Normal View History

{- git-annex remotes
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote (
Remote,
uuid,
name,
storeKey,
retrieveKeyFile,
removeKey,
hasKey,
hasKeyCheap,
2011-03-29 18:55:59 +00:00
remoteTypes,
2011-12-30 23:10:54 +00:00
remoteList,
enabledRemoteList,
remoteMap,
uuidDescriptions,
byName,
2011-07-06 20:06:10 +00:00
prettyPrintUUIDs,
remotesWithUUID,
2011-03-29 03:22:31 +00:00
remotesWithoutUUID,
2011-07-06 20:06:10 +00:00
keyPossibilities,
keyPossibilitiesTrusted,
nameToUUID,
showTriedRemotes,
showLocations,
forceTrust,
logStatus
) where
2011-03-29 03:22:31 +00:00
import qualified Data.Map as M
import Text.JSON
import Text.JSON.Generic
2011-10-05 20:02:51 +00:00
import Common.Annex
import Types.Remote
import qualified Annex
2011-03-29 22:28:37 +00:00
import Config
import Annex.UUID
2011-10-15 20:21:08 +00:00
import Logs.UUID
import Logs.Trust
import Logs.Location
import Logs.Remote
2011-03-29 18:55:59 +00:00
import qualified Remote.Git
import qualified Remote.S3
import qualified Remote.Bup
2011-03-30 17:18:46 +00:00
import qualified Remote.Directory
import qualified Remote.Rsync
import qualified Remote.Web
import qualified Remote.Hook
2011-12-31 08:11:39 +00:00
remoteTypes :: [RemoteType]
remoteTypes =
[ Remote.Git.remote
2011-03-29 03:51:07 +00:00
, Remote.S3.remote
, Remote.Bup.remote
, Remote.Directory.remote
, Remote.Rsync.remote
, Remote.Web.remote
, Remote.Hook.remote
2011-03-28 02:00:44 +00:00
]
{- Builds a list of all available Remotes.
2011-03-29 21:20:22 +00:00
- Since doing so can be expensive, the list is cached. -}
2011-12-31 08:11:39 +00:00
remoteList :: Annex [Remote]
2011-12-30 23:10:54 +00:00
remoteList = do
rs <- Annex.getState Annex.remotes
if null rs
then do
2011-03-29 21:57:20 +00:00
m <- readRemoteLog
l <- mapM (process m) remoteTypes
let rs' = concat l
2011-03-29 20:21:21 +00:00
Annex.changeState $ \s -> s { Annex.remotes = rs' }
return rs'
else return rs
2011-03-29 21:57:20 +00:00
where
2011-05-15 19:27:49 +00:00
process m t =
enumerate t >>=
mapM (gen m t)
2011-03-29 21:57:20 +00:00
gen m t r = do
2011-10-11 18:43:45 +00:00
u <- getRepoUUID r
2011-03-30 19:15:46 +00:00
generate t r u (M.lookup u m)
{- All remotes that are not ignored. -}
2011-12-31 08:11:39 +00:00
enabledRemoteList :: Annex [Remote]
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
{- Map of UUIDs of Remotes and their names. -}
remoteMap :: Annex (M.Map UUID String)
2011-12-30 23:10:54 +00:00
remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> remoteList
{- Map of UUIDs 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
addName :: String -> String -> String
addName desc n
| desc == n = desc
| null desc = n
| otherwise = n ++ " (" ++ desc ++ ")"
{- When a name is specified, looks up the remote matching that name.
- (Or it can be a UUID.) Only finds currently configured git remotes. -}
byName :: Maybe String -> Annex (Maybe Remote)
byName Nothing = return Nothing
byName (Just n) = do
res <- byName' n
case res of
Left e -> error e
Right r -> return $ Just r
2011-12-31 08:11:39 +00:00
byName' :: String -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified"
byName' n = do
2011-12-30 23:10:54 +00:00
match <- filter matching <$> remoteList
if null match
then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
else return $ Right $ Prelude.head match
where
matching r = n == name r || toUUID n == uuid r
{- Looks up a remote by name (or by UUID, or even by description),
- and returns its UUID. Finds even remotes that are not configured in
- .git/config. -}
nameToUUID :: String -> Annex UUID
2011-10-11 18:43:45 +00:00
nameToUUID "." = getUUID -- special case for current repo
nameToUUID "" = error "no remote specified"
2011-11-07 20:34:12 +00:00
nameToUUID n = byName' n >>= go
where
2011-11-07 20:34:12 +00:00
go (Right r) = return $ uuid r
go (Left e) = fromMaybe (error e) <$> bydescription
bydescription = do
m <- uuidMap
2011-11-07 20:34:12 +00:00
case M.lookup n $ transform swap m of
Just u -> return $ Just u
2011-11-07 20:34:12 +00:00
Nothing -> return $ byuuid m
byuuid m = M.lookup (toUUID n) $ transform double m
transform a = M.fromList . map a . M.toList
swap (a, b) = (b, a)
2011-11-07 20:34:12 +00:00
double (a, _) = (a, a)
{- Pretty-prints a list of UUIDs of remotes, for human display.
-
- Shows descriptions from the uuid log, falling back to remote names,
- as some remotes may not be in the uuid log.
-
- When JSON is enabled, also generates a machine-readable description
- of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs desc uuids = do
hereu <- getUUID
m <- uuidDescriptions
maybeShowJSON [(desc, map (jsonify m hereu) uuids)]
return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids
where
finddescription m u = M.findWithDefault "" u m
prettify m hereu u
| not (null d) = fromUUID u ++ " -- " ++ d
| otherwise = fromUUID u
where
ishere = hereu == u
n = finddescription m u
d
| null n && ishere = "here"
| ishere = addName n "here"
| otherwise = n
jsonify m hereu u = toJSObject
[ ("uuid", toJSON $ fromUUID u)
, ("description", toJSON $ finddescription m u)
, ("here", toJSON $ hereu == u)
]
{- 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
2011-10-15 20:21:08 +00:00
{- Cost ordered lists of remotes that the Logs.Location indicate 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 = fst <$> keyPossibilities' False key
2011-06-23 17:39:04 +00:00
2011-10-15 20:21:08 +00:00
{- Cost ordered lists of remotes that the Logs.Location indicate may have a key.
-
- Also returns a list of UUIDs that are trusted to have the key
- (some may not have configured remotes).
-}
2011-12-31 08:11:39 +00:00
keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
2011-06-23 19:30:04 +00:00
keyPossibilitiesTrusted = keyPossibilities' True
2011-12-31 08:11:39 +00:00
keyPossibilities' :: Bool -> Key -> Annex ([Remote], [UUID])
2011-06-23 19:30:04 +00:00
keyPossibilities' withtrusted key = do
2011-10-11 18:43:45 +00:00
u <- getUUID
2011-06-23 19:30:04 +00:00
trusted <- if withtrusted then trustGet Trusted else return []
-- get uuids of all remotes that are recorded to have the key
2011-06-22 20:13:43 +00:00
uuids <- keyLocations key
let validuuids = filter (/= u) uuids
-- note that validuuids is assumed to not have dups
2011-09-06 21:19:29 +00:00
let validtrusteduuids = validuuids `intersect` trusted
-- remotes that match uuids that have the key
allremotes <- enabledRemoteList
let validremotes = remotesWithUUID allremotes validuuids
return (sort validremotes, validtrusteduuids)
{- Displays known locations of a key. -}
showLocations :: Key -> [UUID] -> Annex ()
showLocations key exclude = do
2011-10-11 18:43:45 +00:00
u <- getUUID
uuids <- keyLocations key
untrusteduuids <- trustGet UnTrusted
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
ppuuidswanted <- Remote.prettyPrintUUIDs "wanted" uuidswanted
ppuuidsskipped <- Remote.prettyPrintUUIDs "skipped" uuidsskipped
showLongNote $ message ppuuidswanted ppuuidsskipped
where
filteruuids l x = filter (`notElem` x) l
message [] [] = "No other repository is known to contain the file."
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 ()
showTriedRemotes [] = return ()
showTriedRemotes remotes =
showLongNote $ "Unable to access these remotes: " ++
(join ", " $ map name remotes)
2011-06-02 06:33:31 +00:00
forceTrust :: TrustLevel -> String -> Annex ()
forceTrust level remotename = do
r <- nameToUUID remotename
2011-06-02 06:33:31 +00:00
Annex.changeState $ \s ->
s { Annex.forcetrust = (r, 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. -}
2011-12-31 08:11:39 +00:00
logStatus :: Remote -> Key -> Bool -> Annex ()
logStatus remote key present = logChange key (uuid remote) status
where
status = if present then InfoPresent else InfoMissing