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