├── .travis.yml ├── LICENSE ├── README.md ├── executables ├── APITests.hs ├── APITests │ ├── Catalogue.hs │ ├── Prelude.hs │ └── Util │ │ └── FileSystem.hs ├── Benchmarks │ ├── AcidState.hs │ ├── AcidState │ │ └── AcidStatePlus.hs │ ├── GraphDB.hs │ ├── Model.hs │ ├── Postgres.hs │ ├── Postgres │ │ └── PostgreSQLSimplePlus.hs │ ├── Prelude.hs │ ├── Random.hs │ └── Util │ │ └── FileSystem.hs ├── CompetitionBench.hs ├── Demo.hs ├── InternalTests.hs ├── InternalTests │ ├── GraphTests.hs │ ├── MacrosTests.hs │ ├── StorageTests.hs │ └── THTests.hs └── NonpersistentBench.hs ├── graph-db.cabal └── library ├── GraphDB.hs └── GraphDB ├── Action.hs ├── Client.hs ├── Graph.hs ├── Macros.hs ├── Macros ├── Analysis.hs └── Templates.hs ├── Model.hs ├── Nonpersistent.hs ├── Persistent.hs ├── Persistent └── Log.hs ├── Protocol.hs ├── Server.hs ├── Storage.hs ├── Storage └── Rules.hs └── Util ├── DIOVector.hs ├── FileSystem.hs ├── IOQueue.hs ├── Prelude.hs ├── Prelude └── TH.hs ├── TH.hs └── TH ├── Parsers.hs ├── Q.hs └── Type.hs /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 7.6 5 | - 7.8 6 | 7 | install: 8 | - cabal install happy # haskell-src-exts implicit dependency workaround 9 | - cabal install --only-dependencies 10 | --enable-tests 11 | --enable-benchmarks 12 | --reorder-goals 13 | --force-reinstalls 14 | 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Nikita Volkov 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # GraphDB. A native graph database for Haskell 2 | 3 | This library provides a mutable in-memory graph datastructure with complete ACID guarantees, a persistence layer, a server and a client. 4 | 5 | ## Project Status 6 | 7 | Unreleased and currently on hold. 8 | 9 | The project is compilable and the demos and tests execute fine, so you can get a feeling of what it's about. 10 | 11 | --- 12 | 13 | [![Build Status](https://travis-ci.org/nikita-volkov/graph-db.png?branch=master)](https://travis-ci.org/nikita-volkov/graph-db) 14 | -------------------------------------------------------------------------------- /executables/APITests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | 3 | import Test.Framework 4 | import Test.QuickCheck.Monadic 5 | import APITests.Prelude hiding (traceIO, traceIOWithTime, assert) 6 | import qualified APITests.Prelude as Prelude 7 | import qualified APITests.Util.FileSystem as FS 8 | import qualified GraphDB as G 9 | import APITests.Catalogue 10 | 11 | 12 | main = htfMain $ htf_thisModulesTests 13 | 14 | 15 | -- Debugging 16 | ------------------------- 17 | -- The following functions get enabled during debugging. 18 | 19 | debugging = True 20 | prefix = id 21 | traceIO = if debugging 22 | then Prelude.traceIO . prefix 23 | else const $ return () 24 | traceIOWithTime = if debugging 25 | then Prelude.traceIOWithTime . prefix 26 | else const $ return () 27 | 28 | 29 | -- Tests 30 | ------------------------- 31 | 32 | test_clientServer = do 33 | assertEqual [Identified 1 (Artist "The Beatles")] =<< do 34 | runNonpersistentSession $ do 35 | serve $ runClientSession $ do 36 | G.write $ insertArtist $ Artist "The Beatles" 37 | G.read $ 38 | G.getRoot >>= 39 | flip G.getTargets (Catalogue_Artist_Name "The Beatles") >>= 40 | mapM G.getValue 41 | where 42 | runNonpersistentSession = G.runNonpersistentSession initRoot 43 | serve = G.serve (1, lm, to, mc, log) where 44 | lm = G.ListeningMode_Host 54699 auth where 45 | auth = const $ return True 46 | to = 10^6 47 | mc = 100 48 | log = traceIOWithTime . ("Server: " <>) . unpackText 49 | runClientSession = G.runClientSession (1, url) where 50 | url = G.URL_Host "127.0.0.1" 54699 Nothing 51 | 52 | prop_shutdownDBRestoresToTheSameState = monadicIO $ do 53 | run $ initDir 54 | updates <- pick $ do 55 | amount <- choose (0, 100) 56 | replicateM amount (arbitrary :: Gen (Update G.PersistentSession t)) 57 | stats <- 58 | fmap (either (error . show) id) $ 59 | run $ runPersistentSession $ do 60 | forM_ updates $ \(Update write) -> G.write $ unsafeCoerce $ write 61 | G.read G.getStats 62 | stats' <- 63 | fmap (either (error . show) id) $ 64 | run $ runPersistentSession $ G.read G.getStats 65 | run $ traceIOWithTime $ 66 | "Stats 1: " <> show stats <> ", stats 2: " <> show stats' <> ", " <> 67 | "updates: " <> show (length updates) 68 | assert $ stats == stats' 69 | 70 | -- prop_interruptedDBRestoresToTheSameState = undefined 71 | 72 | 73 | -- * Setup 74 | ------------------------- 75 | 76 | runPersistentSession :: 77 | (MonadBaseControl IO m, MonadIO m) => 78 | G.PersistentSession Catalogue m r -> m (Either G.PersistenceFailure r) 79 | runPersistentSession = G.runPersistentSession (initRoot, dir, buffering) where 80 | buffering = 100 81 | 82 | runNonpersistentSession :: 83 | (MonadIO m) => G.NonpersistentSession Catalogue m r -> m r 84 | runNonpersistentSession = G.runNonpersistentSession initRoot 85 | 86 | serve socket = G.serve (1, lm, to, mc, log) where 87 | lm = if socket 88 | then G.ListeningMode_Socket socketPath 89 | else G.ListeningMode_Host 54699 auth 90 | where 91 | auth = const $ return True 92 | to = 10^6 93 | mc = 100 94 | log = const $ return () 95 | 96 | runClientSession socket = G.runClientSession (1, url) where 97 | url = if socket 98 | then G.URL_Socket socketPath 99 | else G.URL_Host "127.0.0.1" 54699 Nothing 100 | 101 | initDir :: IO () 102 | initDir = do 103 | FS.removeIfExists dir 104 | FS.createTree dir 105 | 106 | socketPath = dir <> ".socket" 107 | dir = "./dist/test/graph-db" 108 | -------------------------------------------------------------------------------- /executables/APITests/Catalogue.hs: -------------------------------------------------------------------------------- 1 | module APITests.Catalogue where 2 | 3 | import APITests.Prelude 4 | import Control.Lens 5 | import qualified GraphDB as G 6 | import qualified Test.QuickCheck as Q hiding (oneof, listOf, elements, choose) 7 | import qualified QuickCheck.GenT as Q 8 | import qualified Data.Vector as V 9 | import Test.QuickCheck.Instances () 10 | 11 | 12 | 13 | -- * Model 14 | ------------------------- 15 | 16 | -- | 17 | -- The root node. 18 | -- For convenience it stores the counters of UID generators. 19 | type Catalogue = (UID Artist, UID Genre, UID Song) 20 | newtype UID a = UID Int deriving (Show, Eq, Ord, Generic, Data, Typeable, Enum, Num, Real, Integral) 21 | data Artist = Artist Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 22 | data Genre = Genre Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 23 | data Song = Song Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 24 | type Name = Text 25 | data Identified a = Identified {-# UNPACK #-} !(UID a) !a deriving (Show, Eq, Ord, Generic, Data, Typeable) 26 | 27 | initRoot :: Catalogue = (0, 0, 0) 28 | 29 | instance Functor Identified where 30 | fmap f (Identified (UID n) a) = Identified (UID n) (f a) 31 | 32 | 33 | -- * Edges 34 | ------------------------- 35 | 36 | instance G.Edge Catalogue (Identified Artist) where 37 | data Index Catalogue (Identified Artist) = 38 | Catalogue_Artist_UID (UID Artist) | 39 | Catalogue_Artist_Name Text | 40 | Catalogue_Artist 41 | deriving (Eq, Generic) 42 | indexes (Identified uid (Artist n)) = 43 | [Catalogue_Artist_UID uid, Catalogue_Artist_Name n, Catalogue_Artist] 44 | 45 | instance G.Edge Catalogue (Identified Genre) where 46 | data Index Catalogue (Identified Genre) = 47 | Catalogue_Genre_UID (UID Genre) | 48 | Catalogue_Genre_Name Text | 49 | Catalogue_Genre 50 | deriving (Eq, Generic) 51 | indexes (Identified uid (Genre n)) = 52 | [Catalogue_Genre_UID uid, Catalogue_Genre_Name n, Catalogue_Genre] 53 | 54 | instance G.Edge Catalogue (Identified Song) where 55 | data Index Catalogue (Identified Song) = 56 | Catalogue_Song_UID (UID Song) | 57 | Catalogue_Song_Name Text | 58 | Catalogue_Song 59 | deriving (Eq, Generic) 60 | indexes (Identified uid (Song n)) = 61 | [Catalogue_Song_UID uid, Catalogue_Song_Name n, Catalogue_Song] 62 | 63 | instance G.Edge (Identified Genre) (Identified Song) where 64 | data Index (Identified Genre) (Identified Song) = 65 | Genre_Song 66 | deriving (Eq, Generic) 67 | indexes _ = [Genre_Song] 68 | 69 | instance G.Edge (Identified Song) (Identified Artist) where 70 | data Index (Identified Song) (Identified Artist) = 71 | Song_Artist 72 | deriving (Eq, Generic) 73 | indexes _ = [Song_Artist] 74 | 75 | 76 | -- * Default Transactions 77 | ------------------------- 78 | 79 | lookupArtistByUID :: UID Artist -> G.Read s Catalogue t (Maybe (Identified Artist)) 80 | lookupArtistByUID uid = 81 | G.getRoot >>= flip G.getTargets (Catalogue_Artist_UID uid) >>= 82 | return . listToMaybe >>= mapM G.getValue 83 | 84 | lookupArtistsByName :: Text -> G.Read s Catalogue t [Identified Artist] 85 | lookupArtistsByName n = 86 | G.getRoot >>= flip G.getTargets (Catalogue_Artist_Name n) >>= mapM G.getValue 87 | 88 | lookupArtistsBySongGenreName :: Text -> G.Read s Catalogue t [Identified Artist] 89 | lookupArtistsBySongGenreName n = 90 | G.getRoot >>= 91 | flip G.getTargets (Catalogue_Genre_Name n) >>= 92 | mapM (flip G.getTargets Genre_Song) >>= 93 | return . concat >>= 94 | mapM (flip G.getTargets Song_Artist) >>= 95 | return . concat >>= 96 | mapM G.getValue 97 | 98 | insertArtist :: Artist -> G.Write s Catalogue t (UID Artist) 99 | insertArtist value = do 100 | root <- G.getRoot 101 | uid <- updateNode root $ zoom _1 $ modify succ >> get 102 | node <- G.newNode (Identified uid value) 103 | G.addTarget root node 104 | return uid 105 | 106 | insertGenre :: Genre -> G.Write s Catalogue t (UID Genre) 107 | insertGenre value = do 108 | root <- G.getRoot 109 | uid <- updateNode root $ zoom _2 $ modify succ >> get 110 | node <- G.newNode (Identified uid value) 111 | G.addTarget root node 112 | return uid 113 | 114 | insertSong :: Song -> [UID Genre] -> [UID Artist] -> G.Write s Catalogue t (UID Song) 115 | insertSong value genreUIDs artistUIDs = do 116 | root <- G.getRoot 117 | uid <- updateNode root $ zoom _3 $ modify succ >> get 118 | node <- G.newNode (Identified uid value) 119 | forM_ genreUIDs $ \uid -> do 120 | genres <- G.getTargets root (Catalogue_Genre_UID uid) 121 | forM_ genres $ \genre -> do 122 | G.addTarget genre node 123 | forM_ artistUIDs $ \uid -> do 124 | artists <- G.getTargets root (Catalogue_Artist_UID uid) 125 | forM_ artists $ \artist -> do 126 | G.addTarget node artist 127 | return uid 128 | 129 | generateUID :: Lens' Catalogue (UID a) -> G.Write s Catalogue t (UID a) 130 | generateUID selector = do 131 | root <- G.getRoot 132 | updateNode root $ zoom selector $ modify succ >> get 133 | 134 | updateNode :: 135 | (G.PolyValue Catalogue v) => 136 | G.Node s Catalogue t v -> State v r -> G.Write s Catalogue t r 137 | updateNode n u = G.getValue n >>= return . runState u >>= \(r, v') -> G.setValue n v' >> return r 138 | 139 | 140 | -- * QuickCheck 141 | ------------------------- 142 | 143 | newtype Update s t = Update (G.Write s Catalogue t ()) 144 | 145 | instance Show (Update s t) where 146 | show _ = "Update" 147 | 148 | instance Q.Arbitrary (Update s t) where 149 | arbitrary = fmap Update $ Q.runGenT $ Q.oneof $ 150 | replicate 200 insertSomeArtist ++ 151 | replicate 2000 insertSomeSong ++ 152 | replicate 30 insertSomeGenre ++ 153 | replicate 10 removeSomeArtist ++ 154 | replicate 100 removeSomeSong ++ 155 | replicate 1 removeSomeGenre 156 | where 157 | insertSomeArtist = do 158 | name <- Q.liftGen $ Q.arbitrary 159 | lift $ void $ insertArtist $ Artist name 160 | insertSomeGenre = do 161 | songs <- chooseSomeSongs 162 | name <- Q.liftGen $ Q.arbitrary 163 | lift $ do 164 | root <- G.getRoot 165 | uid <- generateUID _2 166 | genre <- G.newNode $ Identified uid $ Genre name 167 | G.addTarget root genre 168 | forM_ songs $ \song -> do 169 | G.addTarget genre song 170 | where 171 | chooseSomeSongs = do 172 | list <- lift $ G.getRoot >>= flip G.getTargets Catalogue_Song 173 | let vec = V.fromList list 174 | length = V.length vec 175 | amount <- if length > 0 176 | then Q.choose (0, div length 10) 177 | else return 0 178 | replicateM amount $ Q.choose (0, length - 1) >>= return . V.unsafeIndex vec 179 | insertSomeSong = do 180 | artists <- chooseSomeArtists 181 | name <- Q.liftGen $ Q.arbitrary 182 | lift $ do 183 | root <- G.getRoot 184 | uid <- generateUID _3 185 | song <- G.newNode $ Identified uid $ Song name 186 | G.addTarget root song 187 | forM_ artists $ \artist -> do 188 | G.addTarget song artist 189 | where 190 | chooseSomeArtists = do 191 | list <- lift $ G.getRoot >>= flip G.getTargets Catalogue_Artist 192 | let vec = V.fromList list 193 | length = V.length vec 194 | amount <- if length > 0 195 | then Q.elements $ replicate 100 1 ++ replicate 10 2 ++ replicate 2 3 196 | else return 0 197 | replicateM amount $ Q.choose (0, length - 1) >>= return . V.unsafeIndex vec 198 | removeSomeArtist = do 199 | root <- lift $ G.getRoot 200 | all <- lift $ G.getTargets root Catalogue_Artist 201 | mapM_ (lift . G.remove) =<< Q.elementsMay all 202 | removeSomeSong = do 203 | root <- lift $ G.getRoot 204 | all <- lift $ G.getTargets root Catalogue_Song 205 | mapM_ (lift . G.remove) =<< Q.elementsMay all 206 | removeSomeGenre = do 207 | root <- lift $ G.getRoot 208 | all <- lift $ G.getTargets root Catalogue_Genre 209 | mapM_ (lift . G.remove) =<< Q.elementsMay all 210 | 211 | 212 | -- * Boilerplate 213 | ------------------------- 214 | 215 | G.deriveSetup ''Catalogue 216 | instance (Hashable a) => Hashable (UID a) 217 | instance (Serializable m a) => Serializable m (UID a) 218 | 219 | 220 | -------------------------------------------------------------------------------- /executables/APITests/Prelude.hs: -------------------------------------------------------------------------------- 1 | module APITests.Prelude 2 | ( 3 | module Exports, 4 | 5 | LazyByteString, 6 | LazyText, 7 | 8 | traceM, 9 | traceIO, 10 | traceIOWithTime, 11 | packText, 12 | unpackText, 13 | bug, 14 | (|>), 15 | (<|), 16 | (|$>), 17 | bracketME, 18 | finallyME, 19 | tracingExceptions, 20 | ) 21 | where 22 | 23 | -- base 24 | import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.)) 25 | import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 26 | import Control.Applicative as Exports 27 | import Control.Arrow as Exports hiding (left, right) 28 | import Control.Category as Exports 29 | import Data.Monoid as Exports 30 | import Data.Foldable as Exports 31 | import Data.Traversable as Exports hiding (for) 32 | import Data.Maybe as Exports 33 | import Data.Either as Exports 34 | import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') 35 | import Data.Tuple as Exports 36 | import Data.Ord as Exports (Down(..)) 37 | import Data.String as Exports 38 | import Data.Int as Exports 39 | import Data.Word as Exports 40 | import Data.Ratio as Exports 41 | import Data.Fixed as Exports 42 | import Data.Ix as Exports 43 | import Data.Data as Exports 44 | import Text.Read as Exports (readMaybe, readEither) 45 | import Control.Exception as Exports hiding (tryJust, assert) 46 | import Control.Concurrent as Exports hiding (yield) 47 | import System.Mem.StableName as Exports 48 | import System.Timeout as Exports 49 | import System.Exit as Exports 50 | import System.IO.Unsafe as Exports 51 | import System.IO as Exports (Handle, hClose) 52 | import System.IO.Error as Exports 53 | import Unsafe.Coerce as Exports 54 | import GHC.Exts as Exports hiding (Any, traceEvent, toList) 55 | import GHC.Generics as Exports (Generic) 56 | import GHC.IO.Exception as Exports 57 | import Data.IORef as Exports 58 | import Data.STRef as Exports 59 | import Control.Monad.ST as Exports 60 | import Debug.Trace as Exports hiding (traceIO, traceM) 61 | 62 | -- mtl 63 | import Control.Monad.Identity as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 64 | import Control.Monad.State.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 65 | import Control.Monad.Reader as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 66 | import Control.Monad.Writer.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any) 67 | import Control.Monad.RWS.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any) 68 | import Control.Monad.Error as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 69 | import Control.Monad.Trans as Exports 70 | 71 | -- transformers-base 72 | import Control.Monad.Base as Exports 73 | 74 | -- monad-control 75 | import Control.Monad.Trans.Control as Exports 76 | 77 | -- lifted-async 78 | import Control.Concurrent.Async.Lifted as Exports 79 | 80 | -- bytestring 81 | import Data.ByteString as Exports (ByteString) 82 | 83 | -- text 84 | import Data.Text as Exports (Text) 85 | 86 | -- containers 87 | import Data.Map as Exports (Map) 88 | import Data.IntMap as Exports (IntMap) 89 | import Data.Set as Exports (Set) 90 | import Data.IntSet as Exports (IntSet) 91 | import Data.Sequence as Exports (Seq) 92 | import Data.Tree as Exports (Tree) 93 | 94 | -- hashable 95 | import Data.Hashable as Exports (Hashable(..), hash) 96 | 97 | -- time 98 | import Data.Time.Clock as Exports 99 | 100 | -- cereal-plus 101 | import CerealPlus.Serializable as Exports 102 | 103 | -- system-filepath 104 | import Filesystem.Path as Exports (FilePath) 105 | 106 | -- placeholders 107 | import Development.Placeholders as Exports 108 | 109 | import qualified Debug.Trace.LocationTH 110 | import qualified Data.ByteString.Lazy 111 | import qualified Data.Text.Lazy 112 | import qualified Data.Text 113 | import qualified Prelude 114 | import qualified Debug.Trace 115 | import qualified System.Locale 116 | import qualified Data.Time 117 | 118 | 119 | type LazyByteString = Data.ByteString.Lazy.ByteString 120 | type LazyText = Data.Text.Lazy.Text 121 | 122 | 123 | (|>) :: a -> (a -> b) -> b 124 | a |> aToB = aToB a 125 | {-# INLINE (|>) #-} 126 | 127 | (<|) :: (a -> b) -> a -> b 128 | aToB <| a = aToB a 129 | {-# INLINE (<|) #-} 130 | 131 | -- | 132 | -- The following are all the same: 133 | -- fmap f a == f <$> a == a |> fmap f == a |$> f 134 | -- 135 | -- This operator accomodates the left-to-right operators: >>=, >>>, |>. 136 | (|$>) = flip fmap 137 | {-# INLINE (|$>) #-} 138 | 139 | packText = Data.Text.pack 140 | unpackText = Data.Text.unpack 141 | 142 | bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] 143 | where 144 | msg = "A \"graph-db\" package bug: " :: String 145 | 146 | bottom = [e| $bug "Bottom evaluated" |] 147 | 148 | bracketME :: (MonadError e m) => m a -> (a -> m b) -> (a -> m c) -> m c 149 | bracketME acquire release apply = do 150 | r <- acquire 151 | z <- catchError (liftM Right $ apply r) (return . Left) 152 | release r 153 | either throwError return z 154 | 155 | finallyME :: (MonadError e m) => m a -> m b -> m a 156 | finallyME m f = do 157 | z <- catchError (liftM Right $ m) (return . Left) 158 | f 159 | either throwError return z 160 | 161 | traceM :: (Monad m) => String -> m () 162 | traceM s = trace s $ return () 163 | 164 | traceIO :: (MonadIO m) => String -> m () 165 | traceIO = liftIO . Debug.Trace.traceIO 166 | 167 | traceIOWithTime :: (MonadIO m) => String -> m () 168 | traceIOWithTime s = do 169 | time <- liftIO $ getCurrentTime 170 | traceIO $ 171 | formatTime time <> ": " <> s 172 | where 173 | formatTime = 174 | take 15 . 175 | Data.Time.formatTime System.Locale.defaultTimeLocale "%X.%q" 176 | 177 | tracingExceptions :: (MonadBaseControl IO m) => m a -> m a 178 | tracingExceptions m = 179 | control $ \runInIO -> catch (runInIO m) $ \(SomeException e) -> runInIO $ do 180 | let rep = typeOf e 181 | tyCon = typeRepTyCon rep 182 | traceM $ 183 | "## Uncaught exception: " ++ show e ++ "\n" ++ 184 | " Type: " ++ show rep ++ "\n" ++ 185 | " Module: " ++ tyConModule tyCon ++ "\n" ++ 186 | " Package: " ++ tyConPackage tyCon 187 | liftBase $ throwIO $ e 188 | 189 | -------------------------------------------------------------------------------- /executables/APITests/Util/FileSystem.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Utilities for dealing with 'FilePath'. 3 | -- 4 | module APITests.Util.FileSystem 5 | ( 6 | module Filesystem, 7 | module Filesystem.Path.CurrentOS, 8 | Status(..), 9 | getStatus, 10 | getExists, 11 | getTemporaryDirectory, 12 | remove, 13 | removeIfExists, 14 | removeTreeIfExists, 15 | move, 16 | copy, 17 | resolve, 18 | listFilesByExtension, 19 | ) 20 | where 21 | 22 | import APITests.Prelude hiding (stripPrefix, last) 23 | import Filesystem.Path.CurrentOS 24 | import Filesystem 25 | import qualified System.Directory as Directory 26 | import qualified Data.List as List 27 | import qualified System.IO.Error as IOError 28 | 29 | 30 | 31 | data Status = File | Directory | NotExists 32 | deriving (Show, Eq, Ord, Enum) 33 | 34 | getStatus :: FilePath -> IO Status 35 | getStatus path = do 36 | z <- isFile path 37 | if z 38 | then return File 39 | else do 40 | z <- isDirectory path 41 | if z 42 | then return Directory 43 | else return NotExists 44 | 45 | getExists :: FilePath -> IO Bool 46 | getExists path = getStatus path >>= return . (/= NotExists) 47 | 48 | getTemporaryDirectory :: IO FilePath 49 | getTemporaryDirectory = 50 | Directory.getTemporaryDirectory >>= return . decodeString 51 | 52 | remove :: FilePath -> IO () 53 | remove path = do 54 | status <- getStatus path 55 | case status of 56 | File -> removeFile path 57 | Directory -> removeTree path 58 | NotExists -> IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "" Nothing (Just $ encodeString path) 59 | 60 | removeIfExists :: FilePath -> IO () 61 | removeIfExists path = do 62 | status <- getStatus path 63 | case status of 64 | File -> removeFile path 65 | Directory -> removeTree path 66 | NotExists -> return () 67 | 68 | removeTreeIfExists :: FilePath -> IO () 69 | removeTreeIfExists path = removeTree path `catch` \e -> case e of 70 | _ | IOError.isDoesNotExistError e -> return () 71 | | otherwise -> throwIO e 72 | 73 | move :: FilePath -> FilePath -> IO () 74 | move from to = do 75 | copy from to 76 | remove from 77 | 78 | copy :: FilePath -> FilePath -> IO () 79 | copy from to = do 80 | isDir <- isDirectory from 81 | if isDir 82 | then do 83 | createTree to 84 | copyDirectory from to 85 | else do 86 | createTree $ directory to 87 | copyFile from to 88 | 89 | copyDirectory :: FilePath -> FilePath -> IO () 90 | copyDirectory path path' = do 91 | members <- listDirectory path 92 | let members' = do 93 | member <- members 94 | let relative = 95 | fromMaybe (error "Unexpectedly empty member path") $ 96 | last member 97 | return $ path' <> relative 98 | sequence_ $ zipWith copy members members' 99 | 100 | last :: FilePath -> Maybe FilePath 101 | last p = case splitDirectories p of 102 | [] -> Nothing 103 | l -> Just $ List.last l 104 | 105 | resolve :: FilePath -> IO FilePath 106 | resolve path = case splitDirectories path of 107 | h:t | h == "~" -> do 108 | home <- getHomeDirectory 109 | return $ mconcat $ home : t 110 | _ -> return path 111 | 112 | 113 | listFilesByExtension :: FilePath -> Text -> IO [FilePath] 114 | listFilesByExtension dir extension = 115 | listDirectory dir >>= 116 | return . filter (flip hasExtension extension) 117 | 118 | -------------------------------------------------------------------------------- /executables/Benchmarks/AcidState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module Benchmarks.AcidState where 3 | 4 | import Benchmarks.Prelude 5 | import Control.Lens 6 | import Benchmarks.Model 7 | import qualified Benchmarks.Util.FileSystem as Fil 8 | import qualified Data.IxSet as Ixs 9 | import qualified Data.SafeCopy as Saf 10 | import qualified Benchmarks.AcidState.AcidStatePlus as Aci 11 | 12 | -- * Model Extensions 13 | ------------------------- 14 | 15 | type Catalogue = 16 | ( 17 | IxSetWithUIDs Artist, 18 | IxSetWithUIDs Genre, 19 | IxSetWithUIDs Song 20 | ) 21 | 22 | -- | A basic extension of IxSet for support of UIDs. 23 | type IxSetWithUIDs a = (NextUID a, Ixs.IxSet (Row a)) 24 | type NextUID a = UID a 25 | 26 | data Row a = Row (UID a) a (Relations a) 27 | deriving instance (Show (Relations a), Show a) => Show (Row a) 28 | deriving instance (Eq (Relations a), Eq a) => Eq (Row a) 29 | deriving instance (Ord (Relations a), Ord a) => Ord (Row a) 30 | deriving instance (Generic (Relations a), Generic a) => Generic (Row a) 31 | deriving instance (Data (Relations a), Data a) => Data (Row a) 32 | deriving instance Typeable1 Row 33 | 34 | type family Relations a 35 | type instance Relations Artist = () 36 | type instance Relations Genre = ([UID Song]) 37 | type instance Relations Song = ([UID Artist]) 38 | 39 | 40 | -- * IxSet 41 | ------------------------- 42 | 43 | instance Ixs.Indexable (Row Artist) where 44 | empty = Ixs.ixSet 45 | [ 46 | Ixs.ixFun $ \(Row u (Artist n) _) -> [u], 47 | Ixs.ixFun $ \(Row u (Artist n) _) -> [n] 48 | ] 49 | 50 | instance Ixs.Indexable (Row Genre) where 51 | empty = Ixs.ixSet 52 | [ 53 | Ixs.ixFun $ \(Row u (Genre n) _) -> [u], 54 | Ixs.ixFun $ \(Row u (Genre n) _) -> [n] 55 | ] 56 | 57 | instance Ixs.Indexable (Row Song) where 58 | empty = Ixs.ixSet 59 | [ 60 | Ixs.ixFun $ \(Row u (Song n) _) -> [u], 61 | Ixs.ixFun $ \(Row u (Song n) _) -> [n] 62 | ] 63 | 64 | 65 | -- * SafeCopy 66 | ------------------------- 67 | 68 | instance (Saf.SafeCopy a, Saf.SafeCopy (Relations a)) => Saf.SafeCopy (Row a) where 69 | putCopy (Row arg_aadC arg_aadD arg_aadE) = Saf.contain $ do 70 | safePut_UIDa_aadF <- Saf.getSafePut 71 | safePut_a_aadG <- Saf.getSafePut 72 | safePut_Relationsa_aadH <- Saf.getSafePut 73 | safePut_UIDa_aadF arg_aadC 74 | safePut_a_aadG arg_aadD 75 | safePut_Relationsa_aadH arg_aadE 76 | return () 77 | getCopy = Saf.contain $ do 78 | safeGet_UIDa_aadI <- Saf.getSafeGet; 79 | safeGet_a_aadJ <- Saf.getSafeGet; 80 | safeGet_Relationsa_aadK <- Saf.getSafeGet; 81 | (((return Row) <*> safeGet_UIDa_aadI) <*> safeGet_a_aadJ) <*> safeGet_Relationsa_aadK 82 | version = 0 83 | kind = Saf.base 84 | errorTypeName _ = "Benchmarks.AcidState.Row" 85 | 86 | Saf.deriveSafeCopy 0 'Saf.base ''UID 87 | Saf.deriveSafeCopy 0 'Saf.base ''Identified 88 | Saf.deriveSafeCopy 0 'Saf.base ''Artist 89 | Saf.deriveSafeCopy 0 'Saf.base ''Genre 90 | Saf.deriveSafeCopy 0 'Saf.base ''Song 91 | 92 | 93 | -- * Acid 94 | ------------------------- 95 | 96 | -- ** Events 97 | ------------------------- 98 | 99 | insertArtistEvent :: Artist -> Aci.Update Catalogue (UID Artist) 100 | insertArtistEvent artist = do 101 | liftState $ 102 | zoom _1 $ do 103 | uid <- _1 <<%= succ 104 | _2 %= Ixs.insert (Row uid artist ()) 105 | return uid 106 | 107 | insertGenreEvent :: Genre -> [UID Song] -> Aci.Update Catalogue (UID Genre) 108 | insertGenreEvent genre songUIDs = do 109 | liftState $ 110 | zoom _2 $ do 111 | uid <- _1 <<%= succ 112 | _2 %= Ixs.insert (Row uid genre songUIDs) 113 | return uid 114 | 115 | insertSongEvent :: Song -> [UID Artist] -> Aci.Update Catalogue (UID Song) 116 | insertSongEvent song artistUIDs = do 117 | liftState $ 118 | zoom _3 $ do 119 | uid <- _1 <<%= succ 120 | _2 %= Ixs.insert (Row uid song artistUIDs) 121 | return uid 122 | 123 | -- | A helper, which makes \"lens\" functions usable on Acid-state monads. 124 | liftState :: (MonadState s m) => State s r -> m r 125 | liftState = state . runState 126 | 127 | 128 | Aci.makeAcidic ''Catalogue ['insertArtistEvent, 'insertGenreEvent, 'insertSongEvent] 129 | 130 | 131 | -- ** Setup 132 | ------------------------- 133 | 134 | 135 | interpretSession :: (MonadIO m) => Session m r -> Aci.Session Catalogue m r 136 | interpretSession = iterTM $ \case 137 | InsertArtist a c -> do 138 | r <- Aci.update $ InsertArtistEvent a 139 | c r 140 | InsertGenre g c -> $notImplemented 141 | InsertSong s gl al c -> $notImplemented 142 | LookupArtistByUID u c -> $notImplemented 143 | LookupArtistsByName n c -> $notImplemented 144 | LookupArtistsBySongGenreName n c -> $notImplemented 145 | 146 | 147 | data Settings = 148 | LocalPersistent | 149 | LocalNonpersistent 150 | 151 | runSession :: (MonadIO m, MonadBaseControl IO m) => Settings -> Session m r -> m r 152 | runSession = \case 153 | LocalPersistent -> Aci.runLocalPersistentSession dir initValue . interpretSession 154 | LocalNonpersistent -> Aci.runLocalNonpersistentSession dir initValue . interpretSession 155 | 156 | dir = "./dist/benchmarks/acid-state" 157 | initValue = ((UID 1, Ixs.empty), (UID 1, Ixs.empty), (UID 1, Ixs.empty)) 158 | 159 | initDir :: IO () 160 | initDir = do 161 | Fil.removeIfExists dir 162 | Fil.createTree dir 163 | -------------------------------------------------------------------------------- /executables/Benchmarks/AcidState/AcidStatePlus.hs: -------------------------------------------------------------------------------- 1 | module Benchmarks.AcidState.AcidStatePlus 2 | ( 3 | Session, 4 | runLocalPersistentSession, 5 | runLocalNonpersistentSession, 6 | runRemoteSession, 7 | Aci.Update, 8 | Aci.Query, 9 | update, 10 | query, 11 | Aci.makeAcidic, 12 | ) 13 | where 14 | 15 | import Benchmarks.Prelude 16 | import qualified Data.Acid as Aci 17 | import qualified Data.Acid.Memory as Aci 18 | import qualified Benchmarks.Util.FileSystem as Fil 19 | import qualified Control.Exception.Lifted as ELi 20 | 21 | 22 | newtype Session a m r = Session (ReaderT (Aci.AcidState a) m r) 23 | deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) 24 | 25 | 26 | runLocalPersistentSession :: 27 | (MonadIO m, MonadBaseControl IO m, Aci.IsAcidic a) => 28 | FilePath -> a -> Session a m r -> m r 29 | runLocalPersistentSession dir initState (Session m) = ELi.bracket acquire release apply where 30 | acquire = liftIO $ Aci.openLocalStateFrom (Fil.encodeString dir) initState 31 | release s = liftIO $ do 32 | Aci.createCheckpoint s 33 | Aci.closeAcidState s 34 | apply s = runReaderT m s 35 | 36 | runLocalNonpersistentSession :: 37 | (MonadIO m, MonadBaseControl IO m, Aci.IsAcidic a) => 38 | FilePath -> a -> Session a m r -> m r 39 | runLocalNonpersistentSession dir initState (Session m) = ELi.bracket acquire release apply where 40 | acquire = liftIO $ Aci.openMemoryState initState 41 | release s = liftIO $ Aci.closeAcidState s 42 | apply s = runReaderT m s 43 | 44 | runRemoteSession :: (MonadIO m) => Session a m r -> m r 45 | runRemoteSession = $notImplemented 46 | 47 | update :: 48 | (MonadIO m, Aci.UpdateEvent e, Aci.EventState e ~ a) => 49 | e -> Session a m (Aci.EventResult e) 50 | update e = do 51 | s <- Session $ ask 52 | liftIO $ Aci.update s e 53 | 54 | query :: 55 | (MonadIO m, Aci.QueryEvent e, Aci.EventState e ~ a) => 56 | e -> Session a m (Aci.EventResult e) 57 | query e = do 58 | s <- Session $ ask 59 | liftIO $ Aci.query s e 60 | -------------------------------------------------------------------------------- /executables/Benchmarks/GraphDB.hs: -------------------------------------------------------------------------------- 1 | module Benchmarks.GraphDB where 2 | 3 | import Benchmarks.Prelude 4 | import Benchmarks.Model 5 | import Control.Lens 6 | import qualified GraphDB as G 7 | import qualified Benchmarks.Util.FileSystem as FS 8 | 9 | 10 | -- Values 11 | ------------------------- 12 | 13 | -- | Stores counters of UID generators. 14 | type Catalogue = (UID Artist, UID Genre, UID Song) 15 | 16 | 17 | -- Edges 18 | ------------------------- 19 | 20 | instance G.Edge Catalogue (Identified Artist) where 21 | data Index Catalogue (Identified Artist) = 22 | Catalogue_Artist_UID (UID Artist) | 23 | Catalogue_Artist_Name Text | 24 | Catalogue_Artist 25 | deriving (Eq, Generic) 26 | indexes (Identified uid (Artist n)) = 27 | [Catalogue_Artist_UID uid, Catalogue_Artist_Name n, Catalogue_Artist] 28 | 29 | instance G.Edge Catalogue (Identified Genre) where 30 | data Index Catalogue (Identified Genre) = 31 | Catalogue_Genre_UID (UID Genre) | 32 | Catalogue_Genre_Name Text | 33 | Catalogue_Genre 34 | deriving (Eq, Generic) 35 | indexes (Identified uid (Genre n)) = 36 | [Catalogue_Genre_UID uid, Catalogue_Genre_Name n, Catalogue_Genre] 37 | 38 | instance G.Edge Catalogue (Identified Song) where 39 | data Index Catalogue (Identified Song) = 40 | Catalogue_Song_UID (UID Song) | 41 | Catalogue_Song_Name Text | 42 | Catalogue_Song 43 | deriving (Eq, Generic) 44 | indexes (Identified uid (Song n)) = 45 | [Catalogue_Song_UID uid, Catalogue_Song_Name n, Catalogue_Song] 46 | 47 | instance G.Edge (Identified Genre) (Identified Song) where 48 | data Index (Identified Genre) (Identified Song) = 49 | Genre_Song 50 | deriving (Eq, Generic) 51 | indexes _ = [Genre_Song] 52 | 53 | instance G.Edge (Identified Song) (Identified Artist) where 54 | data Index (Identified Song) (Identified Artist) = 55 | Song_Artist 56 | deriving (Eq, Generic) 57 | indexes _ = [Song_Artist] 58 | 59 | 60 | -- Boilerplate 61 | ------------------------- 62 | 63 | G.deriveSetup ''Catalogue 64 | instance (Hashable a) => Hashable (UID a) 65 | instance (Serializable m a) => Serializable m (UID a) 66 | 67 | 68 | -- Interpreter 69 | ------------------------- 70 | 71 | interpretSession :: 72 | (G.Session s, u ~ Catalogue, 73 | MonadTrans (s u), MonadIO (s u m), 74 | MonadIO m, MonadBaseControl IO m) => 75 | Session m a -> s u m a 76 | interpretSession = iterTM $ \case 77 | InsertArtist a c -> G.write (insertArtist a) >>= c 78 | InsertGenre g c -> G.write (insertGenre g) >>= c 79 | InsertSong s gl al c -> G.write (insertSong s gl al) >>= c 80 | LookupArtistByUID u c -> G.read (lookupArtistByUID u) >>= c 81 | LookupArtistsByName n c -> G.read (lookupArtistsByName n) >>= c 82 | LookupArtistsBySongGenreName n c -> G.read (lookupArtistsBySongGenreName n) >>= c 83 | where 84 | 85 | lookupArtistByUID :: UID Artist -> G.Read s Catalogue t (Maybe (Identified Artist)) 86 | lookupArtistByUID uid = 87 | G.getRoot >>= flip G.getTargets (Catalogue_Artist_UID uid) >>= 88 | return . listToMaybe >>= mapM G.getValue 89 | 90 | lookupArtistsByName :: Text -> G.Read s Catalogue t [Identified Artist] 91 | lookupArtistsByName n = 92 | G.getRoot >>= flip G.getTargets (Catalogue_Artist_Name n) >>= mapM G.getValue 93 | 94 | lookupArtistsBySongGenreName :: Text -> G.Read s Catalogue t [Identified Artist] 95 | lookupArtistsBySongGenreName n = 96 | G.getRoot >>= 97 | flip G.getTargets (Catalogue_Genre_Name n) >>= 98 | mapM (flip G.getTargets Genre_Song) >>= 99 | return . concat >>= 100 | mapM (flip G.getTargets Song_Artist) >>= 101 | return . concat >>= 102 | mapM G.getValue 103 | 104 | insertArtist :: Artist -> G.Write s Catalogue t (UID Artist) 105 | insertArtist value = do 106 | root <- G.getRoot 107 | uid <- updateNode root $ zoom _1 $ modify succ >> get 108 | node <- G.newNode (Identified uid value) 109 | G.addTarget root node 110 | return uid 111 | 112 | insertGenre :: Genre -> G.Write s Catalogue t (UID Genre) 113 | insertGenre value = do 114 | root <- G.getRoot 115 | uid <- updateNode root $ zoom _2 $ modify succ >> get 116 | node <- G.newNode (Identified uid value) 117 | G.addTarget root node 118 | return uid 119 | 120 | insertSong :: Song -> [UID Genre] -> [UID Artist] -> G.Write s Catalogue t (UID Song) 121 | insertSong value genreUIDs artistUIDs = do 122 | root <- G.getRoot 123 | uid <- updateNode root $ zoom _3 $ modify succ >> get 124 | node <- G.newNode (Identified uid value) 125 | forM_ genreUIDs $ \uid -> do 126 | genres <- G.getTargets root (Catalogue_Genre_UID uid) 127 | forM_ genres $ \genre -> do 128 | G.addTarget genre node 129 | forM_ artistUIDs $ \uid -> do 130 | artists <- G.getTargets root (Catalogue_Artist_UID uid) 131 | forM_ artists $ \artist -> do 132 | G.addTarget node artist 133 | return uid 134 | 135 | generateUID :: Lens' Catalogue (UID a) -> G.Write s Catalogue t (UID a) 136 | generateUID selector = do 137 | root <- G.getRoot 138 | updateNode root $ zoom selector $ modify succ >> get 139 | 140 | updateNode :: 141 | (G.PolyValue Catalogue v) => 142 | G.Node s Catalogue t v -> State v r -> G.Write s Catalogue t r 143 | updateNode n u = G.getValue n >>= return . runState u >>= \(r, v') -> G.setValue n v' >> return r 144 | 145 | 146 | -- Setup 147 | ------------------------- 148 | 149 | runPersistentSession :: 150 | (MonadBaseControl IO m, MonadIO m) => 151 | G.PersistentSession Catalogue m r -> m (Either G.PersistenceFailure r) 152 | runPersistentSession = G.runPersistentSession (initialRoot, dir, buffering) where 153 | buffering = 100 154 | 155 | runNonpersistentSession :: 156 | (MonadIO m) => G.NonpersistentSession Catalogue m r -> m r 157 | runNonpersistentSession = G.runNonpersistentSession initialRoot 158 | 159 | serve socket = G.serve (1, lm, to, mc, log) where 160 | lm = if socket 161 | then G.ListeningMode_Socket socketPath 162 | else G.ListeningMode_Host 54699 auth 163 | where 164 | auth = const $ return True 165 | to = 10^6 166 | mc = 100 167 | log = const $ return () 168 | 169 | runClientSession socket = G.runClientSession (1, url) where 170 | url = if socket 171 | then G.URL_Socket socketPath 172 | else G.URL_Host "127.0.0.1" 54699 Nothing 173 | 174 | initDir :: IO () 175 | initDir = do 176 | FS.removeIfExists dir 177 | FS.createTree dir 178 | 179 | socketPath = dir <> ".socket" 180 | dir = "./dist/benchmarks/graph-db" 181 | initialRoot = (UID 0, UID 0, UID 0) 182 | -------------------------------------------------------------------------------- /executables/Benchmarks/Model.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- A shared model. 3 | -- Subjects provide implementation for 'Session'. 4 | module Benchmarks.Model where 5 | 6 | import Benchmarks.Prelude 7 | 8 | 9 | -- * Values 10 | ------------------------- 11 | 12 | newtype UID a = UID Int deriving (Show, Eq, Ord, Generic, Data, Typeable, Enum, Num, Real, Integral) 13 | data Artist = Artist Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 14 | data Genre = Genre Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 15 | data Song = Song Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 16 | type Name = Text 17 | data Identified a = Identified {-# UNPACK #-} !(UID a) !a deriving (Show, Eq, Ord, Generic, Data, Typeable) 18 | 19 | instance Functor Identified where 20 | fmap f (Identified (UID n) a) = Identified (UID n) (f a) 21 | 22 | 23 | -- * Session 24 | ------------------------- 25 | 26 | type Session = FreeT SessionF 27 | data SessionF a = 28 | InsertArtist Artist (UID Artist -> a) | 29 | InsertGenre Genre (UID Genre -> a) | 30 | InsertSong Song [UID Genre] [UID Artist] (UID Song -> a) | 31 | LookupArtistByUID (UID Artist) (Maybe (Identified Artist) -> a) | 32 | LookupArtistsByName Name ([Identified Artist] -> a) | 33 | LookupArtistsBySongGenreName Name ([Identified Artist] -> a) 34 | deriving (Functor) 35 | 36 | makeFree ''SessionF 37 | -------------------------------------------------------------------------------- /executables/Benchmarks/Postgres.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This one requires a database "test" with access for user "postgres" 3 | -- with no password. 4 | -- The user must have appropriate privileges to drop and create tables 5 | -- in that database. 6 | module Benchmarks.Postgres where 7 | 8 | import Benchmarks.Prelude 9 | import Control.Lens 10 | import Benchmarks.Model 11 | import qualified Benchmarks.Postgres.PostgreSQLSimplePlus as P 12 | 13 | 14 | -- * Model 15 | ------------------------- 16 | 17 | deriving instance P.FromField (UID a) 18 | deriving instance P.ToField (UID a) 19 | 20 | instance P.FromRow Artist where 21 | fromRow = Artist <$> P.field 22 | instance P.ToRow Artist where 23 | toRow (Artist n) = [P.toField n] 24 | instance P.FromRow Genre where 25 | fromRow = Genre <$> P.field 26 | instance P.ToRow Genre where 27 | toRow (Genre n) = [P.toField n] 28 | instance P.FromRow Song where 29 | fromRow = Song <$> P.field 30 | instance P.ToRow Song where 31 | toRow (Song n) = [P.toField n] 32 | instance P.FromRow a => P.FromRow (Identified a) where 33 | fromRow = Identified <$> P.field <*> P.fromRow 34 | instance P.ToRow a => P.ToRow (Identified a) where 35 | toRow (Identified uid a) = P.toField uid : P.toRow a 36 | 37 | 38 | -- * Transactions 39 | ------------------------- 40 | 41 | interpretSession :: (MonadIO m) => Session m a -> P.Session m a 42 | interpretSession = iterTM $ \case 43 | InsertArtist artist continue -> 44 | (>>= continue) $ 45 | P.runAction False $ 46 | fmap (P.fromOnly . head) $ 47 | P.query "INSERT INTO artist (name) VALUES (?) RETURNING id" artist 48 | InsertGenre genre continue -> 49 | (>>= continue) $ 50 | P.runAction False $ 51 | fmap (P.fromOnly . head) $ 52 | P.query "INSERT INTO genre (name) VALUES (?) RETURNING id" genre 53 | InsertSong song genreUIDs artistUIDs continue -> 54 | (>>= continue) $ 55 | P.runAction True $ do 56 | songUID <- 57 | fmap (P.fromOnly . head) $ 58 | P.query "INSERT INTO song (name) VALUES (?) RETURNING id" song 59 | 60 | mapM_ (P.execute "INSERT INTO song_genre (id1, id2) VALUES (?, ?)") $ 61 | zip (repeat songUID) genreUIDs 62 | 63 | mapM_ (P.execute "INSERT INTO song_artist (id1, id2) VALUES (?, ?)") $ 64 | zip (repeat songUID) artistUIDs 65 | 66 | return songUID 67 | LookupArtistByUID uid continue -> 68 | P.runAction False (fmap listToMaybe $ P.query sql (P.Only uid)) >>= continue 69 | where 70 | sql = "SELECT * FROM artist WHERE id = ?" 71 | LookupArtistsByName name continue -> 72 | P.runAction False (P.query sql (P.Only name)) >>= continue 73 | where 74 | sql = "SELECT * FROM artist WHERE name = ?" 75 | LookupArtistsBySongGenreName name continue -> 76 | P.runAction False (P.query sql (P.Only name)) >>= continue 77 | where 78 | sql = 79 | [P.sql| 80 | SELECT * 81 | FROM artist 82 | LEFT JOIN song_artist ON song_artist.id2 = artist.id 83 | LEFT JOIN song_genre ON song_genre.id1 = song_artist.id1 84 | LEFT JOIN genre ON genre.id = song_genre.id2 85 | WHERE 86 | genre.name = ? 87 | |] 88 | 89 | 90 | -- * Setup 91 | ------------------------- 92 | 93 | init :: (MonadIO m) => P.Session m () 94 | init = 95 | P.runAction True $ P.execute_ 96 | [P.sql| 97 | SET client_min_messages = 'warning'; 98 | DROP TABLE IF EXISTS "song_artist"; 99 | DROP TABLE IF EXISTS "song_genre"; 100 | DROP TABLE IF EXISTS "song"; 101 | DROP TABLE IF EXISTS "genre"; 102 | DROP TABLE IF EXISTS "artist"; 103 | CREATE TABLE "artist" ( 104 | "id" BIGSERIAL, 105 | "name" varchar NOT NULL, 106 | PRIMARY KEY ("id") 107 | ); 108 | CREATE INDEX "artist_name" ON "artist" USING btree("name"); 109 | CREATE TABLE "genre" ( 110 | "id" BIGSERIAL, 111 | "name" varchar NOT NULL, 112 | PRIMARY KEY ("id") 113 | ); 114 | CREATE INDEX "genre_name" ON "genre" USING btree("name"); 115 | CREATE TABLE "song" ( 116 | "id" BIGSERIAL, 117 | "name" varchar NOT NULL, 118 | PRIMARY KEY ("id") 119 | ); 120 | CREATE INDEX "song_name" ON "song" USING btree("name"); 121 | CREATE TABLE "song_genre" ( 122 | "id1" integer, 123 | "id2" integer, 124 | CONSTRAINT "id1" FOREIGN KEY ("id1") REFERENCES "song" ("id") ON DELETE CASCADE, 125 | CONSTRAINT "id2" FOREIGN KEY ("id2") REFERENCES "genre" ("id") ON DELETE CASCADE 126 | ); 127 | CREATE TABLE "song_artist" ( 128 | "id1" integer, 129 | "id2" integer, 130 | CONSTRAINT "id1" FOREIGN KEY ("id1") REFERENCES "song" ("id") ON DELETE CASCADE, 131 | CONSTRAINT "id2" FOREIGN KEY ("id2") REFERENCES "artist" ("id") ON DELETE CASCADE 132 | ); 133 | |] 134 | 135 | runSession :: (MonadIO m) => P.PoolSize -> P.Session m r -> m r 136 | runSession poolSize sess = do 137 | P.runSession (host, port, user, pw, db, poolSize) $ sess 138 | where 139 | host = "localhost" 140 | port = 5432 141 | user = "postgres" 142 | pw = "" 143 | db = "test" 144 | 145 | 146 | -------------------------------------------------------------------------------- /executables/Benchmarks/Postgres/PostgreSQLSimplePlus.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- A simpler wrapper API for "postgresql-simple" and "ex-pool". 3 | module Benchmarks.Postgres.PostgreSQLSimplePlus 4 | ( 5 | -- * Session 6 | Session, 7 | runSession, 8 | -- ** Settings 9 | Settings, 10 | Host, 11 | Port, 12 | User, 13 | Password, 14 | Database, 15 | PoolSize, 16 | -- * Action 17 | Action, 18 | runAction, 19 | query, 20 | query_, 21 | execute, 22 | execute_, 23 | returning, 24 | -- * Reexports of from "postgresql-simple" 25 | Pos.ToRow(..), 26 | Pos.FromRow(..), 27 | Pos.ToField(..), 28 | Pos.FromField(..), 29 | Pos.field, 30 | Pos.Only(..), 31 | Pos.fromOnly, 32 | Pos.sql, 33 | ) 34 | where 35 | 36 | import Benchmarks.Prelude 37 | import qualified Database.PostgreSQL.Simple as Pos 38 | import qualified Database.PostgreSQL.Simple.SqlQQ as Pos 39 | import qualified Database.PostgreSQL.Simple.FromField as Pos 40 | import qualified Database.PostgreSQL.Simple.ToField as Pos 41 | import qualified Database.PostgreSQL.Simple.FromRow as Pos 42 | import qualified Database.PostgreSQL.Simple.ToRow as Pos 43 | import qualified Data.Pool as Poo 44 | 45 | 46 | -- * Session 47 | ------------------------- 48 | 49 | newtype Session m r = Session (ReaderT (Poo.Pool Pos.Connection) m r) 50 | deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) 51 | 52 | -- FIXME: introduce bracketing if to be used anywhere seriously. 53 | runSession :: MonadIO m => Settings -> Session m r -> m r 54 | runSession (host, port, user, pw, db, poolSize) (Session m) = do 55 | pool <- liftIO $ Poo.createPool connect disconnect stripe timeout poolSize 56 | r <- runReaderT m pool 57 | liftIO $ Poo.purgePool pool 58 | return r 59 | where 60 | connect = Pos.connect $ Pos.ConnectInfo host port user pw db 61 | disconnect c = Pos.close c 62 | stripe = 1 63 | timeout = fromIntegral 30 64 | 65 | type Settings = (Host, Port, User, Password, Database, PoolSize) 66 | type Host = String 67 | type Port = Word16 68 | type User = String 69 | type Password = String 70 | type Database = String 71 | type PoolSize = Word32 72 | 73 | 74 | -- * Action 75 | ------------------------- 76 | 77 | -- | 78 | -- A composition of multiple queries, 79 | -- which will be executed on a single connection and 80 | -- optionally as a single transaction. 81 | -- 82 | -- 'MonadIO' instance is not provided intentionally, 83 | -- since transactions must not produce any side effects besides 84 | -- the database updates. 85 | newtype Action r = Action (ReaderT Pos.Connection IO r) 86 | deriving (Functor, Applicative, Monad) 87 | 88 | -- | 89 | -- Whether to treat a composed action as a transaction. 90 | type AsTransaction = Bool 91 | 92 | -- FIXME: handle exceptions and rollbacks by retrying, 93 | -- if this code is to be used anywhere seriously. 94 | runAction :: (MonadIO m) => AsTransaction -> Action r -> Session m r 95 | runAction asTransaction (Action m) = do 96 | pool <- Session ask 97 | liftIO $ Poo.withResource pool $ \cx -> 98 | (if asTransaction then Pos.withTransaction cx else id) $ 99 | runReaderT m cx 100 | 101 | -- ** Actions 102 | ------------------------- 103 | 104 | query :: (Pos.ToRow a, Pos.FromRow r) => Pos.Query -> a -> Action [r] 105 | query q a = Action $ ReaderT $ \c -> Pos.query c q a 106 | 107 | query_ :: (Pos.FromRow r) => Pos.Query -> Action [r] 108 | query_ q = Action $ ReaderT $ \c -> Pos.query_ c q 109 | 110 | execute :: (Pos.ToRow a) => Pos.Query -> a -> Action () 111 | execute q a = Action $ ReaderT $ \c -> void $ Pos.execute c q a 112 | 113 | execute_ :: Pos.Query -> Action () 114 | execute_ q = Action $ ReaderT $ \c -> void $ Pos.execute_ c q 115 | 116 | returning :: (Pos.ToRow a, Pos.FromRow r) => Pos.Query -> [a] -> Action [r] 117 | returning q a = Action $ ReaderT $ \c -> Pos.returning c q a 118 | -------------------------------------------------------------------------------- /executables/Benchmarks/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Benchmarks.Prelude 2 | ( 3 | module Exports, 4 | 5 | traceM, 6 | traceIO, 7 | traceIOWithTime, 8 | packText, 9 | unpackText, 10 | bug, 11 | (|>), 12 | (<|), 13 | (|$>), 14 | bracketME, 15 | finallyME, 16 | tracingExceptions, 17 | ) 18 | where 19 | 20 | -- base 21 | import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.)) 22 | import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 23 | import Control.Applicative as Exports 24 | import Control.Arrow as Exports hiding (left, right) 25 | import Control.Category as Exports 26 | import Data.Monoid as Exports 27 | import Data.Foldable as Exports 28 | import Data.Traversable as Exports hiding (for) 29 | import Data.Maybe as Exports 30 | import Data.Either as Exports 31 | import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') 32 | import Data.Tuple as Exports 33 | import Data.Ord as Exports (Down(..)) 34 | import Data.String as Exports 35 | import Data.Int as Exports 36 | import Data.Word as Exports 37 | import Data.Ratio as Exports 38 | import Data.Fixed as Exports 39 | import Data.Ix as Exports 40 | import Data.Data as Exports 41 | import Text.Read as Exports (readMaybe, readEither) 42 | import Control.Exception as Exports hiding (tryJust, assert) 43 | import Control.Concurrent as Exports hiding (yield) 44 | import System.Mem.StableName as Exports 45 | import System.Timeout as Exports 46 | import System.Exit as Exports 47 | import System.IO.Unsafe as Exports 48 | import System.IO as Exports (Handle, hClose) 49 | import System.IO.Error as Exports 50 | import Unsafe.Coerce as Exports 51 | import GHC.Exts as Exports hiding (Any, traceEvent, toList) 52 | import GHC.Generics as Exports (Generic) 53 | import GHC.IO.Exception as Exports 54 | import Data.IORef as Exports 55 | import Data.STRef as Exports 56 | import Control.Monad.ST as Exports 57 | import Debug.Trace as Exports hiding (traceIO, traceM) 58 | 59 | -- mtl 60 | import Control.Monad.Identity as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 61 | import Control.Monad.State.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 62 | import Control.Monad.Reader as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 63 | import Control.Monad.Writer.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any) 64 | import Control.Monad.RWS.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any) 65 | import Control.Monad.Error as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 66 | import Control.Monad.Trans as Exports 67 | 68 | -- transformers-base 69 | import Control.Monad.Base as Exports 70 | 71 | -- monad-control 72 | import Control.Monad.Trans.Control as Exports 73 | 74 | -- free 75 | import Control.Monad.Trans.Free as Exports 76 | import Control.Monad.Free.TH as Exports 77 | 78 | -- lifted-async 79 | import Control.Concurrent.Async.Lifted as Exports 80 | 81 | -- bytestring 82 | import Data.ByteString as Exports (ByteString) 83 | 84 | -- text 85 | import Data.Text as Exports (Text) 86 | 87 | -- containers 88 | import Data.Map as Exports (Map) 89 | import Data.IntMap as Exports (IntMap) 90 | import Data.Set as Exports (Set) 91 | import Data.IntSet as Exports (IntSet) 92 | import Data.Sequence as Exports (Seq) 93 | import Data.Tree as Exports (Tree) 94 | 95 | -- hashable 96 | import Data.Hashable as Exports (Hashable(..), hash) 97 | 98 | -- time 99 | import Data.Time.Clock as Exports 100 | 101 | -- string-conversions 102 | import Data.String.Conversions as Exports hiding (LT, ST) 103 | 104 | -- cereal-plus 105 | import CerealPlus.Serializable as Exports 106 | 107 | -- system-filepath 108 | import Filesystem.Path as Exports (FilePath) 109 | 110 | -- placeholders 111 | import Development.Placeholders as Exports 112 | 113 | import qualified Debug.Trace.LocationTH 114 | import qualified Data.ByteString.Lazy 115 | import qualified Data.Text.Lazy 116 | import qualified Data.Text 117 | import qualified Prelude 118 | import qualified Debug.Trace 119 | import qualified System.Locale 120 | import qualified Data.Time 121 | 122 | 123 | (|>) :: a -> (a -> b) -> b 124 | a |> aToB = aToB a 125 | {-# INLINE (|>) #-} 126 | 127 | (<|) :: (a -> b) -> a -> b 128 | aToB <| a = aToB a 129 | {-# INLINE (<|) #-} 130 | 131 | -- | 132 | -- The following are all the same: 133 | -- fmap f a == f <$> a == a |> fmap f == a |$> f 134 | -- 135 | -- This operator accomodates the left-to-right operators: >>=, >>>, |>. 136 | (|$>) = flip fmap 137 | {-# INLINE (|$>) #-} 138 | 139 | packText = Data.Text.pack 140 | unpackText = Data.Text.unpack 141 | 142 | bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] 143 | where 144 | msg = "A \"graph-db\" package bug: " :: String 145 | 146 | bottom = [e| $bug "Bottom evaluated" |] 147 | 148 | bracketME :: (MonadError e m) => m a -> (a -> m b) -> (a -> m c) -> m c 149 | bracketME acquire release apply = do 150 | r <- acquire 151 | z <- catchError (liftM Right $ apply r) (return . Left) 152 | release r 153 | either throwError return z 154 | 155 | finallyME :: (MonadError e m) => m a -> m b -> m a 156 | finallyME m f = do 157 | z <- catchError (liftM Right $ m) (return . Left) 158 | f 159 | either throwError return z 160 | 161 | traceM :: (Monad m) => String -> m () 162 | traceM s = trace s $ return () 163 | 164 | traceIO :: (MonadIO m) => String -> m () 165 | traceIO = liftIO . Debug.Trace.traceIO 166 | 167 | traceIOWithTime :: (MonadIO m) => String -> m () 168 | traceIOWithTime s = do 169 | time <- liftIO $ getCurrentTime 170 | traceIO $ 171 | formatTime time <> ": " <> s 172 | where 173 | formatTime = 174 | take 15 . 175 | Data.Time.formatTime System.Locale.defaultTimeLocale "%X.%q" 176 | 177 | tracingExceptions :: (MonadBaseControl IO m) => m a -> m a 178 | tracingExceptions m = 179 | control $ \runInIO -> catch (runInIO m) $ \(SomeException e) -> runInIO $ do 180 | let rep = typeOf e 181 | tyCon = typeRepTyCon rep 182 | traceM $ 183 | "## Uncaught exception: " ++ show e ++ "\n" ++ 184 | " Type: " ++ show rep ++ "\n" ++ 185 | " Module: " ++ tyConModule tyCon ++ "\n" ++ 186 | " Package: " ++ tyConPackage tyCon 187 | liftBase $ throwIO $ e 188 | 189 | -------------------------------------------------------------------------------- /executables/Benchmarks/Random.hs: -------------------------------------------------------------------------------- 1 | module Benchmarks.Random where 2 | 3 | import Benchmarks.Prelude 4 | import qualified System.Random.MWC as MWC 5 | import qualified Data.Char as Char 6 | 7 | type Gen = MWC.Gen RealWorld 8 | type GenT = ReaderT Gen 9 | 10 | newGen :: IO Gen 11 | newGen = MWC.create 12 | 13 | runGenT :: MonadIO m => Gen -> GenT m r -> m r 14 | runGenT gen t = runReaderT t gen 15 | 16 | generateName :: MonadIO m => GenT m Text 17 | generateName = do 18 | gen <- ask 19 | length <- liftIO $ MWC.uniformR lengthRange gen 20 | chars <- replicateM length $ generateChar 21 | return $! packText chars 22 | where 23 | lengthRange = (1, 50) 24 | 25 | generateChar :: MonadIO m => GenT m Char 26 | generateChar = do 27 | gen <- ask 28 | scenario :: Int <- liftIO $ MWC.uniformR (0, 6) gen 29 | ord <- liftIO $ flip MWC.uniformR gen $ case scenario of 30 | 0 -> upperRange 31 | 1 -> upperRange 32 | 2 -> lowerRange 33 | 3 -> lowerRange 34 | 4 -> lowerRange 35 | 5 -> lowerRange 36 | 6 -> numRange 37 | return $! Char.chr ord 38 | where 39 | upperRange = (Char.ord 'A', Char.ord 'Z') 40 | lowerRange = (Char.ord 'a', Char.ord 'z') 41 | numRange = (Char.ord '0', Char.ord '9') 42 | 43 | generateVariate :: (MonadIO m, MWC.Variate n) => (n, n) -> GenT m n 44 | generateVariate r = ReaderT $ liftIO . MWC.uniformR r 45 | -------------------------------------------------------------------------------- /executables/Benchmarks/Util/FileSystem.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Utilities for dealing with 'FilePath'. 3 | -- 4 | module Benchmarks.Util.FileSystem 5 | ( 6 | module Filesystem, 7 | module Filesystem.Path.CurrentOS, 8 | Status(..), 9 | getStatus, 10 | getExists, 11 | getTemporaryDirectory, 12 | remove, 13 | removeIfExists, 14 | removeTreeIfExists, 15 | move, 16 | copy, 17 | resolve, 18 | listFilesByExtension, 19 | ) 20 | where 21 | 22 | import Benchmarks.Prelude hiding (stripPrefix, last) 23 | import Filesystem.Path.CurrentOS 24 | import Filesystem 25 | import qualified System.Directory as Directory 26 | import qualified Data.List as List 27 | import qualified System.IO.Error as IOError 28 | 29 | 30 | 31 | data Status = File | Directory | NotExists 32 | deriving (Show, Eq, Ord, Enum) 33 | 34 | getStatus :: FilePath -> IO Status 35 | getStatus path = do 36 | z <- isFile path 37 | if z 38 | then return File 39 | else do 40 | z <- isDirectory path 41 | if z 42 | then return Directory 43 | else return NotExists 44 | 45 | getExists :: FilePath -> IO Bool 46 | getExists path = getStatus path >>= return . (/= NotExists) 47 | 48 | getTemporaryDirectory :: IO FilePath 49 | getTemporaryDirectory = 50 | Directory.getTemporaryDirectory >>= return . decodeString 51 | 52 | remove :: FilePath -> IO () 53 | remove path = do 54 | status <- getStatus path 55 | case status of 56 | File -> removeFile path 57 | Directory -> removeTree path 58 | NotExists -> IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "" Nothing (Just $ encodeString path) 59 | 60 | removeIfExists :: FilePath -> IO () 61 | removeIfExists path = do 62 | status <- getStatus path 63 | case status of 64 | File -> removeFile path 65 | Directory -> removeTree path 66 | NotExists -> return () 67 | 68 | removeTreeIfExists :: FilePath -> IO () 69 | removeTreeIfExists path = removeTree path `catch` \e -> case e of 70 | _ | IOError.isDoesNotExistError e -> return () 71 | | otherwise -> throwIO e 72 | 73 | move :: FilePath -> FilePath -> IO () 74 | move from to = do 75 | copy from to 76 | remove from 77 | 78 | copy :: FilePath -> FilePath -> IO () 79 | copy from to = do 80 | isDir <- isDirectory from 81 | if isDir 82 | then do 83 | createTree to 84 | copyDirectory from to 85 | else do 86 | createTree $ directory to 87 | copyFile from to 88 | 89 | copyDirectory :: FilePath -> FilePath -> IO () 90 | copyDirectory path path' = do 91 | members <- listDirectory path 92 | let members' = do 93 | member <- members 94 | let relative = 95 | fromMaybe (error "Unexpectedly empty member path") $ 96 | last member 97 | return $ path' <> relative 98 | sequence_ $ zipWith copy members members' 99 | 100 | last :: FilePath -> Maybe FilePath 101 | last p = case splitDirectories p of 102 | [] -> Nothing 103 | l -> Just $ List.last l 104 | 105 | resolve :: FilePath -> IO FilePath 106 | resolve path = case splitDirectories path of 107 | h:t | h == "~" -> do 108 | home <- getHomeDirectory 109 | return $ mconcat $ home : t 110 | _ -> return path 111 | 112 | 113 | listFilesByExtension :: FilePath -> Text -> IO [FilePath] 114 | listFilesByExtension dir extension = 115 | listDirectory dir >>= 116 | return . filter (flip hasExtension extension) 117 | 118 | -------------------------------------------------------------------------------- /executables/CompetitionBench.hs: -------------------------------------------------------------------------------- 1 | 2 | import Benchmarks.Prelude hiding (group) 3 | import CriterionPlus 4 | import qualified Benchmarks.GraphDB as Gra 5 | import qualified Benchmarks.Random as Ran 6 | import qualified Benchmarks.Postgres as Pos 7 | import qualified Benchmarks.Model as Mod 8 | import qualified Benchmarks.AcidState as Aci 9 | 10 | 11 | main = do 12 | gen <- Ran.newGen 13 | benchmark $ do 14 | standoff "Inserting" $ do 15 | session <- Ran.runGenT gen $ do 16 | list <- replicateM 1000 $ Ran.generateName 17 | return $ forM_ list $ Mod.insertArtist . Mod.Artist 18 | subject "Postgres" $ do 19 | pause 20 | Pos.runSession 1 $ do 21 | Pos.init 22 | lift $ continue 23 | Pos.interpretSession session 24 | lift $ pause 25 | group "AcidState" $ do 26 | subject "Nonpersistent" $ do 27 | pause 28 | liftIO $ Aci.initDir 29 | r <- Aci.runSession Aci.LocalNonpersistent $ do 30 | lift $ continue 31 | !r <- session 32 | lift $ pause 33 | nfIO $ return r 34 | subject "Persistent" $ do 35 | pause 36 | liftIO $ Aci.initDir 37 | Aci.runSession Aci.LocalPersistent $ do 38 | lift $ continue 39 | session 40 | lift $ pause 41 | group "GraphDB" $ do 42 | subject "Persistent" $ do 43 | pause 44 | liftIO $ Gra.initDir 45 | Gra.runPersistentSession $ do 46 | lift $ continue 47 | Gra.interpretSession session 48 | lift $ pause 49 | subject "Nonpersistent" $ do 50 | pause 51 | Gra.runNonpersistentSession $ do 52 | lift $ continue 53 | Gra.interpretSession session 54 | lift $ pause 55 | 56 | -------------------------------------------------------------------------------- /executables/Demo.hs: -------------------------------------------------------------------------------- 1 | 2 | import BasicPrelude 3 | import GHC.Generics (Generic) 4 | import qualified GraphDB as G 5 | import qualified Data.Text as Text 6 | 7 | 8 | -- * Model 9 | ------------------------- 10 | 11 | data Catalogue = Catalogue deriving (Show, Eq, Generic) 12 | data Artist = Artist Name deriving (Show, Eq, Generic) 13 | data Genre = Genre Name deriving (Show, Eq, Generic) 14 | type Name = Text 15 | 16 | -- * Relations 17 | ------------------------- 18 | 19 | instance G.Edge Catalogue Artist where 20 | data Index Catalogue Artist = 21 | Catalogue_Artist | 22 | Catalogue_Artist_SearchTerm Text 23 | deriving (Show, Eq, Generic) 24 | indexes (Artist name) = 25 | Catalogue_Artist : 26 | searchTerms 27 | where 28 | searchTerms = map Catalogue_Artist_SearchTerm $ Text.words name 29 | 30 | instance G.Edge Catalogue Genre where 31 | data Index Catalogue Genre = 32 | Catalogue_Genre | 33 | Catalogue_Genre_Name Text 34 | deriving (Show, Eq, Generic) 35 | indexes (Genre name) = 36 | Catalogue_Genre : 37 | Catalogue_Genre_Name name : 38 | [] 39 | 40 | instance G.Edge Genre Artist where 41 | data Index Genre Artist = 42 | Genre_Artist 43 | deriving (Show, Eq, Generic) 44 | indexes (Artist name) = 45 | [Genre_Artist] 46 | 47 | G.deriveSetup ''Catalogue 48 | 49 | 50 | 51 | main = do 52 | putStrLn "Restoring the graph from the storage." 53 | G.runPersistentSession (Catalogue, "./dist/demo/db", 1) $ do 54 | do 55 | G.read G.getStats >>= \case 56 | (1, 0, 0) -> do 57 | liftIO $ putStrLn "Graph is empty. Populating." 58 | G.write $ populate 59 | _ -> return () 60 | do 61 | G.read G.getStats >>= \(nodes, edges, indexes) -> 62 | liftIO $ putStrLn $ 63 | "There's " <> show nodes <> " nodes, " <> show edges <> " edges " <> 64 | "and " <> show indexes <> " indexes in the graph." 65 | do 66 | liftIO $ putStrLn "Artists by the search term \"The\":" 67 | liftIO . print =<< do 68 | G.read $ 69 | G.getRoot >>= 70 | flip G.getTargets (Catalogue_Artist_SearchTerm "The") >>= 71 | mapM G.getValue 72 | do 73 | liftIO $ putStrLn "Artists by the genre named \"Rock\":" 74 | liftIO . print =<< do 75 | G.read $ 76 | G.getRoot >>= 77 | flip G.getTargets (Catalogue_Genre_Name "Rock") >>= 78 | fmap join . mapM (flip G.getTargets (Genre_Artist)) >>= 79 | mapM G.getValue 80 | 81 | populate :: G.Write s Catalogue t () 82 | populate = do 83 | root <- G.getRoot 84 | 85 | rollingStones <- G.newNode $ Artist "The Rolling Stones" 86 | beatles <- G.newNode $ Artist "The Beatles" 87 | metallica <- G.newNode $ Artist "Metallica" 88 | nirvana <- G.newNode $ Artist "Nirvana" 89 | 90 | rock <- G.newNode $ Genre "Rock" 91 | grunge <- G.newNode $ Genre "Grunge" 92 | metal <- G.newNode $ Genre "Metal" 93 | 94 | G.addTarget root rollingStones 95 | G.addTarget root beatles 96 | G.addTarget root metallica 97 | G.addTarget root nirvana 98 | 99 | G.addTarget root rock 100 | G.addTarget root grunge 101 | G.addTarget root metal 102 | 103 | G.addTarget rock rollingStones 104 | G.addTarget rock beatles 105 | G.addTarget rock metallica 106 | G.addTarget rock nirvana 107 | 108 | G.addTarget grunge nirvana 109 | 110 | G.addTarget metal metallica 111 | 112 | 113 | -------------------------------------------------------------------------------- /executables/InternalTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | 3 | import Test.Framework 4 | import GraphDB.Util.Prelude 5 | 6 | import {-@ HTF_TESTS @-} InternalTests.StorageTests 7 | import {-@ HTF_TESTS @-} InternalTests.GraphTests 8 | import {-@ HTF_TESTS @-} InternalTests.THTests 9 | import {-@ HTF_TESTS @-} InternalTests.MacrosTests 10 | 11 | 12 | main = htfMain $ htf_thisModulesTests : htf_importedTests 13 | -------------------------------------------------------------------------------- /executables/InternalTests/GraphTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module InternalTests.GraphTests where 3 | 4 | import GraphDB.Util.Prelude 5 | import Test.Framework hiding (frequency, oneof, listOf, elements, choose) 6 | import Test.QuickCheck.Monadic 7 | import Test.QuickCheck.Instances () 8 | import QuickCheck.GenT 9 | import GraphDB.Graph 10 | import qualified GraphDB.Util.DIOVector as V 11 | import qualified CerealPlus.Serialize as CS 12 | import qualified CerealPlus.Deserialize as CD 13 | 14 | 15 | -- * Model 16 | ------------------------- 17 | 18 | type Catalogue = () 19 | type Name = Text 20 | type UID = Int 21 | 22 | instance Setup Catalogue where 23 | type Algorithm Catalogue = Basic 24 | data Index Catalogue = 25 | Catalogue_Artist_UID UID | 26 | Catalogue_Artist_Name Name | 27 | Catalogue_Genre_Name Name | 28 | Catalogue_Song_Name Name | 29 | Genre_Song | 30 | Song_Artist 31 | deriving (Eq, Generic) 32 | data Value Catalogue = 33 | Catalogue Catalogue | 34 | Artist UID Name | 35 | Genre Name | 36 | Song Name 37 | deriving (Eq, Generic) 38 | indexes to from = case (to, from) of 39 | (Artist uid n, Catalogue _) -> [Catalogue_Artist_Name n, Catalogue_Artist_UID uid] 40 | (Artist uid n, Song _) -> [Song_Artist] 41 | (Genre n, Catalogue _) -> [Catalogue_Genre_Name n] 42 | (Song n, Catalogue _) -> [Catalogue_Song_Name n] 43 | (Song n, Genre _) -> [Genre_Song] 44 | _ -> [] 45 | 46 | instance Serializable m (Index Catalogue) 47 | instance Serializable m (Value Catalogue) 48 | instance Hashable (Index Catalogue) 49 | instance Hashable (Value Catalogue) 50 | 51 | 52 | -- * QuickCheck 53 | ------------------------- 54 | 55 | newtype Update = Update (ReaderT (Node Catalogue) IO ()) 56 | 57 | instance Show Update where 58 | show _ = "" 59 | 60 | instance Arbitrary Update where 61 | arbitrary = fmap Update $ runGenT $ frequency 62 | [ 63 | (50, addSomeEdge), 64 | (30, removeSomeEdge), 65 | (40, insertArtist), 66 | (20, insertGenre), 67 | (200, insertSong) 68 | ] 69 | where 70 | removeSomeEdge = do 71 | root <- lift $ ask 72 | void $ runMaybeT $ do 73 | source <- MaybeT $ oneof [selectSomeNode, return $ Just root] 74 | target <- MaybeT $ selectSomeNode 75 | liftIO $ removeTarget source target 76 | addSomeEdge = do 77 | void $ runMaybeT $ do 78 | source <- MaybeT selectSomeNode 79 | target <- MaybeT selectSomeNode 80 | liftIO $ addTarget source target 81 | selectSomeNode = do 82 | root <- lift $ ask 83 | targets <- liftIO $ V.new 84 | liftIO $ traverseTargets root $ void . V.append targets 85 | size <- liftIO $ V.size targets 86 | if size > 0 87 | then do 88 | index <- liftGen $ choose (0, size - 1) 89 | fmap Just $ liftIO $ V.unsafeLookup targets index 90 | else 91 | return Nothing 92 | insertArtist = addValueToCatalogue =<< do liftGen $ Artist <$> arbitrary <*> arbitrary 93 | insertGenre = addValueToCatalogue =<< do liftGen $ Genre <$> arbitrary 94 | insertSong = addValueToCatalogue =<< do liftGen $ Song <$> arbitrary 95 | addValueToCatalogue value = do 96 | source <- lift $ ask 97 | target <- liftIO . new $ value 98 | liftIO $ addTarget source target 99 | 100 | 101 | -- * Tests 102 | ------------------------- 103 | 104 | test_remove = do 105 | catalogue <- new $ Catalogue () 106 | michael <- new $ Artist 1 "Michael Jackson" 107 | billieJean <- new $ Song "Billie Jean" 108 | whoIsIt <- new $ Song "Who is it?" 109 | 110 | addTarget catalogue michael 111 | addTarget catalogue billieJean 112 | addTarget catalogue whoIsIt 113 | addTarget billieJean michael 114 | addTarget whoIsIt michael 115 | 116 | remove michael 117 | 118 | assertEqual (3, 2, 2) =<< getStats catalogue 119 | assertEqual 0 . length =<< getSources michael 120 | 121 | test_stats = do 122 | catalogue <- new $ Catalogue () 123 | michael <- new $ Artist 1 "Michael Jackson" 124 | billieJean <- new $ Song "Billie Jean" 125 | whoIsIt <- new $ Song "Who is it?" 126 | 127 | addTarget catalogue michael 128 | addTarget catalogue billieJean 129 | addTarget catalogue whoIsIt 130 | addTarget billieJean michael 131 | addTarget whoIsIt michael 132 | 133 | assertEqual (4, 5, 6) =<< getStats catalogue 134 | 135 | test_addingANodeAffectsTheStats = do 136 | root <- new $ Catalogue () 137 | addTarget root =<< do new $ Artist 1 "Michael Jackson" 138 | assertEqual (2, 1, 2) =<< getStats root 139 | 140 | test_removingANodeAffectsTheStats = do 141 | root <- new $ Catalogue () 142 | artist <- new $ Artist 1 "Michael Jackson" 143 | addTarget root artist 144 | removeTarget root artist 145 | assertEqual (1, 0, 0) =<< getStats root 146 | 147 | test_addingATargetTwiceMakesNoDifference = do 148 | root <- new $ Catalogue () 149 | artist <- new $ Artist 1 "Michael Jackson" 150 | addTarget root artist 151 | addTarget root artist 152 | assertEqual (2, 1, 2) =<< getStats root 153 | 154 | test_traverseTargetsDoesNotRepeat = do 155 | root <- new $ Catalogue () 156 | addTarget root =<< do new $ Artist 1 "Michael Jackson" 157 | counter <- newIORef 0 158 | traverseTargets root $ const $ modifyIORef counter succ 159 | assertEqual 1 =<< readIORef counter 160 | 161 | test_traverseSourcesDoesNotRepeat = do 162 | root <- new $ Catalogue () 163 | artist <- new $ Artist 1 "Michael Jackson" 164 | addTarget root artist 165 | counter <- newIORef 0 166 | traverseSources artist $ const $ modifyIORef counter succ 167 | assertEqual 1 =<< readIORef counter 168 | 169 | prop_serializeDeserializePreservesStats = monadicIO $ do 170 | node <- do 171 | updates :: [Update] <- pick $ do 172 | amount <- choose (0, 100) 173 | replicateM amount arbitrary 174 | run $ do 175 | root <- new $ Catalogue () 176 | forM_ updates $ \(Update u) -> runReaderT u root 177 | return root 178 | 179 | stats <- run $ getStats node 180 | run $ traceIO $ "Stats: " <> show stats 181 | 182 | bs <- run $ CS.exec $ serialize $ node 183 | CD.Done (node' :: Node Catalogue) _ <- run $ CD.runPartial deserialize bs 184 | bs' <- run $ CS.exec $ serialize $ node' 185 | stats' <- run $ getStats node' 186 | 187 | assert $ stats == stats' 188 | -------------------------------------------------------------------------------- /executables/InternalTests/MacrosTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module InternalTests.MacrosTests where 3 | 4 | import Test.Framework 5 | import GraphDB.Util.Prelude 6 | import qualified GraphDB.Util.Prelude.TH as TH 7 | import qualified GraphDB.Model as G 8 | import qualified GraphDB.Macros as G 9 | 10 | 11 | type Catalogue = (UID Artist, UID Genre, UID Song) 12 | newtype UID a = UID Int deriving (Show, Eq, Ord, Generic, Data, Typeable, Enum, Num, Real, Integral) 13 | data Artist = Artist Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 14 | data Genre = Genre Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 15 | data Song = Song Name deriving (Show, Eq, Ord, Generic, Data, Typeable) 16 | type Name = Text 17 | data Identified a = Identified {-# UNPACK #-} !(UID a) !a deriving (Show, Eq, Ord, Generic, Data, Typeable) 18 | 19 | 20 | -- Edges 21 | ------------------------- 22 | 23 | instance G.Edge Catalogue (Identified Artist) where 24 | data Index Catalogue (Identified Artist) = 25 | Catalogue_Artist_UID (UID Artist) | 26 | Catalogue_Artist_Name Text 27 | deriving (Eq, Generic) 28 | indexes (Identified uid (Artist n)) = 29 | [Catalogue_Artist_UID uid, Catalogue_Artist_Name n] 30 | 31 | instance G.Edge Catalogue (Identified Genre) where 32 | data Index Catalogue (Identified Genre) = 33 | Catalogue_Genre_UID (UID Genre) | 34 | Catalogue_Genre_Name Text 35 | deriving (Eq, Generic) 36 | indexes (Identified uid (Genre n)) = 37 | [Catalogue_Genre_UID uid, Catalogue_Genre_Name n] 38 | 39 | instance G.Edge (Identified Genre) (Identified Song) where 40 | data Index (Identified Genre) (Identified Song) = 41 | Genre_Song 42 | deriving (Eq, Generic) 43 | indexes _ = [Genre_Song] 44 | 45 | instance G.Edge (Identified Song) (Identified Artist) where 46 | data Index (Identified Song) (Identified Artist) = 47 | Song_Artist 48 | deriving (Eq, Generic) 49 | indexes _ = [Song_Artist] 50 | 51 | 52 | -- Boilerplate 53 | ------------------------- 54 | 55 | G.deriveSetup ''Catalogue 56 | instance (Hashable a) => Hashable (UID a) 57 | instance (Serializable m a) => Serializable m (UID a) 58 | -------------------------------------------------------------------------------- /executables/InternalTests/StorageTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module InternalTests.StorageTests where 3 | 4 | import Test.Framework 5 | import GraphDB.Util.Prelude 6 | import qualified GraphDB.Storage as Storage 7 | import qualified GraphDB.Util.FileSystem as FS 8 | 9 | 10 | 11 | data A = A { ref :: IORef Float } 12 | deriving (Generic) 13 | 14 | instance Serializable IO A 15 | 16 | data Event = Increase | Decrease | Multiply Float | Divide Float | Get 17 | deriving (Show, Ord, Eq, Generic) 18 | 19 | instance Serializable m Event 20 | 21 | data EventResult = UnitEventResult () | FloatEventResult Float 22 | deriving (Show, Ord, Eq, Generic) 23 | 24 | instance Serializable m EventResult 25 | 26 | 27 | initValue = A <$> newIORef 0 28 | 29 | applyEvent (A ref) e = case e of 30 | Increase -> modifyIORef ref succ 31 | Decrease -> modifyIORef ref pred 32 | Multiply by -> modifyIORef ref (*by) 33 | Divide by -> modifyIORef ref (/by) 34 | 35 | processRequestData (A ref) event = case event of 36 | Increase -> modifyIORef ref succ >> readIORef ref >>= return . FloatEventResult 37 | Decrease -> modifyIORef ref pred >> readIORef ref >>= return . FloatEventResult 38 | Multiply by -> modifyIORef ref (*by) >> readIORef ref >>= return . FloatEventResult 39 | Divide by -> modifyIORef ref (/by) >> readIORef ref >>= return . FloatEventResult 40 | Get -> readIORef ref >>= return . FloatEventResult 41 | 42 | dir = "./dist/test/storage" 43 | 44 | withStorage :: ((Storage.Storage A Event, A) -> IO a) -> IO a 45 | withStorage = bracket acquire release 46 | where 47 | acquire = Storage.acquireAndLoad initValue applyEvent =<< Storage.pathsFromDirectory dir 48 | release = Storage.release . fst 49 | 50 | cleanUp :: IO () 51 | cleanUp = FS.removeIfExists dir 52 | 53 | 54 | 55 | test_loadsPastTenAttempts = do 56 | cleanUp 57 | replicateM 11 $ withStorage $ \(s, a) -> do 58 | Storage.persistEvent s Increase 59 | withStorage $ \(s, a) -> do 60 | assertEqual 11 =<< readIORef . ref =<< return a 61 | 62 | test_loads = do 63 | cleanUp 64 | withStorage $ \(s, a) -> do 65 | Storage.persistEvent s Increase 66 | Storage.persistEvent s Increase 67 | Storage.persistEvent s $ Multiply 3 68 | Storage.persistEvent s Decrease 69 | Storage.persistEvent s Increase 70 | withStorage $ \(s, a) -> do 71 | value <- readIORef . ref =<< return a 72 | assertEqual 6 value 73 | 74 | test_loadsAfterMultipleRuns = do 75 | cleanUp 76 | withStorage $ \(s, a) -> do 77 | Storage.persistEvent s Increase 78 | Storage.persistEvent s $ Multiply 3 79 | Storage.persistEvent s Decrease 80 | Storage.persistEvent s Increase 81 | withStorage $ \(s, a) -> do 82 | assertEqual 3 =<< readIORef . ref =<< return a 83 | Storage.persistEvent s Increase 84 | Storage.persistEvent s Increase 85 | Storage.persistEvent s $ Multiply 3 86 | Storage.persistEvent s Decrease 87 | Storage.persistEvent s Increase 88 | withStorage $ \(s, a) -> do 89 | assertEqual 15 =<< readIORef . ref =<< return a 90 | 91 | test_checkpoint = do 92 | cleanUp 93 | withStorage $ \(s, a) -> do 94 | Storage.persistEvent s Increase 95 | Storage.persistEvent s $ Multiply 3 96 | Storage.persistEvent s Decrease 97 | Storage.persistEvent s Increase 98 | withStorage $ \(s, a) -> do 99 | Storage.checkpoint s =<< A <$> newIORef 3 100 | withStorage $ \(s, a) -> assertEqual 3 =<< readIORef . ref =<< return a 101 | withStorage $ \(s, a) -> do 102 | Storage.checkpoint s =<< A <$> newIORef 3 103 | Storage.persistEvent s Increase 104 | Storage.persistEvent s Increase 105 | Storage.persistEvent s $ Multiply 3 106 | Storage.persistEvent s Decrease 107 | Storage.persistEvent s Increase 108 | withStorage $ \(s, a) -> assertEqual 15 =<< readIORef . ref =<< return a 109 | 110 | test_checkpointWithoutEvents = do 111 | cleanUp 112 | replicateM 11 $ withStorage $ \(s, a) -> do 113 | applyEvent a Increase 114 | applyEvent a Increase 115 | Storage.checkpoint s a 116 | withStorage $ \(s, a) -> do 117 | assertEqual 22 =<< readIORef . ref =<< return a 118 | 119 | test_checkpointWithEvents = do 120 | cleanUp 121 | replicateM 11 $ withStorage $ \(s, a) -> do 122 | Storage.persistEvent s Increase 123 | Storage.persistEvent s Increase 124 | applyEvent a Increase 125 | applyEvent a Increase 126 | Storage.checkpoint s a 127 | withStorage $ \(s, a) -> do 128 | assertEqual 22 =<< readIORef . ref =<< return a 129 | 130 | test_cleanUp = do 131 | cleanUp 132 | withStorage $ \(s, a) -> return () 133 | withStorage $ \(s, a) -> Storage.checkpoint s =<< A <$> newIORef 3 134 | withStorage $ \(s, a) -> Storage.checkpoint s =<< A <$> newIORef 3 135 | withStorage $ \(s, a) -> return () 136 | assertBool =<< FS.getExists (dir <> "4.checkpoint") 137 | assertBool =<< FS.getExists (dir <> "5.events") 138 | assertBool =<< FS.getExists (dir <> "6.events") 139 | assertBool =<< return . not =<< FS.getExists (dir <> "1.events") 140 | assertBool =<< return . not =<< FS.getExists (dir <> "4.events") 141 | assertBool =<< FS.getExists (dir <> "archive/1.events") 142 | assertBool =<< FS.getExists (dir <> "archive/4.events") 143 | assertBool =<< FS.getExists (dir <> "archive/2.checkpoint") 144 | 145 | -------------------------------------------------------------------------------- /executables/InternalTests/THTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF htfpp #-} 2 | module InternalTests.THTests where 3 | 4 | import Test.Framework 5 | import GraphDB.Util.Prelude 6 | import Language.Haskell.TH 7 | import qualified GraphDB.Util.TH as T 8 | import qualified GraphDB.Util.TH.Parsers as P 9 | import qualified GraphDB.Model as M 10 | 11 | data A a b 12 | data B 13 | 14 | test_parseMultiparamInstance :: IO () 15 | test_parseMultiparamInstance = do 16 | assertEqual 17 | "[(GraphDB.Model.Edge,[ConT InternalTests.THTests.B,ConT InternalTests.THTests.B])]" 18 | $( 19 | let content = "instance M.Edge B B where" 20 | in stringE . show =<< P.runParse content P.instances 21 | ) 22 | 23 | test_parseInstanceWithPolymorphicTypes :: IO () 24 | test_parseInstanceWithPolymorphicTypes = do 25 | assertEqual 26 | "[(GraphDB.Model.Edge,[AppT (AppT (ConT InternalTests.THTests.A) (ConT InternalTests.THTests.B)) (ConT InternalTests.THTests.B),ConT InternalTests.THTests.B])]" 27 | $( 28 | let content = "instance M.Edge (A B B) B where" 29 | in stringE . show =<< P.runParse content P.instances 30 | ) 31 | 32 | test_parseInstanceWithVariables :: IO () 33 | test_parseInstanceWithVariables = do 34 | assertEqual 35 | "[(GraphDB.Model.Edge,[AppT (AppT (ConT InternalTests.THTests.A) (ConT InternalTests.THTests.B)) (VarT a),VarT b])]" 36 | $( 37 | let content = "instance M.Edge (A B a) b where" 38 | in stringE . show =<< P.runParse content P.instances 39 | ) 40 | -------------------------------------------------------------------------------- /executables/NonpersistentBench.hs: -------------------------------------------------------------------------------- 1 | 2 | import Benchmarks.Prelude 3 | import qualified CriterionPlus as Cri 4 | import qualified Benchmarks.GraphDB as Gra 5 | import qualified Benchmarks.Random as Ran 6 | import qualified Benchmarks.Model as Mod 7 | 8 | 9 | main = do 10 | gen <- Ran.newGen 11 | Cri.benchmark $ do 12 | Cri.standoff "Inserting" $ do 13 | let subject n = do 14 | session <- Ran.runGenT gen $ do 15 | list <- replicateM n $ Ran.generateName 16 | return $ forM_ list $ Mod.insertArtist . Mod.Artist 17 | Cri.subject (cs $ show n) $ do 18 | Cri.pause 19 | Gra.runNonpersistentSession $ do 20 | lift $ Cri.continue 21 | Gra.interpretSession session 22 | lift $ Cri.pause 23 | subject 21000 24 | subject 16000 25 | subject 11000 26 | subject 6000 27 | subject 1000 28 | -------------------------------------------------------------------------------- /graph-db.cabal: -------------------------------------------------------------------------------- 1 | name: 2 | graph-db 3 | version: 4 | 0.3.0 5 | synopsis: 6 | A native Haskell graph database 7 | description: 8 | Provides a mutable in-memory graph datastructure with complete ACID guarantees, 9 | a persistence layer, a server and a client. 10 | license: 11 | MIT 12 | license-file: 13 | LICENSE 14 | homepage: 15 | https://github.com/nikita-volkov/graph-db 16 | bug-reports: 17 | https://github.com/nikita-volkov/graph-db/issues 18 | author: 19 | Nikita Volkov 20 | maintainer: 21 | Nikita Volkov 22 | copyright: 23 | (c) 2013, Nikita Volkov 24 | category: 25 | Database, Graphs 26 | build-type: 27 | Simple 28 | cabal-version: 29 | >=1.10 30 | 31 | 32 | source-repository head 33 | type: 34 | git 35 | location: 36 | git://github.com/nikita-volkov/graph-db.git 37 | 38 | 39 | library 40 | hs-source-dirs: 41 | library 42 | other-modules: 43 | GraphDB.Macros 44 | GraphDB.Macros.Analysis 45 | GraphDB.Macros.Templates 46 | GraphDB.Model 47 | GraphDB.Server 48 | GraphDB.Client 49 | GraphDB.Protocol 50 | GraphDB.Persistent 51 | GraphDB.Persistent.Log 52 | GraphDB.Nonpersistent 53 | GraphDB.Action 54 | GraphDB.Graph 55 | GraphDB.Storage 56 | GraphDB.Storage.Rules 57 | GraphDB.Util.TH 58 | GraphDB.Util.TH.Q 59 | GraphDB.Util.TH.Type 60 | GraphDB.Util.TH.Parsers 61 | GraphDB.Util.FileSystem 62 | GraphDB.Util.DIOVector 63 | GraphDB.Util.IOQueue 64 | GraphDB.Util.Prelude 65 | GraphDB.Util.Prelude.TH 66 | exposed-modules: 67 | GraphDB 68 | build-depends: 69 | -- parsing: 70 | parsec, 71 | attoparsec, 72 | -- template-haskell: 73 | template-haskell, 74 | th-expand-syns, 75 | th-instance-reification > 0.1.0 && < 0.2, 76 | -- networking: 77 | remotion == 0.2.*, 78 | network == 2.4.*, 79 | network-simple == 0.4.*, 80 | pipes-network == 0.6.*, 81 | -- streaming: 82 | pipes >= 4.0 && < 4.2, 83 | pipes-bytestring == 2.1.*, 84 | pipes-cereal-plus == 0.4.*, 85 | -- file-system: 86 | directory == 1.2.*, 87 | filelock == 0.1.*, 88 | system-filepath == 0.4.*, 89 | system-fileio == 0.3.*, 90 | -- concurrency: 91 | async == 2.*, 92 | lifted-async == 0.1.*, 93 | stm, 94 | SafeSemaphore == 0.10.*, 95 | -- data: 96 | hashtables-plus == 0.2.*, 97 | hashable == 1.2.*, 98 | bytestring, 99 | text, 100 | containers, 101 | unordered-containers, 102 | vector, 103 | time, 104 | old-locale, 105 | -- control: 106 | errors >= 1.4.6 && < 1.5, 107 | free >= 4.6 && < 5, 108 | monad-control == 0.3.*, 109 | transformers-base == 0.4.*, 110 | transformers, 111 | mtl >= 2.1 && < 2.3, 112 | -- debugging: 113 | loch-th == 0.2.*, 114 | placeholders == 0.1.*, 115 | -- 116 | base >= 4.5 && < 5 117 | default-extensions: 118 | Arrows 119 | BangPatterns 120 | ConstraintKinds 121 | DataKinds 122 | DefaultSignatures 123 | DeriveDataTypeable 124 | DeriveFunctor 125 | DeriveGeneric 126 | EmptyDataDecls 127 | FlexibleContexts 128 | FlexibleInstances 129 | FunctionalDependencies 130 | GADTs 131 | GeneralizedNewtypeDeriving 132 | ImpredicativeTypes 133 | LambdaCase 134 | LiberalTypeSynonyms 135 | MultiParamTypeClasses 136 | MultiWayIf 137 | NoImplicitPrelude 138 | NoMonomorphismRestriction 139 | OverloadedStrings 140 | PatternGuards 141 | QuasiQuotes 142 | RankNTypes 143 | RecordWildCards 144 | ScopedTypeVariables 145 | StandaloneDeriving 146 | TemplateHaskell 147 | TupleSections 148 | TypeFamilies 149 | TypeOperators 150 | default-language: 151 | Haskell2010 152 | 153 | 154 | test-suite internal-tests 155 | type: 156 | exitcode-stdio-1.0 157 | hs-source-dirs: 158 | executables 159 | library 160 | main-is: 161 | InternalTests.hs 162 | ghc-options: 163 | -threaded 164 | "-with-rtsopts=-N" 165 | build-depends: 166 | -- testing: 167 | async, 168 | directory, 169 | system-fileio, 170 | old-locale, 171 | time, 172 | cereal-plus, 173 | quickcheck-instances, 174 | QuickCheck-GenT >= 0.1.3 && < 0.2, 175 | QuickCheck, 176 | HUnit, 177 | HTF == 0.12.*, 178 | -- parsing: 179 | parsec, 180 | attoparsec, 181 | -- template-haskell: 182 | template-haskell, 183 | th-expand-syns, 184 | th-instance-reification > 0.1.0 && < 0.2, 185 | -- networking: 186 | remotion == 0.2.*, 187 | network == 2.4.*, 188 | network-simple == 0.4.*, 189 | pipes-network == 0.6.*, 190 | -- streaming: 191 | pipes >= 4.0 && < 4.2, 192 | pipes-bytestring == 2.1.*, 193 | pipes-cereal-plus == 0.4.*, 194 | -- file-system: 195 | directory == 1.2.*, 196 | filelock == 0.1.*, 197 | system-filepath == 0.4.*, 198 | system-fileio == 0.3.*, 199 | -- concurrency: 200 | async == 2.*, 201 | lifted-async == 0.1.*, 202 | stm, 203 | SafeSemaphore == 0.10.*, 204 | -- data: 205 | hashtables-plus == 0.2.*, 206 | hashable == 1.2.*, 207 | bytestring, 208 | text, 209 | containers, 210 | unordered-containers, 211 | vector, 212 | time, 213 | old-locale, 214 | -- control: 215 | errors >= 1.4.6 && < 1.5, 216 | free >= 4.6 && < 5, 217 | monad-control == 0.3.*, 218 | transformers-base == 0.4.*, 219 | transformers, 220 | mtl >= 2.1 && < 2.3, 221 | -- debugging: 222 | loch-th == 0.2.*, 223 | placeholders == 0.1.*, 224 | -- 225 | base >= 4.5 && < 5 226 | default-extensions: 227 | Arrows 228 | BangPatterns 229 | ConstraintKinds 230 | DataKinds 231 | DefaultSignatures 232 | DeriveDataTypeable 233 | DeriveFunctor 234 | DeriveGeneric 235 | EmptyDataDecls 236 | FlexibleContexts 237 | FlexibleInstances 238 | FunctionalDependencies 239 | GADTs 240 | GeneralizedNewtypeDeriving 241 | ImpredicativeTypes 242 | LambdaCase 243 | LiberalTypeSynonyms 244 | MultiParamTypeClasses 245 | MultiWayIf 246 | NoImplicitPrelude 247 | NoMonomorphismRestriction 248 | OverloadedStrings 249 | PatternGuards 250 | QuasiQuotes 251 | RankNTypes 252 | RecordWildCards 253 | ScopedTypeVariables 254 | StandaloneDeriving 255 | TemplateHaskell 256 | TupleSections 257 | TypeFamilies 258 | TypeOperators 259 | default-language: 260 | Haskell2010 261 | 262 | 263 | test-suite api-tests 264 | type: 265 | exitcode-stdio-1.0 266 | hs-source-dirs: 267 | executables 268 | main-is: 269 | APITests.hs 270 | ghc-options: 271 | -threaded 272 | "-with-rtsopts=-N" 273 | build-depends: 274 | -- testing: 275 | graph-db, 276 | old-locale, 277 | time, 278 | cereal-plus, 279 | quickcheck-instances, 280 | QuickCheck-GenT >= 0.1.3 && < 0.2, 281 | QuickCheck, 282 | HUnit, 283 | HTF == 0.12.*, 284 | -- concurrency: 285 | lifted-async, 286 | -- file-system: 287 | directory == 1.2.*, 288 | system-filepath == 0.4.*, 289 | system-fileio == 0.3.*, 290 | -- data: 291 | string-conversions == 0.3.*, 292 | vector, 293 | cereal-plus, 294 | hashable, 295 | containers, 296 | bytestring, 297 | text, 298 | time, 299 | old-locale, 300 | -- control: 301 | lens == 4.*, 302 | monad-control == 0.3.*, 303 | transformers-base == 0.4.*, 304 | transformers, 305 | mtl >= 2.1 && < 2.3, 306 | -- debugging: 307 | loch-th == 0.2.*, 308 | placeholders == 0.1.*, 309 | -- 310 | base >= 4.5 && < 5 311 | default-extensions: 312 | Arrows 313 | BangPatterns 314 | ConstraintKinds 315 | DataKinds 316 | DefaultSignatures 317 | DeriveDataTypeable 318 | DeriveFunctor 319 | DeriveGeneric 320 | EmptyDataDecls 321 | FlexibleContexts 322 | FlexibleInstances 323 | FunctionalDependencies 324 | GADTs 325 | GeneralizedNewtypeDeriving 326 | ImpredicativeTypes 327 | LambdaCase 328 | LiberalTypeSynonyms 329 | MultiParamTypeClasses 330 | MultiWayIf 331 | NoImplicitPrelude 332 | NoMonomorphismRestriction 333 | OverloadedStrings 334 | PatternGuards 335 | QuasiQuotes 336 | RankNTypes 337 | RecordWildCards 338 | ScopedTypeVariables 339 | StandaloneDeriving 340 | TemplateHaskell 341 | TupleSections 342 | TypeFamilies 343 | TypeOperators 344 | default-language: 345 | Haskell2010 346 | 347 | 348 | benchmark competition-bench 349 | type: 350 | exitcode-stdio-1.0 351 | hs-source-dirs: 352 | executables 353 | main-is: 354 | CompetitionBench.hs 355 | ghc-options: 356 | -threaded 357 | "-with-rtsopts=-N" 358 | build-depends: 359 | graph-db, 360 | mwc-random == 0.13.*, 361 | lens == 4.*, 362 | -- acid-state: 363 | acid-state == 0.12.*, 364 | ixset == 1.0.*, 365 | safecopy == 0.8.*, 366 | -- postgres: 367 | postgresql-simple == 0.4.*, 368 | ex-pool == 0.2.*, 369 | -- benchmarking: 370 | criterion-plus == 0.1.*, 371 | -- concurrency: 372 | lifted-async, 373 | -- file-system: 374 | directory == 1.2.*, 375 | system-filepath == 0.4.*, 376 | system-fileio == 0.3.*, 377 | -- data: 378 | string-conversions == 0.3.*, 379 | cereal-plus, 380 | hashable, 381 | containers, 382 | bytestring, 383 | text, 384 | time, 385 | old-locale, 386 | -- control: 387 | lifted-base == 0.2.*, 388 | free >= 4.6 && < 5, 389 | monad-control == 0.3.*, 390 | transformers-base == 0.4.*, 391 | transformers, 392 | mtl >= 2.1 && < 2.3, 393 | -- debugging: 394 | loch-th == 0.2.*, 395 | placeholders == 0.1.*, 396 | -- 397 | base >= 4.5 && < 5 398 | default-extensions: 399 | Arrows 400 | BangPatterns 401 | ConstraintKinds 402 | DataKinds 403 | DefaultSignatures 404 | DeriveDataTypeable 405 | DeriveFunctor 406 | DeriveGeneric 407 | EmptyDataDecls 408 | FlexibleContexts 409 | FlexibleInstances 410 | FunctionalDependencies 411 | GADTs 412 | GeneralizedNewtypeDeriving 413 | ImpredicativeTypes 414 | LambdaCase 415 | LiberalTypeSynonyms 416 | MultiParamTypeClasses 417 | MultiWayIf 418 | NoImplicitPrelude 419 | NoMonomorphismRestriction 420 | OverloadedStrings 421 | PatternGuards 422 | QuasiQuotes 423 | RankNTypes 424 | RecordWildCards 425 | ScopedTypeVariables 426 | StandaloneDeriving 427 | TemplateHaskell 428 | TupleSections 429 | TypeFamilies 430 | TypeOperators 431 | default-language: 432 | Haskell2010 433 | 434 | 435 | benchmark nonpersistent-bench 436 | type: 437 | exitcode-stdio-1.0 438 | hs-source-dirs: 439 | executables 440 | main-is: 441 | NonpersistentBench.hs 442 | ghc-options: 443 | -O2 444 | -threaded 445 | "-with-rtsopts=-N" 446 | build-depends: 447 | graph-db, 448 | mwc-random == 0.13.*, 449 | lens == 4.*, 450 | -- benchmarking: 451 | criterion-plus == 0.1.*, 452 | -- concurrency: 453 | lifted-async, 454 | -- file-system: 455 | directory == 1.2.*, 456 | system-filepath == 0.4.*, 457 | system-fileio == 0.3.*, 458 | -- data: 459 | string-conversions == 0.3.*, 460 | cereal-plus, 461 | hashable, 462 | containers, 463 | bytestring, 464 | text, 465 | time, 466 | old-locale, 467 | -- control: 468 | lifted-base == 0.2.*, 469 | free >= 4.6 && < 5, 470 | monad-control == 0.3.*, 471 | transformers-base == 0.4.*, 472 | transformers, 473 | mtl >= 2.1 && < 2.3, 474 | -- debugging: 475 | loch-th == 0.2.*, 476 | placeholders == 0.1.*, 477 | -- 478 | base >= 4.5 && < 5 479 | default-extensions: 480 | Arrows 481 | BangPatterns 482 | ConstraintKinds 483 | DataKinds 484 | DefaultSignatures 485 | DeriveDataTypeable 486 | DeriveFunctor 487 | DeriveGeneric 488 | EmptyDataDecls 489 | FlexibleContexts 490 | FlexibleInstances 491 | FunctionalDependencies 492 | GADTs 493 | GeneralizedNewtypeDeriving 494 | ImpredicativeTypes 495 | LambdaCase 496 | LiberalTypeSynonyms 497 | MultiParamTypeClasses 498 | MultiWayIf 499 | NoImplicitPrelude 500 | NoMonomorphismRestriction 501 | OverloadedStrings 502 | PatternGuards 503 | QuasiQuotes 504 | RankNTypes 505 | RecordWildCards 506 | ScopedTypeVariables 507 | StandaloneDeriving 508 | TemplateHaskell 509 | TupleSections 510 | TypeFamilies 511 | TypeOperators 512 | default-language: 513 | Haskell2010 514 | 515 | 516 | executable graph-db-demo 517 | hs-source-dirs: 518 | executables 519 | main-is: 520 | Demo.hs 521 | ghc-options: 522 | -O2 523 | -threaded 524 | "-with-rtsopts=-N" 525 | build-depends: 526 | graph-db, 527 | text, 528 | basic-prelude == 0.3.*, 529 | base >= 4.5 && < 5 530 | default-extensions: 531 | Arrows 532 | BangPatterns 533 | ConstraintKinds 534 | DataKinds 535 | DefaultSignatures 536 | DeriveDataTypeable 537 | DeriveFunctor 538 | DeriveGeneric 539 | EmptyDataDecls 540 | FlexibleContexts 541 | FlexibleInstances 542 | FunctionalDependencies 543 | GADTs 544 | GeneralizedNewtypeDeriving 545 | ImpredicativeTypes 546 | LambdaCase 547 | LiberalTypeSynonyms 548 | MultiParamTypeClasses 549 | MultiWayIf 550 | NoImplicitPrelude 551 | NoMonomorphismRestriction 552 | OverloadedStrings 553 | PatternGuards 554 | QuasiQuotes 555 | RankNTypes 556 | RecordWildCards 557 | ScopedTypeVariables 558 | StandaloneDeriving 559 | TemplateHaskell 560 | TupleSections 561 | TypeFamilies 562 | TypeOperators 563 | default-language: 564 | Haskell2010 565 | 566 | -------------------------------------------------------------------------------- /library/GraphDB.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The API is based on multiple monads and monad transformers: 3 | -- 4 | -- * 'Session'. 5 | -- A class of monad transformers, 6 | -- which execute transactions and run the server. 7 | -- 8 | -- * 'Read' and 'Write' transactions. 9 | -- Monads, 10 | -- which execute granular updates or reads on the database with ACID guarantees. 11 | -- 12 | -- The library provides three types of sessions: 13 | -- 14 | -- * A 'Nonpersistent.NonpersistentSession' over an in-memory data structure. 15 | -- 16 | -- * A 'Persistent.PersistentSession' over an in-memory data structure. 17 | -- 18 | -- * A 'Client.ClientSession', 19 | -- which is a networking interface for communication with server. 20 | -- 21 | -- The API of this library is free of exceptions and resource management. 22 | -- This is achieved using monad transformers. 23 | -- All the IO failures are encoded in the results of monad transformers. 24 | -- All the resources are acquired and released automatically. 25 | module GraphDB 26 | ( 27 | -- * Sessions 28 | Session, 29 | -- ** Nonpersistent 30 | Nonpersistent.NonpersistentSession, 31 | runNonpersistentSession, 32 | -- ** Persistent 33 | Persistent.PersistentSession, 34 | PersistentSettings, 35 | Persistent.StoragePath, 36 | Persistent.PersistenceBuffering, 37 | Persistent.PersistenceFailure(..), 38 | runPersistentSession, 39 | -- ** Client 40 | Client.ClientSession, 41 | ClientSettings, 42 | ClientModelVersion, 43 | URL(..), 44 | RemotionClient.Credentials, 45 | ClientFailure(..), 46 | runClientSession, 47 | -- * Transactions 48 | Read, 49 | Write, 50 | ReadOrWrite, 51 | Node, 52 | read, 53 | write, 54 | -- ** Operations 55 | newNode, 56 | getValue, 57 | setValue, 58 | getRoot, 59 | getTargets, 60 | addTarget, 61 | removeTarget, 62 | remove, 63 | getStats, 64 | -- * Modeling 65 | Model.Edge(..), 66 | Graph.Setup, 67 | Model.PolyValue, 68 | Model.PolyIndex, 69 | Macros.deriveSetup, 70 | -- * Server 71 | ServerSettings, 72 | ServerModelVersion, 73 | ListeningMode(..), 74 | RemotionServer.Authenticate, 75 | RemotionServer.Timeout, 76 | RemotionServer.MaxClients, 77 | RemotionServer.Log, 78 | ServerFailure(..), 79 | serve, 80 | -- ** Monad-transformer 81 | Server.Serve, 82 | Server.block, 83 | 84 | ) 85 | where 86 | 87 | import GraphDB.Util.Prelude hiding (write, read, Write, Read, block) 88 | import qualified GraphDB.Model as Model 89 | import qualified GraphDB.Macros as Macros 90 | import qualified GraphDB.Action as Action 91 | import qualified GraphDB.Graph as Graph 92 | import qualified GraphDB.Client as Client 93 | import qualified GraphDB.Persistent as Persistent 94 | import qualified GraphDB.Nonpersistent as Nonpersistent 95 | import qualified GraphDB.Server as Server 96 | import qualified Remotion.Client as RemotionClient 97 | import qualified Remotion.Server as RemotionServer 98 | 99 | 100 | 101 | -- * Sessions 102 | ------------------------- 103 | 104 | -- | 105 | -- A class of monad transformers, 106 | -- which can execute transactions and run a server. 107 | class Session s where 108 | type SessionNode s u 109 | runTransaction :: 110 | (MonadIO m, MonadBaseControl IO m, Graph.Setup u) => 111 | Bool -> SessionAction s u m r -> s u m r 112 | 113 | type Action n u = Action.Action n (Graph.Value u) (Graph.Index u) 114 | type SessionAction s u = Action (SessionNode s u) u 115 | 116 | 117 | 118 | -- ** Nonpersistent 119 | ------------------------- 120 | 121 | instance Session Nonpersistent.NonpersistentSession where 122 | type SessionNode Nonpersistent.NonpersistentSession u = Nonpersistent.Node u 123 | runTransaction w a = Nonpersistent.runTransaction w $ Nonpersistent.runAction $ a 124 | 125 | -- | 126 | -- Run a nonpersistent session, 127 | -- while providing an initial value for the root node. 128 | runNonpersistentSession :: (Model.PolyValue u u, MonadIO m) => u -> Nonpersistent.NonpersistentSession u m r -> m r 129 | runNonpersistentSession v s = do 130 | n <- liftIO $ Graph.new $ Model.packValue $ v 131 | Nonpersistent.runSession n s 132 | 133 | 134 | 135 | -- ** Persistent 136 | ------------------------- 137 | 138 | instance Session Persistent.PersistentSession where 139 | type SessionNode Persistent.PersistentSession u = Persistent.Node u 140 | runTransaction w a = Persistent.runTransaction w $ Persistent.runAction $ a 141 | 142 | -- | 143 | -- Settings of a persistent session. 144 | -- 145 | -- The first parameter is an initial value for the root node. 146 | -- It will only be used if the graph has not been previously persisted, 147 | -- i.e. on the first run of the DB. 148 | type PersistentSettings v = (v, Persistent.StoragePath, Persistent.PersistenceBuffering) 149 | 150 | -- | 151 | -- Run a persistent session with settings. 152 | runPersistentSession :: 153 | (MonadIO m, MonadBaseControl IO m, Model.PolyValue u u) => 154 | PersistentSettings u -> Persistent.PersistentSession u m r -> m (Either Persistent.PersistenceFailure r) 155 | runPersistentSession (v, p, e) s = do 156 | Persistent.runSession (Model.packValue $ v, p, e) s 157 | 158 | 159 | 160 | -- ** Client 161 | ------------------------- 162 | 163 | instance Session Client.ClientSession where 164 | type SessionNode Client.ClientSession u = Int 165 | runTransaction w a = Client.runTransaction w $ Client.runAction $ a 166 | 167 | -- | 168 | -- Settings of a client session. 169 | type ClientSettings = (ClientModelVersion, URL) 170 | 171 | -- | 172 | -- Version of the graph model, 173 | -- which is used to check the client and server compatibility during handshake. 174 | type ClientModelVersion = Int 175 | 176 | -- | 177 | -- Location of the server. 178 | data URL = 179 | -- | Path to the socket-file. 180 | URL_Socket FilePath | 181 | -- | Host name, port and credentials. 182 | URL_Host Text Int RemotionClient.Credentials 183 | 184 | data ClientFailure = 185 | -- | 186 | -- Unable to connect to the provided url. 187 | UnreachableURL | 188 | -- | 189 | -- The server has too many connections already. 190 | -- It's suggested to retry later. 191 | ServerIsBusy | 192 | -- | 193 | -- Incorrect credentials. 194 | Unauthenticated | 195 | -- | 196 | -- Either the connection got interrupted for some reason or 197 | -- a communication timeout has been reached. 198 | ConnectionFailure | 199 | -- | 200 | -- Either the graph model does not match the one on the server or 201 | -- the server runs an incompatible version of \"graph-db\". 202 | Incompatible | 203 | -- | 204 | -- The server was unable to deserialize the request. 205 | -- This is only expected to happen when the same 'ClientModelVersion' 206 | -- was used for incompatible models. 207 | CorruptRequest Text 208 | deriving (Show, Eq) 209 | 210 | -- | 211 | -- Run a client session with settings. 212 | runClientSession :: 213 | (MonadIO m, MonadBaseControl IO m, Graph.Setup u) => 214 | ClientSettings -> Client.ClientSession u m r -> m (Either ClientFailure r) 215 | runClientSession (v, url) (ses) = 216 | fmap (fmapL adaptRemotionFailure) $ Client.runSession (rv, rurl) $ ses 217 | where 218 | adaptRemotionFailure = \case 219 | RemotionClient.UnreachableURL -> UnreachableURL 220 | RemotionClient.ServerIsBusy -> ServerIsBusy 221 | RemotionClient.ProtocolVersionMismatch _ _ -> Incompatible 222 | RemotionClient.UserProtocolSignatureMismatch _ _ -> Incompatible 223 | RemotionClient.Unauthenticated -> Unauthenticated 224 | RemotionClient.ConnectionInterrupted -> ConnectionFailure 225 | RemotionClient.TimeoutReached _ -> ConnectionFailure 226 | RemotionClient.CorruptRequest t -> CorruptRequest t 227 | rv = fromString $ show $ v 228 | rurl = case url of 229 | URL_Socket f -> RemotionClient.Socket f 230 | URL_Host n p c -> RemotionClient.Host n p c 231 | 232 | -- * Transactions 233 | ------------------------- 234 | 235 | -- | 236 | -- A read-only transaction. 237 | -- 238 | -- Gets executed concurrently. 239 | newtype Read s u t r = 240 | Read (SessionAction s u Identity r) 241 | deriving (Functor, Applicative, Monad) 242 | 243 | -- | 244 | -- A write and read transaction. 245 | -- 246 | -- Does not allow concurrency, 247 | -- so all concurrent transactions are put on hold for the time of its execution. 248 | newtype Write s u t r = 249 | Write (SessionAction s u Identity r) 250 | deriving (Functor, Applicative, Monad) 251 | 252 | -- | 253 | -- Transactions of this type can be composed with both 'Read' and 'Write'. 254 | type ReadOrWrite s u t r = 255 | forall tr. (Transaction tr, Monad (tr s u t), Applicative (tr s u t)) => 256 | tr s u t r 257 | 258 | class Transaction tr where 259 | liftAction :: SessionAction s u Identity r -> tr s u t r 260 | instance Transaction Read where liftAction = Read 261 | instance Transaction Write where liftAction = Write 262 | 263 | -- | 264 | -- A transaction-local reference to an actual node of the graph. 265 | -- 266 | -- @t@ is the so called \"state thread\". 267 | -- It is an uninstantiated type-variable, 268 | -- which makes it impossible to return a node from transaction, 269 | -- when it is executed using 'write' or 'read'. 270 | -- Much inspired by the implementation of 'ST'. 271 | newtype Node s u t v = Node (SessionNode s u) 272 | 273 | -- | 274 | -- Execute a read-only transaction. 275 | -- Gets executed concurrently. 276 | -- 277 | -- Concerning the \"forall\" part refer to 'Node'. 278 | read :: (Graph.Setup u, Session s, MonadBaseControl IO m, MonadIO m) => (forall t. Read s u t r) -> s u m r 279 | read (Read a) = runTransaction False $ hoistFreeT (return . runIdentity) $ a 280 | 281 | -- | 282 | -- Execute a writing transaction. 283 | -- 284 | -- Does not allow concurrent transactions, 285 | -- so all concurrent transactions are put on hold for the time of execution. 286 | -- 287 | -- Concerning the \"forall\" part refer to 'Node'. 288 | write :: (Graph.Setup u, Session s, MonadBaseControl IO m, MonadIO m) => (forall t. Write s u t r) -> s u m r 289 | write (Write a) = runTransaction True $ hoistFreeT (return . runIdentity) $ a 290 | 291 | 292 | 293 | -- ** Operations 294 | ------------------------- 295 | 296 | -- | 297 | -- Create a new node. 298 | -- 299 | -- This node won't get stored if you don't insert at least a single edge 300 | -- from another stored node to it. 301 | newNode :: (Model.PolyValue u v) => v -> Write s u t (Node s u t v) 302 | newNode v = fmap Node $ liftAction $ Action.newNode $ Model.packValue v 303 | 304 | -- | 305 | -- Get a value of the node. 306 | getValue :: (Model.PolyValue u v) => Node s u t v -> ReadOrWrite s u t v 307 | getValue (Node n) = 308 | fmap (fromMaybe ($bug "Unexpected packed value") . Model.unpackValue) $ 309 | liftAction $ Action.getValue n 310 | 311 | -- | 312 | -- Replace the value of the specified node. 313 | setValue :: (Model.PolyValue u v) => Node s u t v -> v -> Write s u t () 314 | setValue (Node n) v = Write $ Action.setValue n (Model.packValue v) 315 | 316 | -- | 317 | -- Get the root node. 318 | getRoot :: ReadOrWrite s u t (Node s u t u) 319 | getRoot = fmap Node $ liftAction $ Action.getRoot 320 | 321 | -- | 322 | -- Get target nodes reachable by the provided index. 323 | getTargets :: 324 | (Model.PolyIndex u i, i ~ Model.Index v v') => 325 | Node s u t v -> i -> ReadOrWrite s u t [Node s u t v'] 326 | getTargets (Node n) i = 327 | fmap (map Node) $ liftAction $ Action.getTargets n $ Model.packIndex i 328 | 329 | -- | 330 | -- Add a link to the provided target node /v'/, 331 | -- while automatically generating all the indexes. 332 | -- 333 | -- The result signals, whether the operation has actually been performed. 334 | -- If the node is already there it will return 'False'. 335 | addTarget :: (Model.Edge v v') => Node s u t v -> Node s u t v' -> Write s u t () 336 | addTarget (Node s) (Node t) = Write $ Action.addTarget s t 337 | 338 | -- | 339 | -- Remove the target node /v'/ and all its indexes from the source node /v/. 340 | -- 341 | -- The result signals, whether the operation has actually been performed. 342 | -- If the node is not found it will return 'False'. 343 | removeTarget :: (Model.Edge v v') => Node s u t v -> Node s u t v' -> Write s u t () 344 | removeTarget (Node s) (Node t) = Write $ Action.removeTarget s t 345 | 346 | -- | 347 | -- Remove a node and all edges to it from other nodes. 348 | remove :: Node s u t v -> Write s u t () 349 | remove (Node n) = Write $ Action.remove n 350 | 351 | -- | 352 | -- Count the total amounts of distinct nodes, edges and indexes in the graph. 353 | -- 354 | -- Requires a traversal of the whole graph, so beware. 355 | getStats :: ReadOrWrite s u t (Int, Int, Int) 356 | getStats = liftAction $ Action.getStats 357 | 358 | 359 | 360 | -- * Server 361 | ------------------------- 362 | 363 | -- | 364 | -- Settings of server. 365 | type ServerSettings = 366 | ( 367 | ServerModelVersion, 368 | ListeningMode, 369 | RemotionServer.Timeout, 370 | RemotionServer.MaxClients, 371 | RemotionServer.Log 372 | ) 373 | 374 | -- | 375 | -- Version of the graph model, 376 | -- which is used to check the client and server compatibility during handshake. 377 | type ServerModelVersion = Int 378 | 379 | -- | Defines how to listen for connections. 380 | data ListeningMode = 381 | -- | 382 | -- Listen on a port with an authentication function. 383 | ListeningMode_Host Int RemotionServer.Authenticate | 384 | -- | 385 | -- Listen on a socket file. 386 | -- Since sockets are local no authentication is needed. 387 | -- Works only on UNIX systems. 388 | ListeningMode_Socket FilePath 389 | 390 | -- | 391 | -- A server failure. 392 | data ServerFailure = 393 | ListeningSocketIsBusy 394 | 395 | -- | 396 | -- Run a server on this session. 397 | serve :: 398 | (Session s, MonadIO (s u m), MonadBaseControl IO (s u m), MonadTrans (s u), 399 | MonadBaseControl IO m, MonadIO m, Graph.Setup u) => 400 | ServerSettings -> Server.Serve m r -> s u m (Either ServerFailure r) 401 | serve (v, lm, to, mc, log) (Server.Serve rs) = do 402 | transactionsChan <- liftIO $ newChan 403 | let 404 | ups = fromString $ show $ v 405 | pur = Server.processRequest transactionsChan 406 | settings = (ups, convertListeningMode lm, to, mc, log, pur) 407 | r <- RemotionServer.run settings $ do 408 | r <- liftWith $ \runRS -> do 409 | worker <- asyncRethrowing $ forever $ do 410 | (w, comm) <- liftIO $ readChan transactionsChan 411 | asyncRethrowing $ runTransaction w $ Server.runCommandProcessor comm 412 | r <- lift $ runRS $ rs 413 | cancel worker 414 | return r 415 | restoreT $ return r 416 | return $ fmapL adaptRemotionFailure $ r 417 | where 418 | adaptRemotionFailure = \case 419 | RemotionServer.ListeningSocketIsBusy -> ListeningSocketIsBusy 420 | convertListeningMode = \case 421 | ListeningMode_Host p a -> RemotionServer.Host p a 422 | ListeningMode_Socket f -> RemotionServer.Socket f 423 | -------------------------------------------------------------------------------- /library/GraphDB/Action.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Provides a low-level transaction over union types 3 | -- without distinction between write and read. 4 | module GraphDB.Action where 5 | 6 | import GraphDB.Util.Prelude 7 | 8 | 9 | type Action n v i = FreeT (ActionF n v i) 10 | 11 | data ActionF n v i a = 12 | NewNode v (n -> a) | 13 | GetValue n (v -> a) | 14 | SetValue n v a | 15 | GetRoot (n -> a) | 16 | GetTargets n i ([n] -> a) | 17 | AddTarget n n a | 18 | RemoveTarget n n a | 19 | Remove n a | 20 | GetStats ((Int, Int, Int) -> a) 21 | deriving (Functor) 22 | 23 | makeFree ''ActionF 24 | 25 | -------------------------------------------------------------------------------- /library/GraphDB/Client.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Client where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified GraphDB.Action as A 5 | import qualified GraphDB.Protocol as P 6 | import qualified GraphDB.Graph as G 7 | import qualified Remotion.Client as RC 8 | 9 | 10 | -- * Session 11 | ------------------------- 12 | 13 | -- | 14 | -- A session of communication with server. 15 | newtype ClientSession s m r = 16 | ClientSession (Client s m r) 17 | deriving (Functor, Applicative, Monad, MonadIO) 18 | 19 | type Client s = RC.Client (P.Request s) (P.Response s) 20 | 21 | instance MonadTrans (ClientSession s) where 22 | lift = ClientSession . lift 23 | 24 | instance MonadTransControl (ClientSession s) where 25 | newtype StT (ClientSession s) r = ClientSessionStT (StT (Client s) r) 26 | liftWith runInInner = 27 | ClientSession $ liftWith $ \runClient -> runInInner $ \(ClientSession s) -> 28 | liftM ClientSessionStT $ runClient $ s 29 | restoreT inner = do 30 | ClientSession $ do 31 | ClientSessionStT r <- lift $ inner 32 | restoreT $ return $ r 33 | 34 | instance (MonadBase IO m) => MonadBase IO (ClientSession s m) where 35 | liftBase = ClientSession . liftBase 36 | 37 | instance (MonadBaseControl IO m) => MonadBaseControl IO (ClientSession s m) where 38 | newtype StM (ClientSession s m) a = ClientSessionStM { unClientSessionStM :: ComposeSt (ClientSession s) m a } 39 | liftBaseWith = defaultLiftBaseWith ClientSessionStM 40 | restoreM = defaultRestoreM unClientSessionStM 41 | 42 | type ClientSessionSettings = RC.Settings 43 | 44 | runSession :: 45 | (Serializable IO (G.Value s), Serializable IO (G.Index s), MonadBaseControl IO m, MonadIO m) => 46 | ClientSessionSettings -> ClientSession s m r -> m (Either RC.Failure r) 47 | runSession settings (ClientSession ses) = RC.run settings ses 48 | 49 | 50 | -- * Transaction 51 | ------------------------- 52 | 53 | runTransaction :: 54 | (MonadIO m, Applicative m, Serializable IO (G.Value s), Serializable IO (G.Index s)) => 55 | Bool -> ClientSession s m r -> ClientSession s m r 56 | runTransaction write tx = do 57 | ClientSession $ RC.request $ P.Start write 58 | r <- tx 59 | ClientSession $ RC.request $ P.Finish 60 | return r 61 | 62 | 63 | -- * Action 64 | ------------------------- 65 | 66 | type Action s = A.Action Int (G.Value s) (G.Index s) 67 | 68 | runAction :: 69 | (MonadIO m, Applicative m, Serializable IO (G.Value s), Serializable IO (G.Index s)) => 70 | Action s m r -> ClientSession s m r 71 | runAction = iterTM $ \case 72 | A.NewNode v c -> do 73 | r <- req $ P.NewNode v 74 | case r of 75 | P.Node n -> c n 76 | _ -> $bug "Unexpected response" 77 | A.GetValue n c -> do 78 | r <- req $ P.GetValue n 79 | case r of 80 | P.Value v -> c v 81 | _ -> $bug "Unexpected response" 82 | A.SetValue n v c -> do 83 | r <- req $ P.SetValue n v 84 | case r of 85 | P.Unit -> c 86 | _ -> $bug "Unexpected response" 87 | A.GetRoot c -> do 88 | r <- req $ P.GetRoot 89 | case r of 90 | P.Node n -> c n 91 | _ -> $bug "Unexpected response" 92 | A.GetTargets n i c -> do 93 | r <- req $ P.GetTargets n i 94 | case r of 95 | P.NodeList nl -> c nl 96 | _ -> $bug "Unexpected response" 97 | A.AddTarget s t c -> do 98 | r <- req $ P.AddTarget s t 99 | case r of 100 | P.Unit -> c 101 | _ -> $bug "Unexpected response" 102 | A.RemoveTarget s t c -> do 103 | r <- req $ P.RemoveTarget s t 104 | case r of 105 | P.Unit -> c 106 | _ -> $bug "Unexpected response" 107 | A.Remove n c -> do 108 | (req $ P.Remove n) >>= \case 109 | P.Unit -> c 110 | _ -> $bug "Unexpected response" 111 | A.GetStats c -> do 112 | r <- req $ P.GetStats 113 | case r of 114 | P.Stats r -> c r 115 | _ -> $bug "Unexpected response" 116 | where 117 | req = ClientSession . RC.request . P.Action 118 | 119 | -------------------------------------------------------------------------------- /library/GraphDB/Graph.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- A graph API over monomorphic values. 3 | module GraphDB.Graph where 4 | 5 | import GraphDB.Util.Prelude 6 | import qualified GraphDB.Util.DIOVector as V 7 | import qualified HashtablesPlus as H 8 | import qualified HashtablesPlus.HashRef as HR 9 | 10 | 11 | type Basic = H.Basic 12 | type Cuckoo = H.Cuckoo 13 | type Linear = H.Linear 14 | 15 | class (H.Algorithm (Algorithm s), H.Key (Index s), 16 | Serializable IO (Value s), Serializable IO (Index s)) => Setup s where 17 | -- | 18 | -- Any of the "hashtables-plus" algorithms: 19 | -- 'H.Basic', 'H.Cuckoo', 'H.Linear'. 20 | -- 21 | -- Affects performance and memory footprint of the graph. 22 | type Algorithm s :: * -> * -> * -> * 23 | data Index s 24 | data Value s 25 | indexes :: Value s -> Value s -> [Index s] 26 | 27 | data Refs s = 28 | Refs { 29 | refsValue :: {-# UNPACK #-} !(IORef (Value s)), 30 | refsTargets :: !(H.Multimap (Algorithm s) (Index s) (H.HashRefSet (Algorithm s) (Refs s))), 31 | refsSources :: !(H.HashRefSet (Algorithm s) (Refs s)) 32 | } 33 | 34 | type Node s = HR.HashRef (Refs s) 35 | 36 | 37 | -- * Operations 38 | ------------------------- 39 | 40 | new :: (Setup s) => Value s -> IO (Node s) 41 | new v = HR.new =<< Refs <$> newIORef v <*> H.new <*> H.new 42 | 43 | getValue :: Node s -> IO (Value s) 44 | getValue = readIORef . refsValue . HR.value 45 | 46 | setValue :: (Setup s) => Node s -> Value s -> IO () 47 | setValue node newValue = do 48 | oldValue <- getValue node 49 | H.traverse (refsSources $ HR.value $ node) $ \source -> do 50 | sourceValue <- getValue source 51 | forM_ (indexes oldValue sourceValue) $ \i -> do 52 | H.deleteFast (refsTargets $ HR.value $ source) (i, node) 53 | forM_ (indexes newValue sourceValue) $ \i -> do 54 | H.insertFast (refsTargets $ HR.value $ source) (i, node) 55 | writeIORef (refsValue $ HR.value $ node) newValue 56 | 57 | addTarget :: (Setup s) => Node s -> Node s -> IO () 58 | addTarget source target = do 59 | il <- pure indexes <*> getValue target <*> getValue source 60 | forM_ il $ \i -> H.insertFast (refsTargets . HR.value $ source) (i, target) 61 | H.insertFast (refsSources $ HR.value $ target) source 62 | 63 | removeTarget :: (Setup s) => Node s -> Node s -> IO () 64 | removeTarget source target = do 65 | il <- pure indexes <*> getValue target <*> getValue source 66 | forM_ il $ \i -> H.deleteFast (refsTargets $ HR.value $ source) (i, target) 67 | H.deleteFast (refsSources $ HR.value $ target) source 68 | 69 | traverseTargetsByIndex :: (Setup s) => Node s -> Index s -> (Node s -> IO ()) -> IO () 70 | traverseTargetsByIndex source index = H.traverseMulti (refsTargets $ HR.value $ source) index 71 | 72 | traverseTargets :: (Setup s) => Node s -> (Node s -> IO ()) -> IO () 73 | traverseTargets source f = do 74 | visited :: H.Set H.Basic (Node s) <- H.new 75 | H.traverse (refsTargets $ HR.value $ source) $ \(i, target) -> do 76 | notVisited <- H.insert visited target 77 | when notVisited $ f target 78 | 79 | traverseSources :: (Setup s) => Node s -> (Node s -> IO ()) -> IO () 80 | traverseSources target = H.traverse (refsSources $ HR.value $ target) 81 | 82 | getStats :: (Setup s) => Node s -> IO Stats 83 | getStats root = do 84 | nodesCounter <- newIORef 0 85 | edgesCounter <- newIORef 0 86 | indexesCounter <- newIORef 0 87 | knownSet :: H.Set H.Basic (Node s) <- H.new 88 | loopQueue <- newIORef [] 89 | let 90 | loop = do 91 | dequeue >>= \case 92 | Nothing -> return () 93 | Just node -> do 94 | modifyIORef nodesCounter succ 95 | do 96 | targetsSet :: H.Set H.Basic (Node s) <- H.new 97 | H.traverse (refsTargets $ HR.value $ node) $ \(i, target) -> do 98 | notVisited <- H.insert targetsSet target 99 | when notVisited $ do 100 | modifyIORef edgesCounter succ 101 | enqueue target 102 | modifyIORef indexesCounter succ 103 | loop 104 | dequeue = do 105 | readIORef loopQueue >>= \case 106 | h : t -> writeIORef loopQueue t >> return (Just h) 107 | [] -> return Nothing 108 | enqueue node = do 109 | H.elem knownSet node >>= \case 110 | True -> return () 111 | False -> do 112 | H.insertFast knownSet node 113 | modifyIORef loopQueue (node:) 114 | 115 | enqueue root 116 | loop 117 | 118 | (,,) <$> readIORef nodesCounter <*> readIORef edgesCounter <*> readIORef indexesCounter 119 | 120 | type Stats = (Int, Int, Int) 121 | 122 | 123 | -- ** Higher level operations 124 | ------------------------- 125 | 126 | remove :: (Setup s) => Node s -> IO () 127 | remove node = traverseSources node $ \s -> removeTarget s node 128 | 129 | getTargets :: (Setup s) => Node s -> Index s -> IO [Node s] 130 | getTargets n i = do 131 | l <- newIORef [] 132 | traverseTargetsByIndex n i $ \t -> modifyIORef l (t:) 133 | readIORef l 134 | 135 | getSources :: (Setup s) => Node s -> IO [Node s] 136 | getSources n = do 137 | l <- newIORef [] 138 | traverseSources n $ \s -> modifyIORef l (s:) 139 | readIORef l 140 | 141 | 142 | -- * Serialization 143 | ------------------------- 144 | 145 | instance (Setup s) => Serializable IO (Node s) where 146 | 147 | serialize root = do 148 | loopQueue <- lift $ newIORef [] 149 | knownSet :: H.Set H.Basic (Node s) <- lift $ H.new 150 | indexesMap :: H.Map H.Basic (Node s) Int <- lift $ H.new 151 | indexCounter <- lift $ newIORef 0 152 | let 153 | loop = do 154 | dequeue >>= \case 155 | Nothing -> return () 156 | Just node -> do 157 | (count, serializeTargets) <- liftIO $ do 158 | count <- newIORef (0 :: Int) 159 | serializeTargets <- newIORef (return ()) 160 | traverseTargets node $ \target -> do 161 | modifyIORef count $ succ 162 | modifyIORef serializeTargets $ \acc -> do 163 | acc 164 | serializeValue target 165 | enqueue target 166 | (,) <$> readIORef count <*> readIORef serializeTargets 167 | serialize count 168 | serializeTargets 169 | loop 170 | serializeValue node = do 171 | (liftIO $ H.lookup indexesMap node) >>= \case 172 | Just i -> do 173 | serialize True 174 | serialize i 175 | Nothing -> do 176 | serialize False 177 | do 178 | i <- liftIO $ readIORef indexCounter <* modifyIORef indexCounter succ 179 | liftIO $ H.insertFast indexesMap (node, i) 180 | serialize =<< do liftIO $ getValue node 181 | enqueue node = liftIO $ do 182 | H.elem knownSet node >>= \case 183 | True -> return () 184 | False -> do 185 | H.insertFast knownSet node 186 | modifyIORef loopQueue (node:) 187 | dequeue = liftIO $ do 188 | readIORef loopQueue >>= \case 189 | h : t -> do 190 | writeIORef loopQueue t 191 | return $ Just h 192 | [] -> return Nothing 193 | serializeValue root 194 | enqueue root 195 | loop 196 | 197 | deserialize = do 198 | indexedNodes <- liftIO $ V.newSized $ 10^6 199 | unpopulatedNodes <- liftIO $ newIORef [] 200 | let 201 | fetchUnpopulatedNode = 202 | liftIO $ atomicModifyIORef' unpopulatedNodes $ \case 203 | head : tail -> (tail, Just head) 204 | _ -> ([], Nothing) 205 | enqueueUnpopulatedNode node = 206 | liftIO $ modifyIORef unpopulatedNodes (node:) 207 | deserializeNode = do 208 | deserialize >>= \case 209 | True -> liftIO . V.unsafeLookup indexedNodes =<< deserialize 210 | False -> do 211 | newNode <- liftIO . new =<< deserialize 212 | liftIO $ V.append indexedNodes newNode 213 | enqueueUnpopulatedNode newNode 214 | return newNode 215 | loopAddTargets = do 216 | fetchUnpopulatedNode >>= \case 217 | Nothing -> return () 218 | Just source -> do 219 | count <- deserialize 220 | replicateM_ count $ do 221 | target <- deserializeNode 222 | liftIO $ addTarget source target 223 | loopAddTargets 224 | 225 | node <- deserializeNode 226 | loopAddTargets 227 | 228 | return node 229 | 230 | 231 | 232 | -------------------------------------------------------------------------------- /library/GraphDB/Macros.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Macros where 2 | 3 | import GraphDB.Util.Prelude 4 | import GraphDB.Util.Prelude.TH 5 | import qualified GraphDB.Util.TH as THU 6 | import qualified GraphDB.Graph as G 7 | import qualified GraphDB.Model as M 8 | import qualified GraphDB.Macros.Templates as T 9 | import qualified GraphDB.Macros.Analysis as A 10 | 11 | 12 | -- | 13 | -- Generate all the boilerplate code by the type of the root node. 14 | deriveSetup :: Name -> Q [Dec] 15 | deriveSetup root = do 16 | -- The work is done in three phases: 17 | -- 1. While in the 'Q' monad, reify all the required information. 18 | -- 2. Leave the 'Q' monad and run a pure analysis on that information 19 | -- to produce settings for templates to render. 20 | -- 3. While still out of the 'Q' monad, render all the templates. 21 | -- 22 | -- Such strategy allows to separate the concerns and 23 | -- exploit parallelism in the last two phases. 24 | edgePairs <- reifyEdgePairs 25 | let (polyIndexS, polyValueS, hashableS, serializableS, setupS) = A.decs (ConT root) edgePairs 26 | hashableS' <- filterM (fmap not . isInstance' ''Hashable . (:[])) hashableS 27 | serializableS' <- 28 | filterM 29 | (fmap not . isInstance' ''Serializable . (\t -> [ConT ''IO, t])) 30 | serializableS 31 | 32 | return $ T.renderDecs (polyIndexS, polyValueS, hashableS', serializableS', setupS) 33 | 34 | -- | 35 | -- Scan the current module for instance declarations of 'M.Edge' and 36 | -- collect the pairs of the types they link. 37 | reifyEdgePairs :: Q [(Type, Type)] 38 | reifyEdgePairs = do 39 | instances <- THU.reifyLocalInstances 40 | return $ do 41 | (n, tl) <- instances 42 | guard $ n == ''M.Edge 43 | case tl of [a, b] -> return (a, b) 44 | -------------------------------------------------------------------------------- /library/GraphDB/Macros/Analysis.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Pure computations on a reified data. 3 | module GraphDB.Macros.Analysis where 4 | 5 | import GraphDB.Util.Prelude 6 | import GraphDB.Util.Prelude.TH 7 | import qualified GraphDB.Util.TH.Type as TH 8 | import qualified GraphDB.Model as M 9 | import qualified GraphDB.Graph as G 10 | import qualified GraphDB.Macros.Templates as T 11 | 12 | 13 | type Root = Type 14 | -- | A source and target type of an edge. 15 | type EdgeInfo = (Type, Type) 16 | 17 | decs :: Root -> [EdgeInfo] -> T.Decs 18 | decs root infos = 19 | let 20 | assocs = edgeInfosToConAssocs root infos 21 | indexes = map conAssocToIndex assocs 22 | values = nub $ concatMap conAssocToValues assocs 23 | indexesFunctionClauses = map conAssocToIndexesClause assocs 24 | polyIndexInstances = map (\(c, t) -> (root, c, t)) indexes 25 | polyValueInstances = map (\(c, t) -> (root, c, t)) values 26 | hashableInstances = 27 | nub $ concat $ 28 | [ 29 | ConT ''G.Index `AppT` root, 30 | ConT ''G.Value `AppT` root 31 | ] : 32 | indexTypes : 33 | valueTypes : 34 | leafTypes 35 | where 36 | indexTypes = indexes |> map sumConType 37 | valueTypes = values |> map sumConType 38 | leafTypes = map TH.monoTypes valueTypes 39 | serializableInstances = hashableInstances 40 | in 41 | ( 42 | polyIndexInstances, 43 | polyValueInstances, 44 | hashableInstances, 45 | serializableInstances, 46 | ( 47 | root, 48 | indexes, 49 | values, 50 | indexesFunctionClauses 51 | ) 52 | ) 53 | 54 | -- | An association of an index, source and target. 55 | type ConAssoc = (T.SumConstructor, T.SumConstructor, T.SumConstructor) 56 | 57 | edgeInfosToConAssocs :: Root -> [EdgeInfo] -> [ConAssoc] 58 | edgeInfosToConAssocs root infos = 59 | runST $ do 60 | regIndexType <- regType <$> pure indexPrefix <*> newSTRef 0 <*> newSTRef [] 61 | regValueType <- regType <$> pure valuePrefix <*> newSTRef 0 <*> newSTRef [] 62 | forM infos $ \(l, r) -> do 63 | let indexT = ConT ''M.Index `AppT` l `AppT` r 64 | index <- regIndexType indexT 65 | lc <- regValueType l 66 | rc <- regValueType r 67 | return (index, lc, rc) 68 | where 69 | regType prefix counterRef tableRef t = do 70 | readSTRef tableRef >>= return . lookup t >>= \case 71 | Just c -> return (c, t) 72 | Nothing -> do 73 | i <- readSTRef counterRef 74 | let c = mkName $ prefix <> show i 75 | modifySTRef tableRef ((t, c) :) 76 | writeSTRef counterRef (succ i) 77 | return (c, t) 78 | rootName = case root of 79 | ConT n -> n 80 | _ -> $bug $ "Not a constructor type: " <> show root 81 | indexPrefix = "GraphDB_Index_" <> nameBase rootName <> "_" 82 | valuePrefix = "GraphDB_Value_" <> nameBase rootName <> "_" 83 | 84 | conAssocToIndex :: ConAssoc -> T.SumConstructor 85 | conAssocToIndex (i, _, _) = i 86 | 87 | conAssocToValues :: ConAssoc -> [T.SumConstructor] 88 | conAssocToValues (_, l, r) = [l, r] 89 | 90 | conAssocToIndexesClause :: ConAssoc -> T.IndexesClause 91 | conAssocToIndexesClause ((n, _), (n', _), (n'', _)) = (n, n', n'') 92 | 93 | sumConType :: T.SumConstructor -> Type 94 | sumConType (_, t) = t 95 | -------------------------------------------------------------------------------- /library/GraphDB/Macros/Templates.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module GraphDB.Macros.Templates where 3 | 4 | import GraphDB.Util.Prelude 5 | import GraphDB.Util.Prelude.TH 6 | import qualified GraphDB.Graph as G 7 | import qualified GraphDB.Model as M 8 | 9 | 10 | 11 | type Decs = 12 | ( 13 | [PolyIndexInstance], 14 | [PolyValueInstance], 15 | [HashableInstance], 16 | [SerializableInstance], 17 | SetupInstance 18 | ) 19 | 20 | renderDecs :: Decs -> [Dec] 21 | renderDecs (a, b, c, d, e) = 22 | let 23 | a' = map renderPolyIndexInstance a 24 | b' = map renderPolyValueInstance b 25 | c' = map renderHashableInstance c 26 | d' = map renderSerializableInstance d 27 | e' = renderSetupInstance e 28 | in 29 | e' : a' ++ b' ++ c' ++ d' 30 | 31 | 32 | 33 | type SetupInstance = 34 | ( 35 | Type, 36 | [SumConstructor], 37 | [SumConstructor], 38 | [IndexesClause] 39 | ) 40 | 41 | renderSetupInstance :: SetupInstance -> Dec 42 | renderSetupInstance (setup, indexes, values, indexesFunctionClauses) = 43 | InstanceD 44 | [] 45 | (AppT (ConT ''G.Setup) (setup)) 46 | [ 47 | #if MIN_VERSION_template_haskell(2,9,0) 48 | TySynInstD ''G.Algorithm (TySynEqn [setup] (ConT ''G.Linear)), 49 | #else 50 | TySynInstD ''G.Algorithm [setup] (ConT ''G.Linear), 51 | #endif 52 | renderSumData ''G.Index setup IsStrict indexes, 53 | renderSumData ''G.Value setup NotStrict values, 54 | FunD 'G.indexes (map renderIndexesClause indexesFunctionClauses) 55 | ] 56 | 57 | 58 | 59 | type SumConstructor = (Name, Type) 60 | 61 | renderSumData :: Name -> Type -> Strict -> [SumConstructor] -> Dec 62 | renderSumData name setup strict constructorsData = 63 | DataInstD [] name [setup] constructors derivations 64 | where 65 | constructors = do 66 | (n, t) <- constructorsData 67 | return $ NormalC n [(strict, t)] 68 | derivations = [''Eq, ''Generic] 69 | 70 | 71 | 72 | type IndexesClause = (IndexConstructor, SourceConstructor, TargetConstructor) 73 | type IndexConstructor = Name 74 | type TargetConstructor = Name 75 | type SourceConstructor = Name 76 | 77 | renderIndexesClause :: IndexesClause -> Clause 78 | renderIndexesClause (indexConstructor, sourceConstructor, targetConstructor) = 79 | Clause 80 | [ 81 | ConP targetConstructor [VarP var1], 82 | ConP sourceConstructor [WildP] 83 | ] 84 | (NormalB exp) 85 | [] 86 | where 87 | var1 = mkName "_1" 88 | exp = purify [e| map $(conE indexConstructor) $ M.indexes $(varE var1) |] 89 | 90 | 91 | 92 | type HashableInstance = Type 93 | 94 | renderHashableInstance :: HashableInstance -> Dec 95 | renderHashableInstance t = head $ purify [d| instance Hashable $(return t) |] 96 | 97 | 98 | 99 | type SerializableInstance = Type 100 | 101 | renderSerializableInstance :: SerializableInstance -> Dec 102 | renderSerializableInstance t = head $ purify [d| instance Serializable m $(return t) |] 103 | 104 | 105 | 106 | type PolyValueInstance = (Type, Name, Type) 107 | 108 | renderPolyValueInstance :: PolyValueInstance -> Dec 109 | renderPolyValueInstance (st, c, t) = 110 | InstanceD [] head [packValue, unpackValue] 111 | where 112 | head = ConT ''M.PolyValue `AppT` st `AppT` t 113 | packValue = FunD 'M.packValue [clause] 114 | where 115 | clause = Clause [pattern] body [] 116 | where 117 | pattern = VarP var 118 | var = mkName "_1" 119 | body = NormalB $ purify [e| $(conE c) $(varE var) |] 120 | unpackValue = FunD 'M.unpackValue [clause1, clause2] 121 | where 122 | clause1 = Clause [pattern] body [] 123 | where 124 | pattern = ConP c [VarP var] 125 | var = mkName "_1" 126 | body = NormalB $ purify [e| Just $(varE var) |] 127 | clause2 = Clause [pattern] body [] 128 | where 129 | pattern = WildP 130 | body = NormalB $ purify [e| Nothing |] 131 | 132 | 133 | 134 | type PolyIndexInstance = (Type, Name, Type) 135 | 136 | renderPolyIndexInstance :: PolyIndexInstance -> Dec 137 | renderPolyIndexInstance (setup, c, t) = 138 | head $ purify $ 139 | [d| 140 | instance M.PolyIndex $(pure setup) $(pure t) where 141 | packIndex = $(conE c) 142 | |] 143 | -------------------------------------------------------------------------------- /library/GraphDB/Model.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Model where 2 | 3 | import GraphDB.Util.Prelude hiding (Serializable) 4 | import qualified GHC.Exts 5 | import qualified GraphDB.Util.Prelude as P 6 | import qualified GraphDB.Graph as G 7 | 8 | 9 | type Serializable m s = (P.Serializable m (G.Value s), P.Serializable m (G.Index s)) 10 | 11 | -- | 12 | -- An interface for conversion of a value to an internal representation. 13 | -- 14 | -- Its instances should be generated with 'GraphDB.Model.Macros.deriveUnion'. 15 | class (G.Setup s) => PolyValue s v where 16 | packValue :: v -> G.Value s 17 | unpackValue :: G.Value s -> Maybe v 18 | 19 | -- | 20 | -- An interface for conversion of an index to an internal representation. 21 | -- 22 | -- Its instances should be generated with 'GraphDB.Model.Macros.deriveUnion'. 23 | class (G.Setup s) => PolyIndex s i where 24 | packIndex :: i -> G.Index s 25 | 26 | 27 | -- | 28 | -- Defines a specific set of indexes, which nodes of value /v'/ emit to nodes of value /v/. 29 | -- 30 | -- If the indexes list is empty, 31 | -- the node may still be reached thru 'getTargetsByType'. 32 | -- 33 | -- If there is no instance of this class between two values, 34 | -- then the associated nodes cannot be linked. 35 | -- 36 | class Edge v v' where 37 | data Index v v' 38 | indexes :: v' -> [Index v v'] 39 | indexes = const [] 40 | 41 | 42 | -------------------------------------------------------------------------------- /library/GraphDB/Nonpersistent.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Nonpersistent where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified GraphDB.Action as A 5 | import qualified GraphDB.Graph as G 6 | import qualified Control.Concurrent.FairRWLock as L 7 | 8 | 9 | -- * Session 10 | ------------------------- 11 | 12 | type Node s = G.Node s 13 | 14 | -- | 15 | -- A session of an in-memory graph datastructure with no persistence. 16 | newtype NonpersistentSession s m r = 17 | NonpersistentSession { unSession :: ReaderT (G.Node s) (ReaderT L.RWLock m) r } 18 | deriving (Functor, Applicative, Monad, MonadIO) 19 | 20 | instance MonadTrans (NonpersistentSession s) where 21 | lift = NonpersistentSession . lift . lift 22 | 23 | instance MonadTransControl (NonpersistentSession s) where 24 | newtype StT (NonpersistentSession s) r = SessionStT r 25 | liftWith runInInner = do 26 | root <- NonpersistentSession $ ask 27 | lock <- NonpersistentSession $ lift $ ask 28 | NonpersistentSession $ lift $ lift $ runInInner $ 29 | liftM SessionStT . flip runReaderT lock . flip runReaderT root . unSession 30 | restoreT inner = do 31 | SessionStT r <- NonpersistentSession $ lift $ lift $ inner 32 | return r 33 | 34 | instance (MonadBase IO m) => MonadBase IO (NonpersistentSession s m) where 35 | liftBase = NonpersistentSession . liftBase 36 | 37 | instance (MonadBaseControl IO m) => MonadBaseControl IO (NonpersistentSession s m) where 38 | newtype StM (NonpersistentSession s m) a = SessionStM { unSessionStM :: ComposeSt (NonpersistentSession s) m a } 39 | liftBaseWith = defaultLiftBaseWith SessionStM 40 | restoreM = defaultRestoreM unSessionStM 41 | 42 | runSession :: (MonadIO m) => G.Node s -> NonpersistentSession s m r -> m r 43 | runSession n (NonpersistentSession s) = do 44 | l <- liftIO $ L.new 45 | flip runReaderT l $ flip runReaderT n $ s 46 | 47 | 48 | -- * Transaction 49 | ------------------------- 50 | 51 | runTransaction :: (MonadBaseControl IO m) => Bool -> NonpersistentSession s m r -> NonpersistentSession s m r 52 | runTransaction write tx = do 53 | l <- NonpersistentSession $ lift $ ask 54 | if write 55 | then control $ \runInBase -> L.withWrite l $ runInBase tx 56 | else control $ \runInBase -> L.withRead l $ runInBase tx 57 | 58 | 59 | -- * Action 60 | ------------------------- 61 | 62 | type Action s = A.Action (G.Node s) (G.Value s) (G.Index s) 63 | 64 | runAction :: (MonadIO m, G.Setup s) => Action s m r -> NonpersistentSession s m r 65 | runAction = iterTM $ \case 66 | A.NewNode v c -> liftIO (G.new v) >>= c 67 | A.GetValue n c -> liftIO (G.getValue n) >>= c 68 | A.SetValue n v c -> liftIO (G.setValue n v) >> c 69 | A.GetRoot c -> NonpersistentSession ask >>= c 70 | A.GetTargets n i c -> liftIO (G.getTargets n i) >>= c 71 | A.AddTarget s t c -> liftIO (G.addTarget s t) >> c 72 | A.RemoveTarget s t c -> liftIO (G.removeTarget s t) >> c 73 | A.Remove n c -> liftIO (G.remove n) >> c 74 | A.GetStats c -> NonpersistentSession ask >>= liftIO . G.getStats >>= c 75 | -------------------------------------------------------------------------------- /library/GraphDB/Persistent.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Persistent where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified GraphDB.Action as A 5 | import qualified GraphDB.Graph as G 6 | import qualified GraphDB.Util.FileSystem as FS 7 | import qualified GraphDB.Util.IOQueue as Q 8 | import qualified GraphDB.Storage as S 9 | import qualified GraphDB.Nonpersistent as NP 10 | import qualified GraphDB.Persistent.Log as L 11 | 12 | 13 | -- * Session 14 | ------------------------- 15 | 16 | -- | 17 | -- A session of an in-memory graph datastructure with persistence. 18 | newtype PersistentSession s m r = 19 | PersistentSession (ReaderT (Storage s, Q.IOQueue) (NP.NonpersistentSession s m) r) 20 | deriving (Functor, Applicative, Monad, MonadIO) 21 | 22 | instance MonadTrans (PersistentSession s) where 23 | lift = PersistentSession . lift . lift 24 | 25 | instance MonadTransControl (PersistentSession s) where 26 | newtype StT (PersistentSession s) r = SessionStT (StT (NP.NonpersistentSession s) r) 27 | liftWith runInInner = do 28 | env <- PersistentSession $ ask 29 | PersistentSession $ lift $ liftWith $ \runGraphSession -> runInInner $ \(PersistentSession s) -> 30 | liftM SessionStT . runGraphSession . flip runReaderT env $ s 31 | 32 | restoreT inner = do 33 | PersistentSession $ lift $ do 34 | SessionStT r <- lift inner 35 | restoreT $ return $ r 36 | 37 | instance (MonadBase IO m) => MonadBase IO (PersistentSession s m) where 38 | liftBase = PersistentSession . liftBase 39 | 40 | instance (MonadBaseControl IO m) => MonadBaseControl IO (PersistentSession s m) where 41 | newtype StM (PersistentSession s m) a = SessionStM { unSessionStM :: ComposeSt (PersistentSession s) m a } 42 | liftBaseWith = defaultLiftBaseWith SessionStM 43 | restoreM = defaultRestoreM unSessionStM 44 | 45 | type Storage s = S.Storage (NP.Node s) (L.Log s) 46 | 47 | data PersistenceFailure = 48 | -- | 49 | -- Corrupt data during deserialization of the stored data. 50 | CorruptData Text 51 | deriving (Show) 52 | 53 | type Settings s = (G.Value s, StoragePath, PersistenceBuffering) 54 | -- | 55 | -- A path to a directory, under which update-logs, checkpoints and archive 56 | -- will be stored. 57 | -- 58 | -- The path will be interpreted, 59 | -- so you can use a tilde (@~@) character to refer to user's home directory. 60 | type StoragePath = FilePath 61 | -- | 62 | -- An admissible amount of transactions, 63 | -- by which the persistence layer may be lagging behind the actual state of the graph. 64 | -- Until that amount is reached the persistence of transactions is done asynchronously, 65 | -- thus reducing the time of their execution and of acquisition of related locks. 66 | -- If you want the persisted state to always accomodate to the actual in-memory state, 67 | -- set this to @1@. 68 | -- Thus you can make sure that the persistence of updates is always done synchronously. 69 | type PersistenceBuffering = Int 70 | 71 | runSession :: 72 | (MonadIO m, MonadBaseControl IO m, G.Setup s, Serializable IO (G.Index s)) => 73 | Settings s -> PersistentSession s m r -> m (Either PersistenceFailure r) 74 | runSession (v, p, buffering) (PersistentSession ses) = do 75 | r <- liftBaseWith $ \runInBase -> do 76 | let 77 | acquire = do 78 | paths <- S.pathsFromDirectory p 79 | (storage, graph) <- S.acquireAndLoad initGraph applyLog paths 80 | queue <- Q.start buffering 81 | return (storage, queue, graph) 82 | where 83 | initGraph = G.new v 84 | applyLog graph log = do 85 | void $ runInBase $ NP.runSession graph $ NP.runAction $ L.toAction log 86 | release (storage, queue, graph) = do 87 | Q.finish queue 88 | S.checkpoint storage graph 89 | S.release storage 90 | try $ bracket acquire release $ \(s, q, g) -> do 91 | runInBase $ NP.runSession g $ flip runReaderT (s, q) $ ses 92 | either (return . Left . adaptStorageException) (fmap Right . restoreM) r 93 | where 94 | adaptStorageException = \case 95 | S.DeserializationFailure t -> CorruptData t 96 | 97 | 98 | -- * Transaction 99 | ------------------------- 100 | 101 | newtype Tx s m r = 102 | Tx (StateT (L.Log s) (StateT Int (NP.NonpersistentSession s m)) r) 103 | deriving (Functor, Applicative, Monad, MonadIO) 104 | 105 | instance MonadTrans (Tx s) where 106 | lift = Tx . lift . lift . lift 107 | 108 | runTransaction :: 109 | (MonadBaseControl IO m, Serializable IO (G.Value s), Serializable IO (G.Index s)) => 110 | Bool -> Tx s m r -> PersistentSession s m r 111 | runTransaction write (Tx tx) = PersistentSession $ do 112 | (r, log) <- 113 | lift $ NP.runTransaction write $ flip evalStateT 0 $ flip runStateT [] $ tx 114 | when write $ do 115 | (storage, ioq) <- ask 116 | liftBase $ Q.performAsync ioq $ S.persistEvent storage $ reverse log 117 | return r 118 | 119 | 120 | -- * Action 121 | ------------------------- 122 | 123 | type Action s = A.Action (Node s) (G.Value s) (G.Index s) 124 | type Node s = (G.Node s, Int) 125 | 126 | runAction :: (MonadIO m, G.Setup s) => Action s m r -> Tx s m r 127 | runAction = iterTM $ \case 128 | A.NewNode v c -> do 129 | record $ L.NewNode v 130 | n <- runInner $ A.newNode v 131 | r <- newRef n 132 | c (n, r) 133 | A.GetValue (n, r) c -> do 134 | v <- runInner $ A.getValue n 135 | c v 136 | A.SetValue (n, r) v c -> do 137 | record $ L.SetValue r v 138 | runInner $ A.setValue n v 139 | c 140 | A.GetRoot c -> do 141 | record $ L.GetRoot 142 | n <- runInner $ A.getRoot 143 | r <- newRef n 144 | c (n, r) 145 | A.GetTargets (n, r) i c -> do 146 | record $ L.GetTargets r i 147 | rns <- runInner $ A.getTargets n i 148 | r <- forM rns $ \n -> liftM (n,) $ newRef n 149 | c r 150 | A.AddTarget (sn, sr) (tn, tr) c -> do 151 | record $ L.AddTarget sr tr 152 | runInner $ A.addTarget sn tn 153 | c 154 | A.RemoveTarget (sn, sr) (tn, tr) c -> do 155 | record $ L.RemoveTarget sr tr 156 | runInner $ A.removeTarget sn tn 157 | c 158 | A.Remove (n, r) c -> do 159 | record $ L.Remove r 160 | runInner $ A.remove n 161 | c 162 | A.GetStats c -> do 163 | r <- runInner $ A.getStats 164 | c r 165 | where 166 | record e = Tx $ modify $ (:) e 167 | newRef n = Tx $ lift $ do 168 | index <- get 169 | modify succ 170 | return $ index 171 | runInner = Tx . lift . lift . NP.runAction 172 | 173 | -------------------------------------------------------------------------------- /library/GraphDB/Persistent/Log.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module GraphDB.Persistent.Log where 3 | 4 | import GraphDB.Util.Prelude 5 | 6 | import qualified GraphDB.Action as A 7 | import qualified GraphDB.Graph as G 8 | import qualified GraphDB.Util.FileSystem 9 | import qualified GraphDB.Util.DIOVector as V 10 | 11 | 12 | -- * Log 13 | ------------------------- 14 | 15 | type Log s = [Entry s] 16 | 17 | -- | 18 | -- A serializable representation of a granular transaction action. 19 | -- Essential for persistence. 20 | data Entry s = 21 | GetRoot | 22 | NewNode (G.Value s) | 23 | GetTargets Node (G.Index s) | 24 | AddTarget Node Node | 25 | RemoveTarget Node Node | 26 | Remove Node | 27 | SetValue Node (G.Value s) 28 | deriving (Generic) 29 | 30 | instance (Serializable m (G.Value s), Serializable m (G.Index s)) => Serializable m (Entry s) 31 | 32 | type Node = Int 33 | 34 | 35 | -- * Action 36 | ------------------------- 37 | 38 | toAction :: MonadIO m => Log s -> A.Action n (G.Value s) (G.Index s) m () 39 | toAction log = do 40 | refs <- liftIO $ V.new 41 | let 42 | appendRef = liftIO . void . V.append refs 43 | resolveRef = liftIO . V.unsafeLookup refs 44 | applyEntry = \case 45 | GetRoot -> A.getRoot >>= appendRef 46 | NewNode v -> A.newNode v >>= appendRef 47 | GetTargets r i -> resolveRef r >>= flip A.getTargets i >>= mapM_ appendRef 48 | AddTarget s t -> void $ join $ A.addTarget <$> resolveRef s <*> resolveRef t 49 | RemoveTarget s t -> void $ join $ A.removeTarget <$> resolveRef s <*> resolveRef t 50 | Remove r -> A.remove =<< resolveRef r 51 | SetValue r v -> void $ join $ A.setValue <$> resolveRef r <*> pure v 52 | mapM_ applyEntry log 53 | -------------------------------------------------------------------------------- /library/GraphDB/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | module GraphDB.Protocol where 3 | 4 | import GraphDB.Util.Prelude 5 | import qualified GraphDB.Graph as G 6 | 7 | 8 | data Request s = 9 | Start Write | 10 | Finish | 11 | Action (Action s) 12 | deriving (Generic) 13 | 14 | instance (Serializable m (G.Value s), Serializable m (G.Index s)) => Serializable m (Request s) 15 | 16 | type Write = Bool 17 | 18 | data Action s = 19 | NewNode (G.Value s) | 20 | GetValue Node | 21 | SetValue Node (G.Value s) | 22 | GetRoot | 23 | GetTargets Node (G.Index s) | 24 | AddTarget Node Node | 25 | RemoveTarget Node Node | 26 | Remove Node | 27 | GetStats 28 | deriving (Generic) 29 | 30 | instance (Serializable m (G.Value s), Serializable m (G.Index s)) => Serializable m (Action s) 31 | 32 | type Node = Int 33 | 34 | data Response s = 35 | Unit | 36 | Node Node | 37 | Value (G.Value s) | 38 | NodeList [Node] | 39 | Bool Bool | 40 | Stats G.Stats 41 | deriving (Generic) 42 | 43 | instance (Serializable m (G.Value s), Serializable m (G.Index s)) => Serializable m (Response s) 44 | 45 | -------------------------------------------------------------------------------- /library/GraphDB/Server.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Server where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified Remotion.Server as R 5 | import qualified GraphDB.Util.DIOVector as V 6 | import qualified GraphDB.Protocol as P 7 | import qualified GraphDB.Action as A 8 | import qualified GraphDB.Graph as G 9 | 10 | 11 | type Action n s = A.Action n (G.Value s) (G.Index s) 12 | 13 | type Command s = Maybe (P.Action s) 14 | 15 | type Comm s = (Chan (Command s), MVar (P.Response s)) 16 | 17 | runCommandProcessor :: (MonadIO m) => Comm s -> Action n s m () 18 | runCommandProcessor (commandsChan, responseVar) = do 19 | refs <- liftIO $ V.new 20 | let 21 | newRef = liftIO . V.append refs 22 | resolveRef = liftIO . V.unsafeLookup refs 23 | respond = liftIO . putMVar responseVar 24 | loop = do 25 | com <- liftIO $ readChan commandsChan 26 | case com of 27 | Nothing -> return () 28 | Just ra -> do 29 | case ra of 30 | P.NewNode v -> do 31 | n <- A.newNode v 32 | r <- newRef n 33 | respond $ P.Node r 34 | P.GetValue sr -> do 35 | sn <- resolveRef sr 36 | r <- A.getValue sn 37 | respond $ P.Value r 38 | P.SetValue r v -> do 39 | n <- resolveRef r 40 | A.setValue n v 41 | respond $ P.Unit 42 | P.GetRoot -> do 43 | n <- A.getRoot 44 | r <- newRef n 45 | respond $ P.Node r 46 | P.GetTargets r i -> do 47 | n <- resolveRef r 48 | nl <- A.getTargets n i 49 | rl <- mapM newRef nl 50 | respond $ P.NodeList rl 51 | P.AddTarget s t -> do 52 | sn <- resolveRef s 53 | tn <- resolveRef t 54 | A.addTarget sn tn 55 | respond $ P.Unit 56 | P.RemoveTarget s t -> do 57 | sn <- resolveRef s 58 | tn <- resolveRef t 59 | A.removeTarget sn tn 60 | respond $ P.Unit 61 | P.Remove r -> do 62 | n <- resolveRef r 63 | A.remove n 64 | respond $ P.Unit 65 | P.GetStats -> do 66 | r <- A.getStats 67 | respond $ P.Stats r 68 | loop 69 | in loop 70 | 71 | processRequest :: Chan (Bool, Comm s) -> IORef (Maybe (Comm s)) -> P.Request s -> IO (P.Response s) 72 | processRequest transactionsChan stateRef req = do 73 | -- Initialize the state if needed and determine whether it's the final request. 74 | state <- readIORef stateRef 75 | case req of 76 | P.Start write -> do 77 | when (isJust state) $ $bug "Transaction state is already filled" 78 | state <- (,) <$> newChan <*> newEmptyMVar 79 | writeChan transactionsChan $ (write, state) 80 | writeIORef stateRef $ Just $ state 81 | return $ P.Unit 82 | P.Finish -> do 83 | case state of 84 | Nothing -> $bug "No transaction state" 85 | Just (commandsChan, _) -> do 86 | writeChan commandsChan Nothing 87 | writeIORef stateRef $ Nothing 88 | return $ P.Unit 89 | P.Action act -> do 90 | case state of 91 | Nothing -> $bug "No transaction state" 92 | Just (commandsChan, responseVar) -> do 93 | writeChan commandsChan $ Just act 94 | takeMVar responseVar 95 | 96 | -- * Serve 97 | ------------------------- 98 | 99 | -- | 100 | -- A monad transformer for running the server. 101 | -- 102 | -- Can only be executed inside a 'Session' using 'serve'. 103 | newtype Serve m r = 104 | Serve (R.Server m r) 105 | deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) 106 | 107 | instance MonadTransControl Serve where 108 | newtype StT Serve r = ServeStT (StT R.Server r) 109 | liftWith runInInner = do 110 | Serve $ liftWith $ \runServer -> runInInner $ \(Serve s) -> liftM ServeStT $ runServer s 111 | restoreT inner = do 112 | Serve $ do 113 | ServeStT r <- lift $ inner 114 | restoreT $ return $ r 115 | 116 | instance (MonadBase IO m) => MonadBase IO (Serve m) where 117 | liftBase = Serve . liftBase 118 | 119 | instance (MonadBaseControl IO m) => MonadBaseControl IO (Serve m) where 120 | newtype StM (Serve m) a = ServeStM { unServeStM :: ComposeSt Serve m a } 121 | liftBaseWith = defaultLiftBaseWith ServeStM 122 | restoreM = defaultRestoreM unServeStM 123 | 124 | -- | 125 | -- Block the calling thread until the server stops (which should never happen). 126 | block :: MonadIO m => Serve m () 127 | block = Serve $ R.wait 128 | -------------------------------------------------------------------------------- /library/GraphDB/Storage.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- An API, handling all storage tasks, which includes management of log-files, 3 | -- reading from and writing to them, creating checkpoints, archiving data and etc. 4 | -- 5 | -- It does not know anything about transactions dispatch, nor does it handle any related problems. 6 | -- 7 | module GraphDB.Storage 8 | ( 9 | -- * Configuration 10 | Paths, 11 | pathsFromDirectory, 12 | -- * Workflow 13 | Storage, 14 | acquireAndLoad, 15 | release, 16 | persistEvent, 17 | checkpoint, 18 | StorageException(..), 19 | 20 | ) 21 | where 22 | 23 | import GraphDB.Util.Prelude 24 | import qualified Data.ByteString as ByteString 25 | import qualified Pipes.Prelude as Pipes 26 | import qualified Pipes.ByteString as PipesBS 27 | import qualified GraphDB.Util.FileSystem as FileSystem 28 | import qualified GraphDB.Storage.Rules as Rules 29 | 30 | 31 | -- | 32 | -- A component which manages persistence files, loads them and populates them. 33 | data Storage a e = Storage { 34 | paths :: Paths, 35 | fileLockRef :: IORef (Maybe FileSystem.Lock), 36 | indexRef :: IORef Word, 37 | eventsFileHandleRef :: IORef (Maybe Handle) 38 | } 39 | 40 | -- | 41 | -- Storage paths. Determines where to store logs, checkpoints, archive. 42 | -- 43 | data Paths = Paths { 44 | eventsDir :: FilePath, 45 | checkpointsDir :: FilePath, 46 | archiveDir :: FilePath, 47 | lockFile :: FilePath 48 | } 49 | 50 | data StorageException = 51 | DeserializationFailure Text 52 | deriving (Typeable, Show, Eq, Ord) 53 | instance Exception StorageException 54 | 55 | -- | 56 | -- Determine paths based on a provided root-directory. 57 | pathsFromDirectory :: FilePath -> IO Paths 58 | pathsFromDirectory dir = do 59 | base <- FileSystem.resolve dir 60 | return $ Paths base base (base <> "archive") (base <> ".lock") 61 | 62 | -- | 63 | -- Construct 'Storage' acquiring a lock over the directories. 64 | -- 65 | acquire :: Paths -> IO (Storage a e) 66 | acquire paths@Paths{..} = do 67 | createDirs 68 | storage <- Storage <$> pure paths <*> newIORef Nothing <*> newIORef 0 <*> newIORef Nothing 69 | -- TODO: put locks in all directories. 70 | acquireFileLock storage 71 | return storage 72 | where 73 | createDirs = 74 | traverse_ FileSystem.createTree $ nub $ 75 | [eventsDir, checkpointsDir, archiveDir, FileSystem.directory lockFile] 76 | 77 | -- | 78 | -- Construct 'Storage', locking managed directories and 79 | -- restoring the persisted data structure. 80 | -- 81 | -- [@Usage@] 82 | -- 83 | -- > acquireAndLoad initValue replayEvent paths 84 | -- 85 | -- [@initValue@] Get initial value. Gets called when there's no checkpoint. 86 | -- 87 | -- [@replayEvent@] A function which applies events to this data structure. 88 | -- 89 | -- [@paths@] Paths to storage directories. 90 | -- 91 | acquireAndLoad :: (Serializable IO a, Serializable IO e) => IO a -> (a -> e -> IO ()) -> Paths -> IO (Storage a e, a) 92 | acquireAndLoad initValue replayEvent paths = do 93 | p <- acquire paths 94 | a <- load p initValue replayEvent 95 | return (p, a) 96 | 97 | -- | 98 | -- Release acquired resources. 99 | release :: Storage a e -> IO () 100 | release storage = do 101 | releaseEventsFileHandle storage 102 | releaseFileLock storage 103 | 104 | load :: (Serializable IO a, Serializable IO e) => Storage a e -> IO a -> (a -> e -> IO ()) -> IO a 105 | load storage@Storage{..} initValue replayEvent = do 106 | releaseEventsFileHandle storage -- Release a log, which we may now have to read from. 107 | (replayStartIndex, value) <- do 108 | r <- deserializeLatestCheckpoint 109 | case r of 110 | Just (index, value) -> do 111 | return (index, value) 112 | Nothing -> do 113 | (,) <$> pure 0 <*> initValue 114 | index <- do 115 | r <- replayEventsPastIndex value replayStartIndex 116 | return $ r ?: replayStartIndex + 1 117 | setIndex storage index 118 | return value 119 | where 120 | Paths{..} = paths 121 | deserializeLatestCheckpoint = do 122 | files <- 123 | FileSystem.listFilesByExtension checkpointsDir Rules.checkpointExtension >>= 124 | return . sortWith (Down . fileIndex) 125 | fmap msum $ forM files $ \file -> (fmap . fmap) (fileIndex file, ) $ deserializeFile file 126 | where 127 | fileIndex = fromMaybe (error "Unparsable checkpoint filename") . Rules.checkpointFileIndex 128 | deserializeFile file = do 129 | r <- FileSystem.withFile file FileSystem.ReadMode $ \handle -> runEitherT $ Pipes.head $ 130 | PipesBS.fromHandle handle >-> deserializingPipe 131 | either (throwIO . DeserializationFailure) return r 132 | replayEventsPastIndex value index = do 133 | files <- 134 | FileSystem.listFilesByExtension eventsDir Rules.eventsExtension >>= 135 | return . map (fileIndex &&& id) >>= 136 | return . filter ((> index) . fst) >>= 137 | return . sortWith fst 138 | forM_ files (replayFileEvents . snd) 139 | return $ fmap fst $ lastZ files 140 | where 141 | fileIndex f = Rules.eventsFileIndex f ?: error "Unparsable event filename" 142 | replayFileEvents file = do 143 | FileSystem.withFile file FileSystem.ReadMode $ \handle -> do 144 | r <- runEitherT $ runEffect $ 145 | PipesBS.fromHandle handle >-> 146 | deserializingPipe >-> 147 | (forever $ await >>= liftIO . replayEvent value) 148 | either (throwIO . DeserializationFailure) return r 149 | 150 | -- | 151 | -- Persist an event to disk. 152 | -- Appends the supplied event to the currently active events' log-file. 153 | -- 154 | persistEvent :: Serializable IO e => Storage a e -> e -> IO () 155 | persistEvent Storage{..} event = do 156 | handle <- fromMaybe raiseNoEventsFile <$> readIORef eventsFileHandleRef 157 | runEffect $ for (serializingProducer event) (liftIO . ByteString.hPutStr handle) 158 | where 159 | raiseNoEventsFile = error "TODO: implement raiseNoEventsFile" 160 | 161 | -- | 162 | -- Serialize and store the current state of data structure. 163 | -- 164 | -- Switches the state of event-logging to a new file, 165 | -- so that all consecutive calls to 'persistEvent' 166 | -- don't write to the latest log-file, which accomodates to the state of the data structure 167 | -- when this function gets called. 168 | -- 169 | -- Cleans up after running. 170 | -- 171 | checkpoint :: Serializable IO a => Storage a e -> a -> IO () 172 | checkpoint storage@Storage{..} value = do 173 | index <- readIORef indexRef 174 | setIndex storage $ succ index 175 | file <- return $ checkpointsDir <> Rules.checkpointFileName index 176 | FileSystem.withFile file FileSystem.WriteMode $ \handle -> runEffect $ 177 | for (serializingProducer value) (liftIO . ByteString.hPutStr handle) 178 | cleanUp index 179 | where 180 | Paths{..} = paths 181 | -- | 182 | -- Delete checkpoints past index, considering them corrupt, and 183 | -- archive all preceding checkpoints and event-logs with index up to the specified (and including). 184 | cleanUp index = do 185 | do 186 | checkpointFiles <- FileSystem.listFilesByExtension checkpointsDir Rules.checkpointExtension 187 | let (outdated, current, corrupt) = 188 | precedingMatchAndRemainder ((== index) . checkpointFileIndex) $ 189 | sortWith checkpointFileIndex checkpointFiles 190 | forM_ corrupt FileSystem.removeFile 191 | forM_ outdated moveFileToArchive 192 | do 193 | eventsFiles <- FileSystem.listFilesByExtension eventsDir Rules.eventsExtension 194 | let (outdated, current) = 195 | map snd *** map snd $ 196 | break ((> index) . fst) $ 197 | sortWith fst $ 198 | map (eventsFileIndex &&& id) $ eventsFiles 199 | forM_ outdated moveFileToArchive 200 | where 201 | Paths{..} = paths 202 | checkpointFileIndex = fromMaybe (error "Unparsable checkpoint filename") . Rules.checkpointFileIndex 203 | eventsFileIndex = fromMaybe (error "Unparsable events' filename") . Rules.eventsFileIndex 204 | precedingMatchAndRemainder predicate list = case break predicate list of 205 | (preceding, match : remainder) | predicate match -> (preceding, Just match, remainder) 206 | (preceding, remainder) -> (preceding, Nothing, remainder) 207 | moveFileToArchive file = FileSystem.move file $ archiveDir <> FileSystem.filename file 208 | 209 | acquireFileLock :: Storage a e -> IO () 210 | acquireFileLock storage@Storage{..} = do 211 | releaseFileLock storage 212 | lock <- FileSystem.acquireLock $ lockFile paths 213 | writeIORef fileLockRef $ Just lock 214 | 215 | releaseFileLock :: Storage a e -> IO () 216 | releaseFileLock Storage{..} = do 217 | r <- readIORef fileLockRef 218 | case r of 219 | Just lock -> do 220 | FileSystem.releaseLock lock 221 | writeIORef fileLockRef Nothing 222 | Nothing -> return () 223 | 224 | setIndex :: Storage a e -> Word -> IO () 225 | setIndex storage@Storage{..} index = do 226 | writeIORef indexRef index 227 | acquireEventsFileHandle storage 228 | 229 | acquireEventsFileHandle :: Storage a e -> IO () 230 | acquireEventsFileHandle storage@Storage{..} = do 231 | releaseEventsFileHandle storage 232 | file <- do 233 | index <- readIORef indexRef 234 | return $ eventsDir <> Rules.eventsFileName index 235 | do 236 | exists <- FileSystem.getExists file 237 | when exists $ error $ "Trying to switch logging to an already existing file: " ++ show file 238 | writeIORef eventsFileHandleRef . Just =<< FileSystem.openFile file FileSystem.WriteMode 239 | where 240 | Paths{..} = paths 241 | 242 | releaseEventsFileHandle :: Storage a e -> IO () 243 | releaseEventsFileHandle Storage{..} = 244 | readIORef eventsFileHandleRef >>= 245 | traverse_ (\handle -> hClose handle >> writeIORef eventsFileHandleRef Nothing) 246 | -------------------------------------------------------------------------------- /library/GraphDB/Storage/Rules.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Storage.Rules where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified GraphDB.Util.FileSystem as FS 5 | 6 | 7 | checkpointExtension :: Text 8 | checkpointExtension = "checkpoint" 9 | 10 | eventsExtension :: Text 11 | eventsExtension = "events" 12 | 13 | checkpointFileName :: Word -> FilePath 14 | checkpointFileName index = 15 | FS.decodeString (show index) `FS.addExtension` checkpointExtension 16 | 17 | eventsFileName :: Word -> FilePath 18 | eventsFileName index = 19 | FS.decodeString (show index) `FS.addExtension` eventsExtension 20 | 21 | checkpointFileIndex :: FilePath -> Maybe Word 22 | checkpointFileIndex file = readMaybe $ FS.encodeString $ FS.basename file 23 | 24 | eventsFileIndex :: FilePath -> Maybe Word 25 | eventsFileIndex file = readMaybe $ FS.encodeString $ FS.basename file 26 | -------------------------------------------------------------------------------- /library/GraphDB/Util/DIOVector.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.DIOVector where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified Data.Vector.Mutable as IOVector 5 | 6 | -- | Dynamic mutable vector in 'IO'. 7 | newtype DIOVector a = DIOVector (IORef (IOVector.IOVector a, Int)) 8 | 9 | new :: IO (DIOVector a) 10 | new = newSized (2^8) 11 | 12 | newSized :: Int -> IO (DIOVector a) 13 | newSized size = do 14 | vector <- IOVector.new size 15 | ref <- newIORef (vector, 0) 16 | return $ DIOVector ref 17 | 18 | -- | Append an item and return its index. 19 | append :: DIOVector a -> a -> IO Int 20 | append (DIOVector ref) value = do 21 | (vector, nextIndex) <- readIORef ref 22 | let size = IOVector.length vector 23 | vector' <- 24 | if nextIndex >= size 25 | then IOVector.grow vector size 26 | else return vector 27 | IOVector.write vector' nextIndex value 28 | writeIORef ref (vector', succ nextIndex) 29 | return nextIndex 30 | 31 | lookup :: DIOVector a -> Int -> IO (Maybe a) 32 | lookup v i = do 33 | s <- size v 34 | if i < s && i >= 0 35 | then Just <$> unsafeLookup v i 36 | else pure Nothing 37 | 38 | unsafeLookup :: DIOVector a -> Int -> IO a 39 | unsafeLookup (DIOVector ref) i = do 40 | (vector, _) <- readIORef ref 41 | IOVector.read vector i 42 | 43 | size :: DIOVector a -> IO Int 44 | size (DIOVector ref) = readIORef ref >>= return . snd 45 | 46 | -------------------------------------------------------------------------------- /library/GraphDB/Util/FileSystem.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Utilities for dealing with 'FilePath'. 3 | -- 4 | module GraphDB.Util.FileSystem 5 | ( 6 | module Filesystem, 7 | module Filesystem.Path.CurrentOS, 8 | Status(..), 9 | getStatus, 10 | getExists, 11 | getTemporaryDirectory, 12 | remove, 13 | removeIfExists, 14 | removeTreeIfExists, 15 | move, 16 | copy, 17 | resolve, 18 | Lock, 19 | withLock, 20 | acquireLock, 21 | releaseLock, 22 | listFilesByExtension, 23 | ) 24 | where 25 | 26 | import GraphDB.Util.Prelude hiding (stripPrefix, last) 27 | import Filesystem.Path.CurrentOS 28 | import Filesystem 29 | import qualified System.Directory as Directory 30 | import qualified Data.List as List 31 | import qualified System.IO.Error as IOError 32 | import qualified System.FileLock as Lock 33 | 34 | 35 | 36 | data Status = File | Directory | NotExists 37 | deriving (Show, Eq, Ord, Enum) 38 | 39 | getStatus :: FilePath -> IO Status 40 | getStatus path = do 41 | z <- isFile path 42 | if z 43 | then return File 44 | else do 45 | z <- isDirectory path 46 | if z 47 | then return Directory 48 | else return NotExists 49 | 50 | getExists :: FilePath -> IO Bool 51 | getExists path = getStatus path >>= return . (/= NotExists) 52 | 53 | getTemporaryDirectory :: IO FilePath 54 | getTemporaryDirectory = 55 | Directory.getTemporaryDirectory >>= return . decodeString 56 | 57 | remove :: FilePath -> IO () 58 | remove path = do 59 | status <- getStatus path 60 | case status of 61 | File -> removeFile path 62 | Directory -> removeTree path 63 | NotExists -> IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "" Nothing (Just $ encodeString path) 64 | 65 | removeIfExists :: FilePath -> IO () 66 | removeIfExists path = do 67 | status <- getStatus path 68 | case status of 69 | File -> removeFile path 70 | Directory -> removeTree path 71 | NotExists -> return () 72 | 73 | removeTreeIfExists :: FilePath -> IO () 74 | removeTreeIfExists path = removeTree path `catch` \e -> case e of 75 | _ | IOError.isDoesNotExistError e -> return () 76 | | otherwise -> throwIO e 77 | 78 | move :: FilePath -> FilePath -> IO () 79 | move from to = do 80 | copy from to 81 | remove from 82 | 83 | copy :: FilePath -> FilePath -> IO () 84 | copy from to = do 85 | isDir <- isDirectory from 86 | if isDir 87 | then do 88 | createTree to 89 | copyDirectory from to 90 | else do 91 | createTree $ directory to 92 | copyFile from to 93 | 94 | copyDirectory :: FilePath -> FilePath -> IO () 95 | copyDirectory path path' = do 96 | members <- listDirectory path 97 | let members' = do 98 | member <- members 99 | let relative = 100 | fromMaybe (error "Unexpectedly empty member path") $ 101 | last member 102 | return $ path' <> relative 103 | sequence_ $ zipWith copy members members' 104 | 105 | last :: FilePath -> Maybe FilePath 106 | last p = case splitDirectories p of 107 | [] -> Nothing 108 | l -> Just $ List.last l 109 | 110 | resolve :: FilePath -> IO FilePath 111 | resolve path = case splitDirectories path of 112 | h:t | h == "~" -> do 113 | home <- getHomeDirectory 114 | return $ mconcat $ home : t 115 | _ -> return path 116 | 117 | 118 | 119 | type Lock = Lock.FileLock 120 | 121 | -- | 122 | -- Execute an IO action while using a file as an interprocess lock, 123 | -- thus ensuring that only a single action executes across all processes 124 | -- of the running system. 125 | -- 126 | -- If a file exists already it checks whether it is locked on by any running process, 127 | -- including the current one, 128 | -- and acquires it if it's not. 129 | -- 130 | -- Releases the lock in case of any failure in executed action or when the action is executed. 131 | withLock :: FilePath -> IO a -> IO a 132 | withLock file io = bracket (acquireLock file) releaseLock (const io) 133 | 134 | acquireLock :: FilePath -> IO Lock 135 | acquireLock path = 136 | Lock.tryLockFile (encodeString path) Lock.Exclusive >>= \case 137 | Just lock -> return lock 138 | _ -> error $ "Lock `" ++ show path ++ "` is already in use" 139 | 140 | releaseLock :: Lock -> IO () 141 | releaseLock = Lock.unlockFile 142 | 143 | listFilesByExtension :: FilePath -> Text -> IO [FilePath] 144 | listFilesByExtension dir extension = 145 | listDirectory dir >>= 146 | return . filter (flip hasExtension extension) 147 | 148 | -------------------------------------------------------------------------------- /library/GraphDB/Util/IOQueue.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.IOQueue 2 | ( 3 | IOQueue, 4 | start, 5 | perform, 6 | performAsync, 7 | finish, 8 | ) 9 | where 10 | 11 | import GraphDB.Util.Prelude 12 | import qualified Control.Concurrent.Async as Async 13 | 14 | data IOQueue = IOQueue { 15 | perform :: forall r. IO r -> IO r, 16 | performAsync :: IO () -> IO (), 17 | finish :: IO () 18 | } 19 | 20 | start :: Int -> IO IOQueue 21 | start size = do 22 | (tasksVar, activeVar) <- atomically $ (,) <$> newTBQueue size <*> newTVar True 23 | let loop = do 24 | task <- atomically $ do 25 | tryReadTBQueue tasksVar >>= \case 26 | Nothing -> readTVar activeVar >>= \case 27 | True -> retry 28 | False -> return Nothing 29 | Just task -> return $ Just task 30 | traverse_ (\t -> t >> loop) task 31 | loopAsync <- Async.async $ loop 32 | let performAsync task = do 33 | atomically $ do 34 | readTVar activeVar >>= \case 35 | True -> writeTBQueue tasksVar task 36 | False -> return () 37 | perform :: IO r -> IO r 38 | perform task = do 39 | resultVar <- newEmptyMVar 40 | performAsync $ do 41 | result <- task 42 | putMVar resultVar result 43 | takeMVar resultVar 44 | finish = do 45 | atomically $ writeTVar activeVar False 46 | Async.wait loopAsync 47 | return () 48 | return $ IOQueue perform performAsync finish 49 | -------------------------------------------------------------------------------- /library/GraphDB/Util/Prelude.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.Prelude 2 | ( 3 | module Exports, 4 | 5 | LazyByteString, 6 | LazyText, 7 | 8 | traceM, 9 | traceIO, 10 | traceIOWithTime, 11 | packText, 12 | unpackText, 13 | bug, 14 | (|>), 15 | (<|), 16 | (|$>), 17 | bracketME, 18 | finallyME, 19 | tracingExceptions, 20 | asyncRethrowing, 21 | ) 22 | where 23 | 24 | -- base 25 | import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.)) 26 | import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 27 | import Control.Applicative as Exports 28 | import Control.Arrow as Exports hiding (left, right) 29 | import Control.Category as Exports 30 | import Data.Monoid as Exports 31 | import Data.Foldable as Exports 32 | import Data.Traversable as Exports hiding (for) 33 | import Data.Maybe as Exports 34 | import Data.Either as Exports hiding (isLeft, isRight) 35 | import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') 36 | import Data.Tuple as Exports 37 | import Data.Ord as Exports (Down(..)) 38 | import Data.String as Exports 39 | import Data.Int as Exports 40 | import Data.Word as Exports 41 | import Data.Ratio as Exports 42 | import Data.Fixed as Exports 43 | import Data.Ix as Exports 44 | import Data.Data as Exports hiding (Proxy) 45 | import Text.Read as Exports (readMaybe, readEither) 46 | import Control.Exception as Exports hiding (tryJust, assert) 47 | import Control.Concurrent as Exports hiding (yield) 48 | import System.Mem.StableName as Exports 49 | import System.Timeout as Exports 50 | import System.Exit as Exports 51 | import System.IO.Unsafe as Exports 52 | import System.IO as Exports (Handle, hClose) 53 | import System.IO.Error as Exports 54 | import Unsafe.Coerce as Exports 55 | import GHC.Exts as Exports hiding (Any, traceEvent, toList) 56 | import GHC.Generics as Exports (Generic) 57 | import GHC.IO.Exception as Exports 58 | import Data.IORef as Exports 59 | import Data.STRef as Exports 60 | import Control.Monad.ST as Exports 61 | import Debug.Trace as Exports hiding (traceIO, traceM) 62 | 63 | -- mtl 64 | import Control.Monad.Identity as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 65 | import Control.Monad.State.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 66 | import Control.Monad.Reader as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 67 | import Control.Monad.Writer.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any) 68 | import Control.Monad.RWS.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any) 69 | import Control.Monad.Error as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) 70 | import Control.Monad.Trans as Exports 71 | 72 | -- transformers-base 73 | import Control.Monad.Base as Exports 74 | 75 | -- monad-control 76 | import Control.Monad.Trans.Control as Exports 77 | 78 | -- free 79 | import Control.Monad.Trans.Free as Exports 80 | import Control.Monad.Free.TH as Exports 81 | 82 | -- stm 83 | import Control.Concurrent.STM as Exports 84 | 85 | -- lifted-async 86 | import Control.Concurrent.Async.Lifted as Exports 87 | 88 | -- bytestring 89 | import Data.ByteString as Exports (ByteString) 90 | 91 | -- text 92 | import Data.Text as Exports (Text) 93 | 94 | -- containers 95 | import Data.Map as Exports (Map) 96 | import Data.IntMap as Exports (IntMap) 97 | import Data.Set as Exports (Set) 98 | import Data.IntSet as Exports (IntSet) 99 | import Data.Sequence as Exports (Seq) 100 | import Data.Tree as Exports (Tree) 101 | 102 | -- system-filepath 103 | import Filesystem.Path as Exports (FilePath) 104 | 105 | -- hashable 106 | import Data.Hashable as Exports (Hashable(..), hash) 107 | 108 | -- time 109 | import Data.Time.Clock as Exports 110 | 111 | -- pipes 112 | import Pipes as Exports 113 | 114 | -- pipes-cereal-plus 115 | import PipesCerealPlus as Exports 116 | 117 | -- either 118 | import Control.Error as Exports 119 | 120 | -- placeholders 121 | import Development.Placeholders as Exports 122 | 123 | import qualified Debug.Trace.LocationTH 124 | import qualified Data.ByteString.Lazy 125 | import qualified Data.Text.Lazy 126 | import qualified Data.Text 127 | import qualified Prelude 128 | import qualified Debug.Trace 129 | import qualified System.Locale 130 | import qualified Data.Time 131 | import qualified Control.Concurrent.Async 132 | 133 | type LazyByteString = Data.ByteString.Lazy.ByteString 134 | type LazyText = Data.Text.Lazy.Text 135 | 136 | 137 | (|>) :: a -> (a -> b) -> b 138 | a |> aToB = aToB a 139 | {-# INLINE (|>) #-} 140 | 141 | (<|) :: (a -> b) -> a -> b 142 | aToB <| a = aToB a 143 | {-# INLINE (<|) #-} 144 | 145 | -- | 146 | -- The following are all the same: 147 | -- fmap f a == f <$> a == a |> fmap f == a |$> f 148 | -- 149 | -- This operator accomodates the left-to-right operators: >>=, >>>, |>. 150 | (|$>) = flip fmap 151 | {-# INLINE (|$>) #-} 152 | 153 | packText = Data.Text.pack 154 | unpackText = Data.Text.unpack 155 | 156 | bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] 157 | where 158 | msg = "A \"graph-db\" package bug: " :: String 159 | 160 | bottom = [e| $bug "Bottom evaluated" |] 161 | 162 | bracketME :: (MonadError e m) => m a -> (a -> m b) -> (a -> m c) -> m c 163 | bracketME acquire release apply = do 164 | r <- acquire 165 | z <- catchError (liftM Right $ apply r) (return . Left) 166 | release r 167 | either throwError return z 168 | 169 | finallyME :: (MonadError e m) => m a -> m b -> m a 170 | finallyME m f = do 171 | z <- catchError (liftM Right $ m) (return . Left) 172 | f 173 | either throwError return z 174 | 175 | traceM :: (Monad m) => String -> m () 176 | traceM s = trace s $ return () 177 | 178 | traceIO :: (MonadIO m) => String -> m () 179 | traceIO = liftIO . Debug.Trace.traceIO 180 | 181 | traceIOWithTime :: (MonadIO m) => String -> m () 182 | traceIOWithTime s = do 183 | time <- liftIO $ getCurrentTime 184 | traceIO $ 185 | formatTime time <> ": " <> s 186 | where 187 | formatTime = 188 | take 15 . 189 | Data.Time.formatTime System.Locale.defaultTimeLocale "%X.%q" 190 | 191 | tracingExceptions :: (MonadBaseControl IO m) => m a -> m a 192 | tracingExceptions m = 193 | control $ \runInIO -> catch (runInIO m) $ \(SomeException e) -> do 194 | let rep = typeOf e 195 | tyCon = typeRepTyCon rep 196 | traceIOWithTime $ 197 | "Uncaught exception: " ++ show e ++ "\n" ++ 198 | " Type: " ++ show rep ++ "\n" ++ 199 | " Module: " ++ tyConModule tyCon ++ "\n" ++ 200 | " Package: " ++ tyConPackage tyCon 201 | throwIO $ e 202 | 203 | 204 | -- Async 205 | ------------------------- 206 | 207 | asyncRethrowing :: MonadBaseControl IO m => m a -> m (Async (StM m a)) 208 | asyncRethrowing m = 209 | liftBaseWith $ \runInIO -> do 210 | parentTID <- myThreadId 211 | Control.Concurrent.Async.async $ do 212 | catch (runInIO m) $ \case 213 | se -> if 214 | | Just ThreadKilled <- fromException se -> liftBase $ throwIO ThreadKilled 215 | | otherwise -> throwTo parentTID se >> return undefined 216 | -------------------------------------------------------------------------------- /library/GraphDB/Util/Prelude/TH.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.Prelude.TH 2 | ( 3 | module Exports, 4 | 5 | purify, 6 | tryToReify, 7 | isInstance', 8 | isProperInstance', 9 | ) 10 | where 11 | 12 | import GraphDB.Util.Prelude hiding (Fixity) 13 | import Language.Haskell.TH as Exports 14 | import Language.Haskell.TH.Syntax as Exports 15 | import THInstanceReification as Exports 16 | 17 | 18 | purify :: Q a -> a 19 | purify = unsafePerformIO . runQ 20 | 21 | tryToReify :: Name -> Q (Maybe Info) 22 | tryToReify n = recover (return Nothing) (fmap Just $ reify n) 23 | 24 | isInstance' :: Name -> [Type] -> Q Bool 25 | isInstance' name types = recover (return False) (isInstance name types) 26 | 27 | isProperInstance' :: Name -> [Type] -> Q Bool 28 | isProperInstance' name types = recover (return False) (isProperInstance name types) 29 | -------------------------------------------------------------------------------- /library/GraphDB/Util/TH.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.TH where 2 | 3 | import GraphDB.Util.Prelude 4 | import Language.Haskell.TH 5 | import qualified GraphDB.Util.TH.Parsers as P 6 | 7 | 8 | 9 | caseLambda :: [Match] -> Exp 10 | caseLambda matches = LamE [VarP argName] (CaseE (VarE argName) matches) 11 | where 12 | argName = mkName "_0" 13 | 14 | caseFunDec :: Name -> [Match] -> Dec 15 | caseFunDec name matches = 16 | FunD name [Clause [VarP argName] (NormalB (CaseE (VarE argName) matches)) []] 17 | where 18 | argName = mkName "_0" 19 | 20 | reifyLocalInstances :: Q [(Name, [Type])] 21 | reifyLocalInstances = do 22 | loc <- location 23 | text <- runIO $ readFile $ loc_filename loc 24 | P.runParse text P.instances 25 | -------------------------------------------------------------------------------- /library/GraphDB/Util/TH/Parsers.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.TH.Parsers where 2 | 3 | import GraphDB.Util.Prelude 4 | import qualified Language.Haskell.TH as T 5 | import qualified Text.Parsec as P 6 | import qualified Data.Char as Char 7 | import qualified GraphDB.Util.TH.Type as Type 8 | 9 | 10 | type Parse = P.ParsecT String () 11 | 12 | runParse :: (Monad m) => String -> Parse m r -> m r 13 | runParse content p = do 14 | P.runParserT p () "runParse parser" content 15 | >>= either (fail . ("Parse failed: " <>) . show) return 16 | 17 | type Instance = (T.Name, [T.Type]) 18 | 19 | -- | 20 | -- N.B.: works only on instances with a /where/ clause and concrete parameters. 21 | instances :: Parse T.Q [Instance] 22 | instances = p 23 | where 24 | p = P.sepBy (optional (P.try getInstance) <* P.skipMany (P.noneOf "\n\r")) skipEOL |> 25 | fmap catMaybes 26 | skipEOL = P.skipMany1 (P.oneOf "\n\r") 27 | skipSpace = P.skipMany1 P.space 28 | getInstance = do 29 | P.string "instance" 30 | skipSpace 31 | optional $ P.try skipConstraints *> skipSpace 32 | className <- getTypeName 33 | skipSpace 34 | params <- P.sepEndBy1 (getParamType) skipSpace 35 | P.string "where" 36 | return (className, params) 37 | getParamType = 38 | P.try (inBraces app) <|> 39 | P.try nonApp <|> 40 | inBraces getParamType 41 | where 42 | nonApp = 43 | con <|> 44 | P.try var <|> 45 | P.try tuple <|> 46 | P.try list <|> 47 | inBraces nonApp 48 | var = T.VarT . T.mkName <$> getLowerIdentifier 49 | con = T.ConT <$> getTypeName 50 | tuple = Type.tuple <$> itemsP 51 | where 52 | itemsP = 53 | P.char '(' *> optional skipSpace *> 54 | P.sepBy getParamType (optional skipSpace *> P.char ',' <* optional skipSpace) <* 55 | optional skipSpace <* P.char ')' 56 | list = 57 | T.AppT T.ListT <$> 58 | (P.char '[' *> optional skipSpace *> getParamType <* optional skipSpace <* P.char ']') 59 | app = do 60 | a <- getParamType 61 | skipSpace 62 | b <- P.try app <|> getParamType 63 | return $ case b of 64 | T.AppT b1 b2 -> T.AppT (T.AppT a b1) b2 65 | _ -> T.AppT a b 66 | inBraces p = P.char '(' *> p <* P.char ')' 67 | skipConstraints = 68 | (P.try skipConstraintClause <|> skipAnythingInBraces) *> 69 | P.skipMany P.space *> 70 | P.string "=>" *> pure () 71 | where 72 | skipAnythingInBraces = 73 | P.char '(' *> P.manyTill skip (P.char ')') *> pure () 74 | where 75 | skip = skipAnythingInBraces <|> P.skipMany (P.noneOf "()") 76 | skipConstraintClause = 77 | void $ P.sepEndBy1 (void getParamType <|> skipAnythingInBraces) P.spaces 78 | getTypeName = do 79 | identifier <- P.sepBy1 getUpperIdentifier (P.char '.') |> fmap (intercalate ".") 80 | T.lookupTypeName identifier |> lift >>= \case 81 | Just n -> return n 82 | Nothing -> lift $ fail $ "Type not found: " <> identifier 83 | getUpperIdentifier = do 84 | head <- P.satisfy Char.isUpper 85 | tail <- many (P.satisfy (\c -> Char.isAlphaNum c || c `elem` ['_', '\''])) 86 | return $ head : tail 87 | getLowerIdentifier = do 88 | head <- P.satisfy Char.isLower 89 | tail <- many (P.satisfy (\c -> Char.isAlphaNum c || c `elem` ['_', '\''])) 90 | let i = head : tail 91 | if elem i ["where"] 92 | then empty 93 | else return i 94 | -------------------------------------------------------------------------------- /library/GraphDB/Util/TH/Q.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.TH.Q where 2 | 3 | import GraphDB.Util.Prelude 4 | import Language.Haskell.TH 5 | import qualified GraphDB.Util.TH.Type as Type 6 | import qualified Data.Attoparsec.Text as AP 7 | import qualified Data.Text.IO as Text 8 | import qualified Data.Text as Text 9 | import qualified Data.Char as Char 10 | import qualified Language.Haskell.TH.ExpandSyns as ExpandSyns 11 | 12 | 13 | reifyLocalFunctions :: Q [(Name, Type)] 14 | reifyLocalFunctions = 15 | listTopLevelFunctionLikeNames >>= 16 | mapM (\name -> reifyFunction name >>= mapM (return . (name, ))) >>= 17 | return . catMaybes 18 | where 19 | listTopLevelFunctionLikeNames = do 20 | loc <- location 21 | text <- runIO $ Text.readFile $ loc_filename loc 22 | return $ map (mkName . Text.unpack) $ nub $ parse text 23 | where 24 | parse text = 25 | either (error . ("Local function name parsing failure: " ++)) id $ 26 | AP.parseOnly parser text 27 | where 28 | parser = 29 | AP.sepBy (optional topLevelFunctionP <* AP.skipWhile (not . AP.isEndOfLine)) 30 | AP.endOfLine >>= 31 | return . catMaybes 32 | where 33 | topLevelFunctionP = do 34 | head <- AP.satisfy Char.isLower 35 | tail <- many (AP.satisfy (\c -> Char.isAlphaNum c || c `elem` ['_', '\''])) 36 | return $ Text.pack $ head : tail 37 | 38 | reifyFunction :: Name -> Q (Maybe Type) 39 | reifyFunction name = do 40 | tryToReify name >>= \case 41 | Just (VarI _ t _ _) -> return $ Just $ t 42 | _ -> return Nothing 43 | 44 | reifyType :: Name -> Q (Maybe Type) 45 | reifyType name = do 46 | tryToReify name >>= \case 47 | Just (TyConI _) -> Just <$> conT name 48 | _ -> return Nothing 49 | 50 | expandRootSynType :: Type -> Q (Maybe Type) 51 | expandRootSynType t = 52 | case reverse $ Type.unapply t of 53 | ConT name : applications -> expandTypeSynonym name applications 54 | _ -> return Nothing 55 | 56 | -- | 57 | -- Expand a type synonym identified by name, while providing the types to 58 | -- substitute its variables with. 59 | -- 60 | -- Returns nothing, if it's not a type synonym. 61 | -- 62 | -- TODO: 63 | -- Should fail if incorrect amount of args is provided, hence this function is only supposed 64 | -- to be used as a helper for other functions, which unapply the type internally 65 | -- and know exactly how many arguments to apply to it. 66 | expandTypeSynonym :: Name -> [Type] -> Q (Maybe Type) 67 | expandTypeSynonym name args = tryToReify name >>= return . join . fmap fromInfo 68 | where 69 | fromInfo = \case 70 | TyConI (TySynD _ vars t) -> 71 | Just $ foldr ($) t $ do 72 | (var, arg) <- zip vars args 73 | return $ ExpandSyns.substInType ((tvName var), arg) 74 | _ -> Nothing 75 | tvName = \case 76 | PlainTV n -> n 77 | KindedTV n _ -> n 78 | 79 | tryToReify :: Name -> Q (Maybe Info) 80 | tryToReify n = recover (return Nothing) (fmap Just $ reify n) 81 | 82 | purify :: Q a -> a 83 | purify = unsafePerformIO . runQ 84 | 85 | run :: MonadIO m => Q a -> m a 86 | run = liftIO . runQ 87 | 88 | caseLambda :: [Q Match] -> Q Exp 89 | caseLambda matches = lamE [varP argName] (caseE (varE argName) matches) 90 | where 91 | argName = mkName "_0" 92 | 93 | 94 | -- | 95 | -- Only checks the instances in scope of the calling site, 96 | -- it will not detect the declared instances, if they are not imported. 97 | whenNoInstance :: Monoid a => Name -> [Type] -> Q a -> Q a 98 | whenNoInstance name types f = do 99 | z <- recover (return False) (isInstance name types) 100 | if z 101 | then return mempty 102 | else f 103 | 104 | liftSTM :: STM a -> Q a 105 | liftSTM = runIO . atomically 106 | -------------------------------------------------------------------------------- /library/GraphDB/Util/TH/Type.hs: -------------------------------------------------------------------------------- 1 | module GraphDB.Util.TH.Type where 2 | 3 | import GraphDB.Util.Prelude 4 | import Language.Haskell.TH 5 | 6 | argsAndResult :: Type -> ([Type], Type) 7 | argsAndResult t = case t of 8 | AppT (AppT ArrowT a) b -> case argsAndResult b of (args, result) -> (a : args, result) 9 | t -> ([], t) 10 | 11 | -- | 12 | -- Uncurry a type into a list of args. 13 | -- 14 | -- >>> runQ [t|[Int] -> Int -> Char|] >>= return . unarrow 15 | -- [AppT ListT (ConT GHC.Types.Int),ConT GHC.Types.Int,ConT GHC.Types.Char] 16 | -- 17 | unarrow :: Type -> [Type] 18 | unarrow t = case t of 19 | AppT (AppT ArrowT a) b -> a : unarrow b 20 | _ -> [t] 21 | 22 | -- | 23 | -- Explode a type into a list of applications in reverse order. 24 | -- 25 | -- >>> data A a b c 26 | -- >>> runQ [t|A Int Char Bool|] >>= return . unapply 27 | -- [ConT GHC.Types.Bool,ConT GHC.Types.Char,ConT GHC.Types.Int,ConT :Interactive.A] 28 | -- 29 | unapply :: Type -> [Type] 30 | unapply t = case t of 31 | AppT a b -> b : unapply a 32 | _ -> [t] 33 | 34 | -- | 35 | -- A bijection of 'unapply'. 36 | apply :: [Type] -> Type 37 | apply types = case types of 38 | [t] -> t 39 | t : rest -> AppT (apply rest) t 40 | [] -> error "Empty type list" 41 | 42 | unforall :: Type -> Type 43 | unforall t = case t of 44 | ForallT _ _ t' -> t' 45 | _ -> t 46 | 47 | fromDataInstanceDec :: Dec -> Maybe Type 48 | fromDataInstanceDec dec = case dec of 49 | DataInstD _ name types _ _ -> Just $ apply $ reverse $ ConT name : types 50 | _ -> Nothing 51 | 52 | tuple :: [Type] -> Type 53 | tuple ts = foldl' AppT (TupleT (length ts)) ts 54 | 55 | -- | 56 | -- Extract all applied types from a signature. 57 | monoTypes :: Type -> [Type] 58 | monoTypes = \case 59 | AppT a b -> b : monoTypes a ++ monoTypes b 60 | _ -> [] 61 | --------------------------------------------------------------------------------