diff options
| -rw-r--r-- | Backend.hs | 24 | ||||
| -rw-r--r-- | Backend/SHA.hs | 11 | ||||
| -rw-r--r-- | Backend/WORM.hs | 40 | ||||
| -rw-r--r-- | BackendTypes.hs | 44 | ||||
| -rw-r--r-- | Command.hs | 13 | ||||
| -rw-r--r-- | Command/DropKey.hs | 6 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 5 | ||||
| -rw-r--r-- | Command/FromKey.hs | 2 | ||||
| -rw-r--r-- | Command/InAnnex.hs | 9 | ||||
| -rw-r--r-- | Command/Move.hs | 5 | ||||
| -rw-r--r-- | Command/RecvKey.hs | 3 | ||||
| -rw-r--r-- | Command/SendKey.hs | 3 | ||||
| -rw-r--r-- | Command/Unused.hs | 2 | ||||
| -rw-r--r-- | Content.hs | 3 | ||||
| -rw-r--r-- | Key.hs | 45 | ||||
| -rw-r--r-- | Locations.hs | 9 | ||||
| -rw-r--r-- | Makefile | 1 | ||||
| -rw-r--r-- | Remotes.hs | 5 | ||||
| -rw-r--r-- | Types.hs | 6 | ||||
| -rw-r--r-- | Upgrade.hs | 3 |
20 files changed, 116 insertions, 123 deletions
diff --git a/Backend.hs b/Backend.hs index df23e80a3..94755e8d6 100644 --- a/Backend.hs +++ b/Backend.hs @@ -39,6 +39,7 @@ import Locations import qualified GitRepo as Git import qualified Annex import Types +import Key import qualified BackendTypes as B import Messages @@ -135,18 +136,19 @@ lookupFile file = do getsymlink = do l <- readSymbolicLink file return $ takeFileName l - makekey bs l = do + makekey bs l = + case fileKey l of + Just k -> makeret k l bs + Nothing -> return Nothing + makeret k l bs = case maybeLookupBackendName bs bname of - Nothing -> do - unless (null kname || null bname || - not (isLinkToAnnex l)) $ - warning skip - return Nothing - Just backend -> return $ Just (k, backend) + Just backend -> return $ Just (k, backend) + Nothing -> do + when (isLinkToAnnex l) $ + warning skip + return Nothing where - k = fileKey l - bname = backendName k - kname = keyName k + bname = keyBackendName k skip = "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")" @@ -164,4 +166,4 @@ chooseBackends fs = do keyBackend :: Key -> Annex (Backend Annex) keyBackend key = do bs <- Annex.getState Annex.supportedBackends - return $ lookupBackendName bs $ backendName key + return $ lookupBackendName bs $ keyBackendName key diff --git a/Backend/SHA.hs b/Backend/SHA.hs index 4eea890ce..3cdc3bf80 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -13,6 +13,7 @@ import System.Cmd.Utils import System.IO import System.Directory import Data.Maybe +import System.Posix.Files import qualified Backend.File import BackendTypes @@ -23,6 +24,7 @@ import Content import Types import Utility import qualified SysConfig +import Key type SHASize = Int @@ -63,11 +65,16 @@ shaN size file = do where command = "sha" ++ (show size) ++ "sum" --- A key is a checksum of its contents. +{- A key is a checksum of its contents. -} keyValue :: SHASize -> FilePath -> Annex (Maybe Key) keyValue size file = do s <- shaN size file - return $ Just $ Key (shaName size, s) + stat <- liftIO $ getFileStatus file + return $ Just $ stubKey { + keyName = s, + keyBackendName = shaName size, + keySize = Just $ fromIntegral $ fileSize stat + } -- A key's checksum is checked during fsck. checkKeyChecksum :: SHASize -> Key -> Annex Bool diff --git a/Backend/WORM.hs b/Backend/WORM.hs index a0d814aa0..324aee76b 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -10,9 +10,8 @@ module Backend.WORM (backends) where import Control.Monad.State import System.FilePath import System.Posix.Files -import System.Posix.Types import System.Directory -import Data.String.Utils +import Data.Maybe import qualified Backend.File import BackendTypes @@ -21,6 +20,7 @@ import qualified Annex import Content import Messages import Types +import Key backends :: [Backend Annex] backends = [backend] @@ -32,31 +32,25 @@ backend = Backend.File.backend { fsckKey = Backend.File.checkKey checkKeySize } --- The key is formed from the file size, modification time, and the --- basename of the filename. --- --- That allows multiple files with the same names to have different keys, --- while also allowing a file to be moved around while retaining the --- same key. +{- The key includes the file size, modification time, and the + - basename of the filename. + - + - That allows multiple files with the same names to have different keys, + - while also allowing a file to be moved around while retaining the + - same key. + -} keyValue :: FilePath -> Annex (Maybe Key) keyValue file = do stat <- liftIO $ getFileStatus file - return $ Just $ Key (name backend, key stat) - where - key stat = uniqueid stat ++ sep ++ base - uniqueid stat = show (modificationTime stat) ++ sep ++ - show (fileSize stat) - base = takeFileName file - sep = ":" - -{- Extracts the file size from a key. -} -keySize :: Key -> FileOffset -keySize key = read $ section !! 1 - where - section = split ":" (keyName key) + return $ Just $ Key { + keyName = takeFileName file, + keyBackendName = name backend, + keySize = Just $ fromIntegral $ fileSize stat, + keyMtime = Just $ modificationTime stat + } {- The size of the data for a key is checked against the size encoded in - - the key. Note that the modification time is not checked. -} + - the key's metadata. -} checkKeySize :: Key -> Annex Bool checkKeySize key = do g <- Annex.gitRepo @@ -66,7 +60,7 @@ checkKeySize key = do then return True else do s <- liftIO $ getFileStatus file - if fileSize s == keySize key + if fromIntegral (fileSize s) == fromJust (keySize key) then return True else do dest <- moveBad key diff --git a/BackendTypes.hs b/BackendTypes.hs index c0705a550..48b208a9b 100644 --- a/BackendTypes.hs +++ b/BackendTypes.hs @@ -1,4 +1,4 @@ -{- git-annex key/value backend data types +{- git-annex key/value backend data type - - Most things should not need this, using Types instead - @@ -9,12 +9,7 @@ module BackendTypes where -import Data.String.Utils -import Test.QuickCheck - -type KeyName = String -type BackendName = String -newtype Key = Key (BackendName, KeyName) deriving (Eq, Ord) +import Key data Backend a = Backend { -- name of this backend @@ -42,38 +37,3 @@ instance Show (Backend a) where instance Eq (Backend a) where a == b = name a == name b - --- accessors for the parts of a key -keyName :: Key -> KeyName -keyName (Key (_,k)) = k -backendName :: Key -> BackendName -backendName (Key (b,_)) = b - --- constructs a key in a backend -genKey :: Backend a -> KeyName -> Key -genKey b f = Key (name b,f) - --- show a key to convert it to a string; the string includes the --- name of the backend to avoid collisions between key strings -instance Show Key where - show (Key (b, k)) = b ++ ":" ++ k - -instance Read Key where - readsPrec _ s = [(Key (b,k), "")] - where - l = split ":" s - b = if null l then "" else head l - k = join ":" $ drop 1 l - --- for quickcheck -instance Arbitrary Key where - arbitrary = do - backendname <- arbitrary - keyname <- arbitrary - return $ Key (backendname, keyname) - -prop_idempotent_key_read_show :: Key -> Bool -prop_idempotent_key_read_show k - -- backend names will never contain colons - | ':' `elem` (backendName k) = True - | otherwise = k == (read $ show k) diff --git a/Command.hs b/Command.hs index eba7f2cef..38c63bd77 100644 --- a/Command.hs +++ b/Command.hs @@ -17,11 +17,13 @@ import Data.List import Types import qualified Backend +import qualified BackendTypes import Messages import qualified Annex import qualified GitRepo as Git import Locations import Utility +import Key {- A command runs in four stages. - @@ -233,11 +235,14 @@ cmdlineKey :: Annex Key cmdlineKey = do k <- Annex.getState Annex.defaultkey backends <- Backend.list - return $ genKey (head backends) (keyname' k) + return $ stubKey { + keyName = kname k, + keyBackendName = BackendTypes.name $ head backends + } where - keyname' Nothing = badkey - keyname' (Just "") = badkey - keyname' (Just n) = n + kname Nothing = badkey + kname (Just "") = badkey + kname (Just n) = n badkey = error "please specify the key with --key" {- Given an original list of files, and an expanded list derived from it, diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 8c7566df8..f0450eea3 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -26,8 +26,10 @@ seek = [withKeys start] start :: CommandStartString start keyname = do backends <- Backend.list - let key = genKey (head backends) keyname - present <- inAnnex key + let key = error "fixme!!" + --let key = genKey (head backends) keyname --TODO FIXME + let present = error "fixme!!" + --present <- inAnnex key force <- Annex.getState Annex.force if not present then return Nothing diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 594564cb7..8ed61ba65 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -11,6 +11,7 @@ import Control.Monad (when) import Control.Monad.State (liftIO) import qualified Data.Map as M import System.Directory +import Data.Maybe import Command import Types @@ -19,6 +20,7 @@ import Locations import qualified Annex import qualified Command.Drop import Backend +import Key command :: [Command] command = [Command "dropunused" (paramRepeating paramNumber) seek @@ -55,7 +57,6 @@ readUnusedLog = do return $ M.fromList $ map parse $ lines l else return $ M.empty where - parse line = (head ws, tokey $ unwords $ tail ws) + parse line = (head ws, fromJust $ readKey $ unwords $ tail ws) where ws = words line - tokey s = read s :: Key diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 717d528bc..176d2cd54 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -16,9 +16,9 @@ import Command import qualified Annex import Utility import qualified Backend -import Types import Content import Messages +import Key command :: [Command] command = [Command "fromkey" paramPath seek diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index 68ac9a2c6..4a4102754 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -11,9 +11,10 @@ import Control.Monad.State (liftIO) import System.Exit import Command -import Types import Content import qualified Backend +import qualified BackendTypes +import Key command :: [Command] command = [Command "inannex" (paramRepeating paramKey) seek @@ -25,7 +26,11 @@ seek = [withKeys start] start :: CommandStartString start keyname = do backends <- Backend.list - let key = genKey (head backends) keyname + let key = stubKey { + keyName = keyname, + keyBackendName = BackendTypes.name (head backends) + } + error "BROKEN. fixme!" present <- inAnnex key if present then return Nothing diff --git a/Command/Move.hs b/Command/Move.hs index 3774ccbe9..1b1481308 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -20,7 +20,8 @@ import qualified Remotes import UUID import Messages import Utility - +import Key + command :: [Command] command = [Command "move" paramPath seek "move content of files to/from another repository"] @@ -136,7 +137,7 @@ fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup fromCleanup src True key = do ok <- Remotes.onRemote src (boolSystem, False) "dropkey" [ Params "--quiet --force" - , Param $ "--backend=" ++ backendName key + , Param $ "--backend=" ++ keyBackendName key , Param $ keyName key ] -- better safe than sorry: assume the src dropped the key diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 8a9673050..488bab62d 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -27,6 +27,8 @@ seek = [withKeys start] start :: CommandStartString start keyname = do + error "BROKEN FIXME!" + {- backends <- Backend.list let key = genKey (head backends) keyname present <- inAnnex key @@ -41,3 +43,4 @@ start keyname = do _ <- shutdown liftIO exitSuccess else liftIO exitFailure + -} diff --git a/Command/SendKey.hs b/Command/SendKey.hs index cb883b53a..ff269f21f 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -28,6 +28,8 @@ seek = [withKeys start] start :: CommandStartString start keyname = do + error "BROKEN FIXME!" + {- backends <- Backend.list let key = genKey (head backends) keyname present <- inAnnex key @@ -36,3 +38,4 @@ start keyname = do when present $ liftIO $ rsyncServerSend file liftIO exitFailure + -} diff --git a/Command/Unused.hs b/Command/Unused.hs index a614ce5d9..52e483d87 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -126,4 +126,4 @@ tmpKeys = do contents <- liftIO $ getDirectoryContents tmp files <- liftIO $ filterM doesFileExist $ map (tmp </>) contents - return $ map (fileKey . takeFileName) files + return $ catMaybes $ map (fileKey . takeFileName) files diff --git a/Content.hs b/Content.hs index dc675389f..1a5a80a9f 100644 --- a/Content.hs +++ b/Content.hs @@ -26,6 +26,7 @@ import System.Path import Control.Monad (when, unless, filterM) import System.Posix.Files import System.FilePath +import Data.Maybe import Types import Locations @@ -162,7 +163,7 @@ getKeysPresent' dir = do else do contents <- liftIO $ getDirectoryContents dir files <- liftIO $ filterM present contents - return $ map fileKey files + return $ catMaybes $ map fileKey files where present d = do result <- try $ @@ -5,20 +5,35 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Key where +module Key ( + Key(..), + stubKey, + readKey, + + prop_idempotent_key_read_show +) where import Test.QuickCheck import Utility +import System.Posix.Types -{- A Key has a unique name, is associated with a backend, - - and may contain other metadata. -} +{- A Key has a unique name, is associated with a key/value backend, + - and may contain other optional metadata. -} data Key = Key { keyName :: String, - keyBackend :: String, - keySize :: Maybe Int, - keyMtime :: Maybe Int + keyBackendName :: String, + keySize :: Maybe Integer, + keyMtime :: Maybe EpochTime } deriving (Eq, Ord) +stubKey :: Key +stubKey = Key { + keyName = "", + keyBackendName = "", + keySize = Nothing, + keyMtime = Nothing +} + fieldSep :: Char fieldSep = ',' @@ -26,7 +41,7 @@ fieldSep = ',' - The name field is always shown last, and is the only field - allowed to contain the fieldSep. -} instance Show Key where - show Key { keyBackend = b, keySize = s, keyMtime = m, keyName = n } = + show Key { keyBackendName = b, keySize = s, keyMtime = m, keyName = n } = ('b' : b) +++ ('s' ?: s) +++ ('m' ?: m) +++ ('n' : n) where "" +++ y = y @@ -36,16 +51,9 @@ instance Show Key where _ ?: _ = "" readKey :: String -> Maybe Key -readKey s = if key == stub then Nothing else key +readKey s = if key == Just stubKey then Nothing else key where - key = findfields s stub - - stub = Just Key { - keyName = "", - keyBackend = "", - keySize = Nothing, - keyMtime = Nothing - } + key = findfields s $ Just stubKey findfields ('n':v) (Just k) = Just $ k { keyName = v } findfields (c:v) (Just k) = @@ -54,7 +62,7 @@ readKey s = if key == stub then Nothing else key _ -> Nothing findfields _ v = v - addfield k 'b' v = Just k { keyBackend = v } + addfield k 'b' v = Just k { keyBackendName = v } addfield k 's' v = Just k { keySize = readMaybe v } addfield k 'm' v = Just k { keyMtime = readMaybe v } addfield _ _ _ = Nothing @@ -65,8 +73,7 @@ instance Arbitrary Key where n <- arbitrary b <- elements ['A'..'Z'] s <- arbitrary - m <- arbitrary - return $ Key { keyName = n, keyBackend = [b] , keySize = s, keyMtime = m } + return $ Key { keyName = n, keyBackendName = [b] , keySize = s } prop_idempotent_key_read_show :: Key -> Bool prop_idempotent_key_read_show k = Just k == (readKey $ show k) diff --git a/Locations.hs b/Locations.hs index 91a61ddd7..6cff91088 100644 --- a/Locations.hs +++ b/Locations.hs @@ -31,6 +31,7 @@ import Word import Data.Hash.MD5 import Types +import Key import qualified GitRepo as Git {- Conventions: @@ -123,14 +124,14 @@ keyFile key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ show key {- Reverses keyFile, converting a filename fragment (ie, the basename of - the symlink target) into a key. -} -fileKey :: FilePath -> Key -fileKey file = read $ +fileKey :: FilePath -> Maybe Key +fileKey file = readKey $ replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file {- for quickcheck -} prop_idempotent_fileKey :: String -> Bool -prop_idempotent_fileKey s = k == fileKey (keyFile k) - where k = read $ "test:" ++ s +prop_idempotent_fileKey s = Just k == fileKey (keyFile k) + where k = stubKey { keyName = s, keyBackendName = "test" } {- Given a filename, generates a short directory name to put it in, - to do hashing to protect against filesystems that dislike having @@ -13,6 +13,7 @@ SysConfig.hs: configure.hs TestConfig.hs Touch.hs: Touch.hsc hsc2hs $< + perl -i -pe 's/^{-# INCLUDE.*//' $@ $(bins): SysConfig.hs Touch.hs $(GHCMAKE) $@ diff --git a/Remotes.hs b/Remotes.hs index 3c9db314c..dd733e454 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -27,6 +27,7 @@ import Data.List (intersect, sortBy) import Control.Monad (when, unless, filterM) import Types +import Key import qualified GitRepo as Git import qualified Annex import LocationLog @@ -153,7 +154,7 @@ inAnnex r key = if Git.repoIsUrl r checkremote = do showNote ("checking " ++ Git.repoDescribe r ++ "...") inannex <- onRemote r (boolSystem, False) "inannex" - [Param ("--backend=" ++ backendName key), Param (keyName key)] + [Param ("--backend=" ++ keyBackendName key), Param (keyName key)] return $ Right inannex {- Cost Ordered list of remotes. -} @@ -272,7 +273,7 @@ rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [CommandParam] rsyncParams r sending key file = do Just (shellcmd, shellparams) <- git_annex_shell r (if sending then "sendkey" else "recvkey") - [ Param $ "--backend=" ++ backendName key + [ Param $ "--backend=" ++ keyBackendName key , Param $ keyName key -- Command is terminated with "--", because -- rsync will tack on its own options afterwards, @@ -8,11 +8,9 @@ module Types ( Annex, Backend, - Key, - genKey, - backendName, - keyName + Key ) where import BackendTypes import Annex +import Key diff --git a/Upgrade.hs b/Upgrade.hs index 3c16bcc86..7469d9ba7 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -13,6 +13,7 @@ import Control.Monad.State (liftIO) import Control.Monad (filterM, forM_) import System.Posix.Files import System.FilePath +import Data.Maybe import Content import Types @@ -74,7 +75,7 @@ getKeysPresent0' dir = do else do contents <- liftIO $ getDirectoryContents dir files <- liftIO $ filterM present contents - return $ map fileKey files + return $ catMaybes $ map fileKey files where present d = do result <- try $ |