summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Backend.hs24
-rw-r--r--Backend/SHA.hs11
-rw-r--r--Backend/WORM.hs40
-rw-r--r--BackendTypes.hs44
-rw-r--r--Command.hs13
-rw-r--r--Command/DropKey.hs6
-rw-r--r--Command/DropUnused.hs5
-rw-r--r--Command/FromKey.hs2
-rw-r--r--Command/InAnnex.hs9
-rw-r--r--Command/Move.hs5
-rw-r--r--Command/RecvKey.hs3
-rw-r--r--Command/SendKey.hs3
-rw-r--r--Command/Unused.hs2
-rw-r--r--Content.hs3
-rw-r--r--Key.hs45
-rw-r--r--Locations.hs9
-rw-r--r--Makefile1
-rw-r--r--Remotes.hs5
-rw-r--r--Types.hs6
-rw-r--r--Upgrade.hs3
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 $
diff --git a/Key.hs b/Key.hs
index c542b46ed..178f1ca69 100644
--- a/Key.hs
+++ b/Key.hs
@@ -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
diff --git a/Makefile b/Makefile
index c381ae986..c60e19b31 100644
--- a/Makefile
+++ b/Makefile
@@ -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,
diff --git a/Types.hs b/Types.hs
index 0890efd5e..f48d4079b 100644
--- a/Types.hs
+++ b/Types.hs
@@ -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 $