From a5781fd9ba9d1ee5fe79355c2c3b9c444068de72 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 9 Oct 2012 14:24:17 -0400 Subject: [PATCH] webapp automatic grouping webapp: Adds newly created repositories to one of these groups: clients, drives, servers This is heuristic, but it's a pretty good heuristic, and can always be configured. --- Assistant/MakeRemote.hs | 3 +- Assistant/Pairing/MakeRemote.hs | 2 +- Assistant/WebApp/Configurators/Local.hs | 24 ++++++++----- Assistant/WebApp/Configurators/S3.hs | 28 ++++++++------- Assistant/WebApp/Configurators/Ssh.hs | 40 +++++++++++++--------- debian/changelog | 4 ++- doc/design/assistant/transfer_control.mdwn | 15 ++++++-- 7 files changed, 73 insertions(+), 43 deletions(-) diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 9184cb5298..cce2da0afd 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -28,11 +28,12 @@ import qualified Data.Map as M import Data.Char {- Sets up and begins syncing with a new ssh or rsync remote. -} -makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO () +makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO Remote makeSshRemote st dstatus scanremotes forcersync sshdata = do r <- runThreadState st $ addRemote $ maker (sshRepoName sshdata) sshurl syncNewRemote st dstatus scanremotes r + return r where rsync = forcersync || rsyncOnly sshdata maker diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index fae8c5ee39..ab0bef13c2 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -46,7 +46,7 @@ finishedPairing st dstatus scanremotes msg keypair = do , "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) ] "" - makeSshRemote st dstatus scanremotes False sshdata + void $ makeSshRemote st dstatus scanremotes False sshdata {- Mostly a straightforward conversion. Except: - * Determine the best hostname to use to contact the host. diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index f389af00a0..d519113e5b 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -28,10 +28,13 @@ import Utility.DiskFree import Utility.DataUnits import Utility.Network import Remote (prettyListUUIDs) +import Logs.Group +import Annex.UUID import Yesod import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Set as S import Data.Char import System.Posix.Directory import qualified Control.Exception as E @@ -142,10 +145,10 @@ getNewRepositoryR = bootstrap (Just Config) $ do case res of FormSuccess (RepositoryPath p) -> lift $ do let path = T.unpack p - liftIO $ do - makeRepo path False - initRepo path Nothing - addAutoStart path + liftIO $ makeRepo path False + u <- liftIO $ initRepo path Nothing + runAnnex () $ groupSet u (S.singleton "clients") + liftIO $ addAutoStart path redirect $ SwitchToRepositoryR path _ -> $(widgetFile "configurators/newrepository") @@ -191,8 +194,9 @@ getAddDriveR = bootstrap (Just Config) $ do where go mountpoint = do liftIO $ makerepo dir - liftIO $ initRepo dir $ Just remotename + u <- liftIO $ initRepo dir $ Just remotename r <- addremote dir remotename + runAnnex () $ groupSet u (S.singleton "drives") syncRemote r where dir = mountpoint gitAnnexAssistantDefaultDir @@ -260,9 +264,10 @@ driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts startFullAssistant :: FilePath -> Handler () startFullAssistant path = do webapp <- getYesod + liftIO $ makeRepo path False + u <- liftIO $ initRepo path Nothing + runAnnex () $ groupSet u (S.singleton "clients") url <- liftIO $ do - makeRepo path False - initRepo path Nothing addAutoStart path changeWorkingDirectory path fromJust $ postFirstRun webapp @@ -286,10 +291,11 @@ inDir dir a = do Annex.eval state a {- Initializes a git-annex repository in a directory with a description. -} -initRepo :: FilePath -> Maybe String -> IO () -initRepo dir desc = inDir dir $ +initRepo :: FilePath -> Maybe String -> IO UUID +initRepo dir desc = inDir dir $ do unlessM isInitialized $ initialize desc + getUUID {- Adds a directory to the autostart file. -} addAutoStart :: FilePath -> IO () diff --git a/Assistant/WebApp/Configurators/S3.hs b/Assistant/WebApp/Configurators/S3.hs index 609ff479bd..2b9e6da7a4 100644 --- a/Assistant/WebApp/Configurators/S3.hs +++ b/Assistant/WebApp/Configurators/S3.hs @@ -19,12 +19,14 @@ import Assistant.ThreadedMonad import Utility.Yesod import qualified Remote.S3 as S3 import Logs.Remote -import Remote (prettyListUUIDs) +import qualified Remote import Types.Remote (RemoteConfig) +import Logs.Group import Yesod import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Set as S import qualified Data.Map as M s3Configurator :: Widget -> Handler RepHtml @@ -80,7 +82,7 @@ getAddS3R = s3Configurator $ do case result of FormSuccess s3input -> lift $ do let name = T.unpack $ repoName s3input - makeS3Remote (extractCreds s3input) name $ M.fromList + makeS3Remote (extractCreds s3input) name setgroup $ M.fromList [ ("encryption", "shared") , ("type", "S3") , ("datacenter", T.unpack $ datacenter s3input) @@ -91,6 +93,8 @@ getAddS3R = s3Configurator $ do showform form enctype = do let authtoken = webAppFormAuthToken $(widgetFile "configurators/adds3") + setgroup r = runAnnex () $ + groupSet (Remote.uuid r) (S.singleton "servers") getEnableS3R :: UUID -> Handler RepHtml getEnableS3R uuid = s3Configurator $ do @@ -101,24 +105,24 @@ getEnableS3R uuid = s3Configurator $ do m <- runAnnex M.empty readRemoteLog let name = fromJust $ M.lookup "name" $ fromJust $ M.lookup uuid m - makeS3Remote s3creds name M.empty + makeS3Remote s3creds name (const noop) M.empty _ -> showform form enctype where showform form enctype = do let authtoken = webAppFormAuthToken description <- lift $ runAnnex "" $ - T.pack . concat <$> prettyListUUIDs [uuid] + T.pack . concat <$> Remote.prettyListUUIDs [uuid] $(widgetFile "configurators/enables3") -makeS3Remote :: S3Creds -> String -> RemoteConfig -> Handler () -makeS3Remote (S3Creds ak sk) name config = do +makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler () +makeS3Remote (S3Creds ak sk) name setup config = do webapp <- getYesod let st = fromJust $ threadState webapp remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0 - liftIO $ do - S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk) - r <- runThreadState st $ addRemote $ do - makeSpecialRemote name S3.remote config - return remotename - syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r + liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk) + r <- liftIO $ runThreadState st $ addRemote $ do + makeSpecialRemote name S3.remote config + return remotename + setup r + liftIO $ syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r redirect RepositoriesR diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 2cefff631a..fc3f878e8c 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -19,11 +19,13 @@ import Utility.Yesod import Utility.Rsync (rsyncUrlIsShell) import Logs.Remote import Remote +import Logs.Group import Yesod import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as M +import qualified Data.Set as S import Network.Socket import System.Posix.User @@ -130,7 +132,7 @@ getEnableRsyncR u = do case result of FormSuccess sshinput' | isRsyncNet (hostname sshinput') -> - void $ lift $ makeRsyncNet sshinput' + void $ lift $ makeRsyncNet sshinput' (const noop) | otherwise -> do s <- liftIO $ testServer sshinput' case s of @@ -250,23 +252,23 @@ getConfirmSshR sshdata = sshConfigurator $ do $(widgetFile "configurators/ssh/confirm") getMakeSshGitR :: SshData -> Handler RepHtml -getMakeSshGitR = makeSsh False +getMakeSshGitR = makeSsh False setupGroup getMakeSshRsyncR :: SshData -> Handler RepHtml -getMakeSshRsyncR = makeSsh True +getMakeSshRsyncR = makeSsh True setupGroup -makeSsh :: Bool -> SshData -> Handler RepHtml -makeSsh rsync sshdata +makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml +makeSsh rsync setup sshdata | needsPubKey sshdata = do keypair <- liftIO genSshKeyPair sshdata' <- liftIO $ setupSshKeyPair keypair sshdata - makeSsh' rsync sshdata' (Just keypair) - | otherwise = makeSsh' rsync sshdata Nothing + makeSsh' rsync setup sshdata' (Just keypair) + | otherwise = makeSsh' rsync setup sshdata Nothing -makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml -makeSsh' rsync sshdata keypair = +makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Handler RepHtml +makeSsh' rsync setup sshdata keypair = sshSetup [sshhost, remoteCommand] "" $ - makeSshRepo rsync sshdata + makeSshRepo rsync setup sshdata where sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) remotedir = T.unpack $ sshDirectory sshdata @@ -280,14 +282,15 @@ makeSsh' rsync sshdata keypair = else Nothing ] -makeSshRepo :: Bool -> SshData -> Handler RepHtml -makeSshRepo forcersync sshdata = do +makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml +makeSshRepo forcersync setup sshdata = do webapp <- getYesod - liftIO $ makeSshRemote + r <- liftIO $ makeSshRemote (fromJust $ threadState webapp) (daemonStatus webapp) (scanRemotes webapp) forcersync sshdata + setup r redirect RepositoriesR getAddRsyncNetR :: Handler RepHtml @@ -303,14 +306,14 @@ getAddRsyncNetR = do case result of FormSuccess sshinput | isRsyncNet (hostname sshinput) -> - makeRsyncNet sshinput + makeRsyncNet sshinput setupGroup | otherwise -> showform $ UnusableServer "That is not a rsync.net host name." _ -> showform UntestedServer -makeRsyncNet :: SshInput -> Handler RepHtml -makeRsyncNet sshinput = do +makeRsyncNet :: SshInput -> (Remote -> Handler ()) -> Handler RepHtml +makeRsyncNet sshinput setup = do knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput) keypair <- liftIO $ genSshKeyPair sshdata <- liftIO $ setupSshKeyPair keypair $ @@ -338,8 +341,11 @@ makeRsyncNet sshinput = do , remotecommand ] sshSetup sshopts (sshPubKey keypair) $ - makeSshRepo True sshdata + makeSshRepo True setup sshdata isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host + +setupGroup :: Remote -> Handler () +setupGroup r = runAnnex () $ groupSet (Remote.uuid r) (S.singleton "server") diff --git a/debian/changelog b/debian/changelog index ed3cf9ebcf..02ebae8102 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,10 +1,12 @@ git-annex (3.20121002) UNRELEASED; urgency=low - * group, ungroup: New commands to indicate groups of repositories. * watch, assistant: It's now safe to git annex unlock files while the watcher is running, as well as modify files checked into git as normal files. Additionally, .gitignore settings are now honored. Closes: #689979 + * group, ungroup: New commands to indicate groups of repositories. + * webapp: Adds newly created repositories to one of these groups: + clients, drives, servers * vicfg: New command, allows editing (or simply viewing) most of the repository configuration settings stored in the git-annex branch. * Added preferred content expressions, configurable using vicfg. diff --git a/doc/design/assistant/transfer_control.mdwn b/doc/design/assistant/transfer_control.mdwn index 6093299071..c506f3e643 100644 --- a/doc/design/assistant/transfer_control.mdwn +++ b/doc/design/assistant/transfer_control.mdwn @@ -6,8 +6,19 @@ it doesn't currently have, is covered by the [[partial_content]] page. But often the remote is just a removable drive or a cloud remote, that has a limited size. This page is about making the assistant do -something smart with such remotes. (Which it now does.. **done** except for -an easy way to configure this.) +something smart with such remotes. + +## TODO + +* easy configuration of preferred content +* Drop no longer preferred content. + - When a file is renamed, it might stop being preferred, so + could be checked and dropped. (If there's multiple links to + the same content, this gets tricky.) + - When a file is sent or received, the sender's preferred content + settings may change, causing it to be dropped from the sender. + - May also want to check for things to drop, from both local and remotes, + when doing the expensive trasfer scan. ## specifying what data a remote prefers to contain **done**