prep for enabling remotre gcrypt repos in webapp
This commit is contained in:
parent
588494cbce
commit
735ed3b822
5 changed files with 83 additions and 48 deletions
|
@ -131,6 +131,13 @@ postAddSshR = sshConfigurator $ do
|
||||||
sshTestModal :: Widget
|
sshTestModal :: Widget
|
||||||
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
|
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
|
{- To enable an existing rsync special remote, parse the SshInput from
|
||||||
- its rsyncurl, and display a form whose only real purpose is to check
|
- 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
|
- if ssh public keys need to be set up. From there, we can proceed with
|
||||||
|
|
|
@ -24,6 +24,7 @@ import Logs.Trust
|
||||||
import Logs.Group
|
import Logs.Group
|
||||||
import Config
|
import Config
|
||||||
import Git.Config
|
import Git.Config
|
||||||
|
import Git.Remote
|
||||||
import Assistant.Sync
|
import Assistant.Sync
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import qualified Git
|
import qualified Git
|
||||||
|
@ -156,8 +157,9 @@ repoList reposelector
|
||||||
else return l
|
else return l
|
||||||
unconfigured = liftAnnex $ do
|
unconfigured = liftAnnex $ do
|
||||||
m <- readRemoteLog
|
m <- readRemoteLog
|
||||||
|
g <- gitRepo
|
||||||
map snd . catMaybes . filter selectedremote
|
map snd . catMaybes . filter selectedremote
|
||||||
. map (findinfo m)
|
. map (findinfo m g)
|
||||||
<$> (trustExclude DeadTrusted $ M.keys m)
|
<$> (trustExclude DeadTrusted $ M.keys m)
|
||||||
selectedrepo r
|
selectedrepo r
|
||||||
| Remote.readonly r = False
|
| Remote.readonly r = False
|
||||||
|
@ -167,7 +169,7 @@ repoList reposelector
|
||||||
selectedremote (Just (iscloud, _))
|
selectedremote (Just (iscloud, _))
|
||||||
| onlyCloud reposelector = iscloud
|
| onlyCloud reposelector = iscloud
|
||||||
| otherwise = True
|
| 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 "rsync" -> val True EnableRsyncR
|
||||||
Just "directory" -> val False EnableDirectoryR
|
Just "directory" -> val False EnableDirectoryR
|
||||||
#ifdef WITH_S3
|
#ifdef WITH_S3
|
||||||
|
@ -177,8 +179,16 @@ repoList reposelector
|
||||||
#ifdef WITH_WEBDAV
|
#ifdef WITH_WEBDAV
|
||||||
Just "webdav" -> val True EnableWebDAVR
|
Just "webdav" -> val True EnableWebDAVR
|
||||||
#endif
|
#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
|
_ -> Nothing
|
||||||
where
|
where
|
||||||
|
getconfig k = M.lookup k =<< M.lookup u m
|
||||||
val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
|
val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
|
||||||
list l = liftAnnex $ do
|
list l = liftAnnex $ do
|
||||||
let l' = nubBy (\x y -> fst x == fst y) l
|
let l' = nubBy (\x y -> fst x == fst y) l
|
||||||
|
|
|
@ -65,6 +65,7 @@
|
||||||
/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET
|
/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET
|
||||||
|
|
||||||
/config/repository/enable/rsync/#UUID EnableRsyncR GET POST
|
/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/directory/#UUID EnableDirectoryR GET
|
||||||
/config/repository/enable/S3/#UUID EnableS3R GET POST
|
/config/repository/enable/S3/#UUID EnableS3R GET POST
|
||||||
/config/repository/enable/IA/#UUID EnableIAR GET POST
|
/config/repository/enable/IA/#UUID EnableIAR GET POST
|
||||||
|
|
|
@ -23,8 +23,6 @@ module Git.Construct (
|
||||||
checkForRepo,
|
checkForRepo,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
|
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
import System.Posix.User
|
import System.Posix.User
|
||||||
#else
|
#else
|
||||||
|
@ -36,6 +34,7 @@ import Network.URI
|
||||||
import Common
|
import Common
|
||||||
import Git.Types
|
import Git.Types
|
||||||
import Git
|
import Git
|
||||||
|
import Git.Remote
|
||||||
import qualified Git.Url as Url
|
import qualified Git.Url as Url
|
||||||
import Utility.UserInfo
|
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
|
{- Constructs a new Repo for one of a Repo's remotes using a given
|
||||||
- location (ie, an url). -}
|
- location (ie, an url). -}
|
||||||
fromRemoteLocation :: String -> Repo -> IO Repo
|
fromRemoteLocation :: String -> Repo -> IO Repo
|
||||||
fromRemoteLocation s repo = gen $ calcloc s
|
fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
|
||||||
where
|
where
|
||||||
gen v
|
gen (RemotePath p) = fromRemotePath p repo
|
||||||
#ifdef mingw32_HOST_OS
|
gen (RemoteUrl u) = fromUrl u
|
||||||
| 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
|
|
||||||
|
|
||||||
{- Constructs a Repo from the path specified in the git remotes of
|
{- Constructs a Repo from the path specified in the git remotes of
|
||||||
- another Repo. -}
|
- another Repo. -}
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
|
||||||
module Git.Remote where
|
module Git.Remote where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
|
@ -13,6 +15,8 @@ import qualified Git.Command
|
||||||
import qualified Git.BuildVersion
|
import qualified Git.BuildVersion
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import Network.URI
|
||||||
|
|
||||||
type RemoteName = String
|
type RemoteName = String
|
||||||
|
|
||||||
|
@ -48,3 +52,58 @@ remove remotename = Git.Command.run
|
||||||
else "remove"
|
else "remove"
|
||||||
, Param remotename
|
, 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
|
||||||
|
|
Loading…
Reference in a new issue