674 lines
25 KiB
Haskell
674 lines
25 KiB
Haskell
{- git-annex assistant webapp configurator for ssh-based remotes
|
||
-
|
||
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
|
||
-
|
||
- Licensed under the GNU AGPL version 3 or higher.
|
||
-}
|
||
|
||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
|
||
|
||
module Assistant.WebApp.Configurators.Ssh where
|
||
|
||
import Assistant.WebApp.Common
|
||
import Assistant.WebApp.Gpg
|
||
import Assistant.Ssh
|
||
import Annex.Ssh
|
||
import Assistant.WebApp.MakeRemote
|
||
import Logs.Remote
|
||
import Remote
|
||
import Types.StandardGroups
|
||
import Utility.UserInfo
|
||
import Utility.Gpg
|
||
import Types.Remote (RemoteConfig)
|
||
import Types.ProposedAccepted
|
||
import Git.Types (RemoteName, fromRef, fromConfigKey)
|
||
import qualified Remote.GCrypt as GCrypt
|
||
import qualified Annex
|
||
import qualified Git.Command
|
||
import qualified Annex.Branch
|
||
import Annex.UUID
|
||
import Logs.UUID
|
||
import Annex.SpecialRemote.Config
|
||
import Assistant.RemoteControl
|
||
import Types.Creds
|
||
import Assistant.CredPairCache
|
||
import Annex.Path
|
||
import Utility.Tmp
|
||
import Utility.FileMode
|
||
import Utility.ThreadScheduler
|
||
import Utility.Env
|
||
import Utility.SshHost
|
||
import Utility.Process.Transcript
|
||
|
||
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
|
||
, inputAuthMethod :: AuthMethod
|
||
, inputPassword :: Maybe Text
|
||
, inputDirectory :: Maybe Text
|
||
, inputPort :: Int
|
||
}
|
||
|
||
data AuthMethod
|
||
= Password
|
||
| CachedPassword
|
||
| ExistingSshKey
|
||
deriving (Eq, Show)
|
||
|
||
-- Is a repository a new one that's being created, or did it already exist
|
||
-- and is just being added.
|
||
data RepoStatus = NewRepo | ExistingRepo
|
||
|
||
{- 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
|
||
, sshCapabilities = [] -- untested
|
||
, sshRepoUrl = Nothing
|
||
}
|
||
|
||
mkSshInput :: SshData -> SshInput
|
||
mkSshInput s = SshInput
|
||
{ inputHostname = Just $ sshHostName s
|
||
, inputUsername = sshUserName s
|
||
, inputAuthMethod = if needsPubKey s then CachedPassword else ExistingSshKey
|
||
, inputPassword = Nothing
|
||
, inputDirectory = Just $ sshDirectory s
|
||
, inputPort = sshPort s
|
||
}
|
||
|
||
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
|
||
sshInputAForm hostnamefield d = normalize <$> gen
|
||
where
|
||
gen = SshInput
|
||
<$> aopt check_hostname (bfs "Host name") (Just $ inputHostname d)
|
||
<*> aopt check_username (bfs "User name") (Just $ inputUsername d)
|
||
<*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d)
|
||
<*> aopt passwordField (bfs "Password") Nothing
|
||
<*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory d)
|
||
<*> areq intField (bfs "Port") (Just $ inputPort d)
|
||
|
||
authmethods :: [(Text, AuthMethod)]
|
||
authmethods =
|
||
[ ("password", Password)
|
||
, ("existing ssh key", ExistingSshKey)
|
||
]
|
||
|
||
check_username = checkBool (all (`notElem` ("/:@ \t" :: String)) . T.unpack)
|
||
bad_username textField
|
||
|
||
bad_username = "bad user name" :: Text
|
||
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 mapMaybe 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
|
||
|
||
-- The directory is implicitly in home, so remove any leading ~/
|
||
normalize i = i { inputDirectory = normalizedir <$> inputDirectory i }
|
||
normalizedir dir
|
||
| "~/" `T.isPrefixOf` dir = T.drop 2 dir
|
||
| "/~/" `T.isPrefixOf` dir = T.drop 3 dir
|
||
| otherwise = dir
|
||
|
||
data ServerStatus
|
||
= UntestedServer
|
||
| UnusableServer Text -- reason why it's not usable
|
||
| ServerNeedsPubKey SshPubKey
|
||
| UsableServer [SshServerCapability]
|
||
deriving (Eq)
|
||
|
||
capabilities :: ServerStatus -> [SshServerCapability]
|
||
capabilities (UsableServer cs) = cs
|
||
capabilities _ = []
|
||
|
||
getAddSshR :: Handler Html
|
||
getAddSshR = postAddSshR
|
||
postAddSshR :: Handler Html
|
||
postAddSshR = sshConfigurator $ do
|
||
username <- liftIO $ either (const Nothing) (Just . T.pack) <$> myUserName
|
||
((result, form), enctype) <- liftH $
|
||
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField $
|
||
SshInput Nothing username Password Nothing Nothing 22
|
||
case result of
|
||
FormSuccess sshinput -> do
|
||
s <- liftAssistant $ testServer sshinput
|
||
case s of
|
||
Left status -> showform form enctype status
|
||
Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u
|
||
_ -> showform form enctype UntestedServer
|
||
where
|
||
showform form enctype status = $(widgetFile "configurators/ssh/add")
|
||
|
||
sshTestModal :: Widget
|
||
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
|
||
|
||
sshSetupModal :: SshData -> Widget
|
||
sshSetupModal sshdata = $(widgetFile "configurators/ssh/setupmodal")
|
||
|
||
getEnableRsyncR :: UUID -> Handler Html
|
||
getEnableRsyncR = postEnableRsyncR
|
||
postEnableRsyncR :: UUID -> Handler Html
|
||
postEnableRsyncR = enableSshRemote getsshinput enableRsyncNet enablersync
|
||
where
|
||
enablersync sshdata u = redirect $ ConfirmSshR
|
||
(sshdata { sshCapabilities = [RsyncCapable] }) u
|
||
getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "rsyncurl")
|
||
|
||
{- This only handles gcrypt repositories that are located on ssh servers;
|
||
- ones on local drives are handled via another part of the UI. -}
|
||
getEnableSshGCryptR :: UUID -> Handler Html
|
||
getEnableSshGCryptR = postEnableSshGCryptR
|
||
postEnableSshGCryptR :: UUID -> Handler Html
|
||
postEnableSshGCryptR u = whenGcryptInstalled $
|
||
enableSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
|
||
where
|
||
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
|
||
sshConfigurator $
|
||
checkExistingGCrypt sshdata' $
|
||
giveup "Expected to find an encrypted git repository, but did not."
|
||
getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "gitrepo")
|
||
|
||
getEnableSshGitRemoteR :: UUID -> Handler Html
|
||
getEnableSshGitRemoteR = postEnableSshGitRemoteR
|
||
postEnableSshGitRemoteR :: UUID -> Handler Html
|
||
postEnableSshGitRemoteR = enableSshRemote getsshinput enableRsyncNet enablesshgitremote
|
||
where
|
||
enablesshgitremote sshdata u = redirect $ ConfirmSshR sshdata u
|
||
|
||
getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "location")
|
||
|
||
{- To enable a remote that uses ssh as its transport,
|
||
- parse a config key to get its url, and display a form
|
||
- to prompt for its password.
|
||
-}
|
||
enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html
|
||
enableSshRemote getsshdata rsyncnetsetup genericsetup u = do
|
||
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex remoteConfigMap
|
||
case (unmangle <$> getsshdata m, lookupName m) of
|
||
(Just sshdata, Just reponame) -> sshConfigurator $ do
|
||
((result, form), enctype) <- liftH $
|
||
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
|
||
sshInputAForm textField $ mkSshInput sshdata
|
||
case result of
|
||
FormSuccess sshinput
|
||
| isRsyncNet (inputHostname sshinput) ->
|
||
void $ liftH $ rsyncnetsetup sshinput reponame
|
||
| otherwise -> do
|
||
s <- liftAssistant $ testServer sshinput
|
||
case s of
|
||
Left status -> showform form enctype status
|
||
Right (sshdata', _u) -> void $ liftH $ genericsetup
|
||
( sshdata' { sshRepoName = reponame } ) u
|
||
_ -> showform form enctype UntestedServer
|
||
_ -> redirect AddSshR
|
||
where
|
||
unmangle sshdata = sshdata
|
||
{ sshHostName = T.pack $ unMangleSshHostName $
|
||
T.unpack $ sshHostName sshdata
|
||
}
|
||
showform form enctype status = do
|
||
description <- liftAnnex $ T.pack <$> prettyUUID u
|
||
$(widgetFile "configurators/ssh/enable")
|
||
|
||
{- To deal with git-annex and possibly even git and rsync not being
|
||
- available in the remote server's PATH, when git-annex was installed
|
||
- from the standalone tarball etc, look for a ~/.ssh/git-annex-wrapper
|
||
- and if it's there, use it to run a command. -}
|
||
wrapCommand :: String -> String
|
||
wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper ++ " " ++ cmd ++ "; else " ++ cmd ++ "; fi"
|
||
|
||
commandWrapper :: String
|
||
commandWrapper = "~/.ssh/git-annex-wrapper"
|
||
|
||
{- Test if we can ssh into the server, using the specified AuthMethod.
|
||
-
|
||
- Once logged into the server, probe to see if git-annex-shell,
|
||
- git, and rsync are available.
|
||
-
|
||
- Note that ~/.ssh/git-annex-shell may be present, while
|
||
- git-annex-shell is not in PATH.
|
||
- Also, git and rsync may not be in PATH; as long as the commandWrapper
|
||
- is present, assume it is able to be used to run them.
|
||
-
|
||
- Also probe to see if there is already a git repository at the location
|
||
- with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)
|
||
-}
|
||
testServer :: SshInput -> Assistant (Either ServerStatus (SshData, UUID))
|
||
testServer (SshInput { inputHostname = Nothing }) = return $
|
||
Left $ UnusableServer "Please enter a host name."
|
||
testServer sshinput@(SshInput { inputHostname = Just hn }) = do
|
||
(status, u) <- probe
|
||
case capabilities status of
|
||
[] -> return $ Left status
|
||
cs -> do
|
||
let sshdata = (mkSshData sshinput)
|
||
{ needsPubKey = inputAuthMethod sshinput /= ExistingSshKey
|
||
, sshCapabilities = cs
|
||
}
|
||
return $ Right (sshdata, u)
|
||
where
|
||
probe = do
|
||
let remotecommand = shellWrap $ intercalate ";"
|
||
[ report "loggedin"
|
||
, checkcommand "git-annex-shell"
|
||
, checkcommand "git"
|
||
, checkcommand "rsync"
|
||
, checkcommand shim
|
||
, checkcommand commandWrapper
|
||
, getgitconfig (T.unpack <$> inputDirectory sshinput)
|
||
]
|
||
knownhost <- liftIO $ knownHost hn
|
||
let sshopts =
|
||
{- If this is an already known host, let
|
||
- ssh check it as usual.
|
||
- Otherwise, trust the host key. -}
|
||
[ sshOpt "StrictHostKeyChecking" $
|
||
if knownhost then "yes" else "no"
|
||
, "-n" -- don't read from stdin
|
||
, "-p", show (inputPort sshinput)
|
||
]
|
||
let sshhost = genSshHost
|
||
(fromJust $ inputHostname sshinput)
|
||
(inputUsername sshinput)
|
||
parsetranscript . fst <$> sshAuthTranscript sshinput sshopts sshhost remotecommand Nothing
|
||
parsetranscript s =
|
||
let cs = map snd $ filter (reported . fst)
|
||
[ ("git-annex-shell", GitAnnexShellCapable)
|
||
, (shim, GitAnnexShellCapable)
|
||
, ("git", GitCapable)
|
||
, ("rsync", RsyncCapable)
|
||
, (commandWrapper, GitCapable)
|
||
, (commandWrapper, RsyncCapable)
|
||
]
|
||
u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $
|
||
map (separate (== '=')) $ lines s
|
||
in if null cs
|
||
then (UnusableServer unusablereason, u)
|
||
else (UsableServer cs, u)
|
||
where
|
||
reported r = token r `isInfixOf` s
|
||
unusablereason = if reported "loggedin"
|
||
then "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
|
||
else T.pack $ "Failed to ssh to the server. Transcript: " ++ s
|
||
finduuid (k, v)
|
||
| k == "annex.uuid" = Just $ toUUID v
|
||
| k == fromConfigKey GCrypt.coreGCryptId =
|
||
Just $ genUUIDInNameSpace gCryptNameSpace v
|
||
| otherwise = Nothing
|
||
|
||
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
|
||
token r = "git-annex-probe " ++ r
|
||
report r = "echo " ++ shellEscape (token r)
|
||
shim = "~/.ssh/git-annex-shell"
|
||
getgitconfig (Just d)
|
||
| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
|
||
getgitconfig _ = "echo"
|
||
|
||
{- Runs a ssh command to set up the repository; if it fails shows
|
||
- the user the transcript, and if it succeeds, runs an action. -}
|
||
sshSetup :: SshInput -> [String] -> SshHost -> String -> Maybe String -> Handler Html -> Handler Html
|
||
sshSetup sshinput opts sshhost cmd input a = do
|
||
(transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts sshhost cmd input
|
||
if ok
|
||
then do
|
||
liftAssistant $ expireCachedCred $ getLogin sshinput
|
||
a
|
||
else sshErr sshinput transcript
|
||
|
||
sshErr :: SshInput -> String -> Handler Html
|
||
sshErr sshinput msg
|
||
| inputAuthMethod sshinput == CachedPassword =
|
||
ifM (liftAssistant $ isNothing <$> getCachedCred (getLogin sshinput))
|
||
( sshConfigurator $
|
||
$(widgetFile "configurators/ssh/expiredpassword")
|
||
, showerr
|
||
)
|
||
| otherwise = showerr
|
||
where
|
||
showerr = sshConfigurator $
|
||
$(widgetFile "configurators/ssh/error")
|
||
|
||
{- Runs a ssh command, returning a transcript of its output.
|
||
-
|
||
- Depending on the SshInput, avoids using a password, or uses a
|
||
- cached password. ssh is coaxed to use git-annex as SSH_ASKPASS
|
||
- to get the password.
|
||
-}
|
||
sshAuthTranscript :: SshInput -> [String] -> SshHost -> String -> (Maybe String) -> Assistant (String, Bool)
|
||
sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinput of
|
||
ExistingSshKey -> liftIO $ go [passwordprompts 0] Nothing
|
||
CachedPassword -> setupAskPass
|
||
Password -> do
|
||
cacheCred (login, geti inputPassword) (Seconds $ 60 * 10)
|
||
setupAskPass
|
||
where
|
||
login = getLogin sshinput
|
||
geti f = maybe "" T.unpack (f sshinput)
|
||
|
||
go extraopts environ = processTranscript'
|
||
(askPass environ (proc "ssh" (extraopts ++ opts ++ [fromSshHost sshhost, cmd])))
|
||
-- Always provide stdin, even when empty.
|
||
(Just (fromMaybe "" input))
|
||
|
||
{- ssh will only use SSH_ASKPASS when DISPLAY is set and there
|
||
- is no controlling terminal. -}
|
||
askPass environ p = p
|
||
{ env = environ
|
||
, detach_console = True
|
||
, new_session = True
|
||
}
|
||
|
||
setupAskPass = do
|
||
program <- liftIO programPath
|
||
v <- getCachedCred login
|
||
liftIO $ case v of
|
||
Nothing -> go [passwordprompts 0] Nothing
|
||
Just pass -> withTmpFile "ssh" $ \passfile h -> do
|
||
hClose h
|
||
writeFileProtected (toRawFilePath passfile) pass
|
||
environ <- getEnvironment
|
||
let environ' = addEntries
|
||
[ ("SSH_ASKPASS", program)
|
||
, (sshAskPassEnv, passfile)
|
||
, ("DISPLAY", ":0")
|
||
] environ
|
||
go [passwordprompts 1] (Just environ')
|
||
|
||
passwordprompts :: Int -> String
|
||
passwordprompts = sshOpt "NumberOfPasswordPrompts" . show
|
||
|
||
getLogin :: SshInput -> Login
|
||
getLogin sshinput = geti inputUsername ++ "@" ++ geti inputHostname
|
||
where
|
||
geti f = maybe "" T.unpack (f sshinput)
|
||
|
||
{- The UUID will be NoUUID when the repository does not already exist,
|
||
- or was not a git-annex repository before. -}
|
||
getConfirmSshR :: SshData -> UUID -> Handler Html
|
||
getConfirmSshR sshdata u
|
||
| u == NoUUID = handlenew
|
||
| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidDescMap)
|
||
where
|
||
handlenew = sshConfigurator $ do
|
||
cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
||
secretkeys <- sortBy (comparing snd) . M.toList
|
||
<$> liftIO (secretKeys cmd)
|
||
$(widgetFile "configurators/ssh/confirm")
|
||
handleexisting Nothing = sshConfigurator $
|
||
-- Not a UUID we know, so prompt about combining.
|
||
$(widgetFile "configurators/ssh/combine")
|
||
handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do
|
||
m <- liftAnnex remoteConfigMap
|
||
case fromProposedAccepted <$> (M.lookup typeField =<< M.lookup u m) of
|
||
Just "gcrypt" -> combineExistingGCrypt sshdata' u
|
||
_ -> makeSshRepo ExistingRepo sshdata'
|
||
|
||
{- The user has confirmed they want to combine with a ssh repository,
|
||
- which is not known to us. So it might be using gcrypt. -}
|
||
getCombineSshR :: SshData -> Handler Html
|
||
getCombineSshR sshdata = prepSsh False sshdata $ \sshdata' ->
|
||
sshConfigurator $
|
||
checkExistingGCrypt sshdata' $
|
||
void $ liftH $ makeSshRepo ExistingRepo sshdata'
|
||
|
||
getRetrySshR :: SshData -> Handler ()
|
||
getRetrySshR sshdata = do
|
||
s <- liftAssistant $ testServer $ mkSshInput sshdata
|
||
redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s
|
||
|
||
{- Making a new git repository. -}
|
||
getMakeSshGitR :: SshData -> Handler Html
|
||
getMakeSshGitR sshdata = prepSsh True sshdata (makeSshRepo NewRepo)
|
||
|
||
getMakeSshRsyncR :: SshData -> Handler Html
|
||
getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) (makeSshRepo NewRepo)
|
||
|
||
rsyncOnly :: SshData -> SshData
|
||
rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }
|
||
|
||
getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
|
||
getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
|
||
withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
|
||
getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
|
||
prepSsh False sshdata $ makeGCryptRepo NewRepo 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 = checkGCryptRepoEncryption repourl nope nope $ do
|
||
mu <- liftAnnex $ probeGCryptRemoteUUID repourl
|
||
case mu of
|
||
Just u -> void $ liftH $
|
||
combineExistingGCrypt sshdata u
|
||
Nothing -> giveup "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
||
where
|
||
repourl = genSshUrl sshdata
|
||
|
||
{- Enables an existing gcrypt special remote. -}
|
||
enableGCrypt :: SshData -> RemoteName -> Handler Html
|
||
enableGCrypt sshdata reponame = setupRemote postsetup Nothing Nothing mk
|
||
where
|
||
mk = enableSpecialRemote reponame GCrypt.remote Nothing $
|
||
M.fromList [(Proposed "gitrepo", Proposed (genSshUrl sshdata))]
|
||
postsetup _ = redirect DashboardR
|
||
|
||
{- Combining with a gcrypt repository that may not be
|
||
- known in remote.log, so probe the gcrypt repo. -}
|
||
combineExistingGCrypt :: SshData -> UUID -> Handler Html
|
||
combineExistingGCrypt sshdata u = do
|
||
reponame <- liftAnnex $ getGCryptRemoteName u repourl
|
||
enableGCrypt sshdata reponame
|
||
where
|
||
repourl = genSshUrl sshdata
|
||
|
||
{- Sets up remote repository for ssh, or directory for rsync. -}
|
||
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
|
||
prepSsh needsinit sshdata a
|
||
| needsPubKey sshdata = do
|
||
(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
|
||
prepSsh' needsinit sshdata sshdata' (Just keypair) a
|
||
| sshPort sshdata /= 22 = do
|
||
sshdata' <- liftIO $ setSshConfig sshdata []
|
||
prepSsh' needsinit sshdata sshdata' Nothing a
|
||
| otherwise = prepSsh' needsinit sshdata sshdata Nothing a
|
||
|
||
prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
|
||
prepSsh' needsinit origsshdata sshdata keypair a
|
||
| hasCapability sshdata PushCapable = do
|
||
{- To ensure the repository is initialized, try to push the
|
||
- git-annex branch to it. Then git-annex-shell will see
|
||
- the branch and auto-initialize. -}
|
||
when needsinit $ do
|
||
void $ liftAnnex $ inRepo $ Git.Command.runBool
|
||
[ Param "push"
|
||
, Param (genSshUrl sshdata)
|
||
, Param (fromRef Annex.Branch.name)
|
||
]
|
||
a sshdata
|
||
| otherwise = sshSetup (mkSshInput origsshdata)
|
||
[ "-p", show (sshPort origsshdata)
|
||
]
|
||
(genSshHost (sshHostName origsshdata) (sshUserName origsshdata))
|
||
remoteCommand
|
||
Nothing (a sshdata)
|
||
where
|
||
remotedir = T.unpack $ sshDirectory sshdata
|
||
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
|
||
[ Just $ "mkdir -p " ++ shellEscape remotedir
|
||
, Just $ "cd " ++ shellEscape remotedir
|
||
, if rsynconly then Nothing else Just $ unwords
|
||
[ "if [ ! -d .git ]; then"
|
||
, wrapCommand "git init --bare --shared"
|
||
, "&&"
|
||
, wrapCommand "git config receive.denyNonFastforwards"
|
||
, ";fi"
|
||
]
|
||
, if needsinit then Just (wrapCommand "git annex init") else Nothing
|
||
, if needsPubKey origsshdata
|
||
then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
|
||
else Nothing
|
||
]
|
||
rsynconly = onlyCapability origsshdata RsyncCapable
|
||
|
||
makeSshRepo :: RepoStatus -> SshData -> Handler Html
|
||
makeSshRepo rs sshdata
|
||
| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing mk
|
||
| otherwise = makeSshRepoConnection rs mk setup
|
||
where
|
||
mk = makeSshRemote sshdata
|
||
-- Record the location of the ssh remote in the remote log, so it
|
||
-- can easily be enabled elsewhere using the webapp.
|
||
setup r = do
|
||
m <- remoteConfigMap
|
||
let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m)
|
||
let c' = M.insert (Proposed "location") (Proposed (genSshUrl sshdata)) $
|
||
M.insert typeField (Proposed "git") $
|
||
case fromProposedAccepted <$> M.lookup nameField c of
|
||
Just _ -> c
|
||
Nothing -> M.insert nameField (Proposed (Remote.name r)) c
|
||
configSet (Remote.uuid r) c'
|
||
|
||
makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html
|
||
makeSshRepoConnection rs mk setup = setupRemote postsetup mgroup Nothing mk
|
||
where
|
||
mgroup = case rs of
|
||
NewRepo -> Just TransferGroup
|
||
ExistingRepo -> Nothing
|
||
postsetup r = do
|
||
liftAssistant $ sendRemoteControl RELOAD
|
||
liftAnnex $ setup r
|
||
case rs of
|
||
NewRepo -> redirect $ EditNewRepositoryR (Remote.uuid r)
|
||
ExistingRepo -> redirect DashboardR
|
||
|
||
makeGCryptRepo :: RepoStatus -> KeyId -> SshData -> Handler Html
|
||
makeGCryptRepo rs keyid sshdata = makeSshRepoConnection rs mk (const noop)
|
||
where
|
||
mk = makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
|
||
|
||
getAddRsyncNetR :: Handler Html
|
||
getAddRsyncNetR = postAddRsyncNetR
|
||
postAddRsyncNetR :: Handler Html
|
||
postAddRsyncNetR = do
|
||
((result, form), enctype) <- runFormPostNoToken $
|
||
renderBootstrap3 bootstrapFormLayout $ sshInputAForm hostnamefield $
|
||
SshInput Nothing Nothing Password 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
|
||
cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
||
secretkeys <- sortBy (comparing snd) . M.toList
|
||
<$> liftIO (secretKeys cmd)
|
||
$(widgetFile "configurators/rsync.net/encrypt")
|
||
|
||
getMakeRsyncNetSharedR :: SshData -> Handler Html
|
||
getMakeRsyncNetSharedR = makeSshRepo NewRepo . rsyncOnly
|
||
|
||
{- Make a new gcrypt special remote on rsync.net. -}
|
||
getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
|
||
getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
|
||
withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
|
||
getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
|
||
sshSetup (mkSshInput sshdata) [] sshhost gitinit Nothing $
|
||
makeGCryptRepo NewRepo 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 ExistingRepo . rsyncOnly
|
||
|
||
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
|
||
enableRsyncNetGCrypt sshinput reponame =
|
||
prepRsyncNet sshinput reponame $ \sshdata -> whenGcryptInstalled $
|
||
checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
|
||
enableGCrypt sshdata reponame
|
||
where
|
||
notencrypted = giveup "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
|
||
notinstalled = error "internal"
|
||
|
||
{- Prepares rsync.net ssh key and creates the directory that will be
|
||
- used on rsync.net. If successful, runs an action with its SshData.
|
||
-
|
||
- To append the ssh key to rsync.net's authorized_keys, their
|
||
- documentation recommends a dd methodd, where the line is fed
|
||
- in to ssh over stdin.
|
||
-}
|
||
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
|
||
prepRsyncNet sshinput reponame a = do
|
||
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
|
||
(sshdata, keypair) <- liftIO $ setupSshKeyPair $
|
||
(mkSshData sshinput)
|
||
{ sshRepoName = reponame
|
||
, needsPubKey = True
|
||
, sshCapabilities = [RsyncCapable]
|
||
}
|
||
let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||
let torsyncnet
|
||
| knownhost = []
|
||
| otherwise = [sshOpt "StrictHostKeyChecking" "no"]
|
||
{- I'd prefer to separate commands with && , but
|
||
- rsync.net's shell does not support that. -}
|
||
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)
|
||
]
|
||
sshSetup sshinput torsyncnet sshhost remotecommand
|
||
(Just $ sshPubKey keypair) (a sshdata)
|
||
|
||
isRsyncNet :: Maybe Text -> Bool
|
||
isRsyncNet Nothing = False
|
||
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
|