summaryrefslogtreecommitdiff
path: root/Assistant/WebApp/Configurators/Ssh.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/WebApp/Configurators/Ssh.hs')
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs112
1 files changed, 88 insertions, 24 deletions
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