wire up scan and transfer to newly added removable drive
remote setup still todo
This commit is contained in:
parent
e125ce74b8
commit
3add2cd3ba
6 changed files with 49 additions and 57 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue