wire up scan and transfer to newly added removable drive

remote setup still todo
This commit is contained in:
Joey Hess 2012-08-04 21:18:57 -04:00
parent e125ce74b8
commit 3add2cd3ba
6 changed files with 49 additions and 57 deletions

View file

@ -12,6 +12,7 @@ module Assistant.WebApp.Configurators where
import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.SideBar
import Assistant.Threads.MountWatcher (handleMount)
import Utility.Yesod
import qualified Remote
import Logs.Web (webUUID)
@ -32,7 +33,6 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Char
import System.Posix.Directory
import System.Posix.User
import qualified Control.Exception as E
{- The main configuration screen. -}
@ -199,7 +199,7 @@ selectDriveForm drives def = renderBootstrap $ RemovableDrive
, "free)"
]
{- Making the first repository, when starting the webapp for the first time. -}
{- Adding a removable drive. -}
getAddDriveR :: Handler RepHtml
getAddDriveR = bootstrap (Just Config) $ do
sideBarDisplay
@ -211,50 +211,38 @@ getAddDriveR = bootstrap (Just Config) $ do
selectDriveForm (sort writabledrives) Nothing
case res of
FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do
liftIO $ go $ T.unpack d </> "annex"
webapp <- getYesod
liftIO $ go webapp $ T.unpack d </> "annex"
setMessage $ toHtml $ T.unwords ["Added", d]
redirect ListRepositoriesR
_ -> do
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/adddrive")
where
{- There may already be a git-annex repo on the drive.
- If so, avoid re-initualizing it; this will be the
- case if a user is adding the same removable drive
- to several computers.
-
- Some drives will have FAT or another horrible filesystem
- that does not support symlinks; make a bare repo on those.
-
- Use the basename of the mount point, along with the
- username (but without the hostname as this repo
- travels!), as the repo description, and use the basename
- of the mount point as the git remote name.
-}
go dir = do
go webapp dir = do
r <- E.try getannex :: IO (Either E.SomeException Annex.AnnexState)
state <- case r of
Right state -> return state
case r of
Right _ -> noop
Left _e -> do
createDirectoryIfMissing True dir
bare <- not <$> canMakeSymlink dir
makeRepo dir bare
getannex
desc <- getdesc
Annex.eval state $
unlessM isInitialized $
initialize $ Just desc
initRepo dir $ Just remotename
-- TODO setup up git remotes
-- TODO add it to Annex.remotes
{- Now synthesize a mount event of the new
- git repository. This will sync it, and queue
- file transfers. -}
handleMount
(fromJust $ threadState webapp)
(daemonStatus webapp)
(scanRemotes webapp)
dir
where
getannex = Annex.new =<< Git.Construct.fromAbsPath dir
remotename = takeFileName dir
getdesc = do
username <- userName <$>
(getUserEntryForID =<< getEffectiveUserID)
return $ concat
[ username
, ":"
, remotename
]
{- List of removable drives. -}
driveList :: IO [RemovableDrive]
@ -265,12 +253,12 @@ driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
<*> pure (T.pack dir)
-- filter out some things that are surely not removable drives
sane Mntent { mnt_dir = dir, mnt_fsname = dev }
-- We want real disks like /dev/foo, not
-- dummy mount points like proc or tmpfs or
-- gvfs-fuse-daemon
{- We want real disks like /dev/foo, not
- dummy mount points like proc or tmpfs or
- gvfs-fuse-daemon. -}
| not ('/' `elem` dev) = False
-- Just in case: These mount points are surely not
-- removable disks.
{- Just in case: These mount points are surely not
- removable disks. -}
| dir == "/" = False
| dir == "/tmp" = False
| dir == "/run/shm" = False
@ -305,9 +293,10 @@ makeRepo path bare = do
{- Initializes a git-annex repository in a directory with a description. -}
initRepo :: FilePath -> Maybe String -> IO ()
initRepo path desc = do
g <- Git.Config.read =<< Git.Construct.fromPath path
state <- Annex.new g
Annex.eval state $ initialize desc
state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath path
Annex.eval state $
unlessM isInitialized $
initialize desc
{- Adds a directory to the autostart file. -}
addAutoStart :: FilePath -> IO ()