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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
{- 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.SideBar
import Utility.Yesod
import qualified Remote
import Logs.Web (webUUID)
import Logs.Trust
import Annex.UUID (getUUID)
import Init
import qualified Git.Construct
import qualified Git.Config
import qualified Annex
import Locations.UserConfig
import Utility.FreeDesktop
import Yesod
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char
import System.Posix.Directory
{- The main configuration screen. -}
getConfigR :: Handler RepHtml
getConfigR = ifM (inFirstRun)
( getFirstRepositoryR
, bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Configuration"
$(widgetFile "configurators/main")
)
{- Lists different types of repositories that can be added. -}
getAddRepositoryR :: Handler RepHtml
getAddRepositoryR = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Add repository"
$(widgetFile "configurators/addrepository")
{- Lists known repositories. -}
getListRepositoriesR :: Handler RepHtml
getListRepositoriesR = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Repository list"
repolist <- lift repoList
$(widgetFile "configurators/listrepositories")
{- A numbered list of known repositories, including the current one. -}
repoList :: Handler [(String, String)]
repoList = do
l <- runAnnex [] $ do
u <- getUUID
rs <- map Remote.uuid <$> Remote.remoteList
rs' <- snd <$> trustPartition DeadTrusted rs
Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
return $ zip counter l
where
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
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
data RepositoryPath = RepositoryPath Text
deriving Show
{- Custom field display for a RepositoryPath, with an icon etc.
-
- Validates that the path entered is not empty, and is a safe value
- to use as a repository. -}
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view }
where
view idAttr nameAttr attrs val isReq =
[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
parse [path]
| T.null path = nopath
| otherwise = liftIO $ checkRepositoryPath path
parse [] = return $ Right Nothing
parse _ = nopath
nopath = return $ Left "Enter a location for the repository"
{- As well as checking the path for a lot of silly things, tilde is
- expanded in the returned path. -}
checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
checkRepositoryPath p = do
home <- myHomeDir
let basepath = expandTilde home $ T.unpack p
path <- absPath basepath
let parent = parentDir path
problems <- catMaybes <$> mapM runcheck
[ (return $ path == "/", "Enter the full path to use for the repository.")
, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
, (doesFileExist path, "A file already exists with that name.")
, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
, (cannotWrite path, "Cannot write a repository there.")
]
return $
case headMaybe problems of
Nothing -> Right $ Just $ T.pack basepath
Just prob -> Left prob
where
runcheck (chk, msg) = ifM (chk)
( return $ Just msg
, return Nothing
)
cannotWrite path = do
tocheck <- ifM (doesDirectoryExist path)
(return path, return $ parentDir path)
not <$> (catchBoolIO $ fileAccess tocheck False True False)
expandTilde home ('~':'/':path) = home </> path
expandTilde _ path = path
{- On first run, if run in the home directory, default to putting it in
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
-
- If run in another directory, the user probably wants to put it there. -}
defaultRepositoryPath :: Bool -> IO FilePath
defaultRepositoryPath firstrun = do
cwd <- liftIO $ getCurrentDirectory
home <- myHomeDir
if home == cwd && firstrun
then do
desktop <- userDesktopDir
ifM (doesDirectoryExist desktop)
(relHome (desktop </> "annex"), return "~/annex")
else return cwd
addLocalRepositoryForm :: Form RepositoryPath
addLocalRepositoryForm msg = do
path <- T.pack . addTrailingPathSeparator
<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
let (err, errmsg) = case pathRes of
FormMissing -> (False, "")
FormFailure l -> (True, concat $ map T.unpack l)
FormSuccess _ -> (False, "")
let form = do
webAppFormAuthToken
$(widgetFile "configurators/localrepositoryform")
return (RepositoryPath <$> pathRes, form)
getFirstRepositoryR :: Handler RepHtml
getFirstRepositoryR = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Getting started"
((res, form), enctype) <- lift $ runFormGet addLocalRepositoryForm
case res of
FormSuccess (RepositoryPath p) -> lift $
startFullAssistant $ T.unpack p
_ -> $(widgetFile "configurators/firstrepository")
{- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the
- url to the new webapp. -}
startFullAssistant :: FilePath -> Handler ()
startFullAssistant path = do
webapp <- getYesod
url <- liftIO $ do
makeRepo path
changeWorkingDirectory path
fromJust $ postFirstRun webapp
redirect $ T.pack url
{- Makes a new git-annex repository. -}
makeRepo :: FilePath -> IO ()
makeRepo path = do
unlessM (boolSystem "git" [Param "init", Param "--quiet", File path]) $
error "git init failed!"
g <- Git.Config.read =<< Git.Construct.fromPath path
state <- Annex.new g
Annex.eval state $ initialize Nothing
autostart <- autoStartFile
createDirectoryIfMissing True (parentDir autostart)
appendFile autostart $ path ++ "\n"
|
