From 54a492db5f86093349910cc0028ff1a56714775f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 31 Aug 2012 18:59:57 -0400 Subject: [PATCH] UI for adding a ssh or rsync remote --- Assistant/WebApp/Configurators.hs | 1 - Assistant/WebApp/Configurators/Local.hs | 10 +- Assistant/WebApp/Configurators/Ssh.hs | 112 +++++++++++++++----- Assistant/WebApp/routes | 2 +- Locations.hs | 6 ++ templates/configurators/addssh.hamlet | 38 +++++++ templates/configurators/repositories.hamlet | 14 +-- 7 files changed, 144 insertions(+), 39 deletions(-) create mode 100644 templates/configurators/addssh.hamlet diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 94c84c03ae..4d4d5c9164 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -14,7 +14,6 @@ import Assistant.WebApp import Assistant.WebApp.SideBar import Assistant.DaemonStatus import Assistant.WebApp.Configurators.Local -import Assistant.WebApp.Configurators.Ssh import Utility.Yesod import qualified Remote import qualified Types.Remote as Remote diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 04345f7312..beb41e1f11 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -12,13 +12,9 @@ module Assistant.WebApp.Configurators.Local where import Assistant.Common import Assistant.WebApp import Assistant.WebApp.SideBar -import Assistant.DaemonStatus import Assistant.Threads.MountWatcher (handleMount) import Utility.Yesod -import qualified Remote -import qualified Types.Remote as Remote import Remote.List -import Annex.UUID (getUUID) import Init import qualified Git import qualified Git.Construct @@ -102,7 +98,9 @@ defaultRepositoryPath firstrun = do then do desktop <- userDesktopDir ifM (doesDirectoryExist desktop) - (relHome (desktop "annex"), return "~/annex") + ( relHome $ desktop gitAnnexAssistantDefaultDir + , return $ "~" gitAnnexAssistantDefaultDir + ) else return cwd localRepositoryForm :: Form RepositoryPath @@ -178,7 +176,7 @@ getAddDriveR = bootstrap (Just Config) $ do webapp <- getYesod liftIO $ syncrepo dir webapp where - dir = mountpoint "annex" + dir = mountpoint gitAnnexAssistantDefaultDir remotename = takeFileName mountpoint {- The repo may already exist, when adding removable media - that has already been used elsewhere. -} diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 912bc7866f..afd0e1a796 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -12,33 +12,97 @@ module Assistant.WebApp.Configurators.Ssh where import Assistant.Common import Assistant.WebApp import Assistant.WebApp.SideBar -import Assistant.DaemonStatus -import Assistant.Threads.MountWatcher (handleMount) import Utility.Yesod -import qualified Remote -import qualified Types.Remote as Remote -import Remote.List -import Annex.UUID (getUUID) -import Init -import qualified Git -import qualified Git.Construct -import qualified Git.Config -import qualified Git.Command -import qualified Annex -import Locations.UserConfig -import Utility.FreeDesktop -import Utility.Mounts -import Utility.DiskFree -import Utility.DataUnits -import Utility.Network import Yesod import Data.Text (Text) import qualified Data.Text as T -import Data.Char -import System.Posix.Directory -import qualified Control.Exception as E +import Network.BSD +import System.Posix.User -getAddRemoteServerR :: Handler RepHtml -getAddRemoteServerR = bootstrap (Just Config) $ do - error "TODO" +data SshServer = SshServer + { hostname :: Maybe Text + , username :: Maybe Text + , directory :: Maybe Text + } + deriving Show + +sshServerAForm :: Text -> AForm WebApp WebApp SshServer +sshServerAForm localusername = SshServer + <$> aopt check_hostname "Host name" Nothing + <*> aopt check_username "User name" (Just $ Just localusername) + <*> aopt textField "Directory" (Just $ Just $ T.pack gitAnnexAssistantDefaultDir) + where + check_hostname = checkM (liftIO . checkdns) textField + checkdns t = do + let h = T.unpack t + r <- catchMaybeIO $ getHostByName h + return $ case r of + -- canonicalize input hostname if it had no dot + Just hostentry + | '.' `elem` h -> Right t + | otherwise -> Right $ T.pack $ hostName hostentry + Nothing -> Left bad_hostname + + 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 + | UsableSshServer + +{- Test if we can ssh into the server. If ssh doesn't work, fall back to + - trying rsync protocol. + - + - Before sshing in, if the user doesn't have a ssh key, a special one is + - generated just for this server, and configured to be used for this + - server. (If the user does have a ssh key, we assume they know what + - they're doing, and don't touch their ssh setup.) + - + - If we can ssh in, check that git-annex-shell is installed. If not, this + - will need to be a rsync special remote, rather than a git remote, so + - check that rsync is installed. + - + - When we ssh in, if we set up a ssh key, the server's authorized_keys + - is configured to let it run either git-annex-shell or rsync for that ssh + - key, and nothing else. + - + - Of course, ssh may ask for a passphrase, etc. We rely on ssh-askpass + - or an equivilant being used by ssh. Or, if the assistant is + - running in the foreground, the password will be asked there. + -} +testServer :: SshServer -> IO ServerStatus +testServer (SshServer { hostname = Nothing }) = return $ + UnusableServer "Please enter a host name." +testServer _sshserver = return UsableSshServer + +getAddSshR :: Handler RepHtml +getAddSshR = bootstrap (Just Config) $ do + sideBarDisplay + setTitle "Add a remote server" + u <- liftIO $ T.pack . userName + <$> (getUserEntryForID =<< getEffectiveUserID) + ((result, form), enctype) <- lift $ + runFormGet $ renderBootstrap $ sshServerAForm u + case result of + FormSuccess sshserver -> do + showform form enctype =<< liftIO (testServer sshserver) + _ -> showform form enctype UntestedServer + where + showform form enctype status = do + let authtoken = webAppFormAuthToken + $(widgetFile "configurators/addssh") + + buttonText :: ServerStatus -> Text + buttonText UsableRsyncServer = "Make rsync repository" + buttonText UsableSshServer = "Clone repository to ssh server" + buttonText _ = "Check this server" + + willTest UntestedServer = True + willTest (UnusableServer _) = True + willTest _ = False diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 72b76c33d4..eaa5ac7d16 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -6,7 +6,7 @@ /config ConfigR GET /config/repository RepositoriesR GET /config/repository/add/drive AddDriveR GET -/config/repository/add/remoteserver AddRemoteServerR GET +/config/repository/add/ssh AddSshR GET /config/repository/first FirstRepositoryR GET /transfers/#NotificationId TransfersR GET diff --git a/Locations.hs b/Locations.hs index 330645dfcf..be5fd6c2ff 100644 --- a/Locations.hs +++ b/Locations.hs @@ -30,6 +30,7 @@ module Locations ( gitAnnexHtmlShim, gitAnnexSshDir, gitAnnexRemotesDir, + gitAnnexAssistantDefaultDir, isLinkToAnnex, annexHashes, hashDirMixed, @@ -179,6 +180,11 @@ gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r "ssh" gitAnnexRemotesDir :: Git.Repo -> FilePath gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r "remotes" +{- This is the base directory name used by the assistant when making + - repositories, by default. -} +gitAnnexAssistantDefaultDir :: FilePath +gitAnnexAssistantDefaultDir = "annex" + {- Checks a symlink target to see if it appears to point to annexed content. -} isLinkToAnnex :: FilePath -> Bool isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s diff --git a/templates/configurators/addssh.hamlet b/templates/configurators/addssh.hamlet new file mode 100644 index 0000000000..a0ee9a7ca3 --- /dev/null +++ b/templates/configurators/addssh.hamlet @@ -0,0 +1,38 @@ +
+

+ Adding a remote server using ssh or rsync +

+ Clone this repository to a ssh or rsync server. Your data will be # + uploaded to the server. If you set up other devices to use the same # + server, they will all be kept in sync, using the server as a central # + hub. +

+ You can use nearly any server that has ssh or rsync. For example, you # + could use a Linode or another VPS, or # + an account on a friend's server. +

+ $case status + $of UnusableServer msg +

+ #{msg} + $of _ + Do keep in mind that all your data # + will be synced to the server, so make sure it has enough available # + disk space, bandwidth, and that you trust it with your data. +

+

+
+ ^{form} + ^{authtoken} +
+