1{- git-annex assistant webapp configurators for making local repositories
2 -
3 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
9{-# LANGUAGE RankNTypes, KindSignatures, TypeFamilies, FlexibleContexts #-}
10
11module Assistant.WebApp.Configurators.Local where
12
13import Assistant.WebApp.Common
14import Assistant.WebApp.Gpg
15import Assistant.WebApp.MakeRemote
16import Assistant.Sync
17import Assistant.Restart
18import Assistant.MakeRepo
19import qualified Annex
20import qualified Git
21import qualified Git.Config
22import qualified Git.Command
23import Config.Files.AutoStart
24import Utility.FreeDesktop
25import Utility.DiskFree
26#ifndef mingw32_HOST_OS
27import Utility.Mounts
28#endif
29import Utility.DataUnits
30import Remote (prettyUUID)
31import Annex.UUID
32import Annex.CurrentBranch
33import Types.StandardGroups
34import Logs.PreferredContent
35import Logs.UUID
36import Utility.UserInfo
37import Config
38import Utility.Gpg
39import qualified Remote.GCrypt as GCrypt
40import qualified Types.Remote
41import Utility.Android
42import Types.ProposedAccepted
43
44import qualified Data.Text as T
45import qualified Data.Map as M
46import Data.Char
47import Data.Ord
48import qualified Text.Hamlet as Hamlet
49
50data RepositoryPath = RepositoryPath Text
51	deriving Show
52
53{- Custom field display for a RepositoryPath, with an icon etc.
54 -
55 - Validates that the path entered is not empty, and is a safe value
56 - to use as a repository. -}
57repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
58repositoryPathField autofocus = Field
59	{ fieldParse = \l _ -> parse l
60	, fieldEnctype = UrlEncoded
61	, fieldView = view
62	}
63  where
64	view idAttr nameAttr attrs val isReq =
65		[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
66
67	parse [path]
68		| T.null path = nopath
69		| otherwise = liftIO $ checkRepositoryPath path
70	parse [] = return $ Right Nothing
71	parse _ = nopath
72
73	nopath = return $ Left "Enter a location for the repository"
74
75{- As well as checking the path for a lot of silly things, tilde is
76 - expanded in the returned path. -}
77checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text))
78checkRepositoryPath p = do
79	home <- myHomeDir
80	let basepath = expandTilde home $ T.unpack p
81	path <- fromRawFilePath <$> absPath (toRawFilePath basepath)
82	let parent = fromRawFilePath $ parentDir (toRawFilePath path)
83	problems <- catMaybes <$> mapM runcheck
84		[ (return $ path == "/", "Enter the full path to use for the repository.")
85		, (return $ all isSpace basepath, "A blank path? Seems unlikely.")
86		, (doesFileExist path, "A file already exists with that name.")
87		, (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
88		, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
89		, (not <$> canWrite path, "Cannot write a repository there.")
90		]
91	return $
92		case headMaybe problems of
93			Nothing -> Right $ Just $ T.pack basepath
94			Just prob -> Left prob
95  where
96	runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing )
97	expandTilde home ('~':'/':path) = home </> path
98	expandTilde _ path = path
99
100{- On first run, if run in the home directory, default to putting it in
101 - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
102 -
103 - When on Android, default to ~/storage/shared/annex, which termux sets up
104 - as a link to the sdcard.
105 -
106 - If run in another directory, that the user can write to,
107 - the user probably wants to put it there. Unless that directory
108 - contains a git-annex file, in which case the user has probably
109 - browsed to a directory with git-annex and run it from there. -}
110defaultRepositoryPath :: Bool -> IO FilePath
111defaultRepositoryPath firstrun = do
112#ifndef mingw32_HOST_OS
113	home <- myHomeDir
114	currdir <- liftIO getCurrentDirectory
115	if home == currdir && firstrun
116		then inhome
117		else ifM (legit currdir <&&> canWrite currdir)
118			( return currdir
119			, inhome
120			)
121#else
122	-- On Windows, always default to ~/Desktop/annex or ~/annex,
123	-- no cwd handling because the user might be able to write
124	-- to the entire drive.
125	if firstrun then inhome else inhome
126#endif
127  where
128	inhome = ifM osAndroid
129		( do
130			home <- myHomeDir
131			let storageshared = home </> "storage" </> "shared"
132			ifM (doesDirectoryExist storageshared)
133				( relHome $ storageshared </> gitAnnexAssistantDefaultDir
134				, return $ "~" </> gitAnnexAssistantDefaultDir
135				)
136		, do
137			desktop <- userDesktopDir
138			ifM (doesDirectoryExist desktop <&&> canWrite desktop)
139				( relHome $ desktop </> gitAnnexAssistantDefaultDir
140				, return $ "~" </> gitAnnexAssistantDefaultDir
141				)
142		)
143#ifndef mingw32_HOST_OS
144	-- Avoid using eg, standalone build's git-annex.linux/ directory
145	-- when run from there.
146	legit d = not <$> doesFileExist (d </> "git-annex")
147#endif
148
149newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
150newRepositoryForm defpath msg = do
151	(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
152		(Just $ T.pack $ addTrailingPathSeparator defpath)
153	let (err, errmsg) = case pathRes of
154		FormMissing -> (False, "")
155		FormFailure l -> (True, concatMap T.unpack l)
156		FormSuccess _ -> (False, "")
157	let form = do
158		webAppFormAuthToken
159		$(widgetFile "configurators/newrepository/form")
160	return (RepositoryPath <$> pathRes, form)
161
162{- Making the first repository, when starting the webapp for the first time. -}
163getFirstRepositoryR :: Handler Html
164getFirstRepositoryR = postFirstRepositoryR
165postFirstRepositoryR :: Handler Html
166postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
167	unlessM (liftIO $ inSearchPath "git") $
168		giveup "You need to install git in order to use git-annex!"
169	androidspecial <- liftIO osAndroid
170	path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun
171	((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path
172	case res of
173		FormSuccess (RepositoryPath p) -> liftH $
174			startFullAssistant (T.unpack p) ClientGroup Nothing
175		_ -> $(widgetFile "configurators/newrepository/first")
176
177getAndroidCameraRepositoryR :: Handler ()
178getAndroidCameraRepositoryR = do
179	home <- liftIO myHomeDir
180	let dcim = home </> "storage" </> "dcim"
181	startFullAssistant dcim SourceGroup $ Just addignore
182  where
183	addignore = do
184		liftIO $ unlessM (doesFileExist ".gitignore") $
185			writeFile ".gitignore" ".thumbnails"
186		void $ inRepo $
187			Git.Command.runBool [Param "add", File ".gitignore"]
188
189{- Adding a new local repository, which may be entirely separate, or may
190 - be connected to the current repository. -}
191getNewRepositoryR :: Handler Html
192getNewRepositoryR = postNewRepositoryR
193postNewRepositoryR :: Handler Html
194postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
195	home <- liftIO myHomeDir
196	((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home
197	case res of
198		FormSuccess (RepositoryPath p) -> do
199			let path = T.unpack p
200			isnew <- liftIO $ makeRepo path False
201			u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup)
202			liftIO $ addAutoStartFile path
203			liftIO $ startAssistant path
204			askcombine u path
205		_ -> $(widgetFile "configurators/newrepository")
206  where
207	askcombine newrepouuid newrepopath = do
208		newrepo <- liftIO $ relHome newrepopath
209		mainrepo <- fromJust . relDir <$> liftH getYesod
210		$(widgetFile "configurators/newrepository/combine")
211
212{- Ensure that a remote's description, group, etc are available by
213 - immediately pulling from it. Also spawns a sync to push to it as well. -}
214immediateSyncRemote :: Remote -> Assistant ()
215immediateSyncRemote r = do
216	currentbranch <- liftAnnex $ getCurrentBranch
217	void $ manualPull currentbranch [r]
218	syncRemote r
219
220getCombineRepositoryR :: FilePath -> UUID -> Handler Html
221getCombineRepositoryR newrepopath newrepouuid = do
222	liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename
223	redirect $ EditRepositoryR $ RepoUUID newrepouuid
224  where
225	remotename = takeFileName newrepopath
226
227selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
228selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
229	<$> pure Nothing
230	<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
231	<*> areq textField (bfs "Use this directory on the drive:")
232		(Just $ T.pack gitAnnexAssistantDefaultDir)
233  where
234	pairs = zip (map describe drives) (map mountPoint drives)
235	describe drive = case diskFree drive of
236		Nothing -> mountPoint drive
237		Just free ->
238			let sz = roughSize storageUnits True free
239			in T.unwords
240				[ mountPoint drive
241				, T.concat ["(", T.pack sz]
242				, "free)"
243				]
244	onlywritable = [whamlet|This list only includes drives you can write to.|]
245
246removableDriveRepository :: RemovableDrive -> FilePath
247removableDriveRepository drive =
248	T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
249
250{- Adding a removable drive. -}
251getAddDriveR :: Handler Html
252getAddDriveR = postAddDriveR
253postAddDriveR :: Handler Html
254postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
255	removabledrives <- liftIO driveList
256	writabledrives <- liftIO $
257		filterM (canWrite . T.unpack . mountPoint) removabledrives
258	((res, form), enctype) <- liftH $ runFormPostNoToken $
259		selectDriveForm (sort writabledrives)
260	case res of
261		FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive
262		_ -> $(widgetFile "configurators/adddrive")
263
264{- The repo may already exist, when adding removable media
265 - that has already been used elsewhere. If so, check
266 - the UUID of the repo and see if it's one we know. If not,
267 - the user must confirm the repository merge.
268 -
269 - If the repo does not already exist on the drive, prompt about
270 - encryption. -}
271getConfirmAddDriveR :: RemovableDrive -> Handler Html
272getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
273	( do
274		mu <- liftIO $ probeUUID dir
275		case mu of
276			Nothing -> maybe askcombine isknownuuid
277				=<< liftAnnex (probeGCryptRemoteUUID dir)
278			Just driveuuid -> isknownuuid driveuuid
279	, newrepo
280	)
281  where
282	dir = removableDriveRepository drive
283	newrepo = do
284		cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
285		secretkeys <- sortBy (comparing snd) . M.toList
286			<$> liftIO (secretKeys cmd)
287		page "Encrypt repository?" (Just Configuration) $
288			$(widgetFile "configurators/adddrive/encrypt")
289	knownrepo = getFinishAddDriveR drive NoRepoKey
290	askcombine = page "Combine repositories?" (Just Configuration) $
291		$(widgetFile "configurators/adddrive/combine")
292	isknownuuid driveuuid =
293		ifM (M.member driveuuid <$> liftAnnex uuidDescMap)
294			( knownrepo
295			, askcombine
296			)
297
298setupDriveModal :: Widget
299setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")
300
301getGenKeyForDriveR :: RemovableDrive -> Handler Html
302getGenKeyForDriveR drive = withNewSecretKey $ \keyid ->
303	{- Generating a key takes a long time, and
304	 - the removable drive may have been disconnected
305	 - in the meantime. Check that it is still mounted
306	 - before finishing. -}
307	ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList)
308		( getFinishAddDriveR drive (RepoKey keyid)
309		, getAddDriveR
310		)
311
312getFinishAddDriveR :: RemovableDrive -> RepoKey -> Handler Html
313getFinishAddDriveR drive = go
314  where
315	go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
316		r <- liftAnnex $ addRemote $
317			makeGCryptRemote remotename dir keyid
318		return (Types.Remote.uuid r, r)
319	go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do
320		mu <- liftAnnex $ probeGCryptRemoteUUID dir
321		case mu of
322			Just u -> enableexistinggcryptremote u
323			Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
324	enableexistinggcryptremote u = do
325		remotename' <- liftAnnex $ getGCryptRemoteName u dir
326		makewith $ const $ do
327			r <- liftAnnex $ addRemote $
328				enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
329					[(Proposed "gitrepo", Proposed dir)]
330			return (u, r)
331	{- Making a new unencrypted repo, or combining with an existing one. -}
332	makeunencrypted = makewith $ \isnew -> (,)
333		<$> liftIO (initRepo isnew False dir (Just remotename) Nothing)
334		<*> combineRepos dir remotename
335	makewith a = do
336		liftIO $ createDirectoryIfMissing True dir
337		isnew <- liftIO $ makeRepo dir True
338		{- Removable drives are not reliable media, so enable fsync. -}
339		liftIO $ inDir dir $
340			setConfig "core.fsyncobjectfiles"
341				(Git.Config.boolConfig True)
342		(u, r) <- a isnew
343		when isnew $
344			liftAnnex $ defaultStandardGroup u TransferGroup
345		liftAssistant $ immediateSyncRemote r
346		redirect $ EditNewRepositoryR u
347	mountpoint = T.unpack (mountPoint drive)
348	dir = removableDriveRepository drive
349	remotename = takeFileName mountpoint
350
351{- Each repository is made a remote of the other.
352 - Next call syncRemote to get them in sync. -}
353combineRepos :: FilePath -> String -> Handler Remote
354combineRepos dir name = liftAnnex $ do
355	hostname <- fromMaybe "host" <$> liftIO getHostname
356	mylocation <- fromRepo Git.repoLocation
357	mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile
358		(toRawFilePath dir)
359		(toRawFilePath mylocation)
360	liftIO $ inDir dir $ void $ makeGitRemote hostname mypath
361	addRemote $ makeGitRemote name dir
362
363getEnableDirectoryR :: UUID -> Handler Html
364getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
365	description <- liftAnnex $ T.pack <$> prettyUUID uuid
366	$(widgetFile "configurators/enabledirectory")
367
368{- List of removable drives. -}
369driveList :: IO [RemovableDrive]
370#ifdef mingw32_HOST_OS
371-- Just enumerate all likely drive letters for Windows.
372-- Could use wmic, but it only works for administrators.
373driveList = mapM (\d -> genRemovableDrive $ d:":\\") ['A'..'Z']
374#else
375driveList = mapM (genRemovableDrive . mnt_dir) =<< filter sane <$> getMounts
376  where
377	-- filter out some things that are surely not removable drives
378	sane Mntent { mnt_dir = dir, mnt_fsname = dev }
379		{- We want real disks like /dev/foo, not
380		 - dummy mount points like proc or tmpfs or
381		 - gvfs-fuse-daemon. -}
382		| not ('/' `elem` dev) = False
383		{- Just in case: These mount points are surely not
384		 - removable disks. -}
385		| dir == "/" = False
386		| dir == "/tmp" = False
387		| dir == "/run/shm" = False
388		| dir == "/run/lock" = False
389		| otherwise = True
390#endif
391
392genRemovableDrive :: FilePath -> IO RemovableDrive
393genRemovableDrive dir = RemovableDrive
394	<$> getDiskFree dir
395	<*> pure (T.pack dir)
396	<*> pure (T.pack gitAnnexAssistantDefaultDir)
397
398{- Bootstraps from first run mode to a fully running assistant in a
399 - repository, by running the postFirstRun callback, which returns the
400 - url to the new webapp. -}
401startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler ()
402startFullAssistant path repogroup setup = do
403	webapp <- getYesod
404	url <- liftIO $ do
405		isnew <- makeRepo path False
406		void $ initRepo isnew True path Nothing (Just repogroup)
407		inDir path $ fromMaybe noop setup
408		addAutoStartFile path
409		setCurrentDirectory path
410		fromJust $ postFirstRun webapp
411	redirect $ T.pack url
412
413{- Checks if the user can write to a directory.
414 -
415 - The directory may be in the process of being created; if so
416 - the parent directory is checked instead. -}
417canWrite :: FilePath -> IO Bool
418canWrite dir = do
419	tocheck <- ifM (doesDirectoryExist dir)
420		( return dir
421		, return $ fromRawFilePath $ parentDir $ toRawFilePath dir
422		)
423	catchBoolIO $ fileAccess tocheck False True False
424
425{- Gets the UUID of the git repo at a location, which may not exist, or
426 - not be a git-annex repo. -}
427probeUUID :: FilePath -> IO (Maybe UUID)
428probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
429	u <- getUUID
430	return $ if u == NoUUID then Nothing else Just u
431