diff options
author | 2012-08-31 18:59:57 -0400 | |
---|---|---|
committer | 2012-08-31 18:59:57 -0400 | |
commit | 54a492db5f86093349910cc0028ff1a56714775f (patch) | |
tree | 01a858ea5bb9d68dc8eed71efbd435f383269727 | |
parent | 86fb1305dc623865ef672d499e1559a2608c5be6 (diff) |
UI for adding a ssh or rsync remote
-rw-r--r-- | Assistant/WebApp/Configurators.hs | 1 | ||||
-rw-r--r-- | Assistant/WebApp/Configurators/Local.hs | 10 | ||||
-rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 112 | ||||
-rw-r--r-- | Assistant/WebApp/routes | 2 | ||||
-rw-r--r-- | Locations.hs | 6 | ||||
-rw-r--r-- | templates/configurators/addssh.hamlet | 38 | ||||
-rw-r--r-- | templates/configurators/repositories.hamlet | 14 |
7 files changed, 144 insertions, 39 deletions
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 94c84c03a..4d4d5c916 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 04345f731..beb41e1f1 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 912bc7866..afd0e1a79 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 72b76c33d..eaa5ac7d1 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 330645dfc..be5fd6c2f 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 000000000..a0ee9a7ca --- /dev/null +++ b/templates/configurators/addssh.hamlet @@ -0,0 +1,38 @@ +<div .span9 .hero-unit> + <h2> + Adding a remote server using ssh or rsync + <p> + 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. + <p> + You can use nearly any server that has ssh or rsync. For example, you # + could use a <a href="http://linode.com/">Linode</a> or another VPS, or # + an account on a friend's server. + <p> + $case status + $of UnusableServer msg + <div .alert .alert-error> + <i .icon-warning-sign></i> #{msg} + $of _ + <i .icon-warning-sign></i> 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. + <p> + <form .form-horizontal enctype=#{enctype}> + <fieldset> + ^{form} + ^{authtoken} + <div .form-actions> + <button .btn .btn-primary type=submit :willTest status:onclick="$('#testmodal').modal('show');"> + #{buttonText status} +$if willTest status + <div .modal .fade #testmodal> + <div .modal-header> + <h3> + Testing server ... + <div .modal-body> + <p> + Making a ssh connection to the server to check it. # + You may be prompted for your password to log into the server. diff --git a/templates/configurators/repositories.hamlet b/templates/configurators/repositories.hamlet index b853befcf..06c1b3299 100644 --- a/templates/configurators/repositories.hamlet +++ b/templates/configurators/repositories.hamlet @@ -15,7 +15,7 @@ <div .span4> <h3> <a href="@{AddDriveR}"> - <i .icon-plus></i> Removable drive + <i .icon-plus-sign></i> Removable drive <p> Clone this repository to a USB drive, memory stick, or other # removable media. @@ -25,7 +25,7 @@ between computers. <div .span4> <h3> - <i .icon-plus></i> Local computer + <i .icon-plus-sign></i> Local computer <p> Pair with a local computer to automatically keep files in sync # between computers on your local network. @@ -33,7 +33,7 @@ For easy sharing with family and friends, or between your devices. <div .span4> <h3> - <i .icon-plus></i> Phone + <i .icon-plus-sign></i> Phone <p> Save photos and recordings from your phone. <p> @@ -41,7 +41,7 @@ <div .row-fluid> <div .span4> <h3> - <i .icon-plus></i> The cloud + <i .icon-plus-sign></i> The cloud <p> Store your data on a third-party cloud platform, # including Amazon S3, Box.com, and Rsync.net. @@ -50,10 +50,10 @@ With strong encryption to protect your privacy. <div .span4> <h3> - <a href="@{AddRemoteServerR}"> - <i .icon-plus></i> Remote server + <a href="@{AddSshR}"> + <i .icon-plus-sign></i> Remote server <p> Set up a repository on a remote server using # <tt>ssh</tt> or <tt>rsync</tt>. <p> - To use your own personal cloud. + To build your own personal cloud. |