e864c8d033
This pulls off quite a nice trick: When given a path on rsync.net, it determines if it is an encrypted git repository that the user has the key to decrypt, and merges with it. This is works even when the local repository had no idea that the gcrypt remote exists! (As previously done with local drives.) This commit sponsored by Pedro Côrte-Real
454 lines
16 KiB
Haskell
454 lines
16 KiB
Haskell
{- git-annex assistant webapp configurator for ssh-based remotes
|
||
-
|
||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||
-
|
||
- Licensed under the GNU AGPL version 3 or higher.
|
||
-}
|
||
|
||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
||
{-# LANGUAGE CPP #-}
|
||
|
||
module Assistant.WebApp.Configurators.Ssh where
|
||
|
||
import Assistant.WebApp.Common
|
||
import Assistant.WebApp.Gpg
|
||
import Assistant.Ssh
|
||
import Assistant.MakeRemote
|
||
import Utility.Rsync (rsyncUrlIsShell)
|
||
import Logs.Remote
|
||
import Remote
|
||
import Logs.PreferredContent
|
||
import Types.StandardGroups
|
||
import Utility.UserInfo
|
||
import Utility.Gpg
|
||
import Types.Remote (RemoteConfigKey)
|
||
import Git.Remote
|
||
import Assistant.WebApp.Utility
|
||
import qualified Remote.GCrypt as GCrypt
|
||
|
||
import qualified Data.Text as T
|
||
import qualified Data.Map as M
|
||
import Network.Socket
|
||
import Data.Ord
|
||
|
||
sshConfigurator :: Widget -> Handler Html
|
||
sshConfigurator = page "Add a remote server" (Just Configuration)
|
||
|
||
data SshInput = SshInput
|
||
{ inputHostname :: Maybe Text
|
||
, inputUsername :: Maybe Text
|
||
, inputDirectory :: Maybe Text
|
||
, inputPort :: Int
|
||
}
|
||
deriving (Show)
|
||
|
||
{- SshInput is only used for applicative form prompting, this converts
|
||
- the result of such a form into a SshData. -}
|
||
mkSshData :: SshInput -> SshData
|
||
mkSshData s = SshData
|
||
{ sshHostName = fromMaybe "" $ inputHostname s
|
||
, sshUserName = inputUsername s
|
||
, sshDirectory = fromMaybe "" $ inputDirectory s
|
||
, sshRepoName = genSshRepoName
|
||
(T.unpack $ fromJust $ inputHostname s)
|
||
(maybe "" T.unpack $ inputDirectory s)
|
||
, sshPort = inputPort s
|
||
, needsPubKey = False
|
||
, rsyncOnly = False
|
||
}
|
||
|
||
mkSshInput :: SshData -> SshInput
|
||
mkSshInput s = SshInput
|
||
{ inputHostname = Just $ sshHostName s
|
||
, inputUsername = sshUserName s
|
||
, inputDirectory = Just $ sshDirectory s
|
||
, inputPort = sshPort s
|
||
}
|
||
|
||
#if MIN_VERSION_yesod(1,2,0)
|
||
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
|
||
#else
|
||
sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
|
||
#endif
|
||
sshInputAForm hostnamefield def = SshInput
|
||
<$> aopt check_hostname "Host name" (Just $ inputHostname def)
|
||
<*> aopt check_username "User name" (Just $ inputUsername def)
|
||
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
|
||
<*> areq intField "Port" (Just $ inputPort def)
|
||
where
|
||
check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
|
||
bad_username textField
|
||
|
||
bad_username = "bad user name" :: Text
|
||
#ifndef __ANDROID__
|
||
bad_hostname = "cannot resolve host name" :: Text
|
||
|
||
check_hostname = checkM (liftIO . checkdns) hostnamefield
|
||
checkdns t = do
|
||
let h = T.unpack t
|
||
let canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }
|
||
r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
|
||
return $ case catMaybes . map addrCanonName <$> r of
|
||
-- canonicalize input hostname if it had no dot
|
||
Just (fullname:_)
|
||
| '.' `elem` h -> Right t
|
||
| otherwise -> Right $ T.pack fullname
|
||
Just [] -> Right t
|
||
Nothing -> Left bad_hostname
|
||
#else
|
||
-- getAddrInfo currently broken on Android
|
||
check_hostname = hostnamefield -- unchecked
|
||
#endif
|
||
|
||
data ServerStatus
|
||
= UntestedServer
|
||
| UnusableServer Text -- reason why it's not usable
|
||
| UsableRsyncServer
|
||
| UsableSshInput
|
||
deriving (Eq)
|
||
|
||
usable :: ServerStatus -> Bool
|
||
usable UntestedServer = False
|
||
usable (UnusableServer _) = False
|
||
usable UsableRsyncServer = True
|
||
usable UsableSshInput = True
|
||
|
||
getAddSshR :: Handler Html
|
||
getAddSshR = postAddSshR
|
||
postAddSshR :: Handler Html
|
||
postAddSshR = sshConfigurator $ do
|
||
u <- liftIO $ T.pack <$> myUserName
|
||
((result, form), enctype) <- liftH $
|
||
runFormPost $ renderBootstrap $ sshInputAForm textField $
|
||
SshInput Nothing (Just u) Nothing 22
|
||
case result of
|
||
FormSuccess sshinput -> do
|
||
s <- liftIO $ testServer sshinput
|
||
case s of
|
||
Left status -> showform form enctype status
|
||
Right sshdata -> liftH $ redirect $ ConfirmSshR sshdata
|
||
_ -> showform form enctype UntestedServer
|
||
where
|
||
showform form enctype status = $(widgetFile "configurators/ssh/add")
|
||
|
||
sshTestModal :: Widget
|
||
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
|
||
|
||
{- Note that there's no EnableSshR because ssh remotes are not special
|
||
- remotes, and so their configuration is not shared between repositories.
|
||
-}
|
||
getEnableRsyncR :: UUID -> Handler Html
|
||
getEnableRsyncR = postEnableRsyncR
|
||
postEnableRsyncR :: UUID -> Handler Html
|
||
postEnableRsyncR = enableSpecialSshRemote "rsyncurl" enableRsyncNet enablersync
|
||
where
|
||
enablersync sshdata = redirect $ ConfirmSshR $
|
||
sshdata { rsyncOnly = True }
|
||
|
||
{- 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 = whenGcryptInstalled $
|
||
enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablersync u
|
||
where
|
||
enablersync sshdata = error "TODO enable ssh gcrypt remote"
|
||
|
||
{- 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 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
|
||
(Just sshinput, Just reponame) -> sshConfigurator $ do
|
||
((result, form), enctype) <- liftH $
|
||
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
|
||
case result of
|
||
FormSuccess sshinput'
|
||
| isRsyncNet (inputHostname sshinput') ->
|
||
void $ liftH $ rsyncnetsetup sshinput' reponame
|
||
| otherwise -> do
|
||
s <- liftIO $ testServer sshinput'
|
||
case s of
|
||
Left status -> showform form enctype status
|
||
Right sshdata -> liftH $ genericsetup sshdata
|
||
{ sshRepoName = reponame }
|
||
_ -> showform form enctype UntestedServer
|
||
_ -> redirect AddSshR
|
||
where
|
||
showform form enctype status = do
|
||
description <- liftAnnex $ T.pack <$> prettyUUID u
|
||
$(widgetFile "configurators/ssh/enable")
|
||
|
||
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
|
||
- url; rsync:// urls or bare path names are not supported.
|
||
-
|
||
- The hostname is stored mangled in the remote log for rsync special
|
||
- remotes configured by this webapp. So that mangling has to reversed
|
||
- here to get back the original hostname.
|
||
-}
|
||
parseSshRsyncUrl :: String -> Maybe SshInput
|
||
parseSshRsyncUrl u
|
||
| not (rsyncUrlIsShell u) = Nothing
|
||
| otherwise = Just $ SshInput
|
||
{ inputHostname = val $ unMangleSshHostName host
|
||
, inputUsername = if null user then Nothing else val user
|
||
, inputDirectory = val dir
|
||
, inputPort = 22
|
||
}
|
||
where
|
||
val = Just . T.pack
|
||
(userhost, dir) = separate (== ':') u
|
||
(user, host) = if '@' `elem` userhost
|
||
then separate (== '@') userhost
|
||
else (userhost, "")
|
||
|
||
{- Test if we can ssh into the server.
|
||
-
|
||
- Two probe attempts are made. First, try sshing in using the existing
|
||
- configuration, but don't let ssh prompt for any password. If
|
||
- passwordless login is already enabled, use it. Otherwise,
|
||
- a special ssh key will need to be generated just for this server.
|
||
-
|
||
- Once logged into the server, probe to see if git-annex-shell is
|
||
- available, or rsync. Note that, ~/.ssh/git-annex-shell may be
|
||
- present, while git-annex-shell is not in PATH.
|
||
-}
|
||
testServer :: SshInput -> IO (Either ServerStatus SshData)
|
||
testServer (SshInput { inputHostname = Nothing }) = return $
|
||
Left $ UnusableServer "Please enter a host name."
|
||
testServer sshinput@(SshInput { inputHostname = Just hn }) = do
|
||
status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
|
||
if usable status
|
||
then ret status False
|
||
else do
|
||
status' <- probe []
|
||
if usable status'
|
||
then ret status' True
|
||
else return $ Left status'
|
||
where
|
||
ret status needspubkey = return $ Right $ (mkSshData sshinput)
|
||
{ needsPubKey = needspubkey
|
||
, rsyncOnly = status == UsableRsyncServer
|
||
}
|
||
probe extraopts = do
|
||
let remotecommand = shellWrap $ intercalate ";"
|
||
[ report "loggedin"
|
||
, checkcommand "git-annex-shell"
|
||
, checkcommand "rsync"
|
||
, checkcommand shim
|
||
]
|
||
knownhost <- knownHost hn
|
||
let sshopts = filter (not . null) $ extraopts ++
|
||
{- If this is an already known host, let
|
||
- ssh check it as usual.
|
||
- Otherwise, trust the host key. -}
|
||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||
, "-n" -- don't read from stdin
|
||
, "-p", show (inputPort sshinput)
|
||
, genSshHost
|
||
(fromJust $ inputHostname sshinput)
|
||
(inputUsername sshinput)
|
||
, remotecommand
|
||
]
|
||
parsetranscript . fst <$> sshTranscript sshopts Nothing
|
||
parsetranscript s
|
||
| reported "git-annex-shell" = UsableSshInput
|
||
| reported shim = UsableSshInput
|
||
| reported "rsync" = UsableRsyncServer
|
||
| reported "loggedin" = UnusableServer
|
||
"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
|
||
| otherwise = UnusableServer $ T.pack $
|
||
"Failed to ssh to the server. Transcript: " ++ s
|
||
where
|
||
reported r = token r `isInfixOf` s
|
||
|
||
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
|
||
token r = "git-annex-probe " ++ r
|
||
report r = "echo " ++ token r
|
||
shim = "~/.ssh/git-annex-shell"
|
||
|
||
{- Runs a ssh command; if it fails shows the user the transcript,
|
||
- and if it succeeds, runs an action. -}
|
||
sshSetup :: [String] -> String -> Handler Html -> Handler Html
|
||
sshSetup opts input a = do
|
||
(transcript, ok) <- liftIO $ sshTranscript opts (Just input)
|
||
if ok
|
||
then a
|
||
else showSshErr transcript
|
||
|
||
showSshErr :: String -> Handler Html
|
||
showSshErr msg = sshConfigurator $
|
||
$(widgetFile "configurators/ssh/error")
|
||
|
||
getConfirmSshR :: SshData -> Handler Html
|
||
getConfirmSshR sshdata = sshConfigurator $
|
||
$(widgetFile "configurators/ssh/confirm")
|
||
|
||
getRetrySshR :: SshData -> Handler ()
|
||
getRetrySshR sshdata = do
|
||
s <- liftIO $ testServer $ mkSshInput sshdata
|
||
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
|
||
|
||
getMakeSshGitR :: SshData -> Handler Html
|
||
getMakeSshGitR = makeSsh False
|
||
|
||
getMakeSshRsyncR :: SshData -> Handler Html
|
||
getMakeSshRsyncR = makeSsh True
|
||
|
||
makeSsh :: Bool -> SshData -> Handler Html
|
||
makeSsh rsync sshdata
|
||
| needsPubKey sshdata = do
|
||
keypair <- liftIO genSshKeyPair
|
||
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
|
||
makeSsh' rsync sshdata sshdata' (Just keypair)
|
||
| sshPort sshdata /= 22 = do
|
||
sshdata' <- liftIO $ setSshConfig sshdata []
|
||
makeSsh' rsync sshdata sshdata' Nothing
|
||
| otherwise = makeSsh' rsync sshdata sshdata Nothing
|
||
|
||
makeSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
|
||
makeSsh' rsync origsshdata sshdata keypair = do
|
||
sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $
|
||
makeSshRepo rsync sshdata
|
||
where
|
||
sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
|
||
remotedir = T.unpack $ sshDirectory sshdata
|
||
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
|
||
[ Just $ "mkdir -p " ++ shellEscape remotedir
|
||
, Just $ "cd " ++ shellEscape remotedir
|
||
, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
|
||
, if rsync then Nothing else Just "git annex init"
|
||
, if needsPubKey sshdata
|
||
then addAuthorizedKeysCommand (rsync || rsyncOnly sshdata) remotedir . sshPubKey <$> keypair
|
||
else Nothing
|
||
]
|
||
|
||
makeSshRepo :: Bool -> SshData -> Handler Html
|
||
makeSshRepo forcersync sshdata = do
|
||
r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing
|
||
liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup
|
||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||
|
||
getAddRsyncNetR :: Handler Html
|
||
getAddRsyncNetR = postAddRsyncNetR
|
||
postAddRsyncNetR :: Handler Html
|
||
postAddRsyncNetR = do
|
||
((result, form), enctype) <- runFormPost $
|
||
renderBootstrap $ sshInputAForm hostnamefield $
|
||
SshInput Nothing Nothing Nothing 22
|
||
let showform status = inpage $
|
||
$(widgetFile "configurators/rsync.net/add")
|
||
case result of
|
||
FormSuccess sshinput
|
||
| isRsyncNet (inputHostname sshinput) ->
|
||
go sshinput
|
||
| otherwise ->
|
||
showform $ UnusableServer
|
||
"That is not a rsync.net host name."
|
||
_ -> showform UntestedServer
|
||
where
|
||
inpage = page "Add a Rsync.net repository" (Just Configuration)
|
||
hostnamefield = textField `withExpandableNote` ("Help", help)
|
||
help = [whamlet|
|
||
<div>
|
||
When you sign up for a Rsync.net account, you should receive an #
|
||
email from them with the host name and user name to put here.
|
||
<div>
|
||
The host name will be something like "usw-s001.rsync.net", and the #
|
||
user name something like "7491"
|
||
|]
|
||
go sshinput = do
|
||
let reponame = genSshRepoName "rsync.net"
|
||
(maybe "" T.unpack $ inputDirectory sshinput)
|
||
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
|
||
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
|
||
|
||
{- 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 $
|
||
makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid
|
||
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
|
||
|
||
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
|
||
enableRsyncNetGCrypt sshinput reponame =
|
||
prepRsyncNet sshinput reponame $ \sshdata ->
|
||
checkGCryptRepoEncryption (sshUrl True sshdata) notencrypted $
|
||
enableRsyncNetGCrypt' 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 $
|
||
enableSpecialRemote reponame GCrypt.remote $ M.fromList
|
||
[("gitrepo", sshUrl True sshdata)]
|
||
|
||
{- Prepares rsync.net ssh key, and if successful, runs an action with
|
||
- its SshData. -}
|
||
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
|
||
prepRsyncNet sshinput reponame a = do
|
||
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
|
||
keypair <- liftIO $ genSshKeyPair
|
||
sshdata <- liftIO $ setupSshKeyPair keypair $
|
||
(mkSshData sshinput)
|
||
{ sshRepoName = reponame
|
||
, needsPubKey = True
|
||
, rsyncOnly = True
|
||
}
|
||
{- I'd prefer to separate commands with && , but
|
||
- rsync.net's shell does not support that.
|
||
-
|
||
- The dd method of appending to the authorized_keys file is the
|
||
- one recommended by rsync.net documentation. I touch the file first
|
||
- to not need to use a different method to create it.
|
||
-}
|
||
let remotecommand = intercalate ";"
|
||
[ "mkdir -p .ssh"
|
||
, "touch .ssh/authorized_keys"
|
||
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
||
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
|
||
]
|
||
let sshopts = filter (not . null)
|
||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||
, remotecommand
|
||
]
|
||
sshSetup sshopts (sshPubKey keypair) $ a sshdata
|
||
|
||
isRsyncNet :: Maybe Text -> Bool
|
||
isRsyncNet Nothing = False
|
||
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
|