UI for enabling special remotes
Now other repositories can configure special remotes, and when their configuration has propigated out, they'll appear in the webapp's list of repositories, with a link to enable them. Added support for enabling rsync special remotes, and directory special remotes that are on removable drives. However, encrypted directory special remotes are not supported yet. The removable drive configuator doesn't support them yet anyway.
This commit is contained in:
Joey Hess
parent
df337bb63b
commit
74906ed13f
10 changed files with 253 additions and 89 deletions
|
|
@ -16,10 +16,14 @@ import Assistant.WebApp
|
|||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp.SideBar
|
||||
import Utility.Yesod
|
||||
import Utility.RsyncFile (rsyncUrlIsShell)
|
||||
import Logs.Remote
|
||||
import Remote
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import Network.BSD
|
||||
import System.Posix.User
|
||||
|
||||
|
|
@ -29,32 +33,32 @@ sshConfigurator a = bootstrap (Just Config) $ do
|
|||
setTitle "Add a remote server"
|
||||
a
|
||||
|
||||
data SshServer = SshServer
|
||||
data SshInput = SshInput
|
||||
{ hostname :: Maybe Text
|
||||
, username :: Maybe Text
|
||||
, directory :: Maybe Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
{- SshServer is only used for applicative form prompting, this converts
|
||||
{- SshInput is only used for applicative form prompting, this converts
|
||||
- the result of such a form into a SshData. -}
|
||||
mkSshData :: SshServer -> SshData
|
||||
mkSshData sshserver = SshData
|
||||
{ sshHostName = fromMaybe "" $ hostname sshserver
|
||||
, sshUserName = username sshserver
|
||||
, sshDirectory = fromMaybe "" $ directory sshserver
|
||||
mkSshData :: SshInput -> SshData
|
||||
mkSshData s = SshData
|
||||
{ sshHostName = fromMaybe "" $ hostname s
|
||||
, sshUserName = username s
|
||||
, sshDirectory = fromMaybe "" $ directory s
|
||||
, sshRepoName = genSshRepoName
|
||||
(T.unpack $ fromJust $ hostname sshserver)
|
||||
(maybe "" T.unpack $ directory sshserver)
|
||||
(T.unpack $ fromJust $ hostname s)
|
||||
(maybe "" T.unpack $ directory s)
|
||||
, needsPubKey = False
|
||||
, rsyncOnly = False
|
||||
}
|
||||
|
||||
sshServerAForm :: Maybe Text -> AForm WebApp WebApp SshServer
|
||||
sshServerAForm localusername = SshServer
|
||||
<$> aopt check_hostname "Host name" Nothing
|
||||
<*> aopt check_username "User name" (Just localusername)
|
||||
<*> aopt textField "Directory" (Just $ Just $ T.pack gitAnnexAssistantDefaultDir)
|
||||
sshInputAForm :: SshInput -> AForm WebApp WebApp SshInput
|
||||
sshInputAForm def = SshInput
|
||||
<$> aopt check_hostname "Host name" (Just $ hostname def)
|
||||
<*> aopt check_username "User name" (Just $ username def)
|
||||
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
|
||||
where
|
||||
check_hostname = checkM (liftIO . checkdns) textField
|
||||
checkdns t = do
|
||||
|
|
@ -77,37 +81,92 @@ data ServerStatus
|
|||
= UntestedServer
|
||||
| UnusableServer Text -- reason why it's not usable
|
||||
| UsableRsyncServer
|
||||
| UsableSshServer
|
||||
| UsableSshInput
|
||||
deriving (Eq)
|
||||
|
||||
usable :: ServerStatus -> Bool
|
||||
usable UntestedServer = False
|
||||
usable (UnusableServer _) = False
|
||||
usable UsableRsyncServer = True
|
||||
usable UsableSshServer = True
|
||||
usable UsableSshInput = True
|
||||
|
||||
getAddSshR :: Handler RepHtml
|
||||
getAddSshR = sshConfigurator $ do
|
||||
u <- liftIO $ T.pack . userName
|
||||
<$> (getUserEntryForID =<< getEffectiveUserID)
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap $ sshServerAForm (Just u)
|
||||
runFormGet $ renderBootstrap $ sshInputAForm $
|
||||
SshInput Nothing (Just u) Nothing
|
||||
case result of
|
||||
FormSuccess sshserver -> do
|
||||
(status, needspubkey) <- liftIO $ testServer sshserver
|
||||
if usable status
|
||||
then lift $ redirect $ ConfirmSshR $
|
||||
(mkSshData sshserver)
|
||||
{ needsPubKey = needspubkey
|
||||
, rsyncOnly = status == UsableRsyncServer
|
||||
}
|
||||
else showform form enctype status
|
||||
FormSuccess sshinput -> do
|
||||
s <- liftIO $ testServer sshinput
|
||||
case s of
|
||||
Left status -> showform form enctype status
|
||||
Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
|
||||
_ -> showform form enctype UntestedServer
|
||||
where
|
||||
showform form enctype status = do
|
||||
let authtoken = webAppFormAuthToken
|
||||
$(widgetFile "configurators/ssh/add")
|
||||
|
||||
{- To enable an existing rsync special remote, parse the SshInput from
|
||||
- its rsyncurl, and display a form whose only real purpose is to check
|
||||
- if ssh public keys need to be set up. From there, we can proceed with
|
||||
- the usual repo setup; all that code is idempotent.
|
||||
-
|
||||
- Note that there's no EnableSshR because ssh remotes are not special
|
||||
- remotes, and so their configuration is not shared between repositories.
|
||||
-}
|
||||
getEnableRsyncR :: UUID -> Handler RepHtml
|
||||
getEnableRsyncR u = do
|
||||
m <- runAnnex M.empty readRemoteLog
|
||||
case parseSshRsyncUrl =<< M.lookup "rsyncurl" =<< M.lookup u m of
|
||||
Nothing -> redirect AddSshR
|
||||
Just sshinput -> sshConfigurator $ do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap $ sshInputAForm sshinput
|
||||
case result of
|
||||
FormSuccess sshinput'
|
||||
| isRsyncNet (hostname sshinput') ->
|
||||
void $ lift $ makeRsyncNet sshinput'
|
||||
| otherwise -> do
|
||||
s <- liftIO $ testServer sshinput'
|
||||
case s of
|
||||
Left status -> showform form enctype status
|
||||
Right sshdata -> enable sshdata
|
||||
_ -> showform form enctype UntestedServer
|
||||
where
|
||||
showform form enctype status = do
|
||||
description <- lift $ runAnnex "" $
|
||||
T.pack . concat <$> prettyListUUIDs [u]
|
||||
let authtoken = webAppFormAuthToken
|
||||
$(widgetFile "configurators/ssh/enable")
|
||||
enable sshdata =
|
||||
lift $ redirect $ ConfirmSshR $
|
||||
sshdata { rsyncOnly = True }
|
||||
|
||||
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
|
||||
- url; rsync:// urls or bare path names are not supported.
|
||||
-
|
||||
- The hostname is stored mangled in the remote log for rsync special
|
||||
- remotes configured by this webapp. So that mangling has to reversed
|
||||
- here to get back the original hostname.
|
||||
-}
|
||||
parseSshRsyncUrl :: String -> Maybe SshInput
|
||||
parseSshRsyncUrl u
|
||||
| not (rsyncUrlIsShell u) = Nothing
|
||||
| otherwise = Just $ SshInput
|
||||
{ hostname = val $ unMangleSshHostName host
|
||||
, username = if null user then Nothing else val user
|
||||
, directory = val dir
|
||||
}
|
||||
where
|
||||
val = Just . T.pack
|
||||
(userhost, dir) = separate (== ':') u
|
||||
(user, host) = if '@' `elem` userhost
|
||||
then separate (== '@') userhost
|
||||
else (userhost, "")
|
||||
|
||||
{- Test if we can ssh into the server.
|
||||
-
|
||||
- Two probe attempts are made. First, try sshing in using the existing
|
||||
|
|
@ -118,17 +177,24 @@ getAddSshR = sshConfigurator $ do
|
|||
- Once logged into the server, probe to see if git-annex-shell is
|
||||
- available, or rsync.
|
||||
-}
|
||||
testServer :: SshServer -> IO (ServerStatus, Bool)
|
||||
testServer (SshServer { hostname = Nothing }) = return
|
||||
(UnusableServer "Please enter a host name.", False)
|
||||
testServer sshserver@(SshServer { hostname = Just hn }) = do
|
||||
testServer :: SshInput -> IO (Either ServerStatus SshData)
|
||||
testServer (SshInput { hostname = Nothing }) = return $
|
||||
Left $ UnusableServer "Please enter a host name."
|
||||
testServer sshinput@(SshInput { hostname = Just hn }) = do
|
||||
status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
|
||||
if usable status
|
||||
then return (status, False)
|
||||
then ret status False
|
||||
else do
|
||||
status' <- probe []
|
||||
return (status', True)
|
||||
if usable status'
|
||||
then ret status' True
|
||||
else return $ Left status'
|
||||
where
|
||||
ret status needspubkey = return $ Right $
|
||||
(mkSshData sshinput)
|
||||
{ needsPubKey = needspubkey
|
||||
, rsyncOnly = status == UsableRsyncServer
|
||||
}
|
||||
probe extraopts = do
|
||||
let remotecommand = join ";"
|
||||
[ report "loggedin"
|
||||
|
|
@ -142,12 +208,12 @@ testServer sshserver@(SshServer { hostname = Just hn }) = do
|
|||
- Otherwise, trust the host key. -}
|
||||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||||
, "-n" -- don't read from stdin
|
||||
, genSshHost (fromJust $ hostname sshserver) (username sshserver)
|
||||
, genSshHost (fromJust $ hostname sshinput) (username sshinput)
|
||||
, remotecommand
|
||||
]
|
||||
parsetranscript . fst <$> sshTranscript sshopts ""
|
||||
parsetranscript s
|
||||
| reported "git-annex-shell" = UsableSshServer
|
||||
| reported "git-annex-shell" = UsableSshInput
|
||||
| reported "rsync" = UsableRsyncServer
|
||||
| reported "loggedin" = UnusableServer
|
||||
"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
|
||||
|
|
@ -221,50 +287,53 @@ makeSshRepo forcersync sshdata = do
|
|||
getAddRsyncNetR :: Handler RepHtml
|
||||
getAddRsyncNetR = do
|
||||
((result, form), enctype) <- runFormGet $
|
||||
renderBootstrap $ sshServerAForm Nothing
|
||||
renderBootstrap $ sshInputAForm $
|
||||
SshInput Nothing Nothing Nothing
|
||||
let showform status = bootstrap (Just Config) $ do
|
||||
sideBarDisplay
|
||||
setTitle "Add a Rsync.net repository"
|
||||
let authtoken = webAppFormAuthToken
|
||||
$(widgetFile "configurators/addrsync.net")
|
||||
case result of
|
||||
FormSuccess sshserver -> do
|
||||
knownhost <- liftIO $ maybe (return False) knownHost (hostname sshserver)
|
||||
keypair <- liftIO $ genSshKeyPair
|
||||
sshdata <- liftIO $ setupSshKeyPair keypair
|
||||
(mkSshData sshserver)
|
||||
{ needsPubKey = True
|
||||
, rsyncOnly = True
|
||||
, sshRepoName = "rsync.net"
|
||||
}
|
||||
{- I'd prefer to separate commands with && , but
|
||||
- rsync.net's shell does not support that.
|
||||
-
|
||||
- The dd method of appending to the
|
||||
- authorized_keys file is the one recommended by
|
||||
- rsync.net documentation. I touch the file first
|
||||
- to not need to use a different method to create
|
||||
- it.
|
||||
-}
|
||||
let remotecommand = join ";"
|
||||
[ "mkdir -p .ssh"
|
||||
, "touch .ssh/authorized_keys"
|
||||
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
||||
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
|
||||
]
|
||||
let sshopts = filter (not . null)
|
||||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||||
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||
, remotecommand
|
||||
]
|
||||
|
||||
let host = fromMaybe "" $ hostname sshserver
|
||||
checkhost host showform $
|
||||
sshSetup sshopts (sshPubKey keypair) $
|
||||
makeSshRepo True sshdata
|
||||
FormSuccess sshinput
|
||||
| isRsyncNet (hostname sshinput) ->
|
||||
makeRsyncNet sshinput
|
||||
| otherwise ->
|
||||
showform $ UnusableServer
|
||||
"That is not a rsync.net host name."
|
||||
_ -> showform UntestedServer
|
||||
where
|
||||
checkhost host showform a
|
||||
| ".rsync.net" `T.isSuffixOf` T.toLower host = a
|
||||
| otherwise = showform $ UnusableServer
|
||||
"That is not a rsync.net host name."
|
||||
|
||||
makeRsyncNet :: SshInput -> Handler RepHtml
|
||||
makeRsyncNet sshinput = do
|
||||
knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput)
|
||||
keypair <- liftIO $ genSshKeyPair
|
||||
sshdata <- liftIO $ setupSshKeyPair keypair $
|
||||
(mkSshData sshinput)
|
||||
{ sshRepoName = "rsync.net"
|
||||
, needsPubKey = True
|
||||
, rsyncOnly = True
|
||||
}
|
||||
{- I'd prefer to separate commands with && , but
|
||||
- rsync.net's shell does not support that.
|
||||
-
|
||||
- The dd method of appending to the authorized_keys file is the
|
||||
- one recommended by rsync.net documentation. I touch the file first
|
||||
- to not need to use a different method to create it.
|
||||
-}
|
||||
let remotecommand = join ";"
|
||||
[ "mkdir -p .ssh"
|
||||
, "touch .ssh/authorized_keys"
|
||||
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
||||
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
|
||||
]
|
||||
let sshopts = filter (not . null)
|
||||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||||
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||
, remotecommand
|
||||
]
|
||||
sshSetup sshopts (sshPubKey keypair) $
|
||||
makeSshRepo True sshdata
|
||||
|
||||
isRsyncNet :: Maybe Text -> Bool
|
||||
isRsyncNet Nothing = False
|
||||
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue