adding removable drive repos now basically works
This commit is contained in:
parent
ccedd06023
commit
cb0f435d94
4 changed files with 85 additions and 38 deletions
|
@ -22,10 +22,8 @@ import Utility.ThreadScheduler
|
||||||
import Utility.Mounts
|
import Utility.Mounts
|
||||||
import Remote.List
|
import Remote.List
|
||||||
import qualified Types.Remote as Remote
|
import qualified Types.Remote as Remote
|
||||||
import qualified Remote.Git
|
|
||||||
import qualified Command.Sync
|
import qualified Command.Sync
|
||||||
import Assistant.Threads.Merger
|
import Assistant.Threads.Merger
|
||||||
import Logs.Remote
|
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
|
@ -194,17 +192,8 @@ remotesUnder st dstatus dir = runThreadState st $ do
|
||||||
where
|
where
|
||||||
checkremote repotop r = case Remote.path r of
|
checkremote repotop r = case Remote.path r of
|
||||||
Just p | dirContains dir (absPathFrom repotop p) ->
|
Just p | dirContains dir (absPathFrom repotop p) ->
|
||||||
(,) <$> pure True <*> updateremote r
|
(,) <$> pure True <*> updateRemote r
|
||||||
_ -> return (False, r)
|
_ -> return (False, r)
|
||||||
updateremote r = do
|
|
||||||
liftIO $ debug thisThread ["updating", show r]
|
|
||||||
m <- readRemoteLog
|
|
||||||
repo <- updaterepo $ Remote.repo r
|
|
||||||
remoteGen m (Remote.remotetype r) repo
|
|
||||||
updaterepo repo
|
|
||||||
| Git.repoIsLocal repo || Git.repoIsLocalUnknown repo =
|
|
||||||
Remote.Git.configRead repo
|
|
||||||
| otherwise = return repo
|
|
||||||
|
|
||||||
type MountPoints = S.Set Mntent
|
type MountPoints = S.Set Mntent
|
||||||
|
|
||||||
|
|
|
@ -15,18 +15,22 @@ import Assistant.WebApp.SideBar
|
||||||
import Assistant.Threads.MountWatcher (handleMount)
|
import Assistant.Threads.MountWatcher (handleMount)
|
||||||
import Utility.Yesod
|
import Utility.Yesod
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
|
import Remote.List
|
||||||
import Logs.Web (webUUID)
|
import Logs.Web (webUUID)
|
||||||
import Logs.Trust
|
import Logs.Trust
|
||||||
import Annex.UUID (getUUID)
|
import Annex.UUID (getUUID)
|
||||||
import Init
|
import Init
|
||||||
|
import qualified Git
|
||||||
import qualified Git.Construct
|
import qualified Git.Construct
|
||||||
import qualified Git.Config
|
import qualified Git.Config
|
||||||
|
import qualified Git.Command
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import Locations.UserConfig
|
import Locations.UserConfig
|
||||||
import Utility.FreeDesktop
|
import Utility.FreeDesktop
|
||||||
import Utility.Mounts
|
import Utility.Mounts
|
||||||
import Utility.DiskFree
|
import Utility.DiskFree
|
||||||
import Utility.DataUnits
|
import Utility.DataUnits
|
||||||
|
import Utility.Network
|
||||||
|
|
||||||
import Yesod
|
import Yesod
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -211,38 +215,70 @@ getAddDriveR = bootstrap (Just Config) $ do
|
||||||
selectDriveForm (sort writabledrives) Nothing
|
selectDriveForm (sort writabledrives) Nothing
|
||||||
case res of
|
case res of
|
||||||
FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do
|
FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do
|
||||||
webapp <- getYesod
|
go $ T.unpack d
|
||||||
liftIO $ go webapp $ T.unpack d </> "annex"
|
|
||||||
setMessage $ toHtml $ T.unwords ["Added", d]
|
setMessage $ toHtml $ T.unwords ["Added", d]
|
||||||
redirect ListRepositoriesR
|
redirect ListRepositoriesR
|
||||||
_ -> do
|
_ -> do
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/adddrive")
|
$(widgetFile "configurators/adddrive")
|
||||||
where
|
where
|
||||||
go webapp dir = do
|
go mountpoint = do
|
||||||
r <- E.try getannex :: IO (Either E.SomeException Annex.AnnexState)
|
liftIO $ makerepo dir
|
||||||
|
liftIO $ initRepo dir $ Just remotename
|
||||||
|
addremotes dir remotename
|
||||||
|
webapp <- getYesod
|
||||||
|
liftIO $ syncrepo dir webapp
|
||||||
|
where
|
||||||
|
dir = mountpoint </> "annex"
|
||||||
|
remotename = takeFileName mountpoint
|
||||||
|
{- The repo may already exist, when adding removable media
|
||||||
|
- that has already been used elsewhere. -}
|
||||||
|
makerepo dir = liftIO $ do
|
||||||
|
r <- E.try (inDir dir $ return True) :: IO (Either E.SomeException Bool)
|
||||||
case r of
|
case r of
|
||||||
Right _ -> noop
|
Right _ -> noop
|
||||||
Left _e -> do
|
Left _e -> do
|
||||||
createDirectoryIfMissing True dir
|
createDirectoryIfMissing True dir
|
||||||
bare <- not <$> canMakeSymlink dir
|
bare <- not <$> canMakeSymlink dir
|
||||||
makeRepo dir bare
|
makeRepo dir bare
|
||||||
initRepo dir $ Just remotename
|
{- Synthesize a mount event of the new git repository.
|
||||||
|
- This will sync it, and queue file transfers. -}
|
||||||
-- TODO setup up git remotes
|
syncrepo dir webapp =
|
||||||
-- 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
|
handleMount
|
||||||
(fromJust $ threadState webapp)
|
(fromJust $ threadState webapp)
|
||||||
(daemonStatus webapp)
|
(daemonStatus webapp)
|
||||||
(scanRemotes webapp)
|
(scanRemotes webapp)
|
||||||
dir
|
dir
|
||||||
|
{- Each repository is made a remote of the other. -}
|
||||||
|
addremotes dir name = runAnnex () $ do
|
||||||
|
hostname <- maybe "host" id <$> liftIO getHostname
|
||||||
|
hostlocation <- fromRepo Git.repoLocation
|
||||||
|
void $ liftIO $ inDir dir $
|
||||||
|
addremote hostname hostlocation
|
||||||
|
whenM (addremote name dir) $
|
||||||
|
void $ remoteListRefresh
|
||||||
|
{- Adds a remote only if there is not already one with
|
||||||
|
- the location. -}
|
||||||
|
addremote name location = inRepo $ \r ->
|
||||||
|
if (null $ filter samelocation $ Git.remotes r)
|
||||||
|
then do
|
||||||
|
let name' = uniqueremotename r name (0 :: Int)
|
||||||
|
Git.Command.runBool "remote"
|
||||||
|
[Param "add", Param name', Param location] r
|
||||||
|
else return False
|
||||||
where
|
where
|
||||||
getannex = Annex.new =<< Git.Construct.fromAbsPath dir
|
samelocation x = Git.repoLocation x == location
|
||||||
remotename = takeFileName dir
|
{- Generate an unused name for a remote, adding a number if
|
||||||
|
- necessary. -}
|
||||||
|
uniqueremotename r basename n
|
||||||
|
| null namecollision = name
|
||||||
|
| otherwise = uniqueremotename r basename (succ n)
|
||||||
|
where
|
||||||
|
namecollision = filter samename (Git.remotes r)
|
||||||
|
samename x = Git.remoteName x == Just name
|
||||||
|
name
|
||||||
|
| n == 0 = basename
|
||||||
|
| otherwise = basename ++ show n
|
||||||
|
|
||||||
{- List of removable drives. -}
|
{- List of removable drives. -}
|
||||||
driveList :: IO [RemovableDrive]
|
driveList :: IO [RemovableDrive]
|
||||||
|
@ -290,13 +326,17 @@ makeRepo path bare = do
|
||||||
| bare = baseparams ++ [Param "--bare", File path]
|
| bare = baseparams ++ [Param "--bare", File path]
|
||||||
| otherwise = baseparams ++ [File path]
|
| otherwise = baseparams ++ [File path]
|
||||||
|
|
||||||
|
{- Runs an action in the git-annex repository in the specified directory. -}
|
||||||
|
inDir :: FilePath -> Annex a -> IO a
|
||||||
|
inDir dir a = do
|
||||||
|
state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir
|
||||||
|
Annex.eval state a
|
||||||
|
|
||||||
{- Initializes a git-annex repository in a directory with a description. -}
|
{- Initializes a git-annex repository in a directory with a description. -}
|
||||||
initRepo :: FilePath -> Maybe String -> IO ()
|
initRepo :: FilePath -> Maybe String -> IO ()
|
||||||
initRepo path desc = do
|
initRepo dir desc = inDir dir $
|
||||||
state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath path
|
unlessM isInitialized $
|
||||||
Annex.eval state $
|
initialize desc
|
||||||
unlessM isInitialized $
|
|
||||||
initialize desc
|
|
||||||
|
|
||||||
{- Adds a directory to the autostart file. -}
|
{- Adds a directory to the autostart file. -}
|
||||||
addAutoStart :: FilePath -> IO ()
|
addAutoStart :: FilePath -> IO ()
|
||||||
|
|
9
Init.hs
9
Init.hs
|
@ -14,6 +14,7 @@ module Init (
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Utility.TempFile
|
import Utility.TempFile
|
||||||
|
import Utility.Network
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Annex.Branch
|
import qualified Annex.Branch
|
||||||
import Logs.UUID
|
import Logs.UUID
|
||||||
|
@ -25,18 +26,12 @@ import System.Posix.User
|
||||||
genDescription :: Maybe String -> Annex String
|
genDescription :: Maybe String -> Annex String
|
||||||
genDescription (Just d) = return d
|
genDescription (Just d) = return d
|
||||||
genDescription Nothing = do
|
genDescription Nothing = do
|
||||||
hostname <- getHostname
|
hostname <- maybe "" id <$> liftIO getHostname
|
||||||
let at = if null hostname then "" else "@"
|
let at = if null hostname then "" else "@"
|
||||||
username <- clicketyclickety
|
username <- clicketyclickety
|
||||||
reldir <- liftIO . relHome =<< fromRepo Git.repoPath
|
reldir <- liftIO . relHome =<< fromRepo Git.repoPath
|
||||||
return $ concat [username, at, hostname, ":", reldir]
|
return $ concat [username, at, hostname, ":", reldir]
|
||||||
where
|
where
|
||||||
{- Haskell lacks uname(2) bindings, except in the
|
|
||||||
- Bindings.Uname addon. Rather than depend on that,
|
|
||||||
- use uname -n when available. -}
|
|
||||||
getHostname = liftIO $ catchDefaultIO uname_node ""
|
|
||||||
uname_node = takeWhile (/= '\n') <$>
|
|
||||||
readProcess "uname" ["-n"]
|
|
||||||
clicketyclickety = liftIO $ userName <$>
|
clicketyclickety = liftIO $ userName <$>
|
||||||
(getUserEntryForID =<< getEffectiveUserID)
|
(getUserEntryForID =<< getEffectiveUserID)
|
||||||
|
|
||||||
|
|
|
@ -19,6 +19,7 @@ import Annex.UUID
|
||||||
import Config
|
import Config
|
||||||
import Remote.Helper.Hooks
|
import Remote.Helper.Hooks
|
||||||
import qualified Git
|
import qualified Git
|
||||||
|
import qualified Git.Config
|
||||||
|
|
||||||
import qualified Remote.Git
|
import qualified Remote.Git
|
||||||
#ifdef WITH_S3
|
#ifdef WITH_S3
|
||||||
|
@ -58,12 +59,34 @@ remoteList = do
|
||||||
where
|
where
|
||||||
process m t = enumerate t >>= mapM (remoteGen m t)
|
process m t = enumerate t >>= mapM (remoteGen m t)
|
||||||
|
|
||||||
|
{- Forces the remoteList to be re-generated, re-reading the git config. -}
|
||||||
|
remoteListRefresh :: Annex [Remote]
|
||||||
|
remoteListRefresh = do
|
||||||
|
newg <- inRepo Git.Config.reRead
|
||||||
|
Annex.changeState $ \s -> s
|
||||||
|
{ Annex.remotes = []
|
||||||
|
, Annex.repo = newg
|
||||||
|
}
|
||||||
|
remoteList
|
||||||
|
|
||||||
{- Generates a Remote. -}
|
{- Generates a Remote. -}
|
||||||
remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote
|
remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote
|
||||||
remoteGen m t r = do
|
remoteGen m t r = do
|
||||||
u <- getRepoUUID r
|
u <- getRepoUUID r
|
||||||
addHooks =<< generate t r u (M.lookup u m)
|
addHooks =<< generate t r u (M.lookup u m)
|
||||||
|
|
||||||
|
{- Updates a local git Remote, re-reading its git config. -}
|
||||||
|
updateRemote :: Remote -> Annex Remote
|
||||||
|
updateRemote remote = do
|
||||||
|
m <- readRemoteLog
|
||||||
|
remote' <- updaterepo $ repo remote
|
||||||
|
remoteGen m (remotetype remote) remote'
|
||||||
|
where
|
||||||
|
updaterepo r
|
||||||
|
| Git.repoIsLocal r || Git.repoIsLocalUnknown r =
|
||||||
|
Remote.Git.configRead r
|
||||||
|
| otherwise = return r
|
||||||
|
|
||||||
{- All remotes that are not ignored. -}
|
{- All remotes that are not ignored. -}
|
||||||
enabledRemoteList :: Annex [Remote]
|
enabledRemoteList :: Annex [Remote]
|
||||||
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
|
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue