summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/WebApp/Configurators.hs1
-rw-r--r--Assistant/WebApp/Configurators/Local.hs10
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs112
-rw-r--r--Assistant/WebApp/routes2
-rw-r--r--Locations.hs6
-rw-r--r--templates/configurators/addssh.hamlet38
-rw-r--r--templates/configurators/repositories.hamlet14
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.
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-11 02:02:33 +0000