Fix storing of filenames of v6 unlocked files when the filename is not representable in the current locale.

This is a mostly backwards compatable change. I broke backwards
compatability in the case where a filename starts with double-quote.
That seems likely to be very rare, and v6 unlocked files are a new feature
anyway, and fsck needs to fix missing associated file mappings anyway. So,
I decided that is good enough.

The encoding used is to just show the String when it contains a problem
character. While that adds some overhead to addAssociatedFile and
removeAssociatedFile, those are not called very often. This approach has
minimal decode overhead, because most filenames won't be encoded that way,
and it only has to look for the leading double-quote to skip the expensive
read. So, getAssociatedFiles remains fast.

I did consider using ByteString instead, but getting a FilePath converted
with all chars intact, even surrigates, is difficult, and it looks like
instance PersistField ByteString uses Text, which I don't trust for problem
encoded data. It would probably be slower too, and it would make the
database less easy to inspect manually.

3 files changed, 52 insertions, 9 deletions

diff --git a/Database/Keys.hs b/Database/Keys.hs
index f3d349dc0..246ccd191 100644
--- a/Database/Keys.hs
+++ b/Database/Keys.hs
@@ -174,7 +174,7 @@ scanAssociatedFiles = whenM (isJust <$> inRepo Git.Branch.current) $
 	add h i k = liftIO $ flip SQL.queueDb h $ 
 		void $ insertUnique $ SQL.Associated
 			(toIKey k)
-			(getTopFilePath $ Git.LsTree.file i)
+			(toSFilePath $ getTopFilePath $ Git.LsTree.file i)
 
 {- Stats the files, and stores their InodeCaches. -}
 storeInodeCaches :: Key -> [FilePath] -> Annex ()
diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs
index 456b48e46..88e6ba2dc 100644
--- a/Database/Keys/SQL.hs
+++ b/Database/Keys/SQL.hs
@@ -26,7 +26,7 @@ import Control.Monad
 share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase|
 Associated
   key IKey
-  file FilePath
+  file SFilePath
   KeyFileIndex key file
   FileKeyIndex file key
 Content
@@ -63,8 +63,10 @@ addAssociatedFile ik f = queueDb $ do
 	-- If the same file was associated with a different key before,
 	-- remove that.
 	delete $ from $ \r -> do
-		where_ (r ^. AssociatedFile ==. val (getTopFilePath f) &&. not_ (r ^. AssociatedKey ==. val ik))
-	void $ insertUnique $ Associated ik (getTopFilePath f)
+		where_ (r ^. AssociatedFile ==. val af &&. not_ (r ^. AssociatedKey ==. val ik))
+	void $ insertUnique $ Associated ik af
+  where
+	af = toSFilePath (getTopFilePath f)
 
 {- Note that the files returned were once associated with the key, but
  - some of them may not be any longer. -}
@@ -73,21 +75,25 @@ getAssociatedFiles ik = readDb $ do
 	l <- select $ from $ \r -> do
 		where_ (r ^. AssociatedKey ==. val ik)
 		return (r ^. AssociatedFile)
-	return $ map (asTopFilePath . unValue) l
+	return $ map (asTopFilePath . fromSFilePath . unValue) l
 
 {- Gets any keys that are on record as having a particular associated file.
  - (Should be one or none but the database doesn't enforce that.) -}
 getAssociatedKey :: TopFilePath -> ReadHandle -> IO [IKey]
 getAssociatedKey f = readDb $ do
 	l <- select $ from $ \r -> do
-		where_ (r ^. AssociatedFile ==. val (getTopFilePath f))
+		where_ (r ^. AssociatedFile ==. val af)
 		return (r ^. AssociatedKey)
 	return $ map unValue l
+  where
+	af = toSFilePath (getTopFilePath f)
 
 removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO ()
 removeAssociatedFile ik f = queueDb $ 
 	delete $ from $ \r -> do
-		where_ (r ^. AssociatedKey ==. val ik &&. r ^. AssociatedFile ==. val (getTopFilePath f))
+		where_ (r ^. AssociatedKey ==. val ik &&. r ^. AssociatedFile ==. val af)
+  where
+	af = toSFilePath (getTopFilePath f)
 
 addInodeCaches :: IKey -> [InodeCache] -> WriteHandle -> IO ()
 addInodeCaches ik is = queueDb $
diff --git a/Database/Types.hs b/Database/Types.hs
index 6667bc343..4521bb346 100644
--- a/Database/Types.hs
+++ b/Database/Types.hs
@@ -1,6 +1,6 @@
 {- types for SQL databases
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -11,7 +11,9 @@ module Database.Types where
 
 import Database.Persist.TH
 import Data.Maybe
+import Data.Char
 
+import Utility.PartialPrelude
 import Types.Key
 import Utility.InodeCache
 
@@ -53,6 +55,41 @@ toSInodeCache :: InodeCache -> SInodeCache
 toSInodeCache = I . showInodeCache
 
 fromSInodeCache :: SInodeCache -> InodeCache
-fromSInodeCache (I s) = fromMaybe (error $ "bad serialied InodeCache " ++ s) (readInodeCache s)
+fromSInodeCache (I s) = fromMaybe (error $ "bad serialized InodeCache " ++ s) (readInodeCache s)
 
 derivePersistField "SInodeCache"
+
+-- A serialized FilePath.
+--
+-- Not all unicode characters round-trip through sqlite. In particular,
+-- surrigate code points do not. So, escape the FilePath. But, only when
+-- it contains such characters.
+newtype SFilePath = SFilePath String
+
+-- Note that Read instance does not work when used in any kind of complex
+-- data structure.
+instance Read SFilePath where
+	readsPrec _ s = [(SFilePath s, "")]
+
+instance Show SFilePath where
+	show (SFilePath s) = s
+
+toSFilePath :: FilePath -> SFilePath
+toSFilePath s@('"':_) = SFilePath (show s)
+toSFilePath s
+	| any needsescape s = SFilePath (show s)
+	| otherwise = SFilePath s
+  where
+	needsescape c = case generalCategory c of
+		Surrogate -> True
+		PrivateUse -> True
+		NotAssigned -> True
+		_ -> False
+
+fromSFilePath :: SFilePath -> FilePath
+fromSFilePath (SFilePath s@('"':_)) =
+	fromMaybe (error "bad serialized SFilePath " ++ s) (readish s)
+fromSFilePath (SFilePath s) = s
+
+derivePersistField "SFilePath"
+