mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

got rid of Core module

Browse source 
Most of it was to do with managing annexed Content, so put there
This commit is contained in:
Joey Hess 2011-01-16 16:05:05 -04:00
parent 84836ed804
commit e7b557ef5d
24 changed files with 104 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Backend/File.hs
View file

@ -22,7 +22,7 @@ import LocationLog
import Locations
import qualified Remotes
import qualified GitRepo as Git
import Core
import Content
import qualified Annex
import UUID
import Messages

2
Backend/SHA1.hs
View file

@ -18,7 +18,7 @@ import TypeInternals
import Messages
import qualified Annex
import Locations
import Core
import Content
backend :: Backend
backend = Backend.File.backend {

2
Backend/WORM.hs
View file

@ -18,7 +18,7 @@ import qualified Backend.File
import TypeInternals
import Locations
import qualified Annex
import Core
import Content
import Messages
backend :: Backend

56
CmdLine.hs
View file

@ -1,4 +1,4 @@
{- git-annex command line parsing
{- git-annex command line parsing and dispatch
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
@ -7,22 +7,27 @@
module CmdLine (
dispatch,
parseCmd,
usage,
shutdown
) where
import System.IO.Error (try)
import System.Console.GetOpt
import Control.Monad (when)
import Control.Monad.State (liftIO)
import Control.Monad (when, unless)
import System.Directory
import qualified Annex
import qualified GitRepo as Git
import qualified GitQueue
import Types
import Command
import BackendList
import Core
import Upgrade
import Options
import Messages
import UUID
import Locations
{- Runs the passed command line. -}
dispatch :: Git.Repo -> [String] -> [Command] -> [Option] -> String -> IO ()
@ -68,3 +73,46 @@ usage header cmds options =
indent l = " " ++ l
pad n s = replicate (n - length s) ' '
longest f = foldl max 0 $ map (length . f) cmds
{- Runs a list of Annex actions. Catches IO errors and continues
- (but explicitly thrown errors terminate the whole command).
- Runs shutdown and propigates an overall error status at the end.
-}
tryRun :: AnnexState -> [Annex Bool] -> IO ()
tryRun state actions = tryRun' state 0 actions
tryRun' :: AnnexState -> Integer -> [Annex Bool] -> IO ()
tryRun' state errnum (a:as) = do
result <- try $ Annex.run state a
case result of
Left err -> do
Annex.eval state $ showErr err
tryRun' state (errnum + 1) as
Right (True,state') -> tryRun' state' errnum as
Right (False,state') -> tryRun' state' (errnum + 1) as
tryRun' state errnum [] = do
_ <- try $ Annex.run state $ shutdown errnum
when (errnum > 0) $ error $ show errnum ++ " failed"
{- Actions to perform each time ran. -}
startup :: Annex Bool
startup = do
prepUUID
return True
{- Cleanup actions. -}
shutdown :: Integer -> Annex ()
shutdown errnum = do
q <- Annex.queueGet
unless (q == GitQueue.empty) $ do
showSideAction "Recording state in git..."
Annex.queueRun
-- If nothing failed, clean up any files left in the temp directory,
-- but leave the directory itself. If something failed, temp files
-- are left behind to allow resuming on re-run.
when (errnum == 0) $ do
g <- Annex.gitRepo
let tmp = annexTmpLocation g
exists <- liftIO $ doesDirectoryExist tmp
when exists $ liftIO $ removeDirectoryRecursive tmp
liftIO $ createDirectoryIfMissing True tmp

2
Command/Add.hs
View file

@ -15,7 +15,7 @@ import qualified Annex
import qualified Backend
import LocationLog
import Types
import Core
import Content
import Messages
command :: [Command]

2
Command/Drop.hs
View file

@ -13,7 +13,7 @@ import Command
import qualified Backend
import LocationLog
import Types
import Core
import Content
import Messages
import Utility

2
Command/DropKey.hs
View file

@ -12,7 +12,7 @@ import qualified Annex
import qualified Backend
import LocationLog
import Types
import Core
import Content
import Messages
command :: [Command]

2
Command/Find.hs
View file

@ -11,7 +11,7 @@ import Control.Monad (when)
import Control.Monad.State (liftIO)
import Command
import Core
import Content
command :: [Command]
command = [Command "find" (paramOptional $ paramRepeating paramPath) seek

2
Command/Fix.hs
View file

@ -14,7 +14,7 @@ import System.Directory
import Command
import qualified Annex
import Utility
import Core
import Content
import Messages
command :: [Command]

2
Command/FromKey.hs
View file

@ -17,7 +17,7 @@ import qualified Annex
import Utility
import qualified Backend
import Types
import Core
import Content
import Messages
command :: [Command]

2
Command/Get.hs
View file

@ -10,7 +10,7 @@ module Command.Get where
import Command
import qualified Backend
import Types
import Core
import Content
import Messages
command :: [Command]

2
Command/InAnnex.hs
View file

@ -12,7 +12,7 @@ import System.Exit
import Command
import Types
import Core
import Content
import qualified Backend
command :: [Command]

2
Command/Migrate.hs
View file

@ -16,7 +16,7 @@ import qualified Annex
import qualified Backend
import Locations
import Types
import Core
import Content
import Messages
import qualified Command.Add

2
Command/Move.hs
View file

@ -14,7 +14,7 @@ import qualified Command.Drop
import qualified Annex
import LocationLog
import Types
import Core
import Content
import qualified GitRepo as Git
import qualified Remotes
import UUID

3
Command/RecvKey.hs
View file

@ -13,7 +13,8 @@ import System.Exit
import Command
import Types
import Core
import CmdLine
import Content
import qualified Backend
import RsyncFile

2
Command/SendKey.hs
View file

@ -15,7 +15,7 @@ import Locations
import qualified Annex
import Command
import Types
import Core
import Content
import qualified Backend
import RsyncFile

2
Command/SetKey.hs
View file

@ -16,7 +16,7 @@ import Utility
import qualified Backend
import LocationLog
import Types
import Core
import Content
import Messages
command :: [Command]

2
Command/Unannex.hs
View file

@ -16,7 +16,7 @@ import Utility
import qualified Backend
import LocationLog
import Types
import Core
import Content
import qualified GitRepo as Git
import Messages

2
Command/Unlock.hs
View file

@ -17,7 +17,7 @@ import qualified Backend
import Types
import Messages
import Locations
import Core
import Content
import CopyFile
command :: [Command]

13
Command/Unused.hs
View file

@ -9,13 +9,16 @@ module Command.Unused where
import Control.Monad.State (liftIO)
import qualified Data.Map as M
import Data.Maybe
import Command
import Types
import Core
import Content
import Messages
import Locations
import qualified Annex
import qualified GitRepo as Git
import qualified Backend
command :: [Command]
command = [Command "unused" paramNothing seek "look for unused file content"]
@ -80,3 +83,11 @@ unusedKeys = do
existsMap :: Ord k => [k] -> M.Map k Int
existsMap l = M.fromList $ map (\k -> (k, 1)) l
{- List of keys referenced by symlinks in the git repo. -}
getKeysReferenced :: Annex [Key]
getKeysReferenced = do
g <- Annex.gitRepo
files <- liftIO $ Git.inRepo g [Git.workTree g]
keypairs <- mapM Backend.lookupFile files
return $ map fst $ catMaybes keypairs

75
Core.hs → Content.hs
View file

@ -1,19 +1,30 @@
{- git-annex core functions
{- git-annex file content managing
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Core where
module Content (
inAnnex,
calcGitLink,
logStatus,
getViaTmp,
preventWrite,
allowWrite,
moveAnnex,
removeAnnex,
fromAnnex,
moveBad,
getKeysPresent
) where
import System.IO.Error (try)
import System.Directory
import Control.Monad.State (liftIO)
import System.Path
import Control.Monad (when, unless, filterM)
import Control.Monad (when, filterM)
import System.Posix.Files
import Data.Maybe
import System.FilePath
import Types
@ -21,56 +32,8 @@ import Locations
import LocationLog
import UUID
import qualified GitRepo as Git
import qualified GitQueue
import qualified Annex
import qualified Backend
import Utility
import Messages
{- Runs a list of Annex actions. Catches IO errors and continues
- (but explicitly thrown errors terminate the whole command).
- Runs shutdown and propigates an overall error status at the end.
-}
tryRun :: AnnexState -> [Annex Bool] -> IO ()
tryRun state actions = tryRun' state 0 actions
tryRun' :: AnnexState -> Integer -> [Annex Bool] -> IO ()
tryRun' state errnum (a:as) = do
result <- try $ Annex.run state a
case result of
Left err -> do
Annex.eval state $ showErr err
tryRun' state (errnum + 1) as
Right (True,state') -> tryRun' state' errnum as
Right (False,state') -> tryRun' state' (errnum + 1) as
tryRun' state errnum [] = do
_ <- try $ Annex.run state $ shutdown errnum
when (errnum > 0) $ error $ show errnum ++ " failed"
{- Actions to perform each time ran. -}
startup :: Annex Bool
startup = do
prepUUID
return True
{- When git-annex is done, it runs this. -}
shutdown :: Integer -> Annex Bool
shutdown errnum = do
q <- Annex.queueGet
unless (q == GitQueue.empty) $ do
showSideAction "Recording state in git..."
Annex.queueRun
-- If nothing failed, clean up any files left in the temp directory,
-- but leave the directory itself. If something failed, temp files
-- are left behind to allow resuming on re-run.
when (errnum == 0) $ do
g <- Annex.gitRepo
let tmp = annexTmpLocation g
exists <- liftIO $ doesDirectoryExist tmp
when exists $ liftIO $ removeDirectoryRecursive tmp
liftIO $ createDirectoryIfMissing True tmp
return True
{- Checks if a given key is currently present in the annexLocation. -}
inAnnex :: Key -> Annex Bool
@ -200,11 +163,3 @@ getKeysPresent' dir = do
case result of
Right s -> return $ isRegularFile s
Left _ -> return False
{- List of keys referenced by symlinks in the git repo. -}
getKeysReferenced :: Annex [Key]
getKeysReferenced = do
g <- Annex.gitRepo
files <- liftIO $ Git.inRepo g [Git.workTree g]
keypairs <- mapM Backend.lookupFile files
return $ map fst $ catMaybes keypairs

6
Remotes.hs
View file

@ -34,7 +34,7 @@ import LocationLog
import Locations
import UUID
import Utility
import qualified Core
import qualified Content
import Messages
import CopyFile
import RsyncFile
@ -159,7 +159,7 @@ inAnnex r key = if Git.repoIsUrl r
-- run a local check inexpensively,
-- by making an Annex monad using the remote
a <- Annex.new r []
Annex.eval a (Core.inAnnex key)
Annex.eval a (Content.inAnnex key)
checkremote = do
showNote ("checking " ++ Git.repoDescribe r ++ "...")
inannex <- onRemote r (boolSystem, False) "inannex"
@ -253,7 +253,7 @@ copyToRemote r key
liftIO $ do
a <- Annex.new r []
Annex.eval a $ do
ok <- Core.getViaTmp key $
ok <- Content.getViaTmp key $
\f -> liftIO $ copyFile keysrc f
Annex.queueRun
return ok

2
Upgrade.hs
View file

@ -14,7 +14,7 @@ import Control.Monad (filterM)
import System.Posix.Files
import System.FilePath
import Core
import Content
import Types
import Locations
import qualified GitRepo as Git

4
test.hs
View file

@ -32,7 +32,7 @@ import qualified GitAnnex
import qualified LocationLog
import qualified UUID
import qualified Remotes
import qualified Core
import qualified Content
import qualified Backend.SHA1
import qualified Backend.WORM
import qualified Command.DropUnused
@ -318,7 +318,7 @@ test_fsck = "git-annex fsck" ~: intmpclonerepo $ do
where
corrupt f = do
git_annex "get" ["-q", f] @? "get of file failed"
Core.allowWrite f
Content.allowWrite f
writeFile f (changedcontent f)
r <- git_annex "fsck" ["-q"]
not r @? "fsck failed to fail with corrupted file content"