From c35a9047d39cd5fea9723fd023f4868dddd96ee8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Oct 2019 12:28:01 -0400 Subject: [PATCH] improve data types for sqlite This is a non-backwards compatable change, so not suitable for merging w/o a annex.version bump and transition code. Not yet tested. This improves performance of git-annex benchmark --databases across the board by 10-25%, since eg Key roundtrips as a ByteString. (serializeKey' produces a lazy ByteString, so there is still a copy involved in converting it to a strict ByteString. It may be faster to switch to using bytestring-strict-builder.) FilePath and Key are both stored as blobs. This avoids mojibake in some situations. It would be possible to use varchar instead, if persistent could avoid converting that to Text, but it seems there is no good way to do so. See doc/todo/sqlite_database_improvements.mdwn Eliminated some ugly artifacts of using Read/Show serialization; constructors and quoted strings are no longer stored in sqlite. Renamed SRef to SSha to reflect that it is only ever a git sha, not a ref name. Since it is limited to the characters in a sha, it is not affected by mojibake, so still uses String. --- Annex/WorkTree.hs | 3 +- Database/Benchmark.hs | 11 ++- Database/ContentIdentifier.hs | 14 +-- Database/Export.hs | 33 +++---- Database/Fsck.hs | 16 ++-- Database/Keys.hs | 21 +++-- Database/Keys/SQL.hs | 62 +++++++------ Database/Types.hs | 162 +++++++++++++--------------------- Key.hs | 2 +- 9 files changed, 135 insertions(+), 189 deletions(-) diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index eb64e0cbb1..7c288994a3 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -19,7 +19,6 @@ import Git.FilePath import qualified Git.Ref import qualified Git.LsTree import qualified Git.Types -import Database.Types import qualified Database.Keys import qualified Database.Keys.SQL @@ -91,7 +90,7 @@ scanUnlockedFiles replacefiles = whenM (inRepo Git.Ref.headExists) $ do add i k = do let tf = Git.LsTree.file i Database.Keys.runWriter $ - liftIO . Database.Keys.SQL.addAssociatedFileFast (toIKey k) tf + liftIO . Database.Keys.SQL.addAssociatedFileFast k tf whenM (pure replacefiles <&&> inAnnex k) $ do f <- fromRepo $ fromTopFilePath tf destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs index 865ebcf3c9..d102c3866e 100644 --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -16,7 +16,6 @@ import Types.Benchmark import qualified Database.Keys.SQL as SQL import qualified Database.Queue as H import Database.Init -import Database.Types import Utility.Tmp.Dir import Git.FilePath import Types.Key @@ -55,11 +54,11 @@ benchmarkDbs _ = error "not built with criterion, cannot benchmark" getAssociatedFilesHitBench :: BenchDb -> Benchmark getAssociatedFilesHitBench (BenchDb h num) = bench ("getAssociatedFiles from " ++ show num ++ " (hit)") $ nfIO $ do n <- getStdRandom (randomR (1,num)) - SQL.getAssociatedFiles (toIKey (keyN n)) (SQL.ReadHandle h) + SQL.getAssociatedFiles (keyN n) (SQL.ReadHandle h) getAssociatedFilesMissBench :: BenchDb -> Benchmark getAssociatedFilesMissBench (BenchDb h num) = bench ("getAssociatedFiles from " ++ show num ++ " (miss)") $ nfIO $ - SQL.getAssociatedFiles (toIKey keyMiss) (SQL.ReadHandle h) + SQL.getAssociatedFiles keyMiss (SQL.ReadHandle h) getAssociatedKeyHitBench :: BenchDb -> Benchmark getAssociatedKeyHitBench (BenchDb h num) = bench ("getAssociatedKey from " ++ show num ++ " (hit)") $ nfIO $ do @@ -73,19 +72,19 @@ getAssociatedKeyMissBench (BenchDb h num) = bench ("getAssociatedKey from " ++ s addAssociatedFileOldBench :: BenchDb -> Benchmark addAssociatedFileOldBench (BenchDb h num) = bench ("addAssociatedFile to " ++ show num ++ " (old)") $ nfIO $ do n <- getStdRandom (randomR (1,num)) - SQL.addAssociatedFile (toIKey (keyN n)) (fileN n) (SQL.WriteHandle h) + SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h) H.flushDbQueue h addAssociatedFileNewBench :: BenchDb -> Benchmark addAssociatedFileNewBench (BenchDb h num) = bench ("addAssociatedFile to " ++ show num ++ " (new)") $ nfIO $ do n <- getStdRandom (randomR (1,num)) - SQL.addAssociatedFile (toIKey (keyN n)) (fileN (n+1)) (SQL.WriteHandle h) + SQL.addAssociatedFile (keyN n) (fileN (n+1)) (SQL.WriteHandle h) H.flushDbQueue h populateAssociatedFiles :: H.DbQueue -> Int -> IO () populateAssociatedFiles h num = do forM_ [1..num] $ \n -> - SQL.addAssociatedFile (toIKey (keyN n)) (fileN n) (SQL.WriteHandle h) + SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h) H.flushDbQueue h keyN :: Int -> Key diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index 024825eaec..4c8605b003 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -52,11 +52,11 @@ share [mkPersist sqlSettings, mkMigrate "migrateContentIdentifier"] [persistLowe ContentIdentifiers remote UUID cid ContentIdentifier - key IKey + key Key -- The last git-annex branch tree sha that was used to update -- ContentIdentifiers AnnexBranch - tree SRef + tree SSha UniqueTree tree |] @@ -92,13 +92,13 @@ flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h -- Be sure to also update the git-annex branch when using this. recordContentIdentifier :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> Key -> IO () recordContentIdentifier h (RemoteStateHandle u) cid k = queueDb h $ do - void $ insert_ $ ContentIdentifiers u cid (toIKey k) + void $ insert_ $ ContentIdentifiers u cid k getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier] getContentIdentifiers (ContentIdentifierHandle h) (RemoteStateHandle u) k = H.queryDbQueue h $ do l <- selectList - [ ContentIdentifiersKey ==. toIKey k + [ ContentIdentifiersKey ==. k , ContentIdentifiersRemote ==. u ] [] return $ map (contentIdentifiersCid . entityVal) l @@ -110,18 +110,18 @@ getContentIdentifierKeys (ContentIdentifierHandle h) (RemoteStateHandle u) cid = [ ContentIdentifiersCid ==. cid , ContentIdentifiersRemote ==. u ] [] - return $ map (fromIKey . contentIdentifiersKey . entityVal) l + return $ map (contentIdentifiersKey . entityVal) l recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO () recordAnnexBranchTree h s = queueDb h $ do deleteWhere ([] :: [Filter AnnexBranch]) - void $ insertUnique $ AnnexBranch $ toSRef s + void $ insertUnique $ AnnexBranch $ toSSha s getAnnexBranchTree :: ContentIdentifierHandle -> IO Sha getAnnexBranchTree (ContentIdentifierHandle h) = H.queryDbQueue h $ do l <- selectList ([] :: [Filter AnnexBranch]) [] case l of - (s:[]) -> return $ fromSRef $ annexBranchTree $ entityVal s + (s:[]) -> return $ fromSSha $ annexBranchTree $ entityVal s _ -> return emptyTree {- Check if the git-annex branch has been updated and the database needs diff --git a/Database/Export.hs b/Database/Export.hs index 0da0173fad..8f01076841 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -63,7 +63,7 @@ data ExportHandle = ExportHandle H.DbQueue UUID share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase| -- Files that have been exported to the remote and are present on it. Exported - key IKey + key Key file SFilePath ExportedIndex key file -- Directories that exist on the remote, and the files that are in them. @@ -74,12 +74,12 @@ ExportedDirectory -- The content of the tree that has been exported to the remote. -- Not all of these files are necessarily present on the remote yet. ExportTree - key IKey + key Key file SFilePath ExportTreeIndex key file -- The tree stored in ExportTree ExportTreeCurrent - tree SRef + tree SSha UniqueTree tree |] @@ -115,43 +115,40 @@ flushDbQueue (ExportHandle h _) = H.flushDbQueue h recordExportTreeCurrent :: ExportHandle -> Sha -> IO () recordExportTreeCurrent h s = queueDb h $ do deleteWhere ([] :: [Filter ExportTreeCurrent]) - void $ insertUnique $ ExportTreeCurrent $ toSRef s + void $ insertUnique $ ExportTreeCurrent $ toSSha s getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha) getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do l <- selectList ([] :: [Filter ExportTreeCurrent]) [] case l of - (s:[]) -> return $ Just $ fromSRef $ exportTreeCurrentTree $ entityVal s + (s:[]) -> return $ Just $ fromSSha $ + exportTreeCurrentTree $ entityVal s _ -> return Nothing addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () addExportedLocation h k el = queueDb h $ do - void $ insertUnique $ Exported ik ef + void $ insertUnique $ Exported k ef let edirs = map (\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef) (exportDirectories el) putMany edirs where - ik = toIKey k ef = toSFilePath (fromExportLocation el) removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () removeExportedLocation h k el = queueDb h $ do - deleteWhere [ExportedKey ==. ik, ExportedFile ==. ef] + deleteWhere [ExportedKey ==. k, ExportedFile ==. ef] let subdirs = map (toSFilePath . fromExportDirectory) (exportDirectories el) deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs] where - ik = toIKey k ef = toSFilePath (fromExportLocation el) {- Note that this does not see recently queued changes. -} getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do - l <- selectList [ExportedKey ==. ik] [] + l <- selectList [ExportedKey ==. k] [] return $ map (mkExportLocation . fromSFilePath . exportedFile . entityVal) l - where - ik = toIKey k {- Note that this does not see recently queued changes. -} isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool @@ -164,10 +161,8 @@ isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do {- Get locations in the export that might contain a key. -} getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do - l <- selectList [ExportTreeKey ==. ik] [] + l <- selectList [ExportTreeKey ==. k] [] return $ map (mkExportLocation . fromSFilePath . exportTreeFile . entityVal) l - where - ik = toIKey k {- Get keys that might be currently exported to a location. - @@ -178,23 +173,21 @@ getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do -} getExportTreeKey :: ExportHandle -> ExportLocation -> IO [Key] getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do - map (fromIKey . exportTreeKey . entityVal) + map (exportTreeKey . entityVal) <$> selectList [ExportTreeFile ==. ef] [] where ef = toSFilePath (fromExportLocation el) addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $ - void $ insertUnique $ ExportTree ik ef + void $ insertUnique $ ExportTree k ef where - ik = toIKey k ef = toSFilePath (fromExportLocation loc) removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () removeExportTree h k loc = queueDb h $ - deleteWhere [ExportTreeKey ==. ik, ExportTreeFile ==. ef] + deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef] where - ik = toIKey k ef = toSFilePath (fromExportLocation loc) -- An action that is passed the old and new values that were exported, diff --git a/Database/Fsck.hs b/Database/Fsck.hs index 09f9222be3..d3a68cc090 100644 --- a/Database/Fsck.hs +++ b/Database/Fsck.hs @@ -1,6 +1,6 @@ {- Sqlite database used for incremental fsck. - - - Copyright 2015 Joey Hess + - Copyright 2015-2019 Joey Hess -: - Licensed under the GNU AGPL version 3 or higher. -} @@ -39,7 +39,7 @@ data FsckHandle = FsckHandle H.DbQueue UUID - of the latest incremental fsck pass. -} share [mkPersist sqlSettings, mkMigrate "migrateFsck"] [persistLowerCase| Fscked - key SKey + key Key UniqueKey key |] @@ -74,10 +74,8 @@ closeDb (FsckHandle h u) = do addDb :: FsckHandle -> Key -> IO () addDb (FsckHandle h _) k = H.queueDb h checkcommit $ - void $ insertUnique $ Fscked sk + void $ insertUnique $ Fscked k where - sk = toSKey k - -- commit queue after 1000 files or 5 minutes, whichever comes first checkcommit sz lastcommittime | sz > 1000 = return True @@ -87,9 +85,9 @@ addDb (FsckHandle h _) k = H.queueDb h checkcommit $ {- Doesn't know about keys that were just added with addDb. -} inDb :: FsckHandle -> Key -> IO Bool -inDb (FsckHandle h _) = H.queryDbQueue h . inDb' . toSKey +inDb (FsckHandle h _) = H.queryDbQueue h . inDb' -inDb' :: SKey -> SqlPersistM Bool -inDb' sk = do - r <- selectList [FsckedKey ==. sk] [] +inDb' :: Key -> SqlPersistM Bool +inDb' k = do + r <- selectList [FsckedKey ==. k] [] return $ not $ null r diff --git a/Database/Keys.hs b/Database/Keys.hs index c31f647c09..f1dfcaf879 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -153,20 +153,20 @@ closeDb = Annex.getState Annex.keysdbhandle >>= \case Just h -> liftIO (closeDbHandle h) addAssociatedFile :: Key -> TopFilePath -> Annex () -addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile (toIKey k) f +addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile k f {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} getAssociatedFiles :: Key -> Annex [TopFilePath] -getAssociatedFiles = runReaderIO . SQL.getAssociatedFiles . toIKey +getAssociatedFiles = runReaderIO . SQL.getAssociatedFiles {- 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 -> Annex [Key] -getAssociatedKey = map fromIKey <$$> runReaderIO . SQL.getAssociatedKey +getAssociatedKey = runReaderIO . SQL.getAssociatedKey removeAssociatedFile :: Key -> TopFilePath -> Annex () -removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k) +removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile k {- Stats the files, and stores their InodeCaches. -} storeInodeCaches :: Key -> [FilePath] -> Annex () @@ -178,15 +178,15 @@ storeInodeCaches' k fs ics = withTSDelta $ \d -> =<< liftIO (mapM (`genInodeCache` d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex () -addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is +addInodeCaches k is = runWriterIO $ SQL.addInodeCaches k is {- A key may have multiple InodeCaches; one for the annex object, and one - for each pointer file that is a copy of it. -} getInodeCaches :: Key -> Annex [InodeCache] -getInodeCaches = runReaderIO . SQL.getInodeCaches . toIKey +getInodeCaches = runReaderIO . SQL.getInodeCaches removeInodeCaches :: Key -> Annex () -removeInodeCaches = runWriterIO . SQL.removeInodeCaches . toIKey +removeInodeCaches = runWriterIO . SQL.removeInodeCaches isInodeKnown :: InodeCache -> SentinalStatus -> Annex Bool isInodeKnown i s = or <$> runReaderIO ((:[]) <$$> SQL.isInodeKnown i s) @@ -288,9 +288,8 @@ reconcileStaged qh = do -- Note that database writes done in here will not necessarily -- be visible to database reads also done in here. reconcile file key = do - let ikey = toIKey key - liftIO $ SQL.addAssociatedFileFast ikey file (SQL.WriteHandle qh) - caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh) + liftIO $ SQL.addAssociatedFileFast key file (SQL.WriteHandle qh) + caches <- liftIO $ SQL.getInodeCaches key (SQL.ReadHandle qh) keyloc <- calcRepo (gitAnnexLocation key) keypopulated <- sameInodeCache keyloc caches p <- fromRepo $ fromTopFilePath file @@ -300,6 +299,6 @@ reconcileStaged qh = do populatePointerFile (Restage True) key keyloc p >>= \case Nothing -> return () Just ic -> liftIO $ - SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh) + SQL.addInodeCaches key [ic] (SQL.WriteHandle qh) (False, True) -> depopulatePointerFile key p _ -> return () diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs index 4b7a7ec625..0cfebfb9fa 100644 --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -19,7 +19,7 @@ import qualified Database.Queue as H import Utility.InodeCache import Git.FilePath -import Database.Persist.Sql +import Database.Persist.Sql hiding (Key) import Database.Persist.TH import Data.Time.Clock import Control.Monad @@ -29,13 +29,13 @@ import qualified Data.Conduit.List as CL share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase| Associated - key IKey + key Key file SFilePath KeyFileIndex key file FileKeyIndex file key Content - key IKey - cache SInodeCache + key Key + cache InodeCache KeyCacheIndex key cache |] @@ -62,20 +62,20 @@ queueDb a (WriteHandle h) = H.queueDb h checkcommit a now <- getCurrentTime return $ diffUTCTime now lastcommittime > 300 -addAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO () -addAssociatedFile ik f = queueDb $ do +addAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () +addAssociatedFile k f = queueDb $ do -- If the same file was associated with a different key before, -- remove that. - deleteWhere [AssociatedFile ==. af, AssociatedKey !=. ik] - void $ insertUnique $ Associated ik af + deleteWhere [AssociatedFile ==. af, AssociatedKey !=. k] + void $ insertUnique $ Associated k af where af = toSFilePath (getTopFilePath f) -- Does not remove any old association for a file, but less expensive -- than addAssociatedFile. Calling dropAllAssociatedFiles first and then -- this is an efficient way to update all associated files. -addAssociatedFileFast :: IKey -> TopFilePath -> WriteHandle -> IO () -addAssociatedFileFast ik f = queueDb $ void $ insertUnique $ Associated ik af +addAssociatedFileFast :: Key -> TopFilePath -> WriteHandle -> IO () +addAssociatedFileFast k f = queueDb $ void $ insertUnique $ Associated k af where af = toSFilePath (getTopFilePath f) @@ -85,40 +85,40 @@ dropAllAssociatedFiles = queueDb $ {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} -getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath] -getAssociatedFiles ik = readDb $ do - l <- selectList [AssociatedKey ==. ik] [] +getAssociatedFiles :: Key -> ReadHandle -> IO [TopFilePath] +getAssociatedFiles k = readDb $ do + l <- selectList [AssociatedKey ==. k] [] return $ map (asTopFilePath . fromSFilePath . associatedFile . entityVal) 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 :: TopFilePath -> ReadHandle -> IO [Key] getAssociatedKey f = readDb $ do l <- selectList [AssociatedFile ==. af] [] return $ map (associatedKey . entityVal) l where af = toSFilePath (getTopFilePath f) -removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO () -removeAssociatedFile ik f = queueDb $ - deleteWhere [AssociatedKey ==. ik, AssociatedFile ==. af] +removeAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () +removeAssociatedFile k f = queueDb $ + deleteWhere [AssociatedKey ==. k, AssociatedFile ==. af] where af = toSFilePath (getTopFilePath f) -addInodeCaches :: IKey -> [InodeCache] -> WriteHandle -> IO () -addInodeCaches ik is = queueDb $ - forM_ is $ \i -> insertUnique $ Content ik (toSInodeCache i) +addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO () +addInodeCaches k is = queueDb $ + forM_ is $ \i -> insertUnique $ Content k i {- A key may have multiple InodeCaches; one for the annex object, and one - for each pointer file that is a copy of it. -} -getInodeCaches :: IKey -> ReadHandle -> IO [InodeCache] -getInodeCaches ik = readDb $ do - l <- selectList [ContentKey ==. ik] [] - return $ map (fromSInodeCache . contentCache . entityVal) l +getInodeCaches :: Key -> ReadHandle -> IO [InodeCache] +getInodeCaches k = readDb $ do + l <- selectList [ContentKey ==. k] [] + return $ map (contentCache . entityVal) l -removeInodeCaches :: IKey -> WriteHandle -> IO () -removeInodeCaches ik = queueDb $ - deleteWhere [ContentKey ==. ik] +removeInodeCaches :: Key -> WriteHandle -> IO () +removeInodeCaches k = queueDb $ + deleteWhere [ContentKey ==. k] {- Check if the inode is known to be used for an annexed file. - @@ -131,9 +131,7 @@ isInodeKnown i s = readDb query | sentinalInodesChanged s = withRawQuery likesql [] $ isJust <$> CL.head | otherwise = - isJust <$> selectFirst [ContentCache ==. si] [] - - si = toSInodeCache i + isJust <$> selectFirst [ContentCache ==. i] [] likesql = T.concat [ "SELECT key FROM content WHERE " @@ -143,7 +141,7 @@ isInodeKnown i s = readDb query mklike p = T.concat [ "cache LIKE " - , "'I \"" -- SInodeCache serializes as I "..." + , "'" , T.pack p - , "\"'" + , "'" ] diff --git a/Database/Types.hs b/Database/Types.hs index e86fd30601..bf2ab823a1 100644 --- a/Database/Types.hs +++ b/Database/Types.hs @@ -5,124 +5,50 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Database.Types where +module Database.Types ( + module Database.Types, + Key, +) where -import Database.Persist.TH import Database.Persist.Class hiding (Key) import Database.Persist.Sql hiding (Key) -import Data.Maybe -import Data.Char import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import Control.DeepSeq +import qualified Data.Attoparsec.ByteString as A -import Utility.PartialPrelude import Key import Utility.InodeCache -import Git.Types (Ref(..)) +import Utility.FileSystemEncoding +import Git.Types import Types.UUID import Types.Import --- A serialized Key -newtype SKey = SKey String - deriving (Show, Read) +instance PersistField Key where + toPersistValue = toPersistValue . L.toStrict . serializeKey' + fromPersistValue b = fromPersistValue b >>= parse + where + parse = either (Left . T.pack) Right . A.parseOnly keyParser -toSKey :: Key -> SKey -toSKey = SKey . serializeKey +-- A key can contain arbitrarily encoded characters, so store in sqlite as a +-- blob to avoid encoding problems. +instance PersistFieldSql Key where + sqlType _ = SqlBlob -fromSKey :: SKey -> Key -fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s) +instance PersistField InodeCache where + toPersistValue = toPersistValue . showInodeCache + fromPersistValue b = fromPersistValue b >>= parse + where + parse s = maybe + (Left $ T.pack $ "bad serialized InodeCache "++ s) + Right + (readInodeCache s) -derivePersistField "SKey" - --- A Key index. More efficient than SKey, but its Read instance does not --- work when it's used in any kind of complex data structure. -newtype IKey = IKey String - -instance NFData IKey where - rnf (IKey s) = rnf s - -instance Read IKey where - readsPrec _ s = [(IKey s, "")] - -instance Show IKey where - show (IKey s) = s - -toIKey :: Key -> IKey -toIKey = IKey . serializeKey - -fromIKey :: IKey -> Key -fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s) - -derivePersistField "IKey" - --- A serialized InodeCache -newtype SInodeCache = I String - deriving (Show, Read) - -toSInodeCache :: InodeCache -> SInodeCache -toSInodeCache = I . showInodeCache - -fromSInodeCache :: SInodeCache -> InodeCache -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" - --- A serialized Ref -newtype SRef = SRef Ref - --- Note that Read instance does not work when used in any kind of complex --- data structure. -instance Read SRef where - readsPrec _ s = [(SRef (Ref s), "")] - -instance Show SRef where - show (SRef (Ref s)) = s - -derivePersistField "SRef" - -toSRef :: Ref -> SRef -toSRef = SRef - -fromSRef :: SRef -> Ref -fromSRef (SRef r) = r +instance PersistFieldSql InodeCache where + sqlType _ = SqlString instance PersistField UUID where toPersistValue u = toPersistValue b @@ -146,3 +72,37 @@ instance PersistField ContentIdentifier where instance PersistFieldSql ContentIdentifier where sqlType _ = SqlBlob + +-- A serialized FilePath. Stored as a ByteString to avoid encoding problems. +newtype SFilePath = SFilePath S.ByteString + deriving (Eq, Show) + +toSFilePath :: FilePath -> SFilePath +toSFilePath = SFilePath . encodeBS + +fromSFilePath :: SFilePath -> FilePath +fromSFilePath (SFilePath b) = decodeBS b + +instance PersistField SFilePath where + toPersistValue (SFilePath b) = toPersistValue b + fromPersistValue v = SFilePath <$> fromPersistValue v + +instance PersistFieldSql SFilePath where + sqlType _ = SqlBlob + +-- A serialized git Sha +newtype SSha = SSha String + deriving (Eq, Show) + +toSSha :: Sha -> SSha +toSSha (Ref s) = SSha s + +fromSSha :: SSha -> Ref +fromSSha (SSha s) = Ref s + +instance PersistField SSha where + toPersistValue (SSha b) = toPersistValue b + fromPersistValue v = SSha <$> fromPersistValue v + +instance PersistFieldSql SSha where + sqlType _ = SqlString diff --git a/Key.hs b/Key.hs index 6c369ac425..d666c0c45e 100644 --- a/Key.hs +++ b/Key.hs @@ -140,7 +140,7 @@ deserializeKey :: String -> Maybe Key deserializeKey = deserializeKey' . encodeBS' deserializeKey' :: S.ByteString -> Maybe Key -deserializeKey' b = eitherToMaybe $ A.parseOnly keyParser b +deserializeKey' = eitherToMaybe . A.parseOnly keyParser {- This splits any extension out of the keyName, returning the - keyName minus extension, and the extension (including leading dot).