1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
{- 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
|
