diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 1587d0c4cb..a9a8ea7bc0 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -131,6 +131,13 @@ postAddSshR = sshConfigurator $ do sshTestModal :: Widget sshTestModal = $(widgetFile "configurators/ssh/testmodal") +{- This only handles gcrypt repositories that are located on ssh servers; + - ones on local drives are handled via another part of the UI. -} +getEnableGCryptR :: UUID -> Handler Html +getEnableGCryptR = postEnableGCryptR +postEnableGCryptR :: UUID -> Handler Html +postEnableGCryptR u = error "TODO" + {- To enable an existing rsync special remote, parse the SshInput from - its rsyncurl, and display a form whose only real purpose is to check - if ssh public keys need to be set up. From there, we can proceed with diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index 9b90a4d563..4e5c4fea73 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -24,6 +24,7 @@ import Logs.Trust import Logs.Group import Config import Git.Config +import Git.Remote import Assistant.Sync import Config.Cost import qualified Git @@ -156,8 +157,9 @@ repoList reposelector else return l unconfigured = liftAnnex $ do m <- readRemoteLog + g <- gitRepo map snd . catMaybes . filter selectedremote - . map (findinfo m) + . map (findinfo m g) <$> (trustExclude DeadTrusted $ M.keys m) selectedrepo r | Remote.readonly r = False @@ -167,7 +169,7 @@ repoList reposelector selectedremote (Just (iscloud, _)) | onlyCloud reposelector = iscloud | otherwise = True - findinfo m u = case M.lookup "type" =<< M.lookup u m of + findinfo m g u = case getconfig "type" of Just "rsync" -> val True EnableRsyncR Just "directory" -> val False EnableDirectoryR #ifdef WITH_S3 @@ -177,8 +179,16 @@ repoList reposelector #ifdef WITH_WEBDAV Just "webdav" -> val True EnableWebDAVR #endif + Just "gcrypt" -> + -- Skip gcrypt repos on removable drives; + -- handled separately. + case getconfig "gitrepo" of + Just rr | remoteLocationIsUrl (parseRemoteLocation rr g) -> + val True EnableGCryptR + _ -> Nothing _ -> Nothing where + getconfig k = M.lookup k =<< M.lookup u m val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) list l = liftAnnex $ do let l' = nubBy (\x y -> fst x == fst y) l diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index cab76ab6cc..270213e8db 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -65,6 +65,7 @@ /config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET /config/repository/enable/rsync/#UUID EnableRsyncR GET POST +/config/repository/enable/gcrypt/#UUID EnableGCryptR GET POST /config/repository/enable/directory/#UUID EnableDirectoryR GET /config/repository/enable/S3/#UUID EnableS3R GET POST /config/repository/enable/IA/#UUID EnableIAR GET POST diff --git a/Git/Construct.hs b/Git/Construct.hs index 35c77e9d2a..377ddeeaeb 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -23,8 +23,6 @@ module Git.Construct ( checkForRepo, ) where -{-# LANGUAGE CPP #-} - #ifndef mingw32_HOST_OS import System.Posix.User #else @@ -36,6 +34,7 @@ import Network.URI import Common import Git.Types import Git +import Git.Remote import qualified Git.Url as Url import Utility.UserInfo @@ -143,51 +142,10 @@ remoteNamedFromKey k = remoteNamed basename {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} fromRemoteLocation :: String -> Repo -> IO Repo -fromRemoteLocation s repo = gen $ calcloc s +fromRemoteLocation s repo = gen $ parseRemoteLocation s repo where - gen v -#ifdef mingw32_HOST_OS - | dosstyle v = fromRemotePath (dospath v) repo -#endif - | scpstyle v = fromUrl $ scptourl v - | urlstyle v = fromUrl v - | otherwise = fromRemotePath v repo - -- insteadof config can rewrite remote location - calcloc l - | null insteadofs = l - | otherwise = replacement ++ drop (length bestvalue) l - where - replacement = drop (length prefix) $ - take (length bestkey - length suffix) bestkey - (bestkey, bestvalue) = maximumBy longestvalue insteadofs - longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(k, v) -> - startswith prefix k && - endswith suffix k && - startswith v l - filterconfig f = filter f $ - concatMap splitconfigs $ M.toList $ fullconfig repo - splitconfigs (k, vs) = map (\v -> (k, v)) vs - (prefix, suffix) = ("url." , ".insteadof") - urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v - -- git remotes can be written scp style -- [user@]host:dir - -- but foo::bar is a git-remote-helper location instead - scpstyle v = ":" `isInfixOf` v - && not ("//" `isInfixOf` v) - && not ("::" `isInfixOf` v) - scptourl v = "ssh://" ++ host ++ slash dir - where - (host, dir) = separate (== ':') v - slash d | d == "" = "/~/" ++ d - | "/" `isPrefixOf` d = d - | "~" `isPrefixOf` d = '/':d - | otherwise = "/~/" ++ d -#ifdef mingw32_HOST_OS - -- git on Windows will write a path to .git/config with "drive:", - -- which is not to be confused with a "host:" - dosstyle = hasDrive - dospath = fromInternalGitPath -#endif + gen (RemotePath p) = fromRemotePath p repo + gen (RemoteUrl u) = fromUrl u {- Constructs a Repo from the path specified in the git remotes of - another Repo. -} diff --git a/Git/Remote.hs b/Git/Remote.hs index e853e53cba..3dc6d9e450 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Git.Remote where import Common @@ -13,6 +15,8 @@ import qualified Git.Command import qualified Git.BuildVersion import Data.Char +import qualified Data.Map as M +import Network.URI type RemoteName = String @@ -48,3 +52,58 @@ remove remotename = Git.Command.run else "remove" , Param remotename ] + +data RemoteLocation = RemoteUrl String | RemotePath FilePath + +remoteLocationIsUrl :: RemoteLocation -> Bool +remoteLocationIsUrl (RemoteUrl _) = True +remoteLocationIsUrl _ = False + +{- Determines if a given remote location is an url, or a local + - path. Takes the repository's insteadOf configuration into account. -} +parseRemoteLocation :: String -> Repo -> RemoteLocation +parseRemoteLocation s repo = ret $ calcloc s + where + ret v +#ifdef mingw32_HOST_OS + | dosstyle v = RemotePath (dospath v) +#endif + | scpstyle v = RemoteUrl (scptourl v) + | urlstyle v = RemoteUrl v + | otherwise = RemotePath v + -- insteadof config can rewrite remote location + calcloc l + | null insteadofs = l + | otherwise = replacement ++ drop (length bestvalue) l + where + replacement = drop (length prefix) $ + take (length bestkey - length suffix) bestkey + (bestkey, bestvalue) = maximumBy longestvalue insteadofs + longestvalue (_, a) (_, b) = compare b a + insteadofs = filterconfig $ \(k, v) -> + startswith prefix k && + endswith suffix k && + startswith v l + filterconfig f = filter f $ + concatMap splitconfigs $ M.toList $ fullconfig repo + splitconfigs (k, vs) = map (\v -> (k, v)) vs + (prefix, suffix) = ("url." , ".insteadof") + urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v + -- git remotes can be written scp style -- [user@]host:dir + -- but foo::bar is a git-remote-helper location instead + scpstyle v = ":" `isInfixOf` v + && not ("//" `isInfixOf` v) + && not ("::" `isInfixOf` v) + scptourl v = "ssh://" ++ host ++ slash dir + where + (host, dir) = separate (== ':') v + slash d | d == "" = "/~/" ++ d + | "/" `isPrefixOf` d = d + | "~" `isPrefixOf` d = '/':d + | otherwise = "/~/" ++ d +#ifdef mingw32_HOST_OS + -- git on Windows will write a path to .git/config with "drive:", + -- which is not to be confused with a "host:" + dosstyle = hasDrive + dospath = fromInternalGitPath +#endif