From 74906ed13f85f0b7b9215d82390e7ccb28551642 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 13 Sep 2012 16:47:44 -0400 Subject: 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. --- Assistant/Ssh.hs | 15 ++- Assistant/WebApp/Configurators.hs | 42 +++++-- Assistant/WebApp/Configurators/Local.hs | 9 ++ Assistant/WebApp/Configurators/Ssh.hs | 217 +++++++++++++++++++++----------- Assistant/WebApp/Types.hs | 4 + Assistant/WebApp/routes | 6 +- 6 files changed, 206 insertions(+), 87 deletions(-) (limited to 'Assistant') diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index ded2b0056..32df9cd0b 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -186,8 +186,19 @@ setupSshKeyPair sshkeypair sshdata = do where sshprivkeyfile = "key." ++ mangledhost sshpubkeyfile = sshprivkeyfile ++ ".pub" - mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user - user = maybe "" (\u -> '-' : T.unpack u) (sshUserName sshdata) + mangledhost = mangleSshHostName + (T.unpack $ sshHostName sshdata) + (T.unpack <$> sshUserName sshdata) + +mangleSshHostName :: String -> Maybe String -> String +mangleSshHostName host user = "git-annex-" ++ host ++ (maybe "-" ('-':) user) + +unMangleSshHostName :: String -> String +unMangleSshHostName h + | "git-annex-" `isPrefixOf` h = join "-" (beginning $ drop 2 dashbits) + | otherwise = h + where + dashbits = split "-" h {- Does ssh have known_hosts data for a hostname? -} knownHost :: Text -> IO Bool diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index f6de32166..3f6a3f3e1 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -19,9 +19,12 @@ import Utility.Yesod import qualified Remote import qualified Types.Remote as Remote import Annex.UUID (getUUID) +import Logs.Remote +import Logs.Trust import Yesod import Data.Text (Text) +import qualified Data.Map as M {- The main configuration screen. -} getConfigR :: Handler RepHtml @@ -38,26 +41,45 @@ getRepositoriesR :: Handler RepHtml getRepositoriesR = bootstrap (Just Config) $ do sideBarDisplay setTitle "Repositories" - repolist <- lift repoList + repolist <- lift $ repoList False $(widgetFile "configurators/repositories") {- A numbered list of known repositories, including the current one. -} -repoList :: Handler [(String, String)] -repoList = do - rs <- filter (not . Remote.readonly) . knownRemotes <$> - (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) - l <- runAnnex [] $ do - u <- getUUID - Remote.prettyListUUIDs $ nub $ u : map Remote.uuid rs - return $ zip counter l +repoList :: Bool -> Handler [(String, String, Maybe (Route WebApp))] +repoList onlyconfigured + | onlyconfigured = list =<< configured + | otherwise = list =<< (++) <$> configured <*> unconfigured where + configured = do + rs <- filter (not . Remote.readonly) . knownRemotes <$> + (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) + runAnnex [] $ do + u <- getUUID + return $ zip (u : map Remote.uuid rs) (repeat Nothing) + unconfigured = runAnnex [] $ do + m <- readRemoteLog + catMaybes . map (findtype m) . snd + <$> (trustPartition DeadTrusted $ M.keys m) + findtype m u = case M.lookup u m of + Nothing -> Nothing + Just c -> case M.lookup "type" c of + Just "rsync" -> u `enableswith` EnableRsyncR + Just "directory" -> u `enableswith` EnableDirectoryR + _ -> Nothing + u `enableswith` r = Just (u, Just $ r u) + list l = runAnnex [] $ do + let l' = nubBy (\x y -> fst x == fst y) l + zip3 + <$> pure counter + <*> Remote.prettyListUUIDs (map fst l') + <*> pure (map snd l') counter = map show ([1..] :: [Int]) {- An intro message, list of repositories, and nudge to make more. -} introDisplay :: Text -> Widget introDisplay ident = do webapp <- lift getYesod - repolist <- lift repoList + repolist <- lift $ repoList True let n = length repolist let numrepos = show n let notenough = n < enough diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index dd546881b..e77986674 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -27,6 +27,7 @@ import Utility.Mounts import Utility.DiskFree import Utility.DataUnits import Utility.Network +import Remote (prettyListUUIDs) import Yesod import Data.Text (Text) @@ -194,6 +195,14 @@ getAddDriveR = bootstrap (Just Config) $ do void $ makeGitRemote hostname hostlocation addRemote $ makeGitRemote name dir +getEnableDirectoryR :: UUID -> Handler RepHtml +getEnableDirectoryR uuid = bootstrap (Just Config) $ do + sideBarDisplay + setTitle "Enable a repository" + description <- lift $ runAnnex "" $ + T.pack . concat <$> prettyListUUIDs [uuid] + $(widgetFile "configurators/enabledirectory") + {- Start syncing a newly added remote, using a background thread. -} syncRemote :: Remote -> Handler () syncRemote remote = do diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 925ed23c5..ac705de35 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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 diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index 8cf5d40ad..c00150b65 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -91,3 +91,7 @@ instance PathPiece PairMsg where instance PathPiece SecretReminder where toPathPiece = pack . show fromPathPiece = readish . unpack + +instance PathPiece UUID where + toPathPiece = pack . show + fromPathPiece = readish . unpack diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 10f72a87f..bfc658372 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -5,17 +5,21 @@ /config ConfigR GET /config/repository RepositoriesR GET +/config/repository/first FirstRepositoryR GET + /config/repository/add/drive AddDriveR GET /config/repository/add/ssh AddSshR GET /config/repository/add/ssh/confirm/#SshData ConfirmSshR GET /config/repository/add/ssh/make/git/#SshData MakeSshGitR GET /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET /config/repository/add/rsync.net AddRsyncNetR GET + /config/repository/pair/start StartPairR GET /config/repository/pair/inprogress/#SecretReminder InprogressPairR GET /config/repository/pair/finish/#PairMsg FinishPairR GET -/config/repository/first FirstRepositoryR GET +/config/repository/enable/rsync/#UUID EnableRsyncR GET +/config/repository/enable/directory/#UUID EnableDirectoryR GET /transfers/#NotificationId TransfersR GET /sidebar/#NotificationId SideBarR GET -- cgit v1.2.3