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:
Joey Hess
parent
8eb1ba4cfe
commit
a5781fd9ba
7 changed files with 73 additions and 43 deletions
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue