2011-03-27 19:56:43 +00:00
|
|
|
{- git-annex remotes
|
|
|
|
-
|
|
|
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
module Remote (
|
2011-03-27 21:12:32 +00:00
|
|
|
Remote,
|
|
|
|
uuid,
|
|
|
|
name,
|
|
|
|
storeKey,
|
|
|
|
retrieveKeyFile,
|
|
|
|
removeKey,
|
|
|
|
hasKey,
|
|
|
|
hasKeyCheap,
|
2011-06-01 23:10:38 +00:00
|
|
|
keyPossibilities,
|
2011-06-23 17:39:04 +00:00
|
|
|
keyPossibilitiesTrusted,
|
2011-06-02 06:33:31 +00:00
|
|
|
forceTrust,
|
2011-03-27 21:12:32 +00:00
|
|
|
|
2011-03-29 18:55:59 +00:00
|
|
|
remoteTypes,
|
2011-06-01 21:49:37 +00:00
|
|
|
genList,
|
2011-03-27 20:55:43 +00:00
|
|
|
byName,
|
|
|
|
nameToUUID,
|
2011-03-27 19:56:43 +00:00
|
|
|
remotesWithUUID,
|
2011-03-29 03:22:31 +00:00
|
|
|
remotesWithoutUUID,
|
2011-07-01 19:24:07 +00:00
|
|
|
prettyPrintUUIDs,
|
2011-03-29 03:22:31 +00:00
|
|
|
|
2011-03-29 18:55:59 +00:00
|
|
|
remoteLog,
|
2011-03-29 17:49:54 +00:00
|
|
|
readRemoteLog,
|
2011-03-29 03:22:31 +00:00
|
|
|
configSet,
|
2011-05-16 17:07:56 +00:00
|
|
|
keyValToConfig,
|
|
|
|
configToKeyVal,
|
|
|
|
|
|
|
|
prop_idempotent_configEscape
|
2011-03-27 19:56:43 +00:00
|
|
|
) where
|
|
|
|
|
2011-07-01 19:24:07 +00:00
|
|
|
import Control.Monad (filterM, liftM2)
|
2011-03-27 19:56:43 +00:00
|
|
|
import Data.List
|
2011-03-29 03:22:31 +00:00
|
|
|
import qualified Data.Map as M
|
|
|
|
import Data.Maybe
|
2011-05-16 17:07:56 +00:00
|
|
|
import Data.Char
|
2011-03-27 19:56:43 +00:00
|
|
|
|
2011-06-22 21:08:51 +00:00
|
|
|
import qualified Branch
|
2011-03-27 19:56:43 +00:00
|
|
|
import Types
|
2011-06-02 01:56:04 +00:00
|
|
|
import Types.Remote
|
2011-03-27 19:56:43 +00:00
|
|
|
import UUID
|
|
|
|
import qualified Annex
|
2011-03-29 22:28:37 +00:00
|
|
|
import Config
|
2011-06-01 23:10:38 +00:00
|
|
|
import Trust
|
|
|
|
import LocationLog
|
2011-03-29 18:55:59 +00:00
|
|
|
|
|
|
|
import qualified Remote.Git
|
|
|
|
import qualified Remote.S3
|
2011-04-08 20:44:43 +00:00
|
|
|
import qualified Remote.Bup
|
2011-03-30 17:18:46 +00:00
|
|
|
import qualified Remote.Directory
|
2011-04-28 00:06:07 +00:00
|
|
|
import qualified Remote.Rsync
|
2011-07-01 19:24:07 +00:00
|
|
|
import qualified Remote.Web
|
2011-04-28 21:21:45 +00:00
|
|
|
import qualified Remote.Hook
|
2011-03-27 19:56:43 +00:00
|
|
|
|
2011-03-29 03:51:07 +00:00
|
|
|
remoteTypes :: [RemoteType Annex]
|
|
|
|
remoteTypes =
|
|
|
|
[ Remote.Git.remote
|
|
|
|
, Remote.S3.remote
|
2011-04-08 20:44:43 +00:00
|
|
|
, Remote.Bup.remote
|
2011-03-30 17:18:46 +00:00
|
|
|
, Remote.Directory.remote
|
2011-04-28 00:06:07 +00:00
|
|
|
, Remote.Rsync.remote
|
2011-07-01 19:24:07 +00:00
|
|
|
, Remote.Web.remote
|
2011-04-28 21:21:45 +00:00
|
|
|
, Remote.Hook.remote
|
2011-03-28 02:00:44 +00:00
|
|
|
]
|
2011-03-27 19:56:43 +00:00
|
|
|
|
2011-03-27 20:24:46 +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-03-27 20:24:46 +00:00
|
|
|
genList :: Annex [Remote Annex]
|
|
|
|
genList = 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' }
|
2011-03-27 20:24:46 +00:00
|
|
|
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 >>=
|
|
|
|
filterM remoteNotIgnored >>=
|
|
|
|
mapM (gen m t)
|
2011-03-29 21:57:20 +00:00
|
|
|
gen m t r = do
|
|
|
|
u <- getUUID r
|
2011-03-30 19:15:46 +00:00
|
|
|
generate t r u (M.lookup u m)
|
2011-03-27 19:56:43 +00:00
|
|
|
|
2011-03-27 20:55:43 +00:00
|
|
|
{- Looks up a remote by name. (Or by UUID.) -}
|
|
|
|
byName :: String -> Annex (Remote Annex)
|
|
|
|
byName n = do
|
2011-06-14 02:19:44 +00:00
|
|
|
res <- byName' n
|
|
|
|
case res of
|
|
|
|
Left e -> error e
|
|
|
|
Right r -> return r
|
|
|
|
byName' :: String -> Annex (Either String (Remote Annex))
|
|
|
|
byName' "" = return $ Left "no remote specified"
|
|
|
|
byName' n = do
|
2011-03-27 20:55:43 +00:00
|
|
|
allremotes <- genList
|
|
|
|
let match = filter matching allremotes
|
2011-06-14 02:19:44 +00:00
|
|
|
if (null match)
|
|
|
|
then return $ Left $ "there is no git remote named \"" ++ n ++ "\""
|
|
|
|
else return $ Right $ head match
|
2011-03-27 20:55:43 +00:00
|
|
|
where
|
|
|
|
matching r = n == name r || n == uuid r
|
2011-03-27 19:56:43 +00:00
|
|
|
|
2011-06-14 02:19:44 +00:00
|
|
|
{- Looks up a remote by name (or by UUID, or even by description),
|
|
|
|
- and returns its UUID. -}
|
2011-03-27 20:55:43 +00:00
|
|
|
nameToUUID :: String -> Annex UUID
|
2011-05-15 19:27:49 +00:00
|
|
|
nameToUUID "." = getUUID =<< Annex.gitRepo -- special case for current repo
|
2011-06-14 02:19:44 +00:00
|
|
|
nameToUUID n = do
|
|
|
|
res <- byName' n
|
|
|
|
case res of
|
|
|
|
Left e -> return . (maybe (error e) id) =<< byDescription
|
|
|
|
Right r -> return $ uuid r
|
|
|
|
where
|
|
|
|
byDescription = return . M.lookup n . invertMap =<< uuidMap
|
|
|
|
invertMap = M.fromList . map swap . M.toList
|
|
|
|
swap (a, b) = (b, a)
|
2011-03-27 19:56:43 +00:00
|
|
|
|
2011-07-01 19:24:07 +00:00
|
|
|
{- Pretty-prints a list of UUIDs of remotes. -}
|
|
|
|
prettyPrintUUIDs :: [UUID] -> Annex String
|
|
|
|
prettyPrintUUIDs uuids = do
|
|
|
|
here <- getUUID =<< Annex.gitRepo
|
|
|
|
-- Show descriptions from the uuid log, falling back to remote names,
|
|
|
|
-- as some remotes may not be in the uuid log.
|
|
|
|
m <- liftM2 M.union uuidMap $
|
|
|
|
return . M.fromList . map (\r -> (uuid r, name r)) =<< genList
|
|
|
|
return $ unwords $ map (\u -> "\t" ++ prettify m u here ++ "\n") uuids
|
|
|
|
where
|
|
|
|
prettify m u here = base ++ ishere
|
|
|
|
where
|
|
|
|
base = if not $ null $ findlog m u
|
|
|
|
then u ++ " -- " ++ findlog m u
|
|
|
|
else u
|
|
|
|
ishere = if here == u then " <-- here" else ""
|
|
|
|
findlog m u = M.findWithDefault "" u m
|
|
|
|
|
2011-03-27 20:55:43 +00:00
|
|
|
{- Filters a list of remotes to ones that have the listed uuids. -}
|
|
|
|
remotesWithUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
|
|
|
|
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
|
|
|
|
|
|
|
|
{- Filters a list of remotes to ones that do not have the listed uuids. -}
|
|
|
|
remotesWithoutUUID :: [Remote Annex] -> [UUID] -> [Remote Annex]
|
|
|
|
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
|
|
|
|
|
2011-06-23 17:39:04 +00:00
|
|
|
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
|
|
|
|
-}
|
|
|
|
keyPossibilities :: Key -> Annex [Remote Annex]
|
2011-06-23 19:30:04 +00:00
|
|
|
keyPossibilities key = return . fst =<< keyPossibilities' False key
|
2011-06-23 17:39:04 +00:00
|
|
|
|
2011-06-01 23:10:38 +00:00
|
|
|
{- Cost ordered lists of remotes that the LocationLog 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-06-23 17:39:04 +00:00
|
|
|
keyPossibilitiesTrusted :: Key -> Annex ([Remote Annex], [UUID])
|
2011-06-23 19:30:04 +00:00
|
|
|
keyPossibilitiesTrusted = keyPossibilities' True
|
|
|
|
|
|
|
|
keyPossibilities' :: Bool -> Key -> Annex ([Remote Annex], [UUID])
|
|
|
|
keyPossibilities' withtrusted key = do
|
2011-06-01 23:10:38 +00:00
|
|
|
g <- Annex.gitRepo
|
|
|
|
u <- getUUID g
|
2011-06-23 19:30:04 +00:00
|
|
|
trusted <- if withtrusted then trustGet Trusted else return []
|
2011-06-01 23:10:38 +00:00
|
|
|
|
|
|
|
-- get uuids of all remotes that are recorded to have the key
|
2011-06-22 20:13:43 +00:00
|
|
|
uuids <- keyLocations key
|
2011-06-01 23:10:38 +00:00
|
|
|
let validuuids = filter (/= u) uuids
|
|
|
|
|
|
|
|
-- note that validuuids is assumed to not have dups
|
|
|
|
let validtrusteduuids = intersect validuuids trusted
|
|
|
|
|
|
|
|
-- remotes that match uuids that have the key
|
|
|
|
allremotes <- genList
|
|
|
|
let validremotes = remotesWithUUID allremotes validuuids
|
|
|
|
|
|
|
|
return (sort validremotes, validtrusteduuids)
|
|
|
|
|
2011-06-02 06:33:31 +00:00
|
|
|
forceTrust :: TrustLevel -> String -> Annex ()
|
|
|
|
forceTrust level remotename = do
|
|
|
|
r <- Remote.nameToUUID remotename
|
|
|
|
Annex.changeState $ \s ->
|
|
|
|
s { Annex.forcetrust = (r, level):Annex.forcetrust s }
|
2011-06-01 23:10:38 +00:00
|
|
|
|
2011-03-29 03:22:31 +00:00
|
|
|
{- Filename of remote.log. -}
|
2011-06-22 21:08:51 +00:00
|
|
|
remoteLog :: FilePath
|
|
|
|
remoteLog = "remote.log"
|
2011-03-29 03:22:31 +00:00
|
|
|
|
2011-03-29 17:49:54 +00:00
|
|
|
{- Adds or updates a remote's config in the log. -}
|
2011-04-15 19:09:36 +00:00
|
|
|
configSet :: UUID -> RemoteConfig -> Annex ()
|
2011-03-29 17:49:54 +00:00
|
|
|
configSet u c = do
|
|
|
|
m <- readRemoteLog
|
2011-06-22 21:08:51 +00:00
|
|
|
Branch.change remoteLog $ unlines $ sort $
|
2011-03-29 18:55:59 +00:00
|
|
|
map toline $ M.toList $ M.insert u c m
|
2011-03-29 03:22:31 +00:00
|
|
|
where
|
2011-04-15 19:09:36 +00:00
|
|
|
toline (u', c') = u' ++ " " ++ (unwords $ configToKeyVal c')
|
2011-03-29 03:22:31 +00:00
|
|
|
|
2011-03-29 17:49:54 +00:00
|
|
|
{- Map of remotes by uuid containing key/value config maps. -}
|
2011-04-15 19:09:36 +00:00
|
|
|
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
|
2011-06-22 21:08:51 +00:00
|
|
|
readRemoteLog = return . remoteLogParse =<< Branch.get remoteLog
|
2011-03-29 03:22:31 +00:00
|
|
|
|
2011-04-15 19:09:36 +00:00
|
|
|
remoteLogParse :: String -> M.Map UUID RemoteConfig
|
2011-03-29 17:49:54 +00:00
|
|
|
remoteLogParse s =
|
|
|
|
M.fromList $ catMaybes $ map parseline $ filter (not . null) $ lines s
|
2011-03-29 03:22:31 +00:00
|
|
|
where
|
|
|
|
parseline l
|
2011-03-29 17:49:54 +00:00
|
|
|
| length w > 2 = Just (u, c)
|
2011-03-29 03:22:31 +00:00
|
|
|
| otherwise = Nothing
|
|
|
|
where
|
|
|
|
w = words l
|
|
|
|
u = w !! 0
|
2011-04-15 19:09:36 +00:00
|
|
|
c = keyValToConfig $ tail w
|
2011-03-29 03:22:31 +00:00
|
|
|
|
2011-04-15 19:09:36 +00:00
|
|
|
{- Given Strings like "key=value", generates a RemoteConfig. -}
|
|
|
|
keyValToConfig :: [String] -> RemoteConfig
|
|
|
|
keyValToConfig ws = M.fromList $ map (/=/) ws
|
2011-03-29 03:22:31 +00:00
|
|
|
where
|
|
|
|
(/=/) s = (k, v)
|
|
|
|
where
|
|
|
|
k = takeWhile (/= '=') s
|
2011-05-16 17:07:56 +00:00
|
|
|
v = configUnEscape $ drop (1 + length k) s
|
2011-03-29 03:22:31 +00:00
|
|
|
|
2011-04-15 19:09:36 +00:00
|
|
|
configToKeyVal :: M.Map String String -> [String]
|
|
|
|
configToKeyVal m = map toword $ sort $ M.toList m
|
2011-03-29 03:22:31 +00:00
|
|
|
where
|
2011-05-16 17:07:56 +00:00
|
|
|
toword (k, v) = k ++ "=" ++ configEscape v
|
|
|
|
|
|
|
|
configEscape :: String -> String
|
2011-05-16 19:01:05 +00:00
|
|
|
configEscape = (>>= escape)
|
2011-05-16 17:07:56 +00:00
|
|
|
where
|
|
|
|
escape c
|
|
|
|
| isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";"
|
|
|
|
| otherwise = [c]
|
|
|
|
|
|
|
|
configUnEscape :: String -> String
|
|
|
|
configUnEscape = unescape
|
|
|
|
where
|
|
|
|
unescape [] = []
|
|
|
|
unescape (c:rest)
|
|
|
|
| c == '&' = entity rest
|
|
|
|
| otherwise = c : unescape rest
|
|
|
|
entity s = if ok
|
|
|
|
then chr (read num) : unescape rest
|
|
|
|
else '&' : unescape s
|
|
|
|
where
|
|
|
|
num = takeWhile isNumber s
|
|
|
|
r = drop (length num) s
|
|
|
|
rest = drop 1 r
|
|
|
|
ok = not (null num) &&
|
|
|
|
not (null r) && r !! 0 == ';'
|
|
|
|
|
|
|
|
{- for quickcheck -}
|
|
|
|
prop_idempotent_configEscape :: String -> Bool
|
|
|
|
prop_idempotent_configEscape s = s == (configUnEscape $ configEscape s)
|