webapp can now set up gcrypt repos on ssh servers
This commit is contained in:
Joey Hess
parent
d83a244986
commit
61e06c972f
5 changed files with 87 additions and 70 deletions
|
|
@ -27,20 +27,18 @@ import Utility.Gpg (KeyId)
|
|||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
||||
{- Sets up a new ssh or rsync remote. -}
|
||||
makeSshRemote :: Bool -> SshData -> Annex RemoteName
|
||||
makeSshRemote forcersync sshdata =
|
||||
maker (sshRepoName sshdata) (sshUrl forcersync sshdata)
|
||||
{- Sets up a new git or rsync remote, accessed over ssh. -}
|
||||
makeSshRemote :: SshData -> Annex RemoteName
|
||||
makeSshRemote sshdata = maker (sshRepoName sshdata) (sshUrl sshdata)
|
||||
where
|
||||
rsync = forcersync || sshCapabilities sshdata == [RsyncCapable]
|
||||
maker
|
||||
| rsync = makeRsyncRemote
|
||||
| onlyCapability sshdata RsyncCapable = makeRsyncRemote
|
||||
| otherwise = makeGitRemote
|
||||
|
||||
{- Generates a ssh or rsync url from a SshData. -}
|
||||
sshUrl :: Bool -> SshData -> String
|
||||
sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $
|
||||
if (forcersync || sshCapabilities sshdata == [RsyncCapable])
|
||||
sshUrl :: SshData -> String
|
||||
sshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $
|
||||
if (onlyCapability sshdata RsyncCapable)
|
||||
then [u, h, T.pack ":", sshDirectory sshdata]
|
||||
else [T.pack "ssh://", u, h, d]
|
||||
where
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ import qualified Data.Text as T
|
|||
setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
|
||||
setupAuthorizedKeys msg repodir = do
|
||||
validateSshPubKey pubkey
|
||||
unlessM (liftIO $ addAuthorizedKeys False repodir pubkey) $
|
||||
unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
|
||||
error "failed setting up ssh authorized keys"
|
||||
where
|
||||
pubkey = remoteSshPubKey $ pairMsgData msg
|
||||
|
|
@ -45,7 +45,7 @@ finishedLocalPairing msg keypair = do
|
|||
, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
|
||||
]
|
||||
Nothing
|
||||
r <- liftAnnex $ addRemote $ makeSshRemote False sshdata
|
||||
r <- liftAnnex $ addRemote $ makeSshRemote sshdata
|
||||
liftAnnex $ setRemoteCost r semiExpensiveRemoteCost
|
||||
syncRemote r
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,9 @@ data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
|
|||
hasCapability :: SshData -> SshServerCapability -> Bool
|
||||
hasCapability d c = c `elem` sshCapabilities d
|
||||
|
||||
onlyCapability :: SshData -> SshServerCapability -> Bool
|
||||
onlyCapability d c = all (== c) (sshCapabilities d)
|
||||
|
||||
data SshKeyPair = SshKeyPair
|
||||
{ sshPubKey :: String
|
||||
, sshPrivKey :: String
|
||||
|
|
@ -98,12 +101,12 @@ validateSshPubKey pubkey
|
|||
safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
|
||||
|
||||
addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
|
||||
addAuthorizedKeys rsynconly dir pubkey = boolSystem "sh"
|
||||
[ Param "-c" , Param $ addAuthorizedKeysCommand rsynconly dir pubkey ]
|
||||
addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
|
||||
[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
|
||||
|
||||
removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
|
||||
removeAuthorizedKeys rsynconly dir pubkey = do
|
||||
let keyline = authorizedKeysLine rsynconly dir pubkey
|
||||
removeAuthorizedKeys gitannexshellonly dir pubkey = do
|
||||
let keyline = authorizedKeysLine gitannexshellonly dir pubkey
|
||||
sshdir <- sshDir
|
||||
let keyfile = sshdir </> "authorized_keys"
|
||||
ls <- lines <$> readFileStrict keyfile
|
||||
|
|
@ -116,7 +119,7 @@ removeAuthorizedKeys rsynconly dir pubkey = do
|
|||
- present.
|
||||
-}
|
||||
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
|
||||
addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
|
||||
addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
|
||||
[ "mkdir -p ~/.ssh"
|
||||
, intercalate "; "
|
||||
[ "if [ ! -e " ++ wrapper ++ " ]"
|
||||
|
|
@ -128,7 +131,7 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
|
|||
, "chmod 600 ~/.ssh/authorized_keys"
|
||||
, unwords
|
||||
[ "echo"
|
||||
, shellEscape $ authorizedKeysLine rsynconly dir pubkey
|
||||
, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
|
||||
, ">>~/.ssh/authorized_keys"
|
||||
]
|
||||
]
|
||||
|
|
@ -147,11 +150,11 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
|
|||
runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
|
||||
|
||||
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
|
||||
- long perl script. -}
|
||||
| rsynconly = pubkey
|
||||
| otherwise = limitcommand ++ pubkey
|
||||
| otherwise = pubkey
|
||||
where
|
||||
limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
|
||||
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
|||
where
|
||||
alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
|
||||
setup repodir = setupAuthorizedKeys msg repodir
|
||||
cleanup repodir = removeAuthorizedKeys False repodir $
|
||||
cleanup repodir = removeAuthorizedKeys True repodir $
|
||||
remoteSshPubKey $ pairMsgData msg
|
||||
uuid = Just $ pairUUID $ pairMsgData msg
|
||||
#else
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
|
@ -147,16 +147,19 @@ getEnableGCryptR :: UUID -> Handler Html
|
|||
getEnableGCryptR = postEnableGCryptR
|
||||
postEnableGCryptR :: UUID -> Handler Html
|
||||
postEnableGCryptR u = whenGcryptInstalled $
|
||||
enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablersync u
|
||||
enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablegcrypt u
|
||||
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,
|
||||
- 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
|
||||
- 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
|
||||
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
|
||||
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'
|
||||
case s of
|
||||
Left status -> showform form enctype status
|
||||
Right sshdata -> liftH $ genericsetup sshdata
|
||||
Right sshdata -> void $ liftH $ genericsetup sshdata
|
||||
{ sshRepoName = reponame }
|
||||
_ -> showform form enctype UntestedServer
|
||||
_ -> redirect AddSshR
|
||||
|
|
@ -300,29 +303,58 @@ getRetrySshR sshdata = do
|
|||
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
|
||||
|
||||
getMakeSshGitR :: SshData -> Handler Html
|
||||
getMakeSshGitR = makeSsh False
|
||||
getMakeSshGitR sshdata = prepSsh False sshdata makeSshRepo
|
||||
|
||||
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 = 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
|
||||
makeSsh rsync sshdata
|
||||
{- Enables an existing gcrypt special remote. -}
|
||||
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
|
||||
keypair <- liftIO genSshKeyPair
|
||||
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
|
||||
makeSsh' rsync sshdata sshdata' (Just keypair)
|
||||
prepSsh' gcrypt sshdata sshdata' (Just keypair) a
|
||||
| sshPort sshdata /= 22 = do
|
||||
sshdata' <- liftIO $ setSshConfig sshdata []
|
||||
makeSsh' rsync sshdata sshdata' Nothing
|
||||
| otherwise = makeSsh' rsync sshdata sshdata Nothing
|
||||
prepSsh' gcrypt sshdata sshdata' Nothing a
|
||||
| otherwise = prepSsh' gcrypt sshdata sshdata Nothing a
|
||||
|
||||
makeSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
|
||||
makeSsh' rsynconly origsshdata sshdata keypair = do
|
||||
sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $
|
||||
makeSshRepo rsynconly sshdata
|
||||
prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
|
||||
prepSsh' gcrypt origsshdata sshdata keypair a =
|
||||
sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" (a origsshdata)
|
||||
where
|
||||
sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
|
||||
remotedir = T.unpack $ sshDirectory sshdata
|
||||
|
|
@ -330,15 +362,20 @@ makeSsh' rsynconly origsshdata sshdata keypair = do
|
|||
[ Just $ "mkdir -p " ++ 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 "git annex init"
|
||||
, if (rsynconly || gcrypt) then Nothing else Just "git annex init"
|
||||
, if needsPubKey sshdata
|
||||
then addAuthorizedKeysCommand rsynconly remotedir . sshPubKey <$> keypair
|
||||
then addAuthorizedKeysCommand (hasCapability sshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
|
||||
else Nothing
|
||||
]
|
||||
rsynconly = onlyCapability sshdata RsyncCapable
|
||||
|
||||
makeSshRepo :: Bool -> SshData -> Handler Html
|
||||
makeSshRepo forcersync sshdata = setupCloudRemote TransferGroup Nothing $
|
||||
makeSshRemote forcersync sshdata
|
||||
makeSshRepo :: SshData -> Handler Html
|
||||
makeSshRepo sshdata = setupCloudRemote TransferGroup Nothing $
|
||||
makeSshRemote sshdata
|
||||
|
||||
makeGCryptRepo :: KeyId -> SshData -> Handler Html
|
||||
makeGCryptRepo keyid sshdata = setupCloudRemote TransferGroup Nothing $
|
||||
makeGCryptRemote (sshRepoName sshdata) (sshUrl sshdata) keyid
|
||||
|
||||
getAddRsyncNetR :: Handler Html
|
||||
getAddRsyncNetR = postAddRsyncNetR
|
||||
|
|
@ -372,56 +409,35 @@ postAddRsyncNetR = do
|
|||
let reponame = genSshRepoName "rsync.net"
|
||||
(maybe "" T.unpack $ inputDirectory sshinput)
|
||||
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
|
||||
checkexistinggcrypt sshdata $ do
|
||||
checkExistingGCrypt sshdata $ do
|
||||
secretkeys <- sortBy (comparing snd) . M.toList
|
||||
<$> liftIO secretKeys
|
||||
$(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 = makeSshRepo True sshdata
|
||||
getMakeRsyncNetSharedR = makeSshRepo . rsyncOnly
|
||||
|
||||
{- Make a gcrypt special remote on rsync.net. -}
|
||||
getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
|
||||
getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
|
||||
withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
|
||||
getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do
|
||||
sshSetup [sshhost, gitinit] [] $
|
||||
setupCloudRemote TransferGroup Nothing $
|
||||
makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid
|
||||
sshSetup [sshhost, gitinit] [] $ makeGCryptRepo keyid sshdata
|
||||
where
|
||||
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||
gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
|
||||
|
||||
enableRsyncNet :: SshInput -> String -> Handler Html
|
||||
enableRsyncNet sshinput reponame =
|
||||
prepRsyncNet sshinput reponame $ makeSshRepo True
|
||||
prepRsyncNet sshinput reponame $ makeSshRepo . rsyncOnly
|
||||
|
||||
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
|
||||
enableRsyncNetGCrypt sshinput reponame =
|
||||
prepRsyncNet sshinput reponame $ \sshdata ->
|
||||
checkGCryptRepoEncryption (sshUrl True sshdata) notencrypted $
|
||||
enableRsyncNetGCrypt' sshdata reponame
|
||||
checkGCryptRepoEncryption (sshUrl sshdata) notencrypted $
|
||||
enableGCrypt sshdata reponame
|
||||
where
|
||||
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
|
||||
- its SshData. -}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue