diff options
| -rw-r--r-- | Assistant/Ssh.hs | 15 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 42 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Local.hs | 9 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 217 | ||||
| -rw-r--r-- | Assistant/WebApp/Types.hs | 4 | ||||
| -rw-r--r-- | Assistant/WebApp/routes | 6 | ||||
| -rw-r--r-- | templates/configurators/enabledirectory.hamlet | 10 | ||||
| -rw-r--r-- | templates/configurators/intro.hamlet | 2 | ||||
| -rw-r--r-- | templates/configurators/repositories.hamlet | 7 | ||||
| -rw-r--r-- | templates/configurators/ssh/enable.hamlet | 30 |
10 files changed, 253 insertions, 89 deletions
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 diff --git a/templates/configurators/enabledirectory.hamlet b/templates/configurators/enabledirectory.hamlet new file mode 100644 index 000000000..03da311c5 --- /dev/null +++ b/templates/configurators/enabledirectory.hamlet @@ -0,0 +1,10 @@ +<div .span9 .hero-unit> + <h2> + Enabling #{description} + <p> + Where is this repository located? + <p> + <a .btn href="@{AddDriveR}"> + On a removable drive + <a .btn href="@{RepositoriesR}"> + Cancel diff --git a/templates/configurators/intro.hamlet b/templates/configurators/intro.hamlet index 4a1f228c8..c1642b061 100644 --- a/templates/configurators/intro.hamlet +++ b/templates/configurators/intro.hamlet @@ -17,7 +17,7 @@ \ repositories and devices: <table .table .table-striped .table-condensed> <tbody> - $forall (num, name) <- repolist + $forall (num, name, _) <- repolist <tr> <td> #{num} diff --git a/templates/configurators/repositories.hamlet b/templates/configurators/repositories.hamlet index a38ec10af..32b79708d 100644 --- a/templates/configurators/repositories.hamlet +++ b/templates/configurators/repositories.hamlet @@ -3,12 +3,17 @@ Your repositories <table .table .table-condensed> <tbody> - $forall (num, name) <- repolist + $forall (num, name, needsenabled) <- repolist <tr> <td> #{num} <td> #{name} + <td> + $maybe enable <- needsenabled + not enabled here → # + <a href="@{enable}"> + enable <div .row-fluid> <div .span6> <h2> diff --git a/templates/configurators/ssh/enable.hamlet b/templates/configurators/ssh/enable.hamlet new file mode 100644 index 000000000..1e35e481b --- /dev/null +++ b/templates/configurators/ssh/enable.hamlet @@ -0,0 +1,30 @@ +<div .span9 .hero-unit> + <h2> + Enabling #{description} + <p> + Another repository uses this server, but the server is not # + yet enabled for use here. The first step to enable it is to check if it's # + usable here. + <p> + <p> + <form .form-horizontal enctype=#{enctype}> + <fieldset> + <div .form-actions> + <button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');"> + Check this server + $case status + $of UnusableServer msg + <div .alert .alert-error> + <i .icon-warning-sign></i> #{msg} + $of _ + ^{form} + ^{authtoken} +<div .modal .fade #testmodal> + <div .modal-header> + <h3> + Testing server ... + <div .modal-body> + <p> + Checking ssh connection to the server. This could take a minute. + <p> + You may be prompted for your password to log into the server. |