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

@ -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

View file

@ -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