UI for adding a ssh or rsync remote
This commit is contained in:
parent
86fb1305dc
commit
54a492db5f
7 changed files with 144 additions and 39 deletions
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue