mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

webapp can now set up gcrypt repos on ssh servers

Browse source
This commit is contained in:
Joey Hess 2013-10-01 13:43:35 -04:00
parent d83a244986
commit 61e06c972f
5 changed files with 87 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

16
Assistant/MakeRemote.hs
View file

@ -27,20 +27,18 @@ import Utility.Gpg (KeyId)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
{- Sets up a new ssh or rsync remote. -} {- Sets up a new git or rsync remote, accessed over ssh. -}
makeSshRemote :: Bool -> SshData -> Annex RemoteName makeSshRemote :: SshData -> Annex RemoteName
makeSshRemote forcersync sshdata = makeSshRemote sshdata = maker (sshRepoName sshdata) (sshUrl sshdata)
maker (sshRepoName sshdata) (sshUrl forcersync sshdata)
where where
rsync = forcersync || sshCapabilities sshdata == [RsyncCapable]
maker maker
| rsync = makeRsyncRemote | onlyCapability sshdata RsyncCapable = makeRsyncRemote
| otherwise = makeGitRemote | otherwise = makeGitRemote
{- Generates a ssh or rsync url from a SshData. -} {- Generates a ssh or rsync url from a SshData. -}
sshUrl :: Bool -> SshData -> String sshUrl :: SshData -> String
sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $ sshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $
if (forcersync || sshCapabilities sshdata == [RsyncCapable]) if (onlyCapability sshdata RsyncCapable)
then [u, h, T.pack ":", sshDirectory sshdata] then [u, h, T.pack ":", sshDirectory sshdata]
else [T.pack "ssh://", u, h, d] else [T.pack "ssh://", u, h, d]
where where

4
Assistant/Pairing/MakeRemote.hs
View file

@ -24,7 +24,7 @@ import qualified Data.Text as T
setupAuthorizedKeys :: PairMsg -> FilePath -> IO () setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = do setupAuthorizedKeys msg repodir = do
validateSshPubKey pubkey validateSshPubKey pubkey
unlessM (liftIO $ addAuthorizedKeys False repodir pubkey) $ unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
error "failed setting up ssh authorized keys" error "failed setting up ssh authorized keys"
where where
pubkey = remoteSshPubKey $ pairMsgData msg pubkey = remoteSshPubKey $ pairMsgData msg
@ -45,7 +45,7 @@ finishedLocalPairing msg keypair = do
, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) , "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
] ]
Nothing Nothing
r <- liftAnnex $ addRemote $ makeSshRemote False sshdata r <- liftAnnex $ addRemote $ makeSshRemote sshdata
liftAnnex $ setRemoteCost r semiExpensiveRemoteCost liftAnnex $ setRemoteCost r semiExpensiveRemoteCost
syncRemote r syncRemote r

21
Assistant/Ssh.hs
View file

@ -35,6 +35,9 @@ data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
hasCapability :: SshData -> SshServerCapability -> Bool hasCapability :: SshData -> SshServerCapability -> Bool
hasCapability d c = c `elem` sshCapabilities d hasCapability d c = c `elem` sshCapabilities d
onlyCapability :: SshData -> SshServerCapability -> Bool
onlyCapability d c = all (== c) (sshCapabilities d)
data SshKeyPair = SshKeyPair data SshKeyPair = SshKeyPair
{ sshPubKey :: String { sshPubKey :: String
, sshPrivKey :: String , sshPrivKey :: String
@ -98,12 +101,12 @@ validateSshPubKey pubkey
safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.' safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
addAuthorizedKeys rsynconly dir pubkey = boolSystem "sh" addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
[ Param "-c" , Param $ addAuthorizedKeysCommand rsynconly dir pubkey ] [ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO () removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
removeAuthorizedKeys rsynconly dir pubkey = do removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine rsynconly dir pubkey let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir sshdir <- sshDir
let keyfile = sshdir </> "authorized_keys" let keyfile = sshdir </> "authorized_keys"
ls <- lines <$> readFileStrict keyfile ls <- lines <$> readFileStrict keyfile
@ -116,7 +119,7 @@ removeAuthorizedKeys rsynconly dir pubkey = do
- present. - present.
-} -}
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&" addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
[ "mkdir -p ~/.ssh" [ "mkdir -p ~/.ssh"
, intercalate "; " , intercalate "; "
[ "if [ ! -e " ++ wrapper ++ " ]" [ "if [ ! -e " ++ wrapper ++ " ]"
@ -128,7 +131,7 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
, "chmod 600 ~/.ssh/authorized_keys" , "chmod 600 ~/.ssh/authorized_keys"
, unwords , unwords
[ "echo" [ "echo"
, shellEscape $ authorizedKeysLine rsynconly dir pubkey , shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
, ">>~/.ssh/authorized_keys" , ">>~/.ssh/authorized_keys"
] ]
] ]
@ -147,11 +150,11 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
runshell var = "exec git-annex-shell -c \"" ++ var ++ "\"" runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
authorizedKeysLine rsynconly dir pubkey authorizedKeysLine gitannexshellonly dir pubkey
| gitannexshellonly = limitcommand ++ pubkey
{- TODO: Locking down rsync is difficult, requiring a rather {- TODO: Locking down rsync is difficult, requiring a rather
- long perl script. -} - long perl script. -}
| rsynconly = pubkey | otherwise = pubkey
| otherwise = limitcommand ++ pubkey
where where
limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding " limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "

2
Assistant/WebApp/Configurators/Pairing.hs
View file

@ -152,7 +152,7 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
where where
alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
setup repodir = setupAuthorizedKeys msg repodir setup repodir = setupAuthorizedKeys msg repodir
cleanup repodir = removeAuthorizedKeys False repodir $ cleanup repodir = removeAuthorizedKeys True repodir $
remoteSshPubKey $ pairMsgData msg remoteSshPubKey $ pairMsgData msg
uuid = Just $ pairUUID $ pairMsgData msg uuid = Just $ pairUUID $ pairMsgData msg
#else #else

114
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -1,6 +1,6 @@
{- git-annex assistant webapp configurator for ssh-based remotes {- git-annex assistant webapp configurator for ssh-based remotes
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -147,16 +147,19 @@ getEnableGCryptR :: UUID -> Handler Html
getEnableGCryptR = postEnableGCryptR getEnableGCryptR = postEnableGCryptR
postEnableGCryptR :: UUID -> Handler Html postEnableGCryptR :: UUID -> Handler Html
postEnableGCryptR u = whenGcryptInstalled $ postEnableGCryptR u = whenGcryptInstalled $
enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablersync u enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablegcrypt u
where where
enablersync sshdata = error "TODO enable ssh gcrypt remote" enablegcrypt sshdata = prepSsh True sshdata $ \sshdata' ->
sshConfigurator $
checkExistingGCrypt sshdata' $
error "Expected to find an encrypted git repository, but did not."
{- To enable an special remote that uses ssh as its transport, {- To enable an special remote that uses ssh as its transport,
- parse a config key to get its url, and display a form whose - parse a config key to get its url, and display a form whose
- only real purpose is to check if ssh public keys need to be - only real purpose is to check if ssh public keys need to be
- set up. - set up.
-} -}
enableSpecialSshRemote :: RemoteConfigKey -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> Handler ()) -> UUID -> Handler Html enableSpecialSshRemote :: RemoteConfigKey -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> Handler Html) -> UUID -> Handler Html
enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (parseSshRsyncUrl =<< M.lookup urlkey m, M.lookup "name" m) of case (parseSshRsyncUrl =<< M.lookup urlkey m, M.lookup "name" m) of
@ -171,7 +174,7 @@ enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do
s <- liftIO $ testServer sshinput' s <- liftIO $ testServer sshinput'
case s of case s of
Left status -> showform form enctype status Left status -> showform form enctype status
Right sshdata -> liftH $ genericsetup sshdata Right sshdata -> void $ liftH $ genericsetup sshdata
{ sshRepoName = reponame } { sshRepoName = reponame }
_ -> showform form enctype UntestedServer _ -> showform form enctype UntestedServer
_ -> redirect AddSshR _ -> redirect AddSshR
@ -300,29 +303,58 @@ getRetrySshR sshdata = do
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
getMakeSshGitR :: SshData -> Handler Html getMakeSshGitR :: SshData -> Handler Html
getMakeSshGitR = makeSsh False getMakeSshGitR sshdata = prepSsh False sshdata makeSshRepo
getMakeSshRsyncR :: SshData -> Handler Html getMakeSshRsyncR :: SshData -> Handler Html
getMakeSshRsyncR = makeSsh True getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo
rsyncOnly :: SshData -> SshData
rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }
getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
getMakeSshGCryptR sshdata repokey = error "TODO" getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
prepSsh True sshdata $ makeGCryptRepo keyid
{- Detect if the user entered a location with an existing, known
- gcrypt repository, and enable it. Otherwise, runs the action. -}
checkExistingGCrypt :: SshData -> Widget -> Widget
checkExistingGCrypt sshdata nope = ifM (liftIO isGcryptInstalled)
( checkGCryptRepoEncryption repourl nope $ do
mu <- liftAnnex $ probeGCryptRemoteUUID repourl
case mu of
Just u -> do
reponame <- liftAnnex $ getGCryptRemoteName u repourl
void $ liftH $ enableGCrypt sshdata reponame
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
, nope
)
where
repourl = sshUrl sshdata
makeSsh :: Bool -> SshData -> Handler Html {- Enables an existing gcrypt special remote. -}
makeSsh rsync sshdata enableGCrypt :: SshData -> RemoteName -> Handler Html
enableGCrypt sshdata reponame =
setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote $ M.fromList
[("gitrepo", sshUrl sshdata)]
{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
prepSsh gcrypt sshdata a
| needsPubKey sshdata = do | needsPubKey sshdata = do
keypair <- liftIO genSshKeyPair keypair <- liftIO genSshKeyPair
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
makeSsh' rsync sshdata sshdata' (Just keypair) prepSsh' gcrypt sshdata sshdata' (Just keypair) a
| sshPort sshdata /= 22 = do | sshPort sshdata /= 22 = do
sshdata' <- liftIO $ setSshConfig sshdata [] sshdata' <- liftIO $ setSshConfig sshdata []
makeSsh' rsync sshdata sshdata' Nothing prepSsh' gcrypt sshdata sshdata' Nothing a
| otherwise = makeSsh' rsync sshdata sshdata Nothing | otherwise = prepSsh' gcrypt sshdata sshdata Nothing a
makeSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
makeSsh' rsynconly origsshdata sshdata keypair = do prepSsh' gcrypt origsshdata sshdata keypair a =
sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $ sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" (a origsshdata)
makeSshRepo rsynconly sshdata
where where
sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata) sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
remotedir = T.unpack $ sshDirectory sshdata remotedir = T.unpack $ sshDirectory sshdata
@ -330,15 +362,20 @@ makeSsh' rsynconly origsshdata sshdata keypair = do
[ Just $ "mkdir -p " ++ shellEscape remotedir [ Just $ "mkdir -p " ++ shellEscape remotedir
, Just $ "cd " ++ shellEscape remotedir , Just $ "cd " ++ shellEscape remotedir
, if rsynconly then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi" , if rsynconly then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
, if rsynconly then Nothing else Just "git annex init" , if (rsynconly || gcrypt) then Nothing else Just "git annex init"
, if needsPubKey sshdata , if needsPubKey sshdata
then addAuthorizedKeysCommand rsynconly remotedir . sshPubKey <$> keypair then addAuthorizedKeysCommand (hasCapability sshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
else Nothing else Nothing
] ]
rsynconly = onlyCapability sshdata RsyncCapable
makeSshRepo :: Bool -> SshData -> Handler Html makeSshRepo :: SshData -> Handler Html
makeSshRepo forcersync sshdata = setupCloudRemote TransferGroup Nothing $ makeSshRepo sshdata = setupCloudRemote TransferGroup Nothing $
makeSshRemote forcersync sshdata makeSshRemote sshdata
makeGCryptRepo :: KeyId -> SshData -> Handler Html
makeGCryptRepo keyid sshdata = setupCloudRemote TransferGroup Nothing $
makeGCryptRemote (sshRepoName sshdata) (sshUrl sshdata) keyid
getAddRsyncNetR :: Handler Html getAddRsyncNetR :: Handler Html
getAddRsyncNetR = postAddRsyncNetR getAddRsyncNetR = postAddRsyncNetR
@ -372,56 +409,35 @@ postAddRsyncNetR = do
let reponame = genSshRepoName "rsync.net" let reponame = genSshRepoName "rsync.net"
(maybe "" T.unpack $ inputDirectory sshinput) (maybe "" T.unpack $ inputDirectory sshinput)
prepRsyncNet sshinput reponame $ \sshdata -> inpage $ prepRsyncNet sshinput reponame $ \sshdata -> inpage $
checkexistinggcrypt sshdata $ do checkExistingGCrypt sshdata $ do
secretkeys <- sortBy (comparing snd) . M.toList secretkeys <- sortBy (comparing snd) . M.toList
<$> liftIO secretKeys <$> liftIO secretKeys
$(widgetFile "configurators/rsync.net/encrypt") $(widgetFile "configurators/rsync.net/encrypt")
{- Detect if the user entered an existing gcrypt repository,
- and enable it. -}
checkexistinggcrypt sshdata a = ifM (liftIO isGcryptInstalled)
( checkGCryptRepoEncryption repourl a $ do
mu <- liftAnnex $ probeGCryptRemoteUUID repourl
case mu of
Just u -> do
reponame <- liftAnnex $ getGCryptRemoteName u repourl
void $ liftH $ enableRsyncNetGCrypt' sshdata reponame
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
, a
)
where
repourl = sshUrl True sshdata
getMakeRsyncNetSharedR :: SshData -> Handler Html getMakeRsyncNetSharedR :: SshData -> Handler Html
getMakeRsyncNetSharedR sshdata = makeSshRepo True sshdata getMakeRsyncNetSharedR = makeSshRepo . rsyncOnly
{- Make a gcrypt special remote on rsync.net. -} {- Make a gcrypt special remote on rsync.net. -}
getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $ getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do
sshSetup [sshhost, gitinit] [] $ sshSetup [sshhost, gitinit] [] $ makeGCryptRepo keyid sshdata
setupCloudRemote TransferGroup Nothing $
makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid
where where
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata) gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
enableRsyncNet :: SshInput -> String -> Handler Html enableRsyncNet :: SshInput -> String -> Handler Html
enableRsyncNet sshinput reponame = enableRsyncNet sshinput reponame =
prepRsyncNet sshinput reponame $ makeSshRepo True prepRsyncNet sshinput reponame $ makeSshRepo . rsyncOnly
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
enableRsyncNetGCrypt sshinput reponame = enableRsyncNetGCrypt sshinput reponame =
prepRsyncNet sshinput reponame $ \sshdata -> prepRsyncNet sshinput reponame $ \sshdata ->
checkGCryptRepoEncryption (sshUrl True sshdata) notencrypted $ checkGCryptRepoEncryption (sshUrl sshdata) notencrypted $
enableRsyncNetGCrypt' sshdata reponame enableGCrypt sshdata reponame
where where
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository." notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
enableRsyncNetGCrypt' :: SshData -> RemoteName -> Handler Html
enableRsyncNetGCrypt' sshdata reponame =
setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote $ M.fromList
[("gitrepo", sshUrl True sshdata)]
{- Prepares rsync.net ssh key, and if successful, runs an action with {- Prepares rsync.net ssh key, and if successful, runs an action with
- its SshData. -} - its SshData. -}