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.
This commit is contained in:
parent
8eb1ba4cfe
commit
a5781fd9ba
7 changed files with 73 additions and 43 deletions
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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")
|
||||
|
|
4
debian/changelog
vendored
4
debian/changelog
vendored
|
@ -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.
|
||||
|
|
|
@ -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**
|
||||
|
||||
|
|
Loading…
Reference in a new issue