diff --git a/HGraphStorage.cabal b/HGraphStorage.cabal new file mode 100644 --- /dev/null +++ b/HGraphStorage.cabal @@ -0,0 +1,127 @@ +name: HGraphStorage +version: 0.0.1 +cabal-version: >= 1.8 +build-type: Simple +author: JP Moresmau +maintainer: JP Moresmau +stability: experimental +category: Database +homepage: https://github.com/JPMoresmau/HGraphStorage +synopsis: Graph database stored on disk +description: + A graph database storing its data on disk. + There is currently no transaction or even concurrent access support, this is not made for production. + We try to store the data on disk efficiently, i.e. not rely on having the data in memory. + There is a test suite and a benchmark, which would be the best way to get a feel for how the library works. +copyright: JP Moresmau 2014-2015 +license: BSD3 +license-file: LICENSE + +library + hs-source-dirs: src + build-depends: + base >= 4 && < 5, + binary, + filepath, + directory, + bytestring, + text, + data-default, + containers, + lifted-base, + transformers-base, + transformers, + monad-control, + monad-logger, + resourcet + ghc-options: -Wall + other-modules: Database.Graph.HGraphStorage.Constants + exposed-modules: + Database.Graph.HGraphStorage.FileOps, + Database.Graph.HGraphStorage.API, + Database.Graph.HGraphStorage.Types, + Database.Graph.HGraphStorage.Query, + Database.Graph.HGraphStorage.FreeList, + Database.Graph.HGraphStorage.Index + +--executable HGraphStorage +-- hs-source-dirs: exe +-- main-is: Main.hs +-- build-depends: +-- base >= 4, HGraphStorage, binary, +-- filepath, +-- directory, +-- bytestring, +-- text, +-- data-default, +-- containers, +-- lifted-base, +-- transformers-base, +-- transformers, +-- monad-control, +-- monad-logger, +-- resourcet +-- ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/JPMoresmau/HGraphStorage.git + +test-suite hgraphstorage-test + type: exitcode-stdio-1.0 + main-is: hgraphstorage-test.hs + ghc-options: -Wall -rtsopts + build-depends: + base >= 4 && < 5, + HGraphStorage, + tasty > 0.10, + tasty-hunit, + HUnit, + tasty-quickcheck, + QuickCheck, + filepath, + directory, + bytestring, + text, + data-default, + containers, + lifted-base, + transformers-base, + transformers, + monad-control, + monad-logger, + resourcet + other-modules: + Database.Graph.HGraphStorage.APITest, + Database.Graph.HGraphStorage.QueryTest, + Database.Graph.HGraphStorage.Utils, + Database.Graph.HGraphStorage.FreeListTest, + Database.Graph.HGraphStorage.IndexTest + hs-source-dirs: test + +benchmark HGraphStorage-bench + type: exitcode-stdio-1.0 + build-depends: + base >= 4 && < 5, + HGraphStorage, + bytestring, + zlib , + tar, + directory, + filepath, + Cabal, + containers, + monad-logger, + resourcet, + text, + criterion, + bytestring, + binary, + text-binary, + data-default, + transformers + hs-source-dirs: perf + ghc-options: -Wall -rtsopts + main-is: Main.hs + other-modules: Database.Graph.HGraphStorage.HackageTest + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,12 @@ +Copyright (c) 2014-2015, JP Moresmau +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of JP Moresmau nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/perf/Database/Graph/HGraphStorage/HackageTest.hs b/perf/Database/Graph/HGraphStorage/HackageTest.hs new file mode 100644 --- /dev/null +++ b/perf/Database/Graph/HGraphStorage/HackageTest.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE RankNTypes, OverloadedStrings, PatternGuards, ScopedTypeVariables #-} +module Database.Graph.HGraphStorage.HackageTest where + +import Control.Applicative +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as BS +import System.Directory +import System.FilePath +import Control.Monad (filterM, foldM, when) +import qualified Data.Map.Strict as DM +import qualified Data.Text as T +import Data.Text.Binary () +import Distribution.Package hiding (depends) +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.Verbosity +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Control.Monad.Logger +import qualified Control.Monad.Trans.Resource as R +import Data.Binary + + +import Database.Graph.HGraphStorage.API +import Database.Graph.HGraphStorage.Index as Idx +import Database.Graph.HGraphStorage.Types +import Control.Monad.IO.Class (liftIO) +import Data.Default (def) +import Database.Graph.HGraphStorage.Query + +buildHackageGraph :: IO(DM.Map T.Text (DM.Map T.Text [(T.Text,T.Text)])) +buildHackageGraph = do + let serf= "data" "index.bin" + ex <- doesFileExist serf + if ex + then decode <$> BS.readFile serf + else do + let f= "data" "index.tar.gz" + tmp <- getTemporaryDirectory + let fldr=tmp "hackage-bench" + createDirectoryIfMissing True fldr + unTarGzip f fldr + memG <- createMemoryGraph fldr + BS.writeFile serf $ encode memG + return memG + +-- code to convert serialize to binary +--convertHack :: IO () +--convertHack = do +-- let serf= "data" "index.ser" +-- m :: (DM.Map T.Text (DM.Map T.Text [Dependency])) <- read <$> readFile serf +-- let m2=DM.map toText1 m +-- let binf= "data" "index.bin" +-- BS.writeFile binf $ encode m2 +-- where +-- toText1 byVer = DM.map (map toText2) byVer +-- toText2 (Dependency (PackageName name) range)=(T.pack name,T.pack $ show range) + + +-- |Un-gzip and un-tar a file into a folder. +unTarGzip :: FilePath -> FilePath -> IO () +unTarGzip res folder = do + cnts <- BS.readFile res + let ungzip = GZip.decompress cnts + entries = Tar.read ungzip + createDirectories entries + Tar.unpack folder entries + where createDirectories Tar.Done = return () + createDirectories (Tar.Fail _) = return () + createDirectories (Tar.Next e es) = + case Tar.entryContent e of + Tar.NormalFile _ _ -> do let dir = folder takeDirectory (Tar.entryPath e) + createDirectoryIfMissing True dir + createDirectories es + Tar.Directory -> do let dir = folder Tar.entryPath e + createDirectoryIfMissing True dir + createDirectories es + _ -> createDirectories es + + +createMemoryGraph :: FilePath + -> IO + (DM.Map T.Text (DM.Map T.Text [(T.Text,T.Text)])) +createMemoryGraph folder = do + cnts <- getSubDirs folder + foldM processPackage DM.empty cnts + where + processPackage m d = do + putStrLn d + vrss <- getSubDirs $ folder d + depsByVersion <- foldM (processVersion d) DM.empty vrss + return $ DM.insert (T.pack d) depsByVersion m + processVersion d m vr = do + let cf= addExtension d "cabal" + let fullF= folder d vr cf + ex <- doesFileExist fullF + if ex + then do + putStrLn $ "\t"++vr + gpd <- readPackageDescription normal fullF + let pd=flattenPackageDescription gpd + let mlb=library pd + case mlb of + Just lib -> do + let deps = targetBuildDepends $ libBuildInfo lib + let depText= map toText deps + return $ DM.insert (T.pack vr) depText m + Nothing ->return m + else return m + toText (Dependency (PackageName name) range)=(T.pack name,T.pack $ show range) + +getSubDirs :: FilePath -> IO [FilePath] +getSubDirs folder = do + cnts <- getDirectoryContents folder + filterM isDir cnts + where + isDir d = + if d `notElem` [".",".."] + then doesDirectoryExist $ folder d + else return False + + +writeGraph :: GraphSettings -> DM.Map T.Text (DM.Map T.Text [(T.Text,T.Text)]) -> IO () +writeGraph gs memGraph = withTempDB "hackage-test-graph" True gs $ do + --indexPackageNames <- createIndex "packageNames" + _ <- addIndex $ IndexInfo "packageNames" ["Package"] ["name"] + pkgMap <- foldM createPackage DM.empty $ DM.keys memGraph + mapM_ (createVersions pkgMap) $ DM.toList memGraph + where + createPackage m pkg = do + goPkg <- createObject $ GraphObject Nothing "Package" $ DM.fromList [("name",[PVText pkg])] + --liftIO $ putStrLn $ (T.unpack pkg) ++"->" ++ (show $ textToKey pkg) ++ ":" ++ (show $ goID goPkg) + -- ml <- liftIO $ Idx.lookup key indexPackageNames + -- when (Just (goID goPkg) /= ml) $ error $ "wrong lookup: "++ (show key) ++ "->" ++ show ml + return $ DM.insert pkg goPkg m + createVersions pkgMap (pkg,depsByVersion) + | Just goPkg <- DM.lookup pkg pkgMap = mapM_ (createVersion goPkg pkgMap) $ DM.toList depsByVersion + | otherwise = return () + createVersion goPkg pkgMap (vr,deps) = do + goVer <- createObject $ GraphObject Nothing "Version" $ DM.fromList [("name",[PVText vr])] + _ <- createRelation' $ GraphRelation Nothing goPkg goVer versions DM.empty + mapM_ (createDep goVer pkgMap) deps + createDep goVer pkgMap (name,range) + | Just goPkg <- DM.lookup name pkgMap = do + _ <- createRelation' $ GraphRelation Nothing goVer goPkg depends $ DM.fromList [("range",[PVText range])] + return () + | otherwise = return () + + +nameIndex :: DM.Map T.Text (DM.Map T.Text [(T.Text,T.Text)]) -> IO () +nameIndex memGraph = withTempDB "hackage-test-graph" False def $ do + indexPackageNames <- (snd . head) <$> getIndices + -- :: Trie Int16 ObjectID <- createIndex "packageNames" + let ks = DM.keys memGraph + let pkgLen = length ks + pkgMap <- foldM (getPackage indexPackageNames) DM.empty ks + let idLen = length $ DM.keys pkgMap + when (pkgLen /= idLen) $ error $ "wrong length:" ++ show idLen + return () + where + getPackage indexPackageNames m pkg = do + mid <- liftIO $ Idx.lookup (textToKey pkg) indexPackageNames + return $ case mid of + Just oid -> DM.insert oid pkg m + _ -> error $ "empty lookup:" ++ T.unpack pkg + +yesodQuery :: IO Int +yesodQuery = withTempDB "hackage-test-graph" False def $ do + indexPackageNames <- (snd . head) <$> getIndices + -- :: Trie Int16 ObjectID <- createIndex "packageNames" + mid <- liftIO $ Idx.lookup (textToKey "yesod") indexPackageNames + case mid of + Just oid -> do + res <- queryStep oid def{rsRelTypes=[versions],rsDirection = OUT} + let l = length res + when (l < 111) $ error "less than 111 versions for yesod" + return l + _ -> error "empty lookup for yesod" + + +versions :: T.Text +versions = "versions" + +depends :: T.Text +depends = "depends" + +withTempDB :: forall b. + FilePath -> Bool -> GraphSettings -> GraphStorageT (R.ResourceT (LoggingT IO)) b + -> IO b +withTempDB fn del gs f = do + tmp <- getTemporaryDirectory + let dir = tmp fn + ex <- doesDirectoryExist dir + when (ex && del) $ do + cnts <- getDirectoryContents dir + mapM_ removeFile =<< filterM doesFileExist (map (dir ) cnts) + runStderrLoggingT $ withGraphStorage dir gs f diff --git a/perf/Main.hs b/perf/Main.hs new file mode 100644 --- /dev/null +++ b/perf/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import Criterion.Main +import qualified Data.Map.Strict as DM + +import Database.Graph.HGraphStorage.HackageTest +import Database.Graph.HGraphStorage.Types +import Data.Default (def) +import System.IO (BufferMode(..)) + +main :: IO() +main = do + -- convertHack + g <- buildHackageGraph + let _ = g `seq` () + putStrLn (show (length $ DM.keys g) ++ " packages") + defaultMain + [--bench "Write Hackage Default Buffering" $ nfIO $ writeGraph def g + bench "Write Hackage No Buffering" $ nfIO $ writeGraph def{gsMainBuffering = Just NoBuffering} g + --,bench "Write Hackage Buffering 1024" $ nfIO $ writeGraph def{gsMainBuffering = Just $ BlockBuffering $ Just 1024} g + ,bench "Write Hackage Buffering 4096" $ nfIO $ writeGraph def{gsMainBuffering = Just $ BlockBuffering $ Just 4096} g + --,bench "Write Hackage Buffering 8192" $ nfIO $ writeGraph def{gsMainBuffering = Just $ BlockBuffering $ Just 8192} g + ,bench "Index Lookup" $ nfIO $ nameIndex g + ,bench "Index Lookup+One Step query" $ nfIO yesodQuery] diff --git a/src/Database/Graph/HGraphStorage/API.hs b/src/Database/Graph/HGraphStorage/API.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/API.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, ConstraintKinds, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, DeriveFunctor, GeneralizedNewtypeDeriving, RankNTypes, FlexibleContexts, RecordWildCards #-} +-- | Higher level API for reading and writing +module Database.Graph.HGraphStorage.API where + +import Control.Applicative +import Control.Monad (MonadPlus, liftM, foldM, filterM, void, when, unless) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..) + , ComposeSt, defaultLiftBaseWith + , defaultRestoreM ) +import Control.Arrow + +import qualified Data.Map as DM +import qualified Data.Text as T +import Data.Typeable +import Data.Binary (Binary) +import Data.Default + +import Control.Monad.Logger + +import qualified Control.Monad.Trans.Resource as R +import System.FilePath +import System.IO + +import Database.Graph.HGraphStorage.FileOps +import Database.Graph.HGraphStorage.Types +import Control.Monad.Trans.State.Lazy +import Database.Graph.HGraphStorage.FreeList (addToFreeList) +import Database.Graph.HGraphStorage.Index as Idx +import Data.Int (Int16) +import System.Directory (doesFileExist) +import Data.Maybe (fromMaybe, catMaybes) +import Control.Exception.Lifted (throwIO) + +-- | State for the monad +data GsData = GsData + { gsHandles :: Handles + , gsModel :: Model + , gsDir :: FilePath + , gsSettings :: GraphSettings + , gsIndexes :: [(IndexInfo,Trie Int16 ObjectID)] + } + +-- | Index metadata +data IndexInfo = IndexInfo + { iiName :: T.Text + , iiTypes :: [T.Text] + , iiProps :: [T.Text] + } deriving (Show,Read,Eq,Ord) + + +-- | Run a computation with the graph storage engine, storing the data in the given directory +withGraphStorage :: forall (m :: * -> *) a. + (R.MonadThrow m, MonadIO m, + MonadLogger m, + MonadBaseControl IO m) => + FilePath -> GraphSettings -> GraphStorageT (R.ResourceT m) a -> m a +withGraphStorage dir gs act = R.runResourceT $ do + (rk,hs) <- R.allocate (open dir gs) close + model <- readModel hs + res <- evalStateT (unIs loadIndexes) (GsData hs model dir gs []) + R.release rk + return res + where + loadIndexes = do + idxf <- indexFile + ex <- liftIO $ doesFileExist idxf + when ex $ do + indexInfos <- liftM read $ liftIO $ readFile idxf + mapM_ (addIndex' False) indexInfos + act + + +-- | Our monad transformer +newtype GraphStorageT m a = Gs { unIs :: StateT GsData m a } + deriving ( Functor, Applicative, Alternative, Monad + , MonadFix, MonadPlus, MonadIO, MonadTrans + , R.MonadThrow ) + +deriving instance R.MonadResource m => R.MonadResource (GraphStorageT m) + +instance MonadBase b m => MonadBase b (GraphStorageT m) where + liftBase = lift . liftBase + +instance MonadTransControl GraphStorageT where + newtype StT GraphStorageT a = GsStT { unGsStT :: StT (StateT GsData) a } + liftWith f = Gs $ liftWith (\run -> f (liftM GsStT . run . unIs)) + restoreT = Gs . restoreT . liftM unGsStT + +instance MonadBaseControl b m => MonadBaseControl b (GraphStorageT m) where + newtype StM (GraphStorageT m) a = StMT {unStMT :: ComposeSt GraphStorageT m a} + liftBaseWith = defaultLiftBaseWith StMT + restoreM = defaultRestoreM unStMT + +instance (MonadLogger m) => MonadLogger (GraphStorageT m) where + monadLoggerLog loc src lvl msg=lift $ monadLoggerLog loc src lvl msg + + +--data Graph = Graph [GraphObject] [GraphRelation] +-- deriving (Show,Read,Eq,Ord,Typeable) + +-- | An object with a type and properties +data GraphObject a = GraphObject + { goID :: a + , goType :: T.Text + , goProperties :: DM.Map T.Text [PropertyValue] + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | A relation between two objects, with a type and properties +data GraphRelation a b = GraphRelation + { grID :: a + , grFrom :: GraphObject b + , grTo :: GraphObject b + , grType :: T.Text + , grProperties :: DM.Map T.Text [PropertyValue] + } deriving (Show,Read,Eq,Ord,Typeable) + + + +-- | Get the file handles. +getHandles :: Monad m => GraphStorageT m Handles +getHandles = gsHandles `liftM` Gs get + +-- | Get the currently known model. +getModel :: Monad m => GraphStorageT m Model +getModel = gsModel `liftM` Gs get + +-- | Get the currently known model. +getDirectory :: Monad m => GraphStorageT m FilePath +getDirectory = gsDir `liftM` Gs get + + +-- | Get the current settings. +getSettings :: Monad m => GraphStorageT m GraphSettings +getSettings = gsSettings `liftM` Gs get + +-- | Get the current indices. +getIndices :: Monad m => GraphStorageT m [(IndexInfo,Trie Int16 ObjectID)] +getIndices = gsIndexes `liftM` Gs get + + +indexFile :: Monad m => GraphStorageT m FilePath +indexFile = do + dir <- getDirectory + return $ dir "indices" + + +-- | Create or replace an object. +createObject :: (GraphUsableMonad m) => + GraphObject (Maybe ObjectID)-> GraphStorageT m (GraphObject ObjectID) +createObject obj = do + hs <- getHandles + tid <- objectType $ goType obj + toAdd <- removeOldValuesFromIndex obj (goID obj) + --let props = filter (not . null . snd) $ DM.toList $ goProperties obj + propId <- createProperties $ goProperties obj + nid <- write hs (goID obj) (Object tid def def propId) + insertNewValuesInIndex nid toAdd + return $ obj {goID = nid} + +-- | Replace an object. +updateObject :: (GraphUsableMonad m) => + GraphObject ObjectID -> GraphStorageT m (GraphObject ObjectID) +updateObject obj = do + hs <- getHandles + tid <- objectType $ goType obj + toAdd <- removeOldValuesFromIndex obj (Just $ goID obj) + --let props = filter (not . null . snd) $ DM.toList $ goProperties obj + propId <- createProperties $ goProperties obj + _ <- write hs (Just $ goID obj) (Object tid def def propId) + insertNewValuesInIndex (goID obj) toAdd + return obj + +-- | Checks if there is a duplicate on any applicable index. Then remove obsolete values from the index, and generate the list of values to add +-- We'll only add the values once the object has been properly written, so we can have the ID of new objects. +removeOldValuesFromIndex :: (GraphUsableMonad m) => GraphObject a -> Maybe ObjectID -> GraphStorageT m [(T.Text,[Trie Int16 ObjectID],[PropertyValue])] +removeOldValuesFromIndex g mid = do + idxMap <- indexMap g + if DM.null idxMap + then return [] + else do + oldProps <- case mid of + Nothing -> return DM.empty + Just oid -> do + hs <- getHandles + obj <- readOne hs oid + let pid = oFirstProperty obj + listProperties pid + let (toRem,toAdd) = foldr (removeIdx oldProps (goProperties g)) ([],[]) $ DM.assocs idxMap + checkDuplicates mid toAdd + liftIO $ mapM_ removeVals toRem + return toAdd + where + removeIdx oldP newP (n,tries) (toRem,toAdd) = do + let oldVs = fromMaybe [] $ DM.lookup n oldP + let newVs = fromMaybe [] $ DM.lookup n newP + case (oldVs,newVs) of + ([],[]) -> (toRem,toAdd) -- no values, nothing to do + (vs,[]) -> ((tries,vs):toRem,toAdd) -- no new values, remove old + ([],ns) -> (toRem,(n,tries,ns):toAdd) -- new values, return ref + (ovs,nvs) + | ovs == nvs -> (toRem,toAdd) -- same values, nothing to do + | otherwise -> ((tries,ovs):toRem,(n,tries,nvs):toAdd) + removeVals (tries,vs) = mapM_ (removeVal tries) vs + removeVal tries v = mapM_ (delete (valueToIndex v)) tries + + +-- | Check if duplicates exist in index. +checkDuplicates :: (GraphUsableMonad m) => Maybe ObjectID -> [(T.Text,[Trie Int16 ObjectID],[PropertyValue])] -> GraphStorageT m () +checkDuplicates mid toAdd = do + dups <- liftIO + $ filter (not . null . snd) + . map (second (filter (\ oid -> Just oid /= mid))) + <$> mapM checkDups toAdd + unless (null dups) $ + liftIO $ throwIO $ DuplicateIndexKey $ map fst dups + where + checkDups (n,tries,vs) = do + ids<-concat <$> mapM (checkDup tries) vs + return (n,ids) + checkDup tries v = catMaybes <$> mapM (Idx.lookup (valueToIndex v)) tries + + +-- | Insert new values in applicable indices. +insertNewValuesInIndex :: (GraphUsableMonad m) => ObjectID -> [(T.Text,[Trie Int16 ObjectID],[PropertyValue])] -> GraphStorageT m () +insertNewValuesInIndex gid = liftIO . mapM_ addVals + where + addVals (_,tries,vs) = mapM_ (addVal tries) vs + -- We should not have duplicates here, given removeOldValuesFromIndex + addVal tries v = mapM_ (insert (valueToIndex v) gid) tries + + +-- | Create properties from map, returns the first ID in the chain +createProperties + :: (GraphUsableMonad m) + => DM.Map T.Text [PropertyValue] + -> GraphStorageT m PropertyID +createProperties = foldM addProps def . DM.toList + where + addProps nid (_,[]) = return nid + addProps nid (name,vs@(v:_)) = do + let dt = valueType v + ptid <- propertyType (name,dt) + hs <- getHandles + foldM (writeProperty hs ptid) nid vs + + +-- | filter objects +filterObjects :: (GraphUsableMonad m) => + (GraphObject ObjectID -> GraphStorageT m Bool) -> GraphStorageT m [GraphObject ObjectID] +filterObjects ft = filterM ft =<< (mapM (uncurry populateObject) =<< readAll =<< getHandles) + +-- | (Internal) Fill an object with its properties +populateObject :: (GraphUsableMonad m) => + ObjectID -> Object -> GraphStorageT m (GraphObject ObjectID) +populateObject objId obj = do + let pid = oFirstProperty obj + pmap <- listProperties pid + typeName <- getTypeName obj + return $ GraphObject objId typeName pmap + +-- | Get one object from its ID. +getObject :: (GraphUsableMonad m) => + ObjectID -> GraphStorageT m (GraphObject ObjectID) +getObject gid = populateObject gid =<< flip readOne gid =<< getHandles + + +-- | Get the type name for a given low level Object. +getTypeName :: (GraphUsableMonad m) => Object -> GraphStorageT m T.Text +getTypeName obj = do + mdl <- getModel + let otid = oType obj + throwIfNothing (UnknownObjectType otid) $ DM.lookup otid $ toName $ mObjectTypes mdl + + +-- | (Internal) Build a property map by reading the property list. +listProperties + :: (GraphUsableMonad m) + => PropertyID + -> GraphStorageT m (DM.Map T.Text [PropertyValue]) +listProperties pid = do + hs <- getHandles + mdl <- getModel + ps <- readProperties hs mdl def pid + DM.fromList <$> + mapM propName + (DM.toList $ DM.fromListWith (++) $ map (\ (k, v) -> (k, [v])) ps) + where + propName (p,vs) = do + mdl <- getModel + let ptid = pType p + (pName,_) <- throwIfNothing (UnknownPropertyType ptid) $ DM.lookup ptid $ toName $ mPropertyTypes mdl + return (pName,vs) + + +-- | Create a relation between two objects +createRelation :: (GraphUsableMonad m) => + GraphRelation (Maybe RelationID) (Maybe ObjectID) -> GraphStorageT m (GraphRelation RelationID ObjectID) +createRelation rel = do + fromObj <- getObjectId $ grFrom rel + toObj <- getObjectId $ grTo rel + createRelation' $ GraphRelation (grID rel) fromObj toObj (grType rel) (grProperties rel) + where + getObjectId obj = case goID obj of + Just i -> return obj{goID=i} + Nothing -> createObject obj + +-- | Create a relation between two objects +createRelation' :: (GraphUsableMonad m) => + GraphRelation (Maybe RelationID) ObjectID -> GraphStorageT m (GraphRelation RelationID ObjectID) +createRelation' rel = do + let fromObj = grFrom rel + let fromId = goID fromObj + fromTid <- objectType $ goType fromObj + let toObj = grTo rel + let toId = goID toObj + toTid <- objectType $ goType toObj + rid <- relationType $ grType rel + propId <- createProperties $ grProperties rel + hs <- getHandles + fromTObj <- readOne hs fromId + toTObj <- readOne hs toId + nid <- write hs (grID rel) (Relation fromId fromTid toId toTid rid (oFirstFrom fromTObj) (oFirstTo toTObj) propId) + _ <- write hs (Just fromId) fromTObj{oFirstFrom=nid} + _ <- write hs (Just toId) toTObj{oFirstTo=nid} + + return rel{grID=nid,grFrom=fromObj,grTo=toObj} + + +-- | list relations matchinf a filter +filterRelations :: (GraphUsableMonad m) => + (GraphRelation RelationID ObjectID -> GraphStorageT m Bool) -> GraphStorageT m [GraphRelation RelationID ObjectID] +filterRelations ft = filterM ft =<< (mapM popProperties =<< readAll =<< getHandles) + where + popProperties (relId,rel) = do + mdl <- getModel + let pid = rFirstProperty rel + pmap <- listProperties pid + let rtid = rType rel + typeName <- throwIfNothing (UnknownRelationType rtid) $ DM.lookup rtid $ toName $ mRelationTypes mdl + fromObj <- getObject $ rFrom rel + toObj <- getObject $ rTo rel + return $ GraphRelation relId fromObj toObj typeName pmap + + +-- | Delete a relation from the DB. +deleteRelation + :: (GraphUsableMonad m) + => RelationID + -> GraphStorageT m () +deleteRelation rid = + void $ deleteRelation' rid True True + +-- | (Internal) Delete a relation from the DB. +deleteRelation' + :: (GraphUsableMonad m) + => RelationID + -> Bool -- ^ Should we clean the origin object relation list? + -> Bool -- ^ Should we clean the target object relation list? + -> GraphStorageT m [RelationID] -- ^ The next ids in the chain we didn't clean +deleteRelation' rid cleanFrom cleanTo = do + hs <- getHandles + rel <- readOne hs rid + _ <- write hs (Just rid) (def::Relation) + addToFreeList rid (hRelationFree hs) + deleteProperties hs $ rFirstProperty rel + + let nextFrom = rFromNext rel + ns1 <- if cleanFrom + then do + let fromId = rFrom rel + fromO <- readOne hs fromId + let fstFromId = oFirstFrom fromO + if fstFromId == rid + then void $ write hs (Just fromId) fromO{oFirstFrom = nextFrom} + else fixChain hs fstFromId rFromNext (\r -> r{rFromNext = nextFrom}) + return [] + else return [nextFrom] + + let nextTo = rToNext rel + ns2 <- if cleanTo + then do + let toId = rTo rel + toO <- readOne hs toId + let fstToId = oFirstTo toO + if fstToId == rid + then void $ write hs (Just toId) toO{oFirstTo = nextTo} + else fixChain hs fstToId rToNext (\r -> r{rToNext = nextTo}) + return [] + else return [nextTo] + return $ filter (def /=) $ ns1 ++ ns2 + where + fixChain _ crid _ _ | crid == def = return () + fixChain hs crid getNext setNext = do + rel <- readOne hs crid + let nid = getNext rel + if nid == rid + then void $ write hs (Just crid) $ setNext rel + else fixChain hs nid getNext setNext + +-- | Delete an object +deleteObject + :: (GraphUsableMonad m) + => ObjectID + -> GraphStorageT m () +deleteObject oid = do + hs <- getHandles + obj <- readOne hs oid + typeName <- getTypeName obj + _ <- removeOldValuesFromIndex (GraphObject oid typeName DM.empty) $ Just oid + _ <- write hs (Just oid) (def::Object) + addToFreeList oid (hObjectFree hs) + cleanRef False True $ oFirstFrom obj + cleanRef True False $ oFirstTo obj + deleteProperties hs $ oFirstProperty obj + + where + cleanRef _ _ rid | rid == def = return () + cleanRef cleanFrom cleanTo rid = do + rids <- deleteRelation' rid cleanFrom cleanTo + mapM_ (cleanRef cleanFrom cleanTo) rids + +-- | (Internal) Delete all properties in the list +deleteProperties + :: (GraphUsableMonad m) + => Handles + -> PropertyID + -> GraphStorageT m () +deleteProperties _ pid | pid == def = return () +deleteProperties hs pid = do + p <- readOne hs pid + let next = pNext p + _ <- write hs (Just pid) (def::Property) + addToFreeList pid (hPropertyFree hs) + -- TODO what about reclaiming the space of values? + deleteProperties hs next + +-- | (Internal) retrieve an object type id from its name (creating it if need be) +objectType :: (GraphUsableMonad m) + => T.Text -> GraphStorageT m ObjectTypeID +objectType typeName = fetchType mObjectTypes + (\mdl ots -> mdl {mObjectTypes = ots}) + typeName typeName + ObjectType + +-- | (Internal) retrieve a property type id from its name and data type (creating it if need be) +propertyType :: (GraphUsableMonad m) + => (T.Text,DataType) -> GraphStorageT m PropertyTypeID +propertyType t@(propName,dt) = fetchType mPropertyTypes + (\mdl pts -> mdl {mPropertyTypes = pts}) + t propName + (PropertyType $ dataTypeID dt) + +-- | (Internal) retrieve an relation type id from its name (creating it if need be) +relationType :: (GraphUsableMonad m) + => T.Text -> GraphStorageT m RelationTypeID +relationType relationName = fetchType mRelationTypes + (\mdl rts -> mdl {mRelationTypes = rts}) + relationName relationName + RelationType + +-- | (Internal) Fetch type helper +fetchType :: (GraphUsableMonad m, Ord k, GraphIdSerializable i v) + => (Model -> Lookup i k) + -> (Model -> Lookup i k -> Model) + -> k + -> T.Text + -> (PropertyID -> v) + -> GraphStorageT m i +fetchType getM setM k name build = do + mdl <- getModel + let mid = DM.lookup k $ fromName $ getM mdl + case mid of + Just i -> return i + Nothing -> do + hs <- getHandles + pid <- writeProperty hs namePropertyID def $ PVText name + newid <- write hs Nothing $ build pid + let pts = addToLookup newid k $ getM mdl + mdl2 = setM mdl pts + Gs $ modify (\s -> s{gsModel=mdl2}) + return newid + + +-- | Add an index to be automatically managed. +addIndex :: (GraphUsableMonad m) => IndexInfo -> GraphStorageT m (Trie Int16 ObjectID) +addIndex = addIndex' True + +-- | Add an index to be automatically managed. +addIndex' :: (GraphUsableMonad m) => Bool -> IndexInfo -> GraphStorageT m (Trie Int16 ObjectID) +addIndex' indexExisting ii@(IndexInfo idxName _ props) = do + t <- createIndex idxName + Gs (modify (\s@GsData{..} ->s{ gsIndexes = (ii,t):gsIndexes} )) + idxf <- indexFile + idxs <- getIndices + liftIO $ writeFile idxf $ show $ map fst idxs + when indexExisting $ getHandles >>= \hs->foldAll hs (fillIndex t) () + return t + where + fillIndex :: (GraphUsableMonad m) => Trie Int16 ObjectID -> () -> (ObjectID,Object) -> GraphStorageT m () + fillIndex t _ (gid,obj) = do + typeName <- getTypeName obj + when (isIndexApplicable ii typeName) $ do + go <- populateObject gid obj + let toAdd = map (\(k,v)-> (k,[t],v)) $ filter (\(k,_)->k `elem` props) $ DM.assocs $ goProperties go + checkDuplicates (Just gid) toAdd + insertNewValuesInIndex gid toAdd + return () + + + -- | (Internal) Create an index. +createIndex :: forall k v m. (Binary k,Binary v,Default k,Default v,GraphUsableMonad m) => + T.Text -> GraphStorageT m (Trie k v) +createIndex idxName = do + dir <- getDirectory + --trie <- liftIO $ newFileTrie $ dir T.unpack idxName + (_,trie) <- R.allocate (liftIO $ newFileTrie $ dir T.unpack idxName) (hClose . trHandle) + gs <- getSettings + liftIO $ setBufferMode (trHandle trie) $ gsIndexBuffering gs + return trie + + +-- | Get the indices to update, per property. +indexMap :: (GraphUsableMonad m) => GraphObject a -> GraphStorageT m (DM.Map T.Text [Trie Int16 ObjectID]) +indexMap obj = do + iis <- getIndices + return $ foldr addPropIndex DM.empty iis + where + addPropIndex (ii,tr) dm + | isIndexApplicable ii (goType obj) = foldr (\prop -> DM.insertWith (++) prop [tr]) dm $ iiProps ii + | otherwise = dm + + +-- | Is the given index applicable to the given object type? +isIndexApplicable :: IndexInfo -> T.Text -> Bool +isIndexApplicable ii typ = let + tps = iiTypes ii + in null tps || typ `elem` tps diff --git a/src/Database/Graph/HGraphStorage/Constants.hs b/src/Database/Graph/HGraphStorage/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/Constants.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Some constants values +module Database.Graph.HGraphStorage.Constants where + +import Data.Text (Text) + +-- | The name of the "name" property +namePropertyName :: Text +namePropertyName = "name" + +-- | The name of the object file +objectFile :: FilePath +objectFile = "objects.db" + +-- | The name of the object type file +objectTypeFile :: FilePath +objectTypeFile = "objecttypes.db" + +-- | The name of the relation file +relationFile :: FilePath +relationFile = "relations.db" + +-- | The name of the object type file +relationTypeFile :: FilePath +relationTypeFile = "relationtypes.db" + +-- | The name of the property file +propertyFile :: FilePath +propertyFile = "properties.db" + +-- | The name of the property type file +propertyTypeFile :: FilePath +propertyTypeFile = "propertytypes.db" + +-- | The name of the property value file +propertyValuesFile :: FilePath +propertyValuesFile = "propertyvalues.db" + +-- | Prefix for free list files +freePrefix :: FilePath +freePrefix = "free-" diff --git a/src/Database/Graph/HGraphStorage/FileOps.hs b/src/Database/Graph/HGraphStorage/FileOps.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/FileOps.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE RecordWildCards, MultiParamTypeClasses, TypeSynonymInstances,OverloadedStrings, FlexibleContexts, ConstraintKinds, ExplicitForAll, ScopedTypeVariables #-} +module Database.Graph.HGraphStorage.FileOps where + +import Control.Applicative +import Control.Exception.Base (Exception) + +import Data.Binary +import Data.Default +import Data.Traversable +import System.FilePath +import qualified Data.Map as DM + + +import System.IO +import System.Directory + +import Database.Graph.HGraphStorage.Constants +import Database.Graph.HGraphStorage.Types +import qualified Data.ByteString.Lazy as BS +import Data.Int +import Data.ByteString.Lazy (toStrict, fromStrict) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Control.Monad (foldM, when, join) +import Control.Monad.Base (MonadBase) +import Control.Exception.Lifted (throwIO) +import Control.Monad.IO.Class (liftIO) +import Database.Graph.HGraphStorage.FreeList + +-- | Open all the file handles +open :: FilePath -> GraphSettings -> IO Handles +open dir gs = do + createDirectoryIfMissing True dir + Handles + <$> getHandle objectFile + <*> getFreeList objectFile (def::ObjectID) + <*> getHandle objectTypeFile + <*> getHandle relationFile + <*> getFreeList relationFile (def::RelationID) + <*> getHandle relationTypeFile + <*> getHandle propertyFile + <*> getFreeList propertyFile (def::PropertyID) + <*> getHandle propertyTypeFile + <*> getHandle propertyValuesFile + where + getHandle :: FilePath -> IO Handle + getHandle name = do + let f = dir name + h <- openBinaryFile f ReadWriteMode + setBufferMode h $ gsMainBuffering gs + return h + getFreeList :: (Binary a) => FilePath -> a -> IO (FreeList a) + getFreeList name d = do + let f = dir freePrefix ++ name + h<- openBinaryFile f ReadWriteMode + setBufferMode h $ gsFreeBuffering gs + initFreeList (fromIntegral $ binLength d) h (do + ex <- doesFileExist f + when ex $ removeFile f) + + +setBufferMode :: Handle -> Maybe BufferMode -> IO() +setBufferMode _ Nothing = return () +setBufferMode h (Just bm) = hSetBuffering h bm + +-- | Close all the file handles +close :: Handles -> IO () +close Handles{..} = do + hClose hObjects + _ <- closeFreeList hObjectFree + hClose hObjectTypes + hClose hRelations + _ <- closeFreeList hRelationFree + hClose hRelationTypes + hClose hProperties + _ <- closeFreeList hPropertyFree + hClose hPropertyTypes + hClose hPropertyValues + +-- | Read the current model from the handles +-- generate a default model if none present (new db) +readModel :: (GraphUsableMonad m) + => Handles -> m Model +readModel hs = do + let defMdl = def + pts <- readAll hs + when (null pts) $ do + let t = "name" + a <- write hs Nothing (Property namePropertyID 0 0 (BS.length t)) + b <- write hs Nothing (PropertyType (dataTypeID DTText) a) + when (b /= namePropertyID) $ throwIO $ IncoherentNamePropertyTypeID namePropertyID b + liftIO $ do + hSeek (hPropertyValues hs) AbsoluteSeek 0 + BS.hPut (hPropertyValues hs) t + return () + ots <- readAll hs + rts <- readAll hs + mdlWithProps <- foldM addProp defMdl pts + mdlWithObjs <- foldM addOType mdlWithProps ots + foldM addRType mdlWithObjs rts + where + addProp mdl (ptId,pt) = addN mdl (ptFirstProperty pt) ptId $ \name -> + return mdl{mPropertyTypes = addToLookup ptId (name,dataType $ ptDataType pt) $ mPropertyTypes mdl} + + addOType mdl (otId,ot) = addN mdl (otFirstProperty ot) otId $ \name -> + return mdl {mObjectTypes = addToLookup otId name $ mObjectTypes mdl} + + addRType mdl (rtId,rt) = addN mdl (rtFirstProperty rt) rtId $ \name -> + return mdl {mRelationTypes = addToLookup rtId name $ mRelationTypes mdl} + + addN mdl pId tId f = do + pvs <- readProperties hs mdl namePropertyID pId + case pvs of + [(_,PVText name)] -> f name + [] -> throwIO $ NoNameProperty tId + _ -> throwIO $ MultipleNameProperty tId + +-- | Generic write operation: write the given binary using the given ID and record size +-- if no id, we write at then end +-- otherwise we always ensure that we write at the proper offset, which is why we have fixed length records +writeGeneric :: (GraphUsableMonad m) + => (Integral a,Binary a,Default a, Binary b) => Handle -> Maybe (FreeList a) -> Int64 -> Maybe a -> b -> m a +writeGeneric h _ sz (Just a) b = + liftIO $ do + hSeek h AbsoluteSeek (toInteger (a - 1) * toInteger sz) + BS.hPut h $ encode b + return a +writeGeneric h mf sz Nothing b = do + mid <- liftIO $ join <$> for mf getFromFreeList + case mid of + Just i -> writeGeneric h mf sz (Just i) b + Nothing -> liftIO $ do + hSeek h SeekFromEnd 0 + allsz <- hTell h + let a=div allsz $ toInteger sz + BS.hPut h $ encode b + return $ fromInteger a + 1 + +-- | Read a binary with a given ID from the given handle +readGeneric :: (GraphUsableMonad m) + => (Integral a, Binary b) => Handle -> Int64 -> a -> m b +readGeneric h sz a = + liftIO $ do + hSeek h AbsoluteSeek (toInteger (a - 1) * toInteger sz) + decode <$> BS.hGet h (fromIntegral sz) + +-- | Read all binary objects from a given handle, generating their IDs from their offset +readAll :: (GraphUsableMonad m,GraphIdSerializable a b) => Handles -> m [(a,b)] +readAll hs = foldAll hs (\a b->return $ b:a) [] + +-- | Read all binary objects from a given handle, generating their IDs from their offset +foldAllGeneric :: (GraphUsableMonad m) + => (Integral a, Eq b, Binary b, Default b) => Handle -> Int64 + -> (c -> (a,b) -> m c) -> c -> m c +foldAllGeneric h sz f st = do + liftIO $ hSeek h AbsoluteSeek 0 + go (fromIntegral sz) 0 st + where go isz a st2 = do + bs <- liftIO $ BS.hGet h isz + if BS.null bs + then return st2 + else do + let b = decode bs + i = a + 1 + l2 <- if b == def + then return st2 + else f st2 (i,b) + go isz i l2 + +-- | Read all properties, starting from a given one, with an optional filter on the Property Type +readProperties :: (GraphUsableMonad m) + => Handles -> Model -> PropertyTypeID -> PropertyID -> m [(Property,PropertyValue)] +readProperties _ _ _ pid | pid == def = return [] +readProperties hs mdl ptid pid = do + p <- readOne hs pid + vs <- if ptid == def || pType p == ptid + then + do + let m = DM.lookup (pType p) $ toName $ mPropertyTypes mdl + (_, dt) <- throwIfNothing (UnknownPropertyType (pType p)) m + val <- readPropertyValue hs dt (pOffset p) (pLength p) + return [(p,val)] + else return [] + let p2 = pNext p + (vs ++) <$> readProperties hs mdl ptid p2 + + +-- | Write a property, knowing the next one in the chain +writeProperty :: (GraphUsableMonad m) + => Handles -> PropertyTypeID -> PropertyID -> PropertyValue -> m PropertyID +writeProperty hs ptid nextid v = do + let h = hPropertyValues hs + liftIO $ hSeek h SeekFromEnd 0 + off <- liftIO $ fromIntegral <$> hTell h + let bs = toBin v + liftIO $ BS.hPut h bs + write hs Nothing $ Property ptid nextid off (BS.length bs) + where + toBin (PVBinary bs) = bs + toBin (PVText t) = fromStrict $ encodeUtf8 t + toBin (PVInteger i) = encode i + +-- | Helper method throwing an exception if we got a Maybe, otherwise return the Just value +throwIfNothing :: (MonadBase IO m, + Exception e) => + e -> Maybe a -> m a +throwIfNothing e Nothing = throwIO e +throwIfNothing _ (Just a) = return a + +-- | Read a property value given an offset and length +readPropertyValue :: (GraphUsableMonad m) + => Handles -> DataType -> PropertyValueOffset -> PropertyValueLength -> m PropertyValue +readPropertyValue hs dt off len = do + let h = hPropertyValues hs + liftIO $ hSeek h AbsoluteSeek (fromIntegral off) + liftIO $ toValue dt <$> BS.hGet h (fromIntegral len) + where + toValue DTBinary = PVBinary + toValue DTText = PVText . decodeUtf8 . toStrict + toValue DTInteger = PVInteger . decode + +-- | A class that defines basic read and write operations for a given ID and binary object +class (Integral a, Binary b) => GraphIdSerializable a b where + write :: (GraphUsableMonad m) => Handles -> Maybe a -> b -> m a + readOne :: (GraphUsableMonad m) => Handles -> a -> m b + foldAll :: (GraphUsableMonad m) => Handles -> (c -> (a,b) -> m c) -> c -> m c + + +-- | Serialization methods for ObjectID + Object +instance GraphIdSerializable ObjectID Object where + write hs = writeGeneric (hObjects hs) (Just $ hObjectFree hs) objectSize + readOne hs = readGeneric (hObjects hs) objectSize + foldAll hs = foldAllGeneric(hObjects hs) objectSize + +-- | Serialization methods for RelationID + Relation +instance GraphIdSerializable RelationID Relation where + write hs = writeGeneric (hRelations hs) (Just $ hRelationFree hs) relationSize + readOne hs = readGeneric (hRelations hs) relationSize + foldAll hs = foldAllGeneric(hRelations hs) relationSize + +-- | Serialization methods for PropertyID + Property +instance GraphIdSerializable PropertyID Property where + write hs = writeGeneric (hProperties hs) (Just $ hPropertyFree hs) propertySize + readOne hs = readGeneric (hProperties hs) propertySize + foldAll hs = foldAllGeneric(hProperties hs) propertySize + +-- | Serialization methods for PropertyTypeID + PropertyType +instance GraphIdSerializable PropertyTypeID PropertyType where + write hs = writeGeneric (hPropertyTypes hs) Nothing propertyTypeSize + readOne hs = readGeneric (hPropertyTypes hs) propertyTypeSize + foldAll hs = foldAllGeneric(hPropertyTypes hs) propertyTypeSize + +-- | Serialization methods for ObjectTypeID + ObjectType +instance GraphIdSerializable ObjectTypeID ObjectType where + write hs = writeGeneric (hObjectTypes hs) Nothing objectTypeSize + readOne hs = readGeneric (hObjectTypes hs) objectTypeSize + foldAll hs = foldAllGeneric(hObjectTypes hs) objectTypeSize + +-- | Serialization methods for RelationTypeID + RelationType +instance GraphIdSerializable RelationTypeID RelationType where + write hs = writeGeneric (hRelationTypes hs) Nothing relationTypeSize + readOne hs = readGeneric (hRelationTypes hs) relationTypeSize + foldAll hs = foldAllGeneric(hRelationTypes hs) relationTypeSize + diff --git a/src/Database/Graph/HGraphStorage/FreeList.hs b/src/Database/Graph/HGraphStorage/FreeList.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/FreeList.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts #-} +-- | Free list management +module Database.Graph.HGraphStorage.FreeList where + +import System.IO +import Data.Binary +import Data.Default +import qualified Data.ByteString.Lazy as BS +import Control.Monad.IO.Class (liftIO, MonadIO) + +-- | Free List structure +data FreeList a = FreeList + { flSize :: Integer -- ^ Record size + , flHandle :: Handle -- ^ File handle + , flOnEmptyClose :: IO() -- ^ What to do on close if no record + } + +-- | position handle +initFreeList :: (Binary a,MonadIO m) => Integer -> Handle -> IO() -> m (FreeList a) +initFreeList sz h onClose = liftIO $ do + --at end + hSeek h SeekFromEnd 0 + return $ FreeList sz h onClose + + +-- | Close underlying handle and return if we have still objects in the list +closeFreeList :: (Binary a,MonadIO m) => FreeList a -> m Bool +closeFreeList (FreeList sz h onClose)= liftIO $ do + i <- liftIO $ hTell h + hClose h + if i>=sz + then return True + else do + onClose + return False + +-- | Add object to list +addToFreeList :: (Binary a,MonadIO m) => a -> FreeList a -> m () +addToFreeList b (FreeList _ h _) = liftIO $ + BS.hPut h $ encode b + -- at end + +-- | get object to list if list is non empty +getFromFreeList :: (Binary a,Eq a,Default a,MonadIO m) => FreeList a -> m (Maybe a) +getFromFreeList f@(FreeList sz h _) = do + i <- liftIO $ hTell h + if i>=sz + then do + bs <- liftIO $ do + hSeek h RelativeSeek (-sz) + let isz = fromIntegral sz + bs <- BS.hGet h isz + hSeek h RelativeSeek (-sz) + return bs + if BS.null bs + then return Nothing + else do + let r = decode bs + if r /= def + then return $ Just r + else getFromFreeList f + else return Nothing diff --git a/src/Database/Graph/HGraphStorage/Index.hs b/src/Database/Graph/HGraphStorage/Index.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/Index.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables, ConstraintKinds, FlexibleContexts, RankNTypes #-} +-- | Index on disk +-- +-- +module Database.Graph.HGraphStorage.Index + ( Trie (..) + , newTrie + , newFileTrie + , insertNew + , insert + , Database.Graph.HGraphStorage.Index.lookup + , prefix + , delete) +where + +import Control.Applicative +import Data.Binary +import Data.Int (Int64) +import System.IO +import Data.Typeable +import GHC.Generics (Generic) +import Database.Graph.HGraphStorage.Types + +import Data.Default +import qualified Data.ByteString.Lazy as BS +import System.FilePath +import System.Directory + + +-- | Trie on disk +data Trie k v = Trie + { trHandle :: Handle -- ^ The disk Handle + , trRecordLength :: Int64 -- ^ The length of a record + } + +-- | A Trie Node +data TrieNode k v = TrieNode + { tnKey :: k -- ^ the key (def for nothing) + , tnValue :: v -- ^ the value (def for nothing) + , tnNext :: Int64 -- ^ the offset of next sibling (def for nothing) + , tnChild :: Int64 -- ^ the offset of first child (def for nothing) + } deriving (Show,Read,Eq,Ord,Typeable,Generic) + + +-- | Simple binary instance +instance (Binary k, Binary v) => Binary (TrieNode k v) + + +-- | Build a file backed trie +newFileTrie :: forall k v. (Binary k,Binary v,Default k,Default v) => FilePath -> IO (Trie k v) +newFileTrie file = do + let dir = takeDirectory file + createDirectoryIfMissing True dir + h<- openBinaryFile file ReadWriteMode + return $ newTrie h + + +-- | Create a new trie with a given handle +-- The limitations are: +-- Key and Value must have a binary representation of constant length! +newTrie :: forall k v. (Binary k,Binary v,Default k,Default v) => Handle -> Trie k v +newTrie h = Trie h (keyL+valL+pointL*2) + where + keyL = binLength (def::k) + valL = binLength (def::v) + pointL = binLength (def::Int64) + + +-- | Insert a value if it does not exist in the tree +-- if it exists, return the old value and does nothing +insertNew :: (Binary k,Eq k,Default k,Binary v,Eq v,Default v) => [k] -> v -> Trie k v -> IO (Maybe v) +insertNew key val tr = insertValue key val tr $ \h (off,node) -> do + let v=tnValue node + if v /= def + then return $ Just v + else do + hSeek h AbsoluteSeek $ fromIntegral off + BS.hPut h $ encode (node{tnValue=val}) + return Nothing + + +-- | Insert a value for a key +-- if the value existed for that key, return the old value +insert :: (Binary k,Eq k,Default k,Binary v,Eq v,Default v) => [k] -> v -> Trie k v -> IO (Maybe v) +insert key val tr = insertValue key val tr $ \h (off,node) -> do + hSeek h AbsoluteSeek $ fromIntegral off + BS.hPut h $ encode (node{tnValue=val}) + let v=tnValue node + return $ if v /= def + then Just v + else Nothing + + +-- | Insert a value performing a given action if the key is already present +insertValue :: (Binary k,Eq k,Default k,Binary v,Eq v,Default v) + => [k] -> v -> Trie k v + -> (Handle -> (Int64,TrieNode k v) ->IO (Maybe v)) + -> IO (Maybe v) +insertValue key val tr onExisting = + readRecord tr 0 >>= insert' key + where + h = trHandle tr + insert' [] _ = return Nothing + insert' (k:ks) Nothing = do + hSeek h AbsoluteSeek 0 + let newC = TrieNode k (if null ks then val else def) def def + BS.hPut h $ encode newC + insertChild ks (Just (0,newC)) + insert' (k:ks) (Just (off,node)) = + if k == tnKey node + then case ks of + [] -> onExisting h (off,node) + _ -> insertChild ks (Just (off,node)) + else do + mn <- readChildRecord tr $ tnNext node + case mn of + Just n -> insert' (k:ks) $ Just n + Nothing -> do + hSeek h SeekFromEnd 0 + allsz <- fromIntegral <$> hTell h + let newN = TrieNode k (if null ks then val else def) def def + BS.hPut h $ encode newN + hSeek h AbsoluteSeek $ fromIntegral off + BS.hPut h $ encode (node{tnNext=allsz}) + insertChild ks (Just (allsz,newN)) + insertChild [] _ = return Nothing + insertChild _ Nothing = return Nothing + insertChild ks@(k':ks') (Just (off,node)) = do + mc <- readChildRecord tr $ tnChild node + case mc of + Just c -> insert' ks $ Just c + Nothing -> do + hSeek h SeekFromEnd 0 + allsz <- fromIntegral <$> hTell h + let newC = TrieNode k' (if null ks' then val else def) def def + BS.hPut h $ encode newC + hSeek h AbsoluteSeek $ fromIntegral off + BS.hPut h $ encode (node{tnChild=allsz}) + insertChild ks' (Just (allsz,newC)) + +-- | Read a given record +readRecord :: (Binary k,Binary v) => Trie k v -> Int64 -> IO (Maybe (Int64,TrieNode k v)) +readRecord tr off = do + hSeek h AbsoluteSeek $ fromIntegral off + bs <- BS.hGet h isz + if BS.null bs + then return Nothing + else return $ Just (off, decode bs) + where + h = trHandle tr + isz = fromIntegral $ trRecordLength tr + + +-- | Read a given record whose offset must be greater than 0 +readChildRecord :: (Binary k,Binary v) => Trie k v -> Int64 -> IO (Maybe (Int64,TrieNode k v)) +readChildRecord _ 0 = return Nothing +readChildRecord tr off = readRecord tr off + + +-- | Lookup a value from a key +lookup :: (Binary k,Eq k,Binary v,Eq v,Default v) => [k] -> Trie k v -> IO (Maybe v) +lookup key tr = do + mnode <- lookupNode key tr + return $ case mnode of + Just (_,node) -> + let v=tnValue node + in if v /= def + then Just v + else Nothing + _ -> Nothing + + +-- | Lookup a node from a Key +lookupNode :: (Binary k,Eq k,Binary v,Eq v,Default v) => [k] -> Trie k v -> IO (Maybe (Int64, TrieNode k v)) +lookupNode key tr = readRecord tr 0 >>= lookup' key + where + lookup' [] r = return r + lookup' _ Nothing = return Nothing + lookup' (k:ks) (Just (off,node)) = + if k == tnKey node + then + if null ks + then return $ Just (off,node) + else readChildRecord tr (tnChild node) >>= lookup' ks + else + readChildRecord tr (tnNext node) >>= lookup' (k : ks) + + +-- | Return all key and values for the given prefix which may be null (in which case all mappings are returned). +prefix :: (Binary k,Eq k,Binary v,Eq v,Default v) => [k] -> Trie k v -> IO [([k],v)] +prefix key tr = lookupNode key tr >>= collect (null key) key + where + collect _ _ Nothing = return [] + collect withNexts k (Just (_,node)) = do + let k' = tnKey node + let v = tnValue node + let nk = if withNexts then k++[k'] else k + let me = if v == def then [] else [(nk,v)] + subs <- readChildRecord tr (tnChild node) >>= collect True nk + nexts <- if withNexts then readChildRecord tr (tnNext node) >>= collect True k else return [] + return $ me ++ subs ++ nexts + + +-- | Delete the value associated with a key +-- This only remove the value from the trienode, it doesn't prune the trie in any way. +delete :: forall k v. (Binary k,Eq k,Binary v,Eq v,Default v) => [k] -> Trie k v-> IO (Maybe v) +delete key tr = do + mnode <- lookupNode key tr + case mnode of + Just (off,node) -> do + let oldV = tnValue node + if oldV /= def + then do + hSeek h AbsoluteSeek $ fromIntegral off + let (node'::TrieNode k v) = node{tnValue=def} + BS.hPut h $ encode node' + return $ Just oldV + else return Nothing + _ -> return Nothing + where + h = trHandle tr diff --git a/src/Database/Graph/HGraphStorage/Query.hs b/src/Database/Graph/HGraphStorage/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/Query.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveDataTypeable, ConstraintKinds, FlexibleContexts, PatternGuards #-} +-- | Higher level API for querying +module Database.Graph.HGraphStorage.Query where + +import Control.Applicative +import Data.Default +import Data.Typeable +import qualified Data.Text as T +import qualified Data.Map as DM + +import Database.Graph.HGraphStorage.API +import Database.Graph.HGraphStorage.FileOps +import Database.Graph.HGraphStorage.Types + +-- | Direction to follow +data RelationDir = OUT | IN | BOTH + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | One step in the query +data RelationStep = RelationStep + { rsRelTypes :: [T.Text] -- ^ Types of relations to follow (empty -> all) + , rsDirection :: RelationDir -- ^ Direction of relation + , rsTgtTypes :: [T.Text] -- ^ Types of objects to retrieve (empty -> all) + , rsTgtFilter :: GraphObject ObjectID -> Bool -- ^ Condition to match on objects + , rsLimit :: Maybe Int -- ^ Maximum number of relations to follow (limit applies after all other filters) + } deriving (Typeable) + +-- | Default instance: navigates all out links +instance Default RelationStep where + def = RelationStep [] OUT [] (const True) Nothing + +-- | Result of a query step +data StepResult = StepResult + { srRelationID :: RelationID -- ^ Relation id + , srDirection :: RelationDir -- ^ Direction of relation + , srType :: T.Text -- ^ Type of relation + , srProperties :: DM.Map T.Text [PropertyValue] -- ^ Properties of relation + , srObject :: GraphObject ObjectID -- ^ Target object + } deriving (Show,Read,Eq,Ord,Typeable) + + +-- | Run a one step query on one given object +queryStep + :: (GraphUsableMonad m) + => ObjectID -> RelationStep -> GraphStorageT m [StepResult] +queryStep oid rs = do + hs <- getHandles + o <- readOne hs oid + restrictedRelTypes <- mapM relationType $ rsRelTypes rs + restrictedObjTypes <- mapM objectType $ rsTgtTypes rs + let filt1 = filterRels hs restrictedRelTypes restrictedObjTypes (rsTgtFilter rs) + froms <- + if rsDirection rs `elem` [OUT,BOTH] + then filt1 (oFirstFrom o) rFromNext rToType rTo OUT ([],0) + else return ([],0) + if rsDirection rs `elem` [IN,BOTH] + then fst <$> filt1 (oFirstTo o) rToNext rFromType rFrom IN froms + else return $ fst froms + where + isRestricted [] _ =True + isRestricted ls l = l `elem` ls + filterRels hs resRels resObjs filt fid tonext tgtType tgtId dir (accum,cnt) + | fid == def = return (accum,cnt) + | Just a <- rsLimit rs , + cnt==a = return (accum,cnt) + | otherwise = do + rel <- readOne hs fid + let next = tonext rel + accum2 <- if isRestricted resRels (rType rel) && isRestricted resObjs (tgtType rel) + then do + let oid2 = tgtId rel + obj <- getObject oid2 + if filt obj + then do + mdl <- getModel + let pid = rFirstProperty rel + pmap <- listProperties pid + let rtid = rType rel + typeName <- throwIfNothing (UnknownRelationType rtid) $ DM.lookup rtid $ toName $ mRelationTypes mdl + return (StepResult fid dir typeName pmap obj : accum,cnt+1) + else return (accum,cnt) + else return (accum,cnt) + filterRels hs resRels resObjs filt next tonext tgtType tgtId dir accum2 diff --git a/src/Database/Graph/HGraphStorage/Types.hs b/src/Database/Graph/HGraphStorage/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Graph/HGraphStorage/Types.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Base types and simple functions on them +module Database.Graph.HGraphStorage.Types where + +import Control.Exception.Base +import Data.Binary +import Data.Bits +import qualified Data.ByteString.Lazy as BS +import Data.Default +import Data.Int +import qualified Data.Map as DM +import qualified Data.Text as T +import Data.Typeable + +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Control.Monad.Trans.Resource as R +import GHC.Generics (Generic) +import System.IO + +import Database.Graph.HGraphStorage.Constants +import Database.Graph.HGraphStorage.FreeList + + +-- | put our constraints in one synonym +type GraphUsableMonad m=(MonadBaseControl IO m, R.MonadResource m, MonadLogger m) + +-- | IDs for objects +type ObjectID = Int32 + +-- | IDs for types of objects +type ObjectTypeID = Int16 + +-- | IDs for relations +type RelationID = Int32 + +-- | IDs for types of relations +type RelationTypeID = Int16 + +-- | IDs for property values +type PropertyID = Int32 + +-- | IDs for types of properties +type PropertyTypeID = Int16 + +-- | IDs for data types +type DataTypeID = Int8 + +-- | Offset of property value on value file +type PropertyValueOffset = Int64 + +-- | Length of property value on value file +type PropertyValueLength = Int64 + +-- | An object as represented in the object file +data Object = Object + { + oType :: ObjectTypeID -- ^ type of object + , oFirstFrom :: RelationID -- ^ first relation starting from the object + , oFirstTo :: RelationID -- ^ first relation arriving at the object + , oFirstProperty :: PropertyID -- ^ first property + } deriving (Show,Read,Eq,Ord,Typeable,Generic) + +-- | Simple binary instance +instance Binary Object + +-- | Simple default instance +instance Default Object where + def = Object 0 0 0 0 + +-- | Size of an object record +objectSize :: Int64 +objectSize = binLength (def::Object) + +-- | Calculates the length of the binary serialization of the given object +binLength :: (Binary b) => b -> Int64 +binLength = BS.length . encode + +-- | A relation as represented in the relation file +data Relation = Relation + { rFrom :: ObjectID -- ^ origin object + , rFromType :: ObjectTypeID -- ^ origin object type + , rTo :: ObjectID -- ^ target object + , rToType :: ObjectTypeID -- ^ target object type + , rType :: RelationTypeID -- ^ type of the relation + , rFromNext :: RelationID -- ^ next relation of origin object + , rToNext :: RelationID -- ^ next relation of target object + , rFirstProperty :: PropertyID -- ^ first property id + } deriving (Show,Read,Eq,Ord,Typeable,Generic) + +-- | simple binary instance +instance Binary Relation + +-- | simple default instance +instance Default Relation where + def = Relation 0 0 0 0 0 0 0 0 + +-- | size of a relation record +relationSize :: Int64 +relationSize = binLength (def::Relation) + +-- | A property as represented in the property file +data Property = Property + { pType :: PropertyTypeID -- ^ type of the property + , pNext :: PropertyID -- ^ next property id + , pOffset :: PropertyValueOffset -- ^ offset of the value + , pLength :: PropertyValueLength -- ^ length of the value + } deriving (Show,Read,Eq,Ord,Typeable,Generic) + +-- | simple binary instance +instance Binary Property + +-- | simple default instance +instance Default Property where + def = Property 0 0 0 0 + +-- | size of a property record +propertySize :: Int64 +propertySize = binLength (def::Property) + +-- | Type of a property as represented in the property type file +data PropertyType = PropertyType + { ptDataType :: DataTypeID -- ^ Data type ID + , ptFirstProperty :: PropertyID -- ^ first property of the type itself + } deriving (Show,Read,Eq,Ord,Typeable,Generic) + +-- | simple binary instance +instance Binary PropertyType + +-- | simple default instance +instance Default PropertyType where + def = PropertyType 0 0 + +-- | size of a property type record +propertyTypeSize :: Int64 +propertyTypeSize = binLength (def::PropertyType) + +-- | Type of an object as represented in the object type file +data ObjectType = ObjectType + { otFirstProperty :: PropertyID -- ^ First property of the type itself + }deriving (Show,Read,Eq,Ord,Typeable,Generic) + +-- | simple binary instance +instance Binary ObjectType + +-- | simple default instance +instance Default ObjectType where + def = ObjectType 0 + +-- | Size of an object type record +objectTypeSize :: Int64 +objectTypeSize = binLength (def::ObjectType) + +-- | Type of a relation as represented in the relation type file +data RelationType = RelationType + { rtFirstProperty :: PropertyID -- ^ First property of the type itself + }deriving (Show,Read,Eq,Ord,Typeable,Generic) + +-- | simple binary instance +instance Binary RelationType + +-- | simple default instance +instance Default RelationType where + def = RelationType 0 + +-- | Size of a relation type record +relationTypeSize :: Int64 +relationTypeSize = binLength (def::RelationType) + +-- | Handles to the various files +data Handles = Handles + { hObjects :: Handle + , hObjectFree :: FreeList ObjectID + , hObjectTypes :: Handle + , hRelations :: Handle + , hRelationFree :: FreeList ObjectID + , hRelationTypes :: Handle + , hProperties :: Handle + , hPropertyFree :: FreeList ObjectID + , hPropertyTypes :: Handle + , hPropertyValues :: Handle + } + +-- | The current model: lookup tables between names and ids types of artifacts +data Model = Model + { mObjectTypes :: Lookup ObjectTypeID T.Text + , mRelationTypes :: Lookup RelationTypeID T.Text + , mPropertyTypes :: Lookup PropertyTypeID (T.Text,DataType) + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | Default model: a "name" property property type with a name property +instance Default Model where + def = Model def def (Lookup (DM.singleton (namePropertyName,DTText) namePropertyID) (DM.singleton namePropertyID (namePropertyName,DTText))) + +-- | the ID of the "name" property +namePropertyID :: PropertyTypeID +namePropertyID = 1 + + + +-- | A lookup table allowing two ways lookup +data Lookup a b = Lookup + { fromName :: DM.Map b a + , toName :: DM.Map a b + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | Default instance (empty tables) +instance Default (Lookup a b) where + def = Lookup DM.empty DM.empty + +-- | Add to the lookup maps +addToLookup :: (Ord a, Ord b) => a -> b -> Lookup a b -> Lookup a b +addToLookup a b (Lookup fn tn) = Lookup (DM.insert b a fn) (DM.insert a b tn) + +-- | the supported data types for properties +data DataType = DTText | DTInteger | DTBinary + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | Convert a DataType object to its ID +dataTypeID :: DataType -> DataTypeID +dataTypeID = fromIntegral . fromEnum + +-- | Convert a DataType ID to the Haskell object +dataType :: DataTypeID -> DataType +dataType = toEnum . fromIntegral + +-- | A typed property value +data PropertyValue = + PVText T.Text + | PVInteger Integer + | PVBinary BS.ByteString + deriving (Show,Read,Eq,Ord,Typeable) + +-- | Get the data type for a given value +valueType :: PropertyValue -> DataType +valueType (PVText _) = DTText +valueType (PVInteger _) = DTInteger +valueType (PVBinary _) = DTBinary + +-- | Get the value in a format ready to index +valueToIndex :: PropertyValue -> [Int16] +valueToIndex (PVText t) = textToKey t +valueToIndex (PVInteger i) = integerToKey i +valueToIndex (PVBinary b) = bytestringToKey b + + +-- | Transform a text in a index key +textToKey :: T.Text -> [Int16] +textToKey = map (fromIntegral . fromEnum) . T.unpack + +-- | Transform an integer in a index key +integerToKey :: Integer -> [Int16] +integerToKey i = if i < maxI && i > minI + then [fromIntegral i] + else integerToKey (i `shift` (-16)) ++ [fromIntegral $ i .&. 0xFFFF] + where + maxI = fromIntegral (maxBound :: Int16) + minI = fromIntegral (minBound :: Int16) + +-- | Transform a bytestring in a index key +bytestringToKey :: BS.ByteString -> [Int16] +bytestringToKey = map fromIntegral . BS.unpack + + +-- | The exceptions we may throw +data GraphStorageException = + IncoherentNamePropertyTypeID PropertyTypeID PropertyTypeID -- ^ Something is not right with the name property + | UnknownPropertyType PropertyTypeID + | NoNameProperty PropertyTypeID + | MultipleNameProperty PropertyTypeID + | UnknownObjectType ObjectTypeID + | UnknownRelationType RelationTypeID + | DuplicateIndexKey [T.Text] + deriving (Show,Read,Eq,Ord,Typeable) + +-- | Make our exception a standard exception +instance Exception GraphStorageException + +-- | Settings for the Graph DB +data GraphSettings = GraphSettings + { gsMainBuffering :: Maybe BufferMode + , gsFreeBuffering :: Maybe BufferMode + , gsIndexBuffering :: Maybe BufferMode + } deriving (Show,Read,Eq,Ord,Typeable) + +-- | Default instance for settings +instance Default GraphSettings where + def = GraphSettings Nothing Nothing Nothing diff --git a/test/Database/Graph/HGraphStorage/APITest.hs b/test/Database/Graph/HGraphStorage/APITest.hs new file mode 100644 --- /dev/null +++ b/test/Database/Graph/HGraphStorage/APITest.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Test API access +module Database.Graph.HGraphStorage.APITest where + +import Test.Tasty +import Control.Monad.IO.Class (liftIO) +import Test.Tasty.HUnit + + +import qualified Data.Map as DM + + +import Database.Graph.HGraphStorage.API +import Database.Graph.HGraphStorage.FileOps +import Database.Graph.HGraphStorage.Types +import Database.Graph.HGraphStorage.Query +import Database.Graph.HGraphStorage.Utils +import Data.Maybe + +import qualified Control.Monad.Trans.Resource as R + +import Control.Monad.Logger +import Data.Default (def) +import Database.Graph.HGraphStorage.Index + + +apiTests :: TestTree +apiTests = testGroup "API tests" + [ testCase "Create objects" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + objs <- filterObjects (return . const True) + liftIO $ do + 2 @=? length objs + (th `elem` objs) @? "th not in list!" + (fg `elem` objs) @? "fg not in list!" + return () + , testCase "Create relations" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + fgp <- createRelation' (GraphRelation Nothing th fg "Played" $ DM.fromList [("role",[PVText "Forrest Gump"])]) + ss <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Sleepless in Seattle"]),("year",[PVInteger 1990])]) + ssp <- createRelation' (GraphRelation Nothing th ss "Played" $ DM.fromList [("role",[PVText "Sam Baldwin"])]) + rels <- filterRelations (return . const True) + liftIO $ do + 2 @=? length rels + (fgp `elem` rels) @? "fgp not in list!" + (ssp `elem` rels) @? "ssp not in list!" + , testCase "Check runtime Model" $ + checkModel getModel + , testCase "Check saved Model" $ + checkModel (readModel =<< getHandles) + , testCase "Delete objects" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + _ <- createRelation' (GraphRelation Nothing th fg "Played" $ DM.fromList [("role",[PVText "Forrest Gump"])]) + ss <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Sleepless in Seattle"]),("year",[PVInteger 1990])]) + _ <- createRelation' (GraphRelation Nothing th ss "Played" $ DM.fromList [("role",[PVText "Sam Baldwin"])]) + deleteObject $ goID th + objs <- filterObjects (return . const True) + rels <- filterRelations (return . const True) + liftIO $ do + 2 @=? length objs + (th `notElem` objs) @? "th in list!" + 0 @=? length rels + , testCase "Delete relations" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + fgp <- createRelation' (GraphRelation Nothing th fg "Played" $ DM.fromList [("role",[PVText "Forrest Gump"])]) + ss <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Sleepless in Seattle"]),("year",[PVInteger 1990])]) + ssp <- createRelation' (GraphRelation Nothing th ss "Played" $ DM.fromList [("role",[PVText "Sam Baldwin"])]) + deleteRelation $ grID ssp + qs1 <- queryStep (goID th) def + let sr1_1 = StepResult (grID fgp) OUT "Played" (DM.fromList [("role",[PVText "Forrest Gump"])]) fg + qs2 <- queryStep (goID th) def{rsDirection = IN} + qs3 <- queryStep (goID ss) def{rsDirection = IN} + qs4 <- queryStep (goID fg) def + qs5 <- queryStep (goID fg) def{rsDirection = IN} + let sr5_1 = StepResult (grID fgp) IN "Played" (DM.fromList [("role",[PVText "Forrest Gump"])]) th + deleteRelation $ grID fgp + qs6 <- queryStep (goID th) def + qs7 <- queryStep (goID fg) def{rsDirection = IN} + fgp2 <- createRelation' (GraphRelation Nothing th fg "Played" $ DM.fromList [("role",[PVText "Forrest Gump"])]) + ssp2 <- createRelation' (GraphRelation Nothing th ss "Played" $ DM.fromList [("role",[PVText "Sam Baldwin"])]) + deleteRelation $ grID fgp2 + qs8 <- queryStep (goID th) def + let sr8_1 = StepResult (grID ssp2) OUT "Played" (DM.fromList [("role",[PVText "Sam Baldwin"])]) ss + + liftIO $ do + 1 @=? length qs1 + (sr1_1 `elem` qs1) @? "sr1_1 not in out list!" + 0 @=? length qs2 + 0 @=? length qs3 + 0 @=? length qs4 + 1 @=? length qs5 + (sr5_1 `elem` qs5) @? "sr5_1 not in in list!" + 0 @=? length qs6 + 0 @=? length qs7 + 1 @=? length qs8 + (sr8_1 `elem` qs8) @? "sr8_1 not in in list!" + , testCase "Delete objects recovers id" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + deleteObject $ goID th + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + liftIO $ + goID th @=? goID fg + , testCase "Edit objects" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + let nProps= DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 61]),("hair",[PVText "curly"])] + th2 <- updateObject th{goProperties=nProps} + th3 <- getObject $ goID th2 + let nProps2= DM.fromList [("name",[PVText "Tom Hanks"]),("hair",[PVText "curly"])] + th4 <- updateObject th3{goProperties=nProps2} + th5 <- getObject $ goID th3 + liftIO $ do + goID th @=? goID th2 + goID th @=? goID th3 + nProps @=? goProperties th3 + goID th @=? goID th4 + goID th @=? goID th5 + nProps2 @=? goProperties th5 + , testCase "Indexing one object" $ + withTempDB $ do + tr<-addIndex $ IndexInfo "LastName" ["Actor"] ["lastName"] + allIdx0 <- liftIO $ prefix [] tr + th0 <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("firstName",[PVText "Tom"]),("lastName",[PVText "Hanks"])]) + allIdx1 <- liftIO $ prefix [] tr + _ <- updateObject (GraphObject (goID th0) "Actor" $ DM.fromList [("firstName",[PVText "Tom"]),("lastName",[PVText "Cruise"])]) + allIdx2 <- liftIO $ prefix [] tr + deleteObject $ goID th0 + allIdx3 <- liftIO $ prefix [] tr + liftIO $ do + allIdx0 @?= [] + allIdx1 @?= [(textToKey "Hanks",goID th0)] + allIdx2 @?= [(textToKey "Cruise",goID th0)] + allIdx3 @?= [] + , testCase "Indexing two objects" $ + withTempDB $ do + tr<-addIndex $ IndexInfo "LastName" ["Actor"] ["lastName"] + allIdx0 <- liftIO $ prefix [] tr + th0 <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("firstName",[PVText "Tom"]),("lastName",[PVText "Hanks"])]) + allIdx1 <- liftIO $ prefix [] tr + th1 <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("firstName",[PVText "Tom"]),("lastName",[PVText "Cruise"])]) + allIdx2 <- liftIO $ prefix [] tr + deleteObject $ goID th0 + allIdx3 <- liftIO $ prefix [] tr + liftIO $ do + allIdx0 @?= [] + allIdx1 @?= [(textToKey "Hanks",goID th0)] + allIdx2 @?= [(textToKey "Hanks",goID th0),(textToKey "Cruise",goID th1)] + allIdx3 @?= [(textToKey "Cruise",goID th1)] + , testCase "Create index after objects" $ + withTempDB $ do + th0 <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("firstName",[PVText "Tom"]),("lastName",[PVText "Hanks"])]) + th1 <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("firstName",[PVText "Tom"]),("lastName",[PVText "Cruise"])]) + tr<-addIndex $ IndexInfo "LastName" ["Actor"] ["lastName"] + allIdx0 <- liftIO $ prefix [] tr + liftIO $ + allIdx0 @?= [(textToKey "Hanks",goID th0),(textToKey "Cruise",goID th1)] + , testCase "Index persistence" $ do + let ii = IndexInfo "LastName" ["Actor"] ["lastName"] + dir <- withTempDB $ do + _<- addIndex ii + getDirectory + runStderrLoggingT $ withGraphStorage dir def $ do + idxs <- getIndices + liftIO $ + [ii] @=? map fst idxs + ] + +checkModel :: GraphStorageT + (R.ResourceT + (LoggingT IO)) + Model + -> IO () +checkModel r = + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + _ <- createRelation' (GraphRelation Nothing th fg "Played" $ DM.fromList [("role",[PVText "Forrest Gump"])]) + mdl2 <- r + let propL k = DM.lookup k $ fromName $ mPropertyTypes mdl2 + let typeL k = DM.lookup k $ fromName $ mObjectTypes mdl2 + let relL k = DM.lookup k $ fromName $ mRelationTypes mdl2 + liftIO $ do + isJust (propL ("name",DTText)) @? "no name property type!" + isJust (propL ("age",DTInteger)) @? "no age property type!" + isJust (propL ("year",DTInteger)) @? "no year property type!" + isJust (propL ("role",DTText)) @? "no role property type!" + isJust (typeL "Actor") @? "no actor object type!" + isJust (typeL "Movie") @? "no movie object type!" + isJust (relL "Played") @? "no played relation type!" + diff --git a/test/Database/Graph/HGraphStorage/FreeListTest.hs b/test/Database/Graph/HGraphStorage/FreeListTest.hs new file mode 100644 --- /dev/null +++ b/test/Database/Graph/HGraphStorage/FreeListTest.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Database.Graph.HGraphStorage.FreeListTest where + +import Database.Graph.HGraphStorage.FreeList +import Database.Graph.HGraphStorage.Utils + +import Data.Int +import System.IO + +import Test.Tasty +import Test.Tasty.HUnit + +freeListTests :: TestTree +freeListTests = testGroup "Free List tests" + [ testCase "Free List ending empty" $ + withTempFile $ \f -> do + h <- openBinaryFile f ReadWriteMode + (fl::FreeList Int8) <- initFreeList 1 h (return ()) + m1 <- getFromFreeList fl + m1 @?= Nothing + addToFreeList 3 fl + m2 <- getFromFreeList fl + m2 @?= Just 3 + addToFreeList 4 fl + addToFreeList 5 fl + m3 <- getFromFreeList fl + m3 @?= Just 5 + m4 <- getFromFreeList fl + m4 @?= Just 4 + m5 <- getFromFreeList fl + m5 @?= Nothing + hasData <- closeFreeList fl + not hasData @? "has data at end" + , testCase "Free List ending with data" $ + withTempFile $ \f -> do + h <- openBinaryFile f ReadWriteMode + (fl::FreeList Int8) <- initFreeList 1 h (return ()) + m1 <- getFromFreeList fl + m1 @?= Nothing + addToFreeList 3 fl + hasData <- closeFreeList fl + hasData @? "has no data at end" + ] diff --git a/test/Database/Graph/HGraphStorage/IndexTest.hs b/test/Database/Graph/HGraphStorage/IndexTest.hs new file mode 100644 --- /dev/null +++ b/test/Database/Graph/HGraphStorage/IndexTest.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +-- | Test index +module Database.Graph.HGraphStorage.IndexTest where + +import Database.Graph.HGraphStorage.Index as GI +import Database.Graph.HGraphStorage.Utils + +import Data.Int +import System.IO + +import qualified Data.Text as T + +import Test.Tasty +import Test.Tasty.HUnit + +indexTests :: TestTree +indexTests = testGroup "Index tests" + [ testCase "Trie test" $ + withTempFile $ \f -> do + h <- openBinaryFile f ReadWriteMode + let tr :: (Trie Int16 Int16) = newTrie h + equalsM Nothing $ GI.lookup (toInt16 "A") tr + equalsM Nothing $ GI.lookup (toInt16 "to") tr + equalsM Nothing $ insertNew (toInt16 "A") 15 tr + equalsM (Just 15) $ GI.lookup (toInt16 "A") tr + equalsM Nothing $ GI.lookup (toInt16 "to") tr + equalsM Nothing $ insertNew (toInt16 "tea") 3 tr + equalsM (Just 3) $ GI.lookup (toInt16 "tea") tr + -- insert another value: ignored + equalsM (Just 15) $ insertNew (toInt16 "A") 16 tr + equalsM (Just 15) $ GI.lookup (toInt16 "A") tr + equalsM Nothing $ GI.lookup (toInt16 "to") tr + equalsM (Just 3) $ insertNew (toInt16 "tea") 3 tr + equalsM (Just 15) $ GI.lookup (toInt16 "A") tr + equalsM Nothing $ GI.lookup (toInt16 "to") tr + equalsM (Just 3) $ GI.lookup (toInt16 "tea") tr + equalsM Nothing $ insertNew (toInt16 "ted") 4 tr + equalsM Nothing $ insertNew (toInt16 "ten") 12 tr + equalsM Nothing $ insertNew (toInt16 "to") 7 tr + equalsM Nothing $ insertNew (toInt16 "in") 5 tr + equalsM Nothing $ insert (toInt16 "inn") 9 tr + equalsM Nothing $ insert (toInt16 "i") 11 tr + equalsM (Just 15) $ GI.lookup (toInt16 "A") tr + equalsM (Just 3) $ GI.lookup (toInt16 "tea") tr + equalsM (Just 4) $ GI.lookup (toInt16 "ted") tr + equalsM (Just 12) $ GI.lookup (toInt16 "ten") tr + equalsM (Just 7) $ GI.lookup (toInt16 "to") tr + equalsM (Just 5) $ GI.lookup (toInt16 "in") tr + equalsM (Just 9) $ GI.lookup (toInt16 "inn") tr + equalsM (Just 11) $ GI.lookup (toInt16 "i") tr + equalsM Nothing $ GI.lookup (toInt16 "none") tr + equalsM Nothing $ GI.lookup (toInt16 "t") tr + equalsM Nothing $ GI.lookup (toInt16 "te") tr + -- insert and override + equalsM (Just 15) $ insert (toInt16 "A") 16 tr + equalsM (Just 16) $ GI.lookup (toInt16 "A") tr + -- delete + equalsM (Just 5) $ GI.delete (toInt16 "in") tr + equalsM Nothing $ GI.lookup (toInt16 "in") tr + equalsM (Just 9) $ GI.lookup (toInt16 "inn") tr + equalsM (Just 11) $ GI.lookup (toInt16 "i") tr + hClose h + , testCase "Collision test" $ + withTempFile $ \f -> do + tr :: (Trie Int16 Int32) <- newFileTrie f + equalsM Nothing $ insert (toInt16 "3d-graphics-examples") 1 tr + equalsM (Just 1) $ GI.lookup (toInt16 "3d-graphics-examples") tr + equalsM Nothing $ GI.lookup (toInt16 "ace") tr + equalsM Nothing $ GI.lookup (toInt16 "ac-machine") tr + equalsM Nothing $ insertNew (toInt16 "ac-machine") 945 tr + equalsM Nothing $ insertNew (toInt16 "ac-machine-conduit") 946 tr + equalsM (Just 945) $ GI.lookup (toInt16 "ac-machine") tr + equalsM Nothing $ insertNew (toInt16 "accelerate-fourier-benchmark") 956 tr + equalsM Nothing $ insertNew (toInt16 "ace") 961 tr + equalsM (Just 961) $ GI.lookup (toInt16 "ace") tr + equalsM (Just 945) $ GI.lookup (toInt16 "ac-machine") tr + hClose $ trHandle tr + , testCase "Prefix test" $ + withTempFile $ \f -> do + h <- openBinaryFile f ReadWriteMode + let tr :: (Trie Int16 Int16) = newTrie h + equalsM Nothing $ insertNew (toInt16 "A") 15 tr + equalsM Nothing $ insertNew (toInt16 "tea") 3 tr + equalsM Nothing $ insertNew (toInt16 "ted") 4 tr + equalsM Nothing $ insertNew (toInt16 "to") 7 tr + equalsM [] $ prefix (toInt16 "AB") tr + equalsM [((toInt16 "tea"),3)] $ prefix (toInt16 "tea") tr + equalsM [((toInt16 "tea"),3),((toInt16 "ted"),4)] $ prefix (toInt16 "te") tr + equalsM [((toInt16 "tea"),3),((toInt16 "ted"),4),((toInt16 "to"),7)] $ prefix (toInt16 "t") tr + equalsM [((toInt16 "A"),15),((toInt16 "tea"),3),((toInt16 "ted"),4),((toInt16 "to"),7)] $ prefix [] tr + ] + + +-- | equals assertion in the monad +equalsM :: (Show a, Eq a) => + a -> IO a -> IO () +equalsM a f = (a @=?) =<< f + + +-- | Convert a string to an array of int16 +toInt16 :: T.Text -> [Int16] +toInt16 = map (fromIntegral . fromEnum) . T.unpack diff --git a/test/Database/Graph/HGraphStorage/QueryTest.hs b/test/Database/Graph/HGraphStorage/QueryTest.hs new file mode 100644 --- /dev/null +++ b/test/Database/Graph/HGraphStorage/QueryTest.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Test queries +module Database.Graph.HGraphStorage.QueryTest where + +import Database.Graph.HGraphStorage.API +import Database.Graph.HGraphStorage.Query +import Database.Graph.HGraphStorage.Utils +import Database.Graph.HGraphStorage.Types + +import qualified Data.Map as DM + +import Test.Tasty +import Test.Tasty.HUnit +import Data.Default (def) +import Control.Monad.IO.Class (liftIO) + +queryTests :: TestTree +queryTests = testGroup "Query tests" + [ testCase "Single Step" $ + withTempDB $ do + th <- createObject (GraphObject Nothing "Actor" $ DM.fromList [("name",[PVText "Tom Hanks"]),("age",[PVInteger 60])]) + fg <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Forrest Gump"]),("year",[PVInteger 1990])]) + fgp <- createRelation' (GraphRelation Nothing th fg "Played" $ DM.fromList [("role",[PVText "Forrest Gump"])]) + ss <- createObject (GraphObject Nothing "Movie" $ DM.fromList [("name",[PVText "Sleepless in Seattle"]),("year",[PVInteger 1990])]) + ssp <- createRelation' (GraphRelation Nothing th ss "Played" $ DM.fromList [("role",[PVText "Sam Baldwin"])]) + qs1 <- queryStep (goID th) def + let sr1_1 = StepResult (grID fgp) OUT "Played" (DM.fromList [("role",[PVText "Forrest Gump"])]) fg + let sr1_2 = StepResult (grID ssp) OUT "Played" (DM.fromList [("role",[PVText "Sam Baldwin"])]) ss + qs2 <- queryStep (goID th) def{rsDirection = IN} + qs3 <- queryStep (goID th) def{rsDirection = BOTH} + qs4 <- queryStep (goID fg) def + qs5 <- queryStep (goID fg) def{rsDirection = IN} + let sr5_1 = StepResult (grID fgp) IN "Played" (DM.fromList [("role",[PVText "Forrest Gump"])]) th + qs6 <- queryStep (goID fg) def{rsDirection = BOTH} + qs7 <- queryStep (goID th) def{rsLimit = Just 1} + liftIO $ do + 2 @=? length qs1 + (sr1_1 `elem` qs1) @? "sr1_1 not in out list!" + (sr1_2 `elem` qs1) @? "sr1_2 not in out list!" + 0 @=? length qs2 + 2 @=? length qs3 + (sr1_1 `elem` qs3) @? "sr1_1 not in both list!" + (sr1_2 `elem` qs3) @? "sr1_2 not in both list!" + 0 @=? length qs4 + 1 @=? length qs5 + (sr5_1 `elem` qs5) @? "sr5_1 not in in list!" + 1 @=? length qs6 + (sr5_1 `elem` qs6) @? "r5_1 not in both list!" + 1 @=? length qs7 + (sr1_2 `elem` qs7) @? "sr1_1 not in out limited list!" + + ] diff --git a/test/Database/Graph/HGraphStorage/Utils.hs b/test/Database/Graph/HGraphStorage/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Database/Graph/HGraphStorage/Utils.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes #-} +-- | test utilities +module Database.Graph.HGraphStorage.Utils where + + +import Database.Graph.HGraphStorage.API +import System.Directory +import System.FilePath +import Control.Monad (when, filterM) +import qualified Control.Monad.Trans.Resource as R + +import Control.Monad.Logger +import Data.Default (def) + +withTempDB :: forall b. + GraphStorageT (R.ResourceT (LoggingT IO)) b + -> IO b +withTempDB f = do + tmp <- getTemporaryDirectory + let dir = tmp "graph-test" + ex <- doesDirectoryExist dir + when ex $ do + cnts <- getDirectoryContents dir + mapM_ removeFile =<< filterM doesFileExist (map (dir ) cnts) + runStderrLoggingT $ withGraphStorage dir def f + +withTempFile :: (FilePath -> IO b) + -> IO b +withTempFile func = do + tmp <- getTemporaryDirectory + let f = tmp "graph-test.tmp" + ex <- doesFileExist f + when ex $ removeFile f + b<-func f + ex2 <- doesFileExist f + when ex2 $ removeFile f + return b diff --git a/test/hgraphstorage-test.hs b/test/hgraphstorage-test.hs new file mode 100644 --- /dev/null +++ b/test/hgraphstorage-test.hs @@ -0,0 +1,14 @@ +module Main where +import Database.Graph.HGraphStorage.APITest +import Database.Graph.HGraphStorage.FreeListTest +import Database.Graph.HGraphStorage.QueryTest +import Database.Graph.HGraphStorage.IndexTest + +import Test.Tasty + + +main :: IO() +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Graph Storage Tests" [freeListTests, indexTests, apiTests,queryTests]