git-annex/Assistant/WebApp/Configurators/Ssh.hs

{- 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 TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}

module Assistant.WebApp.Configurators.Ssh where

import Assistant.WebApp.Common
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 qualified Data.Text as T
import qualified Data.Map as M
import Network.Socket

sshConfigurator :: Widget -> Handler RepHtml
sshConfigurator = page "Add a remote server" (Just Config)

data SshInput = SshInput
	{ hostname :: Maybe Text
	, username :: Maybe Text
	, directory :: Maybe Text
	}
	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 "" $ hostname s
	, sshUserName = username s
	, sshDirectory = fromMaybe "" $ directory s
	, sshRepoName = genSshRepoName
		(T.unpack $ fromJust $ hostname s)
		(maybe "" T.unpack $ directory s)
	, needsPubKey = False
	, rsyncOnly = False
	}

sshInputAForm :: (Field WebApp WebApp Text) -> SshInput -> AForm WebApp WebApp SshInput
sshInputAForm hostnamefield def = SshInput
	<$> aopt check_hostname "Host name" (Just $ hostname def)
	<*> aopt check_username "User name" (Just $ username def)
	<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
  where
	check_hostname = checkM (liftIO . checkdns) hostnamefield
	checkdns t = do
		let h = T.unpack t
		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
	canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }

	check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
		bad_username textField
		
	bad_hostname = "cannot resolve host name" :: Text
	bad_username = "bad user name" :: Text

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 RepHtml
getAddSshR = sshConfigurator $ do
	u <- liftIO $ T.pack <$> myUserName
	((result, form), enctype) <- lift $
		runFormGet $ renderBootstrap $ sshInputAForm textField $
			SshInput Nothing (Just u) Nothing
	case result of
		FormSuccess sshinput -> do
			s <- liftIO $ testServer sshinput
			case s of
				Left status -> showform form enctype status
				Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
		_ -> showform form enctype UntestedServer
  where
	showform form enctype status = $(widgetFile "configurators/ssh/add")

{- To enable an existing rsync special remote, parse the SshInput from
 - 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
 - the usual repo setup; all that code is idempotent.
 -
 - 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 RepHtml
getEnableRsyncR u = do
	m <- fromMaybe M.empty . M.lookup u <$> runAnnex M.empty readRemoteLog
	case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
		(Just sshinput, Just reponame) -> sshConfigurator $ do
			((result, form), enctype) <- lift $
				runFormGet $ renderBootstrap $ sshInputAForm textField sshinput
			case result of
				FormSuccess sshinput'
					| isRsyncNet (hostname sshinput') ->
						void $ lift $ makeRsyncNet sshinput' reponame (const noop)
					| otherwise -> do
						s <- liftIO $ testServer sshinput'
						case s of
							Left status -> showform form enctype status
							Right sshdata -> enable sshdata
								{ sshRepoName = reponame }
				_ -> showform form enctype UntestedServer
		_ -> redirect AddSshR
  where
	showform form enctype status = do
		description <- lift $ runAnnex "" $
			T.pack . concat <$> prettyListUUIDs [u]
		$(widgetFile "configurators/ssh/enable")
	enable sshdata = lift $ redirect $ ConfirmSshR $
		sshdata { rsyncOnly = True }

{- 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
			{ hostname = val $ unMangleSshHostName host
			, username = if null user then Nothing else val user
			, directory = val dir
			}
  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 { hostname = Nothing }) = return $
	Left $ UnusableServer "Please enter a host name."
testServer sshinput@(SshInput { hostname = 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 = join ";"
			[ 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
			, genSshHost (fromJust $ hostname sshinput) (username sshinput)
			, remotecommand
			]
		parsetranscript . fst <$> sshTranscript sshopts ""
	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 RepHtml -> Handler RepHtml
sshSetup opts input a = do
	(transcript, ok) <- liftIO $ sshTranscript opts input
	if ok
		then a
		else showSshErr transcript

showSshErr :: String -> Handler RepHtml
showSshErr msg = sshConfigurator $
	$(widgetFile "configurators/ssh/error")

getConfirmSshR :: SshData -> Handler RepHtml
getConfirmSshR sshdata = sshConfigurator $
	$(widgetFile "configurators/ssh/confirm")

getMakeSshGitR :: SshData -> Handler RepHtml
getMakeSshGitR = makeSsh False setupGroup

getMakeSshRsyncR :: SshData -> Handler RepHtml
getMakeSshRsyncR = makeSsh True setupGroup

makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
makeSsh rsync setup sshdata
	| needsPubKey sshdata = do
		keypair <- liftIO genSshKeyPair
		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
		makeSsh' rsync setup sshdata' (Just keypair)
	| otherwise = makeSsh' rsync setup sshdata Nothing

makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Handler RepHtml
makeSsh' rsync setup sshdata keypair =
	sshSetup [sshhost, remoteCommand] "" $
		makeSshRepo rsync setup sshdata
  where
	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
	remotedir = T.unpack $ sshDirectory sshdata
	remoteCommand = join "&&" $ catMaybes
		[ Just $ "mkdir -p " ++ shellEscape remotedir
		, Just $ "cd " ++ shellEscape remotedir
		, if rsync then Nothing else Just "git init --bare --shared"
		, if rsync then Nothing else Just "git annex init"
		, if needsPubKey sshdata
			then addAuthorizedKeysCommand (rsyncOnly sshdata) remotedir . sshPubKey <$> keypair
			else Nothing
		]

makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
makeSshRepo forcersync setup sshdata = do
	r <- liftAssistant $ makeSshRemote forcersync sshdata
	setup r
	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

getAddRsyncNetR :: Handler RepHtml
getAddRsyncNetR = do
	((result, form), enctype) <- runFormGet $
		renderBootstrap $ sshInputAForm hostnamefield $
			SshInput Nothing Nothing Nothing
	let showform status = page "Add a Rsync.net repository" (Just Config) $
		$(widgetFile "configurators/addrsync.net")
	case result of
		FormSuccess sshinput
			| isRsyncNet (hostname sshinput) -> do
				let reponame = genSshRepoName "rsync.net" 
					(maybe "" T.unpack $ directory sshinput)
				makeRsyncNet sshinput reponame setupGroup
			| otherwise ->
				showform $ UnusableServer
					"That is not a rsync.net host name."
		_ -> showform UntestedServer
  where
	hostnamefield = textField `withNote` help
	help = [whamlet|
<a .btn data-toggle="collapse" data-target="#help">
  Help
<div #help .collapse>
  <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"
|]

makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml
makeRsyncNet sshinput reponame setup = do
	knownhost <- liftIO $ maybe (return False) knownHost (hostname 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 = join ";"
		[ "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) $
		makeSshRepo True setup sshdata

isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host

setupGroup :: Remote -> Handler ()
setupGroup r = runAnnex () $ setStandardGroup (Remote.uuid r) TransferGroup