74906ed13f
Now other repositories can configure special remotes, and when their configuration has propigated out, they'll appear in the webapp's list of repositories, with a link to enable them. Added support for enabling rsync special remotes, and directory special remotes that are on removable drives. However, encrypted directory special remotes are not supported yet. The removable drive configuator doesn't support them yet anyway.
91 lines
2.7 KiB
Haskell
91 lines
2.7 KiB
Haskell
{- git-annex assistant webapp configurators
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
|
|
|
module Assistant.WebApp.Configurators where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp.SideBar
|
|
import Assistant.DaemonStatus
|
|
import Assistant.WebApp.Configurators.Local
|
|
import Utility.Yesod
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import Annex.UUID (getUUID)
|
|
import Logs.Remote
|
|
import Logs.Trust
|
|
|
|
import Yesod
|
|
import Data.Text (Text)
|
|
import qualified Data.Map as M
|
|
|
|
{- The main configuration screen. -}
|
|
getConfigR :: Handler RepHtml
|
|
getConfigR = ifM (inFirstRun)
|
|
( getFirstRepositoryR
|
|
, bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Configuration"
|
|
$(widgetFile "configurators/main")
|
|
)
|
|
|
|
{- Lists known repositories, followed by options to add more. -}
|
|
getRepositoriesR :: Handler RepHtml
|
|
getRepositoriesR = bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Repositories"
|
|
repolist <- lift $ repoList False
|
|
$(widgetFile "configurators/repositories")
|
|
|
|
{- A numbered list of known repositories, including the current one. -}
|
|
repoList :: Bool -> Handler [(String, String, Maybe (Route WebApp))]
|
|
repoList onlyconfigured
|
|
| onlyconfigured = list =<< configured
|
|
| otherwise = list =<< (++) <$> configured <*> unconfigured
|
|
where
|
|
configured = do
|
|
rs <- filter (not . Remote.readonly) . knownRemotes <$>
|
|
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
|
|
runAnnex [] $ do
|
|
u <- getUUID
|
|
return $ zip (u : map Remote.uuid rs) (repeat Nothing)
|
|
unconfigured = runAnnex [] $ do
|
|
m <- readRemoteLog
|
|
catMaybes . map (findtype m) . snd
|
|
<$> (trustPartition DeadTrusted $ M.keys m)
|
|
findtype m u = case M.lookup u m of
|
|
Nothing -> Nothing
|
|
Just c -> case M.lookup "type" c of
|
|
Just "rsync" -> u `enableswith` EnableRsyncR
|
|
Just "directory" -> u `enableswith` EnableDirectoryR
|
|
_ -> Nothing
|
|
u `enableswith` r = Just (u, Just $ r u)
|
|
list l = runAnnex [] $ do
|
|
let l' = nubBy (\x y -> fst x == fst y) l
|
|
zip3
|
|
<$> pure counter
|
|
<*> Remote.prettyListUUIDs (map fst l')
|
|
<*> pure (map snd l')
|
|
counter = map show ([1..] :: [Int])
|
|
|
|
{- An intro message, list of repositories, and nudge to make more. -}
|
|
introDisplay :: Text -> Widget
|
|
introDisplay ident = do
|
|
webapp <- lift getYesod
|
|
repolist <- lift $ repoList True
|
|
let n = length repolist
|
|
let numrepos = show n
|
|
let notenough = n < enough
|
|
let barelyenough = n == enough
|
|
let morethanenough = n > enough
|
|
$(widgetFile "configurators/intro")
|
|
lift $ modifyWebAppState $ \s -> s { showIntro = False }
|
|
where
|
|
enough = 2
|