From 3add2cd3ba560bbda353c4696c8f9d25443d61fe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 4 Aug 2012 21:18:57 -0400 Subject: wire up scan and transfer to newly added removable drive remote setup still todo --- Assistant.hs | 2 +- Assistant/Threads/MountWatcher.hs | 23 +++++-------- Assistant/Threads/WebApp.hs | 5 ++- Assistant/WebApp.hs | 2 ++ Assistant/WebApp/Configurators.hs | 69 ++++++++++++++++----------------------- Command/WebApp.hs | 5 ++- 6 files changed, 49 insertions(+), 57 deletions(-) diff --git a/Assistant.hs b/Assistant.hs index b81806ff9..075254dbc 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -155,7 +155,7 @@ startAssistant assistant daemonize webappwaiter = do mapM_ startthread [ watch $ commitThread st changechan commitchan transferqueue dstatus #ifdef WITH_WEBAPP - , assist $ webAppThread (Just st) dstatus transferqueue Nothing webappwaiter + , assist $ webAppThread (Just st) dstatus scanremotes transferqueue Nothing webappwaiter #endif , assist $ pushThread st dstatus commitchan pushmap , assist $ pushRetryThread st dstatus pushmap diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 4baef1d11..9a3396285 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -154,13 +154,14 @@ pollingThread st dstatus scanremotes = go =<< currentMountPoints go nowmounted handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> MountPoints -> MountPoints -> IO () -handleMounts st dstatus scanremotes wasmounted nowmounted = mapM_ (handleMount st dstatus scanremotes) $ - S.toList $ newMountPoints wasmounted nowmounted +handleMounts st dstatus scanremotes wasmounted nowmounted = + mapM_ (handleMount st dstatus scanremotes . mnt_dir) $ + S.toList $ newMountPoints wasmounted nowmounted -handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Mntent -> IO () -handleMount st dstatus scanremotes mntent = do +handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> FilePath -> IO () +handleMount st dstatus scanremotes dir = do debug thisThread ["detected mount of", dir] - rs <- remotesUnder st dstatus mntent + rs <- remotesUnder st dstatus dir unless (null rs) $ do branch <- runThreadState st $ Command.Sync.currentBranch let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs @@ -171,8 +172,6 @@ handleMount st dstatus scanremotes mntent = do now <- getCurrentTime pushToRemotes thisThread now st Nothing nonspecial addScanRemotes scanremotes rs - where - dir = mnt_dir mntent {- Finds remotes located underneath the mount point. - @@ -182,8 +181,8 @@ handleMount st dstatus scanremotes mntent = do - at startup time, or may have changed (it could even be a different - repository at the same remote location..) -} -remotesUnder :: ThreadState -> DaemonStatusHandle -> Mntent -> IO [Remote] -remotesUnder st dstatus mntent = runThreadState st $ do +remotesUnder :: ThreadState -> DaemonStatusHandle -> FilePath -> IO [Remote] +remotesUnder st dstatus dir = runThreadState st $ do repotop <- fromRepo Git.repoPath rs <- remoteList pairs <- mapM (checkremote repotop) rs @@ -194,7 +193,7 @@ remotesUnder st dstatus mntent = runThreadState st $ do return $ map snd $ filter fst pairs where checkremote repotop r = case Remote.path r of - Just p | under mntent (absPathFrom repotop p) -> + Just p | dirContains dir (absPathFrom repotop p) -> (,) <$> pure True <*> updateremote r _ -> return (False, r) updateremote r = do @@ -214,7 +213,3 @@ currentMountPoints = S.fromList <$> getMounts newMountPoints :: MountPoints -> MountPoints -> MountPoints newMountPoints old new = S.difference new old - -{- Checks if a mount point contains a path. The path must be absolute. -} -under :: Mntent -> FilePath -> Bool -under = dirContains . mnt_dir diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 7ea7314e0..7343c39fe 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -19,6 +19,7 @@ import Assistant.WebApp.Configurators import Assistant.WebApp.Documentation import Assistant.ThreadedMonad import Assistant.DaemonStatus +import Assistant.ScanRemotes import Assistant.TransferQueue import Utility.WebApp import Utility.FileMode @@ -40,14 +41,16 @@ type Url = String webAppThread :: (Maybe ThreadState) -> DaemonStatusHandle + -> ScanRemoteMap -> TransferQueue -> Maybe (IO String) -> Maybe (Url -> FilePath -> IO ()) -> IO () -webAppThread mst dstatus transferqueue postfirstrun onstartup = do +webAppThread mst dstatus scanremotes transferqueue postfirstrun onstartup = do webapp <- WebApp <$> pure mst <*> pure dstatus + <*> pure scanremotes <*> pure transferqueue <*> (pack <$> genRandomToken) <*> getreldir mst diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 4042d410e..cdfab0993 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -13,6 +13,7 @@ module Assistant.WebApp where import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus +import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.Alert hiding (Widget) import Utility.NotificationBroadcaster @@ -32,6 +33,7 @@ mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") data WebApp = WebApp { threadState :: Maybe ThreadState , daemonStatus :: DaemonStatusHandle + , scanRemotes :: ScanRemoteMap , transferQueue :: TransferQueue , secretToken :: Text , relDir :: Maybe FilePath diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 30c7c9330..dd6eb39c2 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -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 () diff --git a/Command/WebApp.hs b/Command/WebApp.hs index d3153f630..3b1952073 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -11,6 +11,7 @@ import Common.Annex import Command import Assistant import Assistant.DaemonStatus +import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.Threads.WebApp import Utility.WebApp @@ -83,10 +84,12 @@ autoStart autostartfile = do firstRun :: IO () firstRun = do dstatus <- atomically . newTMVar =<< newDaemonStatus + scanremotes <- newScanRemoteMap transferqueue <- newTransferQueue v <- newEmptyMVar let callback a = Just $ a v - webAppThread Nothing dstatus transferqueue (callback signaler) (callback mainthread) + webAppThread Nothing dstatus scanremotes transferqueue + (callback signaler) (callback mainthread) where signaler v = do putMVar v "" -- cgit v1.2.3