diff options
Diffstat (limited to 'Database')
| -rw-r--r-- | Database/Keys.hs | 2 | ||||
| -rw-r--r-- | Database/Keys/SQL.hs | 18 | ||||
| -rw-r--r-- | Database/Types.hs | 41 |
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" + |