305 lines
11 KiB
Haskell
305 lines
11 KiB
Haskell
{- git-annex assistant webapp configurator for editing existing repos
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
|
|
|
module Assistant.WebApp.Configurators.Edit where
|
|
|
|
import Assistant.WebApp.Common
|
|
import Assistant.WebApp.Gpg
|
|
import Assistant.WebApp.Configurators
|
|
import Assistant.DaemonStatus
|
|
import Assistant.WebApp.MakeRemote (uniqueRemoteName)
|
|
import Assistant.ScanRemotes
|
|
import Assistant.Sync
|
|
import Assistant.Alert
|
|
import qualified Assistant.WebApp.Configurators.AWS as AWS
|
|
import qualified Assistant.WebApp.Configurators.IA as IA
|
|
#ifdef WITH_S3
|
|
import qualified Remote.S3 as S3
|
|
#endif
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import qualified Remote.List as Remote
|
|
import Logs.UUID
|
|
import Logs.Group
|
|
import Logs.PreferredContent
|
|
import Logs.Remote
|
|
import Types.StandardGroups
|
|
import qualified Git
|
|
import qualified Git.Types as Git
|
|
import qualified Git.Command
|
|
import qualified Git.Config
|
|
import qualified Annex
|
|
import Git.Remote
|
|
import Remote.Helper.Encryptable (extractCipher)
|
|
import Types.Crypto
|
|
import Utility.Gpg
|
|
import Annex.UUID
|
|
import Assistant.Ssh
|
|
import Config
|
|
|
|
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
|
|
{ repoName :: Text
|
|
, repoDescription :: Maybe Text
|
|
, repoGroup :: RepoGroup
|
|
, repoAssociatedDirectory :: Maybe Text
|
|
, repoSyncable :: Bool
|
|
}
|
|
deriving (Show)
|
|
|
|
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
|
getRepoConfig uuid mremote = do
|
|
-- Ensure we're editing current data by discarding caches.
|
|
void groupMapLoad
|
|
void uuidMapLoad
|
|
|
|
groups <- lookupGroups uuid
|
|
remoteconfig <- M.lookup uuid <$> readRemoteLog
|
|
let (repogroup, associateddirectory) = case getStandardGroup groups of
|
|
Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
|
|
Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)
|
|
|
|
description <- fmap T.pack . M.lookup uuid <$> uuidMap
|
|
|
|
syncable <- case mremote of
|
|
Just r -> return $ remoteAnnexSync $ Remote.gitconfig r
|
|
Nothing -> annexAutoCommit <$> Annex.getGitConfig
|
|
|
|
return $ RepoConfig
|
|
(T.pack $ maybe "here" Remote.name mremote)
|
|
description
|
|
repogroup
|
|
(T.pack <$> associateddirectory)
|
|
syncable
|
|
|
|
setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
|
|
setRepoConfig uuid mremote oldc newc = do
|
|
when descriptionChanged $ liftAnnex $ do
|
|
maybe noop (describeUUID uuid . T.unpack) (repoDescription newc)
|
|
void uuidMapLoad
|
|
when nameChanged $ do
|
|
liftAnnex $ do
|
|
name <- fromRepo $ uniqueRemoteName (legalName newc) 0
|
|
{- git remote rename expects there to be a
|
|
- remote.<name>.fetch, and exits nonzero if
|
|
- there's not. Special remotes don't normally
|
|
- have that, and don't use it. Temporarily add
|
|
- it if it's missing. -}
|
|
let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch"
|
|
needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch)
|
|
when needfetch $
|
|
inRepo $ Git.Command.run
|
|
[Param "config", Param remotefetch, Param ""]
|
|
inRepo $ Git.Command.run
|
|
[ Param "remote"
|
|
, Param "rename"
|
|
, Param $ T.unpack $ repoName oldc
|
|
, Param name
|
|
]
|
|
void Remote.remoteListRefresh
|
|
liftAssistant updateSyncRemotes
|
|
when associatedDirectoryChanged $ case repoAssociatedDirectory newc of
|
|
Nothing -> noop
|
|
Just t
|
|
| T.null t -> noop
|
|
| otherwise -> liftAnnex $ do
|
|
let dir = takeBaseName $ T.unpack t
|
|
m <- readRemoteLog
|
|
case M.lookup uuid m of
|
|
Nothing -> noop
|
|
Just remoteconfig -> configSet uuid $
|
|
M.insert "preferreddir" dir remoteconfig
|
|
when groupChanged $ do
|
|
liftAnnex $ case repoGroup newc of
|
|
RepoGroupStandard g -> setStandardGroup uuid g
|
|
RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
|
|
{- Enabling syncing will cause a scan,
|
|
- so avoid queueing a duplicate scan. -}
|
|
when (repoSyncable newc && not syncableChanged) $ liftAssistant $
|
|
case mremote of
|
|
Just remote -> addScanRemotes True [remote]
|
|
Nothing -> addScanRemotes True
|
|
=<< syncDataRemotes <$> getDaemonStatus
|
|
when syncableChanged $
|
|
liftAssistant $ changeSyncable mremote (repoSyncable newc)
|
|
where
|
|
syncableChanged = repoSyncable oldc /= repoSyncable newc
|
|
associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc
|
|
groupChanged = repoGroup oldc /= repoGroup newc
|
|
nameChanged = isJust mremote && legalName oldc /= legalName newc
|
|
descriptionChanged = repoDescription oldc /= repoDescription newc
|
|
|
|
legalName = makeLegalName . T.unpack . repoName
|
|
|
|
editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig
|
|
editRepositoryAForm mremote def = RepoConfig
|
|
<$> areq (if ishere then readonlyTextField else textField)
|
|
(bfs "Name") (Just $ repoName def)
|
|
<*> aopt textField (bfs "Description") (Just $ repoDescription def)
|
|
<*> areq (selectFieldList groups `withNote` help) (bfs "Repository group") (Just $ repoGroup def)
|
|
<*> associateddirectory
|
|
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
|
|
where
|
|
ishere = isNothing mremote
|
|
isspecial = fromMaybe False $
|
|
(== Git.Unknown) . Git.location . Remote.repo <$> mremote
|
|
groups = customgroups ++ standardgroups
|
|
standardgroups :: [(Text, RepoGroup)]
|
|
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) $
|
|
filter sanegroup [minBound..maxBound]
|
|
sanegroup
|
|
| isspecial = const True
|
|
| otherwise = not . specialRemoteOnly
|
|
customgroups :: [(Text, RepoGroup)]
|
|
customgroups = case repoGroup def of
|
|
RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
|
|
_ -> []
|
|
help = [whamlet|<a href="@{RepoGroupR}">What's this?</a>|]
|
|
|
|
associateddirectory = case repoAssociatedDirectory def of
|
|
Nothing -> aopt hiddenField "" Nothing
|
|
Just d -> aopt textField (bfs "Associated directory") (Just $ Just d)
|
|
|
|
getEditRepositoryR :: RepoId -> Handler Html
|
|
getEditRepositoryR = postEditRepositoryR
|
|
|
|
postEditRepositoryR :: RepoId -> Handler Html
|
|
postEditRepositoryR = editForm False
|
|
|
|
getEditNewRepositoryR :: UUID -> Handler Html
|
|
getEditNewRepositoryR = postEditNewRepositoryR
|
|
|
|
postEditNewRepositoryR :: UUID -> Handler Html
|
|
postEditNewRepositoryR = editForm True . RepoUUID
|
|
|
|
getEditNewCloudRepositoryR :: UUID -> Handler Html
|
|
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
|
|
|
|
postEditNewCloudRepositoryR :: UUID -> Handler Html
|
|
postEditNewCloudRepositoryR uuid = connectionNeeded >> editForm True (RepoUUID uuid)
|
|
|
|
editForm :: Bool -> RepoId -> Handler Html
|
|
editForm new (RepoUUID uuid)
|
|
| uuid == webUUID || uuid == bitTorrentUUID = page "The web" (Just Configuration) $ do
|
|
$(widgetFile "configurators/edit/webrepository")
|
|
| otherwise = page "Edit repository" (Just Configuration) $ do
|
|
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
|
|
when (mremote == Nothing) $
|
|
whenM ((/=) uuid <$> liftAnnex getUUID) $
|
|
error "unknown remote"
|
|
curr <- liftAnnex $ getRepoConfig uuid mremote
|
|
liftAnnex $ checkAssociatedDirectory curr mremote
|
|
((result, form), enctype) <- liftH $
|
|
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr
|
|
case result of
|
|
FormSuccess input -> liftH $ do
|
|
setRepoConfig uuid mremote curr input
|
|
liftAnnex $ checkAssociatedDirectory input mremote
|
|
redirect DashboardR
|
|
_ -> do
|
|
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
|
|
config <- liftAnnex $ M.lookup uuid <$> readRemoteLog
|
|
let repoInfo = getRepoInfo mremote config
|
|
let repoEncryption = getRepoEncryption mremote config
|
|
$(widgetFile "configurators/edit/repository")
|
|
editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
|
|
mr <- liftAnnex (repoIdRemote r)
|
|
let repoInfo = getRepoInfo mr Nothing
|
|
g <- liftAnnex gitRepo
|
|
let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation . Remote.repo) mr
|
|
$(widgetFile "configurators/edit/nonannexremote")
|
|
|
|
{- Makes any directory associated with the repository. -}
|
|
checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex ()
|
|
checkAssociatedDirectory _ Nothing = noop
|
|
checkAssociatedDirectory cfg (Just r) = do
|
|
repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog
|
|
case repoGroup cfg of
|
|
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
|
|
Just d -> inRepo $ \g ->
|
|
createDirectoryIfMissing True $
|
|
Git.repoPath g </> d
|
|
Nothing -> noop
|
|
_ -> noop
|
|
|
|
getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
|
|
getRepoInfo (Just r) (Just c) = case M.lookup "type" c of
|
|
Just "S3"
|
|
#ifdef WITH_S3
|
|
| S3.configIA c -> IA.getRepoInfo c
|
|
#endif
|
|
| otherwise -> AWS.getRepoInfo c
|
|
Just t
|
|
| t /= "git" -> [whamlet|#{t} remote|]
|
|
_ -> getGitRepoInfo $ Remote.repo r
|
|
getRepoInfo (Just r) _ = getRepoInfo (Just r) (Just $ Remote.config r)
|
|
getRepoInfo _ _ = [whamlet|git repository|]
|
|
|
|
getGitRepoInfo :: Git.Repo -> Widget
|
|
getGitRepoInfo r = do
|
|
let loc = Git.repoLocation r
|
|
[whamlet|git repository located at <tt>#{loc}</tt>|]
|
|
|
|
getRepoEncryption :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
|
|
getRepoEncryption (Just _) (Just c) = case extractCipher c of
|
|
Nothing ->
|
|
[whamlet|not encrypted|]
|
|
(Just (SharedCipher _)) ->
|
|
[whamlet|encrypted: encryption key stored in git repository|]
|
|
(Just (EncryptedCipher _ _ (KeyIds { keyIds = ks }))) -> do
|
|
knownkeys <- liftIO secretKeys
|
|
[whamlet|
|
|
encrypted using gpg key:
|
|
<ul style="list-style: none">
|
|
$forall k <- ks
|
|
<li>
|
|
^{gpgKeyDisplay k (M.lookup k knownkeys)}
|
|
|]
|
|
getRepoEncryption _ _ = return () -- local repo
|
|
|
|
getUpgradeRepositoryR :: RepoId -> Handler ()
|
|
getUpgradeRepositoryR (RepoUUID _) = redirect DashboardR
|
|
getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
|
|
where
|
|
go Nothing = redirect DashboardR
|
|
go (Just rmt) = do
|
|
liftIO fixSshKeyPairIdentitiesOnly
|
|
liftAnnex $ setConfig
|
|
(remoteConfig (Remote.repo rmt) "ignore")
|
|
(Git.Config.boolConfig False)
|
|
liftAnnex $ void Remote.remoteListRefresh
|
|
liftAssistant updateSyncRemotes
|
|
liftAssistant $ syncRemote rmt
|
|
redirect DashboardR
|
|
|
|
{- If there is no currently connected remote, display an alert suggesting
|
|
- to set up one. -}
|
|
connectionNeeded :: Handler ()
|
|
connectionNeeded = whenM noconnection $ do
|
|
urlrender <- getUrlRender
|
|
void $ liftAssistant $ do
|
|
close <- asIO1 removeAlert
|
|
addAlert $ connectionNeededAlert $ AlertButton
|
|
{ buttonLabel = "Connect"
|
|
, buttonUrl = urlrender ConnectionNeededR
|
|
, buttonAction = Just close
|
|
, buttonPrimary = True
|
|
}
|
|
where
|
|
noconnection = S.null . currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
|
|
|
|
getConnectionNeededR :: Handler Html
|
|
getConnectionNeededR = page "Connection needed" (Just Configuration) $ do
|
|
$(widgetFile "configurators/needconnection")
|