first pass at using new keys

It compiles. It sorta works. Several subcommands are FIXME marked and
broken, because things that used to accept separate --backend and --key
params need to be changed to accept just a --key that encodes all the key
info, now that there is metadata in keys.

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

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

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

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)

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,

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

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

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

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

Command/Move.hs

@@ -20,6 +20,7 @@ import qualified Remotes
 import UUID
 import Messages
 import Utility
+import Key
 
 command :: [Command]
 command = [Command "move" paramPath seek
@@ -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

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
+	-}

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
+	-}

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

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 $

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)

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

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) $@

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,

Types.hs

@@ -8,11 +8,9 @@
 module Types (
 	Annex,
 	Backend,
-	Key,
-	genKey,
-	backendName,
-	keyName
+	Key
 ) where
 
 import BackendTypes
 import Annex
+import Key

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 $