move stuff out of Core
This commit is contained in:
parent
10f30cf638
commit
0e55d6a907
4 changed files with 105 additions and 82 deletions
|
@ -9,14 +9,15 @@ module Command.Init where
|
|||
|
||||
import Control.Monad.State (liftIO)
|
||||
import Control.Monad (when)
|
||||
import System.Directory
|
||||
|
||||
import Command
|
||||
import qualified Annex
|
||||
import Core
|
||||
import qualified GitRepo as Git
|
||||
import UUID
|
||||
import Version
|
||||
import Messages
|
||||
import Locations
|
||||
|
||||
seek :: [SubCmdSeek]
|
||||
seek = [withString start]
|
||||
|
@ -46,3 +47,40 @@ cleanup = do
|
|||
liftIO $ Git.run g ["add", logfile]
|
||||
liftIO $ Git.run g ["commit", "-m", "git annex init", logfile]
|
||||
return True
|
||||
|
||||
{- configure git to use union merge driver on state files, if it is not
|
||||
- already -}
|
||||
gitAttributes :: Git.Repo -> IO ()
|
||||
gitAttributes repo = do
|
||||
exists <- doesFileExist attributes
|
||||
if (not exists)
|
||||
then do
|
||||
writeFile attributes $ attrLine ++ "\n"
|
||||
commit
|
||||
else do
|
||||
content <- readFile attributes
|
||||
when (all (/= attrLine) (lines content)) $ do
|
||||
appendFile attributes $ attrLine ++ "\n"
|
||||
commit
|
||||
where
|
||||
attrLine = stateLoc ++ "*.log merge=union"
|
||||
attributes = Git.attributes repo
|
||||
commit = do
|
||||
Git.run repo ["add", attributes]
|
||||
Git.run repo ["commit", "-m", "git-annex setup",
|
||||
attributes]
|
||||
|
||||
{- set up a git pre-commit hook, if one is not already present -}
|
||||
gitPreCommitHook :: Git.Repo -> IO ()
|
||||
gitPreCommitHook repo = do
|
||||
let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++
|
||||
"/hooks/pre-commit"
|
||||
exists <- doesFileExist hook
|
||||
if (exists)
|
||||
then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
|
||||
else do
|
||||
writeFile hook $ "#!/bin/sh\n" ++
|
||||
"# automatically configured by git-annex\n" ++
|
||||
"git annex pre-commit .\n"
|
||||
p <- getPermissions hook
|
||||
setPermissions hook $ p {executable = True}
|
||||
|
|
81
Core.hs
81
Core.hs
|
@ -26,7 +26,6 @@ import qualified Annex
|
|||
import qualified Backend
|
||||
import Utility
|
||||
import Messages
|
||||
import Version
|
||||
|
||||
{- Runs a list of Annex actions. Catches IO errors and continues
|
||||
- (but explicitly thrown errors terminate the whole command).
|
||||
|
@ -46,11 +45,10 @@ tryRun' state errnum (a:as) = do
|
|||
tryRun' _ errnum [] =
|
||||
when (errnum > 0) $ error $ show errnum ++ " failed"
|
||||
|
||||
{- Sets up a git repo for git-annex. -}
|
||||
{- Actions to perform each time ran. -}
|
||||
startup :: Annex Bool
|
||||
startup = do
|
||||
prepUUID
|
||||
autoUpgrade
|
||||
return True
|
||||
|
||||
{- When git-annex is done, it runs this. -}
|
||||
|
@ -71,43 +69,6 @@ shutdown = do
|
|||
|
||||
return True
|
||||
|
||||
{- configure git to use union merge driver on state files, if it is not
|
||||
- already -}
|
||||
gitAttributes :: Git.Repo -> IO ()
|
||||
gitAttributes repo = do
|
||||
exists <- doesFileExist attributes
|
||||
if (not exists)
|
||||
then do
|
||||
writeFile attributes $ attrLine ++ "\n"
|
||||
commit
|
||||
else do
|
||||
content <- readFile attributes
|
||||
when (all (/= attrLine) (lines content)) $ do
|
||||
appendFile attributes $ attrLine ++ "\n"
|
||||
commit
|
||||
where
|
||||
attrLine = stateLoc ++ "*.log merge=union"
|
||||
attributes = Git.attributes repo
|
||||
commit = do
|
||||
Git.run repo ["add", attributes]
|
||||
Git.run repo ["commit", "-m", "git-annex setup",
|
||||
attributes]
|
||||
|
||||
{- set up a git pre-commit hook, if one is not already present -}
|
||||
gitPreCommitHook :: Git.Repo -> IO ()
|
||||
gitPreCommitHook repo = do
|
||||
let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++
|
||||
"/hooks/pre-commit"
|
||||
exists <- doesFileExist hook
|
||||
if (exists)
|
||||
then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
|
||||
else do
|
||||
writeFile hook $ "#!/bin/sh\n" ++
|
||||
"# automatically configured by git-annex\n" ++
|
||||
"git annex pre-commit .\n"
|
||||
p <- getPermissions hook
|
||||
setPermissions hook $ p {executable = True}
|
||||
|
||||
{- Checks if a given key is currently present in the annexLocation. -}
|
||||
inAnnex :: Key -> Annex Bool
|
||||
inAnnex key = do
|
||||
|
@ -237,43 +198,3 @@ getKeysReferenced = do
|
|||
files <- liftIO $ Git.inRepo g $ Git.workTree g
|
||||
keypairs <- mapM Backend.lookupFile files
|
||||
return $ map fst $ catMaybes keypairs
|
||||
|
||||
{- Uses the annex.version git config setting to automate upgrades. -}
|
||||
autoUpgrade :: Annex ()
|
||||
autoUpgrade = do
|
||||
version <- getVersion
|
||||
case version of
|
||||
Just "0" -> upgradeFrom0
|
||||
Nothing -> return () -- repo not initted yet, no version
|
||||
Just v | v == currentVersion -> return ()
|
||||
Just _ -> error "this version of git-annex is too old for this git repository!"
|
||||
|
||||
upgradeFrom0 :: Annex ()
|
||||
upgradeFrom0 = do
|
||||
showSideAction "Upgrading object directory layout..."
|
||||
g <- Annex.gitRepo
|
||||
|
||||
-- do the reorganisation of the files
|
||||
let olddir = annexDir g
|
||||
keys <- getKeysPresent' olddir
|
||||
_ <- mapM (\k -> moveAnnex k $ olddir ++ "/" ++ keyFile k) keys
|
||||
|
||||
-- update the symlinks to the files
|
||||
files <- liftIO $ Git.inRepo g $ Git.workTree g
|
||||
fixlinks files
|
||||
Annex.queueRun
|
||||
|
||||
setVersion
|
||||
|
||||
where
|
||||
fixlinks [] = return ()
|
||||
fixlinks (f:fs) = do
|
||||
r <- Backend.lookupFile f
|
||||
case r of
|
||||
Nothing -> return ()
|
||||
Just (k, _) -> do
|
||||
link <- calcGitLink f k
|
||||
liftIO $ removeFile f
|
||||
liftIO $ createSymbolicLink link f
|
||||
Annex.queue "add" ["--"] f
|
||||
fixlinks fs
|
||||
|
|
63
Upgrade.hs
Normal file
63
Upgrade.hs
Normal file
|
@ -0,0 +1,63 @@
|
|||
{- git-annex upgrade support
|
||||
-
|
||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Upgrade where
|
||||
|
||||
import System.Directory
|
||||
import Control.Monad.State (liftIO)
|
||||
import System.Posix.Files
|
||||
|
||||
import Core
|
||||
import Types
|
||||
import Locations
|
||||
import qualified GitRepo as Git
|
||||
import qualified Annex
|
||||
import qualified Backend
|
||||
import Messages
|
||||
import Version
|
||||
|
||||
{- Uses the annex.version git config setting to automate upgrades. -}
|
||||
upgrade :: Annex Bool
|
||||
upgrade = do
|
||||
version <- getVersion
|
||||
case version of
|
||||
Just "0" -> upgradeFrom0
|
||||
Nothing -> return True -- repo not initted yet, no version
|
||||
Just v | v == currentVersion -> return True
|
||||
Just _ -> error "this version of git-annex is too old for this git repository!"
|
||||
|
||||
upgradeFrom0 :: Annex Bool
|
||||
upgradeFrom0 = do
|
||||
showSideAction "Upgrading object directory layout..."
|
||||
g <- Annex.gitRepo
|
||||
|
||||
-- do the reorganisation of the files
|
||||
let olddir = annexDir g
|
||||
keys <- getKeysPresent' olddir
|
||||
_ <- mapM (\k -> moveAnnex k $ olddir ++ "/" ++ keyFile k) keys
|
||||
|
||||
-- update the symlinks to the files
|
||||
files <- liftIO $ Git.inRepo g $ Git.workTree g
|
||||
fixlinks files
|
||||
Annex.queueRun
|
||||
|
||||
setVersion
|
||||
|
||||
return True
|
||||
|
||||
where
|
||||
fixlinks [] = return ()
|
||||
fixlinks (f:fs) = do
|
||||
r <- Backend.lookupFile f
|
||||
case r of
|
||||
Nothing -> return ()
|
||||
Just (k, _) -> do
|
||||
link <- calcGitLink f k
|
||||
liftIO $ removeFile f
|
||||
liftIO $ createSymbolicLink link f
|
||||
Annex.queue "add" ["--"] f
|
||||
fixlinks fs
|
|
@ -9,6 +9,7 @@ import System.Environment
|
|||
|
||||
import qualified Annex
|
||||
import Core
|
||||
import Upgrade
|
||||
import CmdLine
|
||||
import qualified GitRepo as Git
|
||||
import BackendList
|
||||
|
@ -19,4 +20,4 @@ main = do
|
|||
gitrepo <- Git.repoFromCwd
|
||||
state <- Annex.new gitrepo allBackends
|
||||
(configure, actions) <- parseCmd args state
|
||||
tryRun state $ [startup] ++ configure ++ actions ++ [shutdown]
|
||||
tryRun state $ [startup, upgrade] ++ configure ++ actions ++ [shutdown]
|
||||
|
|
Loading…
Reference in a new issue