5b9900133c
This is not quite right yet, since it disables it so hard it doesn't show up in the repo list anymore!
139 lines
4.5 KiB
Haskell
139 lines
4.5 KiB
Haskell
{- git-annex assistant webapp configurator for editing existing repos
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
|
|
|
module Assistant.WebApp.Configurators.Edit where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp.SideBar
|
|
import Assistant.WebApp.Configurators.Local (syncRemote)
|
|
import Assistant.WebApp.DashBoard (cancelTransfer)
|
|
import Assistant.DaemonStatus
|
|
import Assistant.TransferQueue
|
|
import Assistant.ThreadedMonad
|
|
import Utility.Yesod
|
|
import qualified Remote
|
|
import qualified Remote.List as Remote
|
|
import qualified Types.Remote as Remote
|
|
import Logs.UUID
|
|
import Logs.Group
|
|
import Logs.PreferredContent
|
|
import Logs.Transfer
|
|
import Types.StandardGroups
|
|
import Config
|
|
import Annex.UUID
|
|
|
|
import Yesod
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
|
|
data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
|
|
deriving (Show, Eq)
|
|
|
|
data RepoConfig = RepoConfig
|
|
{ repoDescription :: Text
|
|
, repoGroup :: RepoGroup
|
|
, repoEnabled :: Bool
|
|
}
|
|
deriving (Show)
|
|
|
|
getRepoConfig :: Remote -> Annex RepoConfig
|
|
getRepoConfig r = RepoConfig
|
|
<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
|
|
<*> getrepogroup
|
|
<*> (thisrepo <||> (elem r <$> Remote.enabledRemoteList))
|
|
where
|
|
getrepogroup = do
|
|
groups <- lookupGroups uuid
|
|
return $
|
|
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
|
|
(getStandardGroup groups)
|
|
thisrepo = (==) uuid <$> getUUID
|
|
uuid = Remote.uuid r
|
|
|
|
{- Returns Just False if the repository has been disabled,
|
|
- or Just True when enabled. -}
|
|
setRepoConfig :: Remote -> RepoConfig -> Annex (Maybe Bool)
|
|
setRepoConfig r c = do
|
|
describeUUID uuid $ T.unpack $ repoDescription c
|
|
case repoGroup c of
|
|
RepoGroupStandard g -> setStandardGroup uuid g
|
|
RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
|
|
ifM ((==) uuid <$> getUUID)
|
|
( return Nothing
|
|
, do
|
|
enabled <- elem r <$> Remote.enabledRemoteList
|
|
if (enabled /= repoEnabled c)
|
|
then do
|
|
setConfig annex_ignore $
|
|
if enabled then "true" else "false"
|
|
void $ Remote.remoteListRefresh
|
|
return $ Just $ repoEnabled c
|
|
else return Nothing
|
|
)
|
|
where
|
|
uuid = Remote.uuid r
|
|
annex_ignore = remoteConfig (Remote.repo r) "ignore"
|
|
|
|
changeEnabled :: Remote -> Bool -> Handler ()
|
|
changeEnabled r True = syncRemote r
|
|
changeEnabled r False = do
|
|
webapp <- getYesod
|
|
let dstatus = daemonStatus webapp
|
|
let st = fromJust $ threadState webapp
|
|
liftIO $ runThreadState st $ updateKnownRemotes dstatus
|
|
{- Stop all transfers to or from this disabled remote.
|
|
- XXX Can't stop any ongoing scan, or git syncs. -}
|
|
void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
|
|
mapM_ (cancelTransfer False) =<<
|
|
filter tofrom . M.keys <$>
|
|
liftIO (currentTransfers <$> getDaemonStatus dstatus)
|
|
where
|
|
tofrom t = transferUUID t == Remote.uuid r
|
|
|
|
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
|
|
editRepositoryAForm def = RepoConfig
|
|
<$> areq textField "Description" (Just $ repoDescription def)
|
|
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
|
|
<*> areq checkBoxField "Syncing enabled" (Just $ repoEnabled def)
|
|
where
|
|
standardgroups :: [(Text, RepoGroup)]
|
|
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
|
|
[minBound :: StandardGroup .. maxBound :: StandardGroup]
|
|
customgroups :: [(Text, RepoGroup)]
|
|
customgroups = case repoGroup def of
|
|
RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
|
|
_ -> []
|
|
|
|
getEditRepositoryR :: UUID -> Handler RepHtml
|
|
getEditRepositoryR uuid = bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Configure repository"
|
|
|
|
r <- lift $ fromMaybe (error "Unknown UUID") . M.lookup uuid
|
|
<$> runAnnex M.empty (Remote.remoteMap id)
|
|
curr <- lift $ runAnnex undefined $ getRepoConfig r
|
|
((result, form), enctype) <- lift $
|
|
runFormGet $ renderBootstrap $ editRepositoryAForm curr
|
|
case result of
|
|
FormSuccess input -> lift $ do
|
|
maybe noop (changeEnabled r) =<<
|
|
runAnnex undefined (setRepoConfig r input)
|
|
redirect RepositoriesR
|
|
_ -> showform form enctype
|
|
where
|
|
showform form enctype = do
|
|
let authtoken = webAppFormAuthToken
|
|
description <- lift $
|
|
runAnnex T.empty $ T.pack . concat <$>
|
|
Remote.prettyListUUIDs [uuid]
|
|
$(widgetFile "configurators/editrepository")
|