got rid of Core module
Most of it was to do with managing annexed Content, so put there
This commit is contained in:
parent
84836ed804
commit
e7b557ef5d
24 changed files with 104 additions and 89 deletions
|
@ -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
|
||||
|
|
|
@ -18,7 +18,7 @@ import TypeInternals
|
|||
import Messages
|
||||
import qualified Annex
|
||||
import Locations
|
||||
import Core
|
||||
import Content
|
||||
|
||||
backend :: Backend
|
||||
backend = Backend.File.backend {
|
||||
|
|
|
@ -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
56
CmdLine.hs
|
@ -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
|
||||
|
|
|
@ -15,7 +15,7 @@ import qualified Annex
|
|||
import qualified Backend
|
||||
import LocationLog
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -13,7 +13,7 @@ import Command
|
|||
import qualified Backend
|
||||
import LocationLog
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
import Utility
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ import qualified Annex
|
|||
import qualified Backend
|
||||
import LocationLog
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -14,7 +14,7 @@ import System.Directory
|
|||
import Command
|
||||
import qualified Annex
|
||||
import Utility
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -17,7 +17,7 @@ import qualified Annex
|
|||
import Utility
|
||||
import qualified Backend
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -10,7 +10,7 @@ module Command.Get where
|
|||
import Command
|
||||
import qualified Backend
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -12,7 +12,7 @@ import System.Exit
|
|||
|
||||
import Command
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import qualified Backend
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -16,7 +16,7 @@ import qualified Annex
|
|||
import qualified Backend
|
||||
import Locations
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
import qualified Command.Add
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -13,7 +13,8 @@ import System.Exit
|
|||
|
||||
import Command
|
||||
import Types
|
||||
import Core
|
||||
import CmdLine
|
||||
import Content
|
||||
import qualified Backend
|
||||
import RsyncFile
|
||||
|
||||
|
|
|
@ -15,7 +15,7 @@ import Locations
|
|||
import qualified Annex
|
||||
import Command
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import qualified Backend
|
||||
import RsyncFile
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ import Utility
|
|||
import qualified Backend
|
||||
import LocationLog
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import Messages
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -16,7 +16,7 @@ import Utility
|
|||
import qualified Backend
|
||||
import LocationLog
|
||||
import Types
|
||||
import Core
|
||||
import Content
|
||||
import qualified GitRepo as Git
|
||||
import Messages
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ import qualified Backend
|
|||
import Types
|
||||
import Messages
|
||||
import Locations
|
||||
import Core
|
||||
import Content
|
||||
import CopyFile
|
||||
|
||||
command :: [Command]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
4
test.hs
|
@ -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"
|
||||
|
|
Loading…
Reference in a new issue