├── .ghcid ├── compile.sh ├── runTest.sh ├── runBench.sh ├── src ├── Acid │ ├── Core │ │ ├── State.hs │ │ ├── Backend.hs │ │ ├── Serialise.hs │ │ ├── Backend │ │ │ ├── Memory.hs │ │ │ ├── Abstract.hs │ │ │ ├── Postgresql.hs │ │ │ └── FS.hs │ │ ├── Serialise │ │ │ ├── JSON │ │ │ │ └── Partial.hs │ │ │ ├── JSON.hs │ │ │ ├── SafeCopy.hs │ │ │ ├── Postgresql.hs │ │ │ ├── CBOR.hs │ │ │ └── Abstract.hs │ │ ├── Segment.hs │ │ ├── State │ │ │ ├── PureState.hs │ │ │ └── Abstract.hs │ │ ├── Utils.hs │ │ └── CacheState.hs │ ├── World.hs │ └── Core.hs └── dataFiles │ └── stateFolderReadMe.md ├── .gitignore ├── stack.yaml ├── shared └── Shared │ ├── TH.hs │ ├── App.hs │ └── Schema.hs ├── LICENSE ├── benchmark └── Benchmark.hs ├── README.md ├── acid-world.cabal └── test └── Test.hs /.ghcid: -------------------------------------------------------------------------------- 1 | --command "stack ghci acid-world --test --ghci-options=-fobject-code" 2 | --restart "acid-world.cabal" 3 | -------------------------------------------------------------------------------- /compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | stack build --test --no-run-tests --bench --no-run-benchmarks --file-watch --ghc-options="-Wwarn" 3 | # 4 | -------------------------------------------------------------------------------- /runTest.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | .stack-work/dist/x86_64-linux/Cabal-2.0.1.0/build/acid-world-test/acid-world-test "$@" 3 | # example pattern: -p '$2 ~ /FS/ && $3 ~ /CBOR/ && $4 ~ /Restore/' 4 | -------------------------------------------------------------------------------- /runBench.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | .stack-work/dist/x86_64-linux/Cabal-2.0.1.0/build/acid-world-benchmark/acid-world-benchmark "$@" 3 | # pattern eg: -m "glob" "*CBOR/1m*/*" 4 | # --profile = +RTS -p 5 | # --trace = +RTS -xc -------------------------------------------------------------------------------- /src/Acid/Core/State.hs: -------------------------------------------------------------------------------- 1 | 2 | module Acid.Core.State ( 3 | module Acid.Core.State.Abstract, 4 | module Acid.Core.State.PureState 5 | 6 | ) where 7 | 8 | import Acid.Core.State.PureState 9 | import Acid.Core.State.Abstract 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Numerous always-ignore extensions 2 | *.diff 3 | *.err 4 | *.orig 5 | *.log 6 | *.log.html 7 | *.rej 8 | *.swo 9 | *.swp 10 | *.vi 11 | *~ 12 | *.sass-cache 13 | *.directory 14 | tmp/* 15 | var/* 16 | # OS or Editor folders 17 | .stack-work 18 | *.stack-work 19 | *.sublime-project 20 | *.sublime-workspace -------------------------------------------------------------------------------- /src/Acid/Core/Backend.hs: -------------------------------------------------------------------------------- 1 | 2 | module Acid.Core.Backend ( 3 | module Acid.Core.Backend.Abstract, 4 | module Acid.Core.Backend.FS, 5 | module Acid.Core.Backend.Memory, 6 | module Acid.Core.Backend.Postgresql 7 | 8 | ) where 9 | 10 | import Acid.Core.Backend.Abstract 11 | import Acid.Core.Backend.FS 12 | import Acid.Core.Backend.Memory 13 | import Acid.Core.Backend.Postgresql 14 | -------------------------------------------------------------------------------- /src/Acid/World.hs: -------------------------------------------------------------------------------- 1 | module Acid.World ( 2 | module Acid.Core, 3 | module Acid.Core.Segment, 4 | module Acid.Core.Utils, 5 | module Acid.Core.State, 6 | module Acid.Core.Serialise, 7 | module Acid.Core.Backend 8 | ) where 9 | 10 | 11 | import Acid.Core 12 | import Acid.Core.Segment 13 | import Acid.Core.Utils 14 | import Acid.Core.State 15 | 16 | import Acid.Core.Serialise 17 | import Acid.Core.Backend 18 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.6 2 | allow-newer: true 3 | packages: 4 | - '.' 5 | extra-deps: 6 | - rio-0.1.4.0 7 | - vinyl-0.8.1.1 8 | - basic-sop-0.2.0.2 9 | - serialise-0.2.0.0 10 | - cborg-0.2.0.0 11 | - crc-0.1.0.0 12 | - git: git@github.com:matchwood/ixset-typed.git 13 | commit: 60b62d73d189b5ab2cd417fbaf517029111bb4eb 14 | - git: git@github.com:matchwood/lmdb-simple.git 15 | commit: 637f702aae298ce8000dacb3a1b5e3ac7b0a2664 -------------------------------------------------------------------------------- /src/Acid/Core/Serialise.hs: -------------------------------------------------------------------------------- 1 | 2 | module Acid.Core.Serialise ( 3 | module Acid.Core.Serialise.Abstract, 4 | module Acid.Core.Serialise.JSON, 5 | module Acid.Core.Serialise.CBOR, 6 | module Acid.Core.Serialise.SafeCopy, 7 | module Acid.Core.Serialise.Postgresql, 8 | 9 | ) where 10 | 11 | import Acid.Core.Serialise.Abstract 12 | import Acid.Core.Serialise.JSON 13 | import Acid.Core.Serialise.CBOR 14 | import Acid.Core.Serialise.SafeCopy 15 | import Acid.Core.Serialise.Postgresql -------------------------------------------------------------------------------- /shared/Shared/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Shared.TH where 3 | import RIO 4 | import Language.Haskell.TH 5 | import Acid.World 6 | 7 | 8 | eventableNames :: Int -> [String] 9 | eventableNames i = map (\s -> "events" ++ show s) [0..i] 10 | 11 | generateEventables :: [String] -> Q [Dec] 12 | generateEventables ss = do 13 | res <- fmap concat $ sequence $ map (eventableDef ) ss 14 | 15 | let ts = foldl' (\t s -> appT (appT promotedConsT (litT (strTyLit s))) t) promotedNilT ss 16 | 17 | res2 <- [d| 18 | type GeneratedEventNames = $(ts) 19 | 20 | |] 21 | 22 | return $ res ++ res2 23 | 24 | 25 | 26 | 27 | eventableDef :: String -> Q [Dec] 28 | eventableDef s = do 29 | let n = litT (strTyLit s) 30 | res <- 31 | [d| 32 | instance Eventable $(n) where 33 | type EventArgs $(n) = '[] 34 | type EventResult $(n) = () 35 | type EventSegments $(n) = '[] 36 | runEvent _ _ = pure () 37 | |] 38 | pure res 39 | 40 | -------------------------------------------------------------------------------- /src/Acid/Core/Backend/Memory.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Acid.Core.Backend.Memory where 5 | import RIO 6 | import qualified RIO.ByteString as BS 7 | import qualified RIO.ByteString.Lazy as BL 8 | 9 | 10 | 11 | import Acid.Core.State 12 | import Acid.Core.Utils 13 | import Acid.Core.Backend.Abstract 14 | 15 | data AcidWorldBackendMemory 16 | 17 | 18 | 19 | 20 | 21 | instance AcidWorldBackend AcidWorldBackendMemory where 22 | data AWBState AcidWorldBackendMemory = AWBStateMemory 23 | data AWBConfig AcidWorldBackendMemory = AWBConfigMemory deriving Show 24 | type AWBSerialiseT AcidWorldBackendMemory = BL.ByteString 25 | type AWBSerialiseConduitT AcidWorldBackendMemory = BS.ByteString 26 | initialiseBackend _ _ = pure . pure $ AWBStateMemory 27 | handleUpdateEventC _ _ awu _ ec prePersistHook postPersistHook = eBind (runUpdateC awu ec) $ \(_, r, onSuccess, onFail) -> do 28 | ioRPre <- onException (prePersistHook r) onFail 29 | onSuccess 30 | ioRPost <- (postPersistHook r) 31 | 32 | pure . Right $ (r, (ioRPre, ioRPost)) 33 | 34 | -------------------------------------------------------------------------------- /src/dataFiles/stateFolderReadMe.md: -------------------------------------------------------------------------------- 1 | ## State folder structure 2 | 3 | Inside the state folder there will be one `current` folder, and possibly one `previous`. The presence of a `previous` folder indicates that the last attempt at checkpointing did not complete. `acid-world` will automatically sort this out when it is next succesfully started. 4 | 5 | By default, the `current` (or the `current` + `previous`) folders contain the most recent checkpoint and any events that have been persisted since that checkpoint. 6 | 7 | All previous checkpoints and event logs are contained in the `archive` folder. Each individual folder in the `archive` folder contains a valid possible state that can be used to restore from. The folders are named with the full UTC date and time of their creation. To restore from an archived state simply rename / remove the existing `current` (or `current` + `previous`) folders, and copy the archive folder you are interested in to `[statePath]/current`. 8 | 9 | All of the folders in the `archive` folder are not necessary for restoring the current state, but if you are interested in querying historial event logs then you need to keep them around. If you are not interested in historical event logs then they can safely be deleted or removed. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2018 Matchwood 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /src/Acid/Core/Serialise/JSON/Partial.hs: -------------------------------------------------------------------------------- 1 | module Acid.Core.Serialise.JSON.Partial where 2 | 3 | import RIO 4 | import qualified RIO.Text as T 5 | import qualified RIO.ByteString.Lazy as BL 6 | import qualified RIO.ByteString as BS 7 | 8 | --import Control.Arrow (left) 9 | import Generics.SOP 10 | 11 | 12 | import qualified Data.Aeson as Aeson 13 | import Data.Aeson(FromJSON(..), Value(..)) 14 | import Data.Aeson.Internal (ifromJSON, IResult(..), formatError) 15 | import qualified Data.Attoparsec.ByteString as Atto 16 | import qualified Data.Attoparsec.ByteString.Lazy as Atto.L 17 | import Acid.Core.Utils 18 | 19 | {- Partial decoding for json -} 20 | eitherPartialDecode' :: (FromJSON a) => BS.ByteString -> JSONResult a 21 | eitherPartialDecode' = eitherPartialDecodeWith Aeson.json' ifromJSON 22 | 23 | eitherPartialDecodeWith :: forall a. Atto.Parser Value -> (Value -> IResult a) -> BS.ByteString 24 | -> JSONResult a 25 | eitherPartialDecodeWith p tra s = handleRes (Atto.parse p s) 26 | where 27 | handleRes :: Atto.IResult BS.ByteString Value -> JSONResult a 28 | handleRes (Atto.Done i v) = 29 | case tra v of 30 | ISuccess a -> JSONResultDone (i, a) 31 | IError path msg -> JSONResultFail (T.pack $ formatError path msg) 32 | handleRes (Atto.Partial np) = JSONResultPartial (handleRes . np) 33 | handleRes (Atto.Fail _ _ msg) = JSONResultFail (T.pack msg) 34 | 35 | data JSONResult a = 36 | JSONResultFail Text 37 | | JSONResultPartial (BS.ByteString -> JSONResult a) 38 | | JSONResultDone (BS.ByteString, a) 39 | 40 | 41 | 42 | 43 | 44 | {- Decoding with remainder - needed because of how we serialise event names -} 45 | eitherDecodeLeftover :: (FromJSON a) => BL.ByteString -> Either Text (BL.ByteString, a) 46 | eitherDecodeLeftover = eitherDecodeLeftoverWithParser ifromJSON 47 | 48 | eitherDecodeLeftoverWithParser :: (Value -> IResult a) -> BL.ByteString -> Either Text (BL.ByteString, a) 49 | eitherDecodeLeftoverWithParser p = eitherDecodeLeftoverWith Aeson.json' p 50 | 51 | eitherDecodeLeftoverWith :: Atto.L.Parser Value -> (Value -> IResult a) -> BL.ByteString 52 | -> Either Text (BL.ByteString, a) 53 | eitherDecodeLeftoverWith p tra s = 54 | case Atto.L.parse p s of 55 | Atto.L.Done bs v -> case tra v of 56 | ISuccess a -> pure (bs, a) 57 | IError path msg -> Left (T.pack $ formatError path msg) 58 | Atto.L.Fail _ _ msg -> Left (T.pack msg) 59 | 60 | consumeMatchAndParse :: forall a b. (FromJSON a, FromJSON b, Eq a, Show a) => Proxy a -> a -> BL.ByteString -> Either Text b 61 | consumeMatchAndParse _ aMatch bs = do 62 | (bs', (a :: a)) <- eitherDecodeLeftover bs 63 | if a == aMatch 64 | then fmap snd $ eitherDecodeLeftover bs' 65 | else Left $ "Expected " <> showT aMatch <> " when consuming prefix, but got " <> showT a 66 | -------------------------------------------------------------------------------- /src/Acid/Core/Backend/Abstract.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | 4 | 5 | module Acid.Core.Backend.Abstract where 6 | import RIO 7 | import qualified RIO.Text as T 8 | import Data.Typeable 9 | import Data.Proxy(Proxy(..)) 10 | import Acid.Core.Segment 11 | import Acid.Core.State 12 | import Acid.Core.Utils 13 | import Conduit 14 | import Acid.Core.Serialise.Abstract 15 | import Generics.SOP.NP 16 | import Generics.SOP 17 | 18 | class AcidWorldBackend (b :: k) where 19 | data AWBState b 20 | data AWBConfig b 21 | type AWBSerialiseT b :: * 22 | type AWBSerialiseConduitT b :: * 23 | type AWBSerialiseSegmentT b :: * 24 | type AWBSerialiseSegmentT b = AWBSerialiseConduitT b 25 | type AWBDeserialiseSegmentT b :: * 26 | type AWBDeserialiseSegmentT b = AWBSerialiseConduitT b 27 | 28 | backendName :: Proxy b -> Text 29 | default backendName :: (Typeable b) => Proxy b -> Text 30 | backendName p = T.pack $ (showsTypeRep . typeRep $ p) "" 31 | backendConfigInfo :: AWBConfig b -> Text 32 | default backendConfigInfo :: (Show (AWBConfig b)) => AWBConfig b -> Text 33 | backendConfigInfo = showT 34 | initialiseBackend :: (MonadUnliftIO m, AcidSerialiseEvent t) => AWBConfig b -> AcidSerialiseEventOptions t -> m (Either AWException (AWBState b)) 35 | closeBackend :: (MonadIO m) => AWBState b -> m () 36 | closeBackend _ = pure () 37 | 38 | 39 | createCheckpointBackend :: (AcidSerialiseEvent t, AcidSerialiseSegmentT t ~ AWBSerialiseSegmentT b, MonadUnliftIO m, MonadThrow m, PrimMonad m, ValidAcidWorldState u ss, ValidSegmentsSerialise t ss ) => AWBState b -> AWState u ss -> AcidSerialiseEventOptions t -> m () 40 | createCheckpointBackend _ _ _ = pure () 41 | 42 | -- should return the most recent checkpoint state, if any 43 | getInitialState :: (AcidSerialiseEvent t, MonadUnliftIO m, PrimMonad m, MonadThrow m, AcidDeserialiseSegmentT t ~ AWBDeserialiseSegmentT b, ValidSegmentsSerialise t ss ) => SegmentsState ss -> AWBState b -> AcidSerialiseEventOptions t -> m (Either AWException (SegmentsState ss)) 44 | getInitialState defState _ _ = pure . pure $ defState 45 | -- return events since the last checkpoint, if any 46 | loadEvents :: (MonadUnliftIO m, AcidSerialiseEvent t) => 47 | (ConduitT (AWBSerialiseConduitT b) (Either Text (WrappedEvent ss nn)) (ResourceT IO) ()) -> 48 | AWBState b -> 49 | AcidSerialiseEventOptions t -> 50 | m (Either AWException (LoadEventsConduit m ss nn)) 51 | loadEvents _ _ _ = pure . pure $ LoadEventsConduit $ \rest -> liftIO $ runConduitRes $ yieldMany [] .| rest 52 | handleUpdateEventC :: ( 53 | AcidSerialiseEvent t 54 | , All (IsValidEvent ss nn) (firstN ': ns) 55 | , All (ValidEventName ss) (firstN ': ns) 56 | , MonadUnliftIO m 57 | , ValidAcidWorldState u ss) => 58 | (NP (StorableEvent ss nn) (firstN ': ns) -> AWBSerialiseT b) 59 | -> (AWBState b) 60 | -> (AWState u ss) 61 | -> AcidSerialiseEventOptions t 62 | -> EventC (firstN ': ns) 63 | -> (EventResult firstN -> m ioResPre) -- run after state update but before persistence - if this errors then the events will not be persisted 64 | -> (EventResult firstN -> m ioResPost) -- run after persistence - question - should it be run while updates are locked? there is no particular reason for that aside from possible user requirements, but then again, if it runs afterwards then what is the point in having it, as it is the same as handleUpdateEventC >>= postPersist - maybe just get rid of it entirely? 65 | -> m (Either AWException (EventResult firstN, (ioResPre, ioResPost))) 66 | 67 | -------------------------------------------------------------------------------- /benchmark/Benchmark.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Main (main) where 5 | 6 | import RIO 7 | import qualified RIO.Text as T 8 | import Data.Proxy (Proxy(..)) 9 | import Criterion.Main 10 | import qualified RIO.Directory as Dir 11 | 12 | import Shared.App 13 | 14 | import Acid.World 15 | import qualified Test.QuickCheck as QC 16 | import Database.LMDB.Simple 17 | 18 | 19 | 20 | main :: IO () 21 | main = do 22 | 23 | -- void $ mapM makeTestState allSerialisers 24 | let conf = defaultConfig 25 | -- it seems like we should perRunEnv for the generateUser part of this, but that causes major issues with criterion - something like 3 or 4 order of magnitude slow down in the benchmarked code 26 | defaultMainWith conf $ 27 | map serialiserBenchmarks allSerialisers ++ 28 | 29 | [bgroup "LMDB" [ 30 | env (openLMDB) $ \ ~(e, db) -> 31 | bench "insertUserIndividually" $ whnfIO ((QC.generate $ generateUsers 50) >>= (\us -> mapM (\u -> transaction e (put db (userId u) (Just u))) us)), 32 | env (openLMDB) $ \ ~(e, db) -> 33 | bench "insertUserGrouped" $ whnfIO ((QC.generate $ generateUsers 50) >>= (\us -> transaction e (mapM (\u -> put db (userId u) (Just u)) us))) 34 | ]] 35 | 36 | serialiserBenchmarks :: AppValidSerialiser -> Benchmark 37 | serialiserBenchmarks (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = 38 | let sName = T.unpack . serialiserName $ (Proxy :: Proxy s) 39 | in bgroup sName [ 40 | env (openAppAcidWorldFreshFS o True) $ \aw -> 41 | bgroup "Empty state" [ 42 | bench "insertUser" $ whnfIO (generateUserIO >>= runInsertUser aw) 43 | ], 44 | env (openAppAcidWorldRestoreState o (sName <> hundredK)) $ \aw -> 45 | bgroup "100K restored state" [ 46 | bench "insertUser" $ whnfIO (generateUserIO >>= runInsertUser aw) 47 | ], 48 | env (openAppAcidWorldRestoreState o (sName <> oneM)) $ \aw -> 49 | bgroup "1m restored state" [ 50 | bench "insertUser" $ whnfIO (generateUserIO >>= runInsertUser aw) 51 | ] 52 | ] 53 | instance NFData (Database a b) where 54 | rnf _ = () 55 | instance NFData (Environment e) where 56 | rnf _ = () 57 | 58 | openLMDB :: IO (Environment ReadWrite, Database Int User) 59 | openLMDB = do 60 | t <- mkTempDir 61 | e <- openEnvironment t (defaultLimits{maxDatabases = 200, mapSize = 1024 * 1024 * 1000}) 62 | db <- readWriteTransaction e $ (getDatabase (Just "users")) 63 | pure (e, db) 64 | 65 | makeTestState :: AppValidSerialiser -> IO () 66 | makeTestState (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = do 67 | let sName = T.unpack . serialiserName $ (Proxy :: Proxy s) 68 | tmpP <- Dir.makeAbsolute topLevelTestDir 69 | let newTestDir = tmpP <> "/newTestState" 70 | Dir.createDirectoryIfMissing True newTestDir 71 | 72 | mapM_ (createForNums $ newTestDir <> "/" <> sName) [ 73 | (100000, hundredK) 74 | , (1000000, oneM) 75 | ] 76 | where 77 | createForNums :: FilePath -> (Int, String) -> IO () 78 | createForNums newTDir (n, name) = do 79 | Dir.createDirectoryIfMissing True (newTDir <> name) 80 | 81 | aw <- insertUsers n $ openAppAcidWorldFresh (const $ AWBConfigFS (newTDir <> name) True) o 82 | as <- QC.generate $ generateAddresses (n `divInt` 10) 83 | ps <- QC.generate $ generatePhonenumbers (n `divInt` 10) 84 | mapM_ (runInsertAddress aw) as 85 | mapM_ (runInsertPhonenumber aw) ps 86 | createCheckpoint aw 87 | closeAcidWorld aw 88 | 89 | hundredK, oneM :: String 90 | hundredK = "/100kUsers" 91 | oneM = "/1mUsers" 92 | 93 | divInt :: Int -> Int -> Int 94 | divInt a b = ceiling $ ((/) `on` (fromIntegral :: Int -> Double)) a b -------------------------------------------------------------------------------- /src/Acid/Core/Segment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | 4 | module Acid.Core.Segment where 5 | 6 | import RIO 7 | import Generics.SOP 8 | import GHC.TypeLits 9 | 10 | import qualified Data.Vinyl as V 11 | import qualified Data.Vinyl.TypeLevel as V 12 | import Acid.Core.Utils 13 | 14 | 15 | 16 | class (ToUniqueText segmentName) => Segment (segmentName :: Symbol) where 17 | type SegmentS segmentName :: * 18 | defaultState :: Proxy segmentName -> SegmentS segmentName 19 | 20 | type family ToSegmentFields (segmentNames :: [Symbol]) = (segmentFields :: [(Symbol, *)]) where 21 | ToSegmentFields '[] = '[] 22 | ToSegmentFields (s ': ss) = '(s, SegmentS s) ': ToSegmentFields ss 23 | 24 | type family ToSegmentElFields (segmentNames :: [Symbol]) = (segmentFields :: [(Symbol, *)]) where 25 | ToSegmentElFields '[] = '[] 26 | ToSegmentElFields (s ': ss) = '(s, SegmentS s) ': ToSegmentElFields ss 27 | 28 | type family ToSegmentTypes (segmentNames :: [Symbol]) :: [*] where 29 | ToSegmentTypes '[] = '[] 30 | ToSegmentTypes (s ': ss) = (SegmentS s) ': ToSegmentTypes ss 31 | 32 | prettySegment :: (Segment s) => Proxy s -> Text 33 | prettySegment ps = "*Segment '" <> toUniqueText ps <> "'* " 34 | 35 | newtype SegmentsState segmentNames = SegmentsState {segmentsStateFieldRec :: V.AFieldRec (ToSegmentFields segmentNames)} 36 | 37 | 38 | class (V.KnownField a, Segment (V.Fst a), SegmentS (V.Fst a) ~ (V.Snd a)) => KnownSegmentField a 39 | instance (V.KnownField a, Segment (V.Fst a), SegmentS (V.Fst a) ~ (V.Snd a)) => KnownSegmentField a 40 | 41 | 42 | class (V.HasField V.ARec s (ToSegmentFields segmentNames) (SegmentS s), KnownSymbol s) => HasSegment segmentNames s 43 | instance (V.HasField V.ARec s (ToSegmentFields segmentNames) (SegmentS s), KnownSymbol s) => HasSegment segmentNames s 44 | 45 | 46 | class (SegmentS n ~ s) => SegmentNameToState n s 47 | instance (SegmentS n ~ s) => SegmentNameToState n s 48 | 49 | 50 | class (KnownSegmentField sField, HasSegment ss (V.Fst sField)) => SegmentFetching ss sField 51 | instance (KnownSegmentField sField, HasSegment ss (V.Fst sField)) => SegmentFetching ss sField 52 | 53 | 54 | type ValidSegmentNames segmentNames = 55 | ( V.AllFields (ToSegmentFields segmentNames) 56 | , V.AllConstrained KnownSegmentField (ToSegmentFields segmentNames) 57 | , V.NatToInt (V.RLength (ToSegmentFields segmentNames)) 58 | , UniqueElementsWithErr segmentNames ~ 'True 59 | ) 60 | 61 | class ( AllZip SegmentNameToState ss (ToSegmentTypes ss) 62 | , All (SegmentFetching ss) (ToSegmentFields ss) 63 | , All (HasSegment ss) ss 64 | , ValidSegmentNames ss) 65 | => ValidSegments ss 66 | 67 | instance ( AllZip SegmentNameToState ss (ToSegmentTypes ss) 68 | , All (SegmentFetching ss) (ToSegmentFields ss) 69 | , All (HasSegment ss) ss 70 | , ValidSegmentNames ss) 71 | => ValidSegments ss 72 | 73 | 74 | npToSegmentsState :: forall ss. (ValidSegmentNames ss) => NP V.ElField (ToSegmentFields ss) -> SegmentsState ss 75 | npToSegmentsState np = SegmentsState $ npToARec (Proxy :: Proxy ss) np 76 | 77 | npToARec :: (ValidSegmentNames ss) => Proxy ss -> NP V.ElField (ToSegmentFields ss) -> V.AFieldRec (ToSegmentFields ss) 78 | npToARec _ np = npToVinylARec id np 79 | 80 | makeDefaultSegment :: forall a. KnownSegmentField a => V.ElField '(V.Fst a, (V.Snd a)) 81 | makeDefaultSegment = (V.Label :: V.Label (V.Fst a)) V.=: (defaultState (Proxy :: Proxy (V.Fst a))) 82 | 83 | 84 | defaultSegmentsState :: forall segmentNames. (ValidSegmentNames segmentNames) => SegmentsState segmentNames 85 | defaultSegmentsState = SegmentsState $ V.toARec $ V.rpureConstrained (Proxy :: Proxy KnownSegmentField) makeDefaultSegment 86 | 87 | putSegmentP :: forall s ss. (HasSegment ss s) => Proxy s -> SegmentS s -> SegmentsState ss -> SegmentsState ss 88 | putSegmentP _ seg (SegmentsState fr) = SegmentsState $ V.rputf (V.Label :: V.Label s) seg fr 89 | 90 | getSegmentP :: forall s ss. (HasSegment ss s) => Proxy s -> SegmentsState ss -> SegmentS s 91 | getSegmentP _ (SegmentsState fr) = V.getField $ V.rgetf (V.Label :: V.Label s) fr 92 | 93 | 94 | -------------------------------------------------------------------------------- /src/Acid/Core/State/PureState.hs: -------------------------------------------------------------------------------- 1 | module Acid.Core.State.PureState where 2 | 3 | import RIO 4 | 5 | import Generics.SOP 6 | import qualified Control.Monad.State.Strict as St 7 | import qualified Control.Monad.Reader as Re 8 | import qualified RIO.HashMap as HM 9 | 10 | import qualified Control.Concurrent.STM.TMVar as TMVar 11 | import qualified Control.Concurrent.STM as STM 12 | 13 | import Acid.Core.Utils 14 | import Acid.Core.Segment 15 | import Acid.Core.State.Abstract 16 | import Conduit 17 | 18 | 19 | data AcidStatePureState 20 | 21 | 22 | 23 | instance AcidWorldState AcidStatePureState where 24 | data AWState AcidStatePureState ss = AWStatePureState { 25 | aWStatePureStateState :: !(TMVar (SegmentsState ss)), -- @todo this implementation does not allow for queries to run while updates are running, so guarantees the absolute multi threaded order of updates and queries. This stops a situation when you issue a query and follow it with an update dependent on those results, even though a separate update was in progress. should be provide a way to run queries while updates are running? 26 | awStatePureStateInvariants :: Invariants ss 27 | } 28 | data AWConfig AcidStatePureState ss = AWConfigPureState 29 | 30 | newtype AWUpdate AcidStatePureState ss a = AWUpdatePureState {extractAWUpdatePureState :: Re.ReaderT (Invariants ss) (St.StateT (ChangedSegmentsInvariantsMap AcidStatePureState ss) (St.State (SegmentsState ss))) a} 31 | deriving (Functor, Applicative, Monad) 32 | newtype AWQuery AcidStatePureState ss a = AWQueryPureState (Re.Reader (SegmentsState ss) a) 33 | deriving (Functor, Applicative, Monad) 34 | getSegment ps = AWUpdatePureState . lift . lift $ getSegmentP ps `fmap` St.get 35 | 36 | putSegment (ps :: Proxy s) seg = AWUpdatePureState $ do 37 | invariants <- ask 38 | case getInvariantP invariants of 39 | Nothing -> pure () 40 | Just (invar :: Invariant ss s) -> lift (St.modify' (registerChangedSegment invar)) 41 | 42 | lift . lift $ St.modify' (putSegmentP ps seg) 43 | askSegment ps = AWQueryPureState $ getSegmentP ps `fmap` Re.ask 44 | initialiseState :: forall z ss nn. (MonadIO z, ValidSegmentsAndInvar ss) => AWConfig AcidStatePureState ss -> (BackendHandles z ss nn) -> (Invariants ss) -> z (Either AWException (AWState AcidStatePureState ss)) 45 | initialiseState _ (BackendHandles{..}) invars = do 46 | 47 | 48 | eBind bhGetInitialState $ \initState -> do 49 | eS <- runLoadEventsConduit bhLoadEvents (breakOnLeft applyToState initState) 50 | case eS of 51 | Left err -> pure . Left . AWExceptionEventDeserialisationError $ err 52 | Right s -> do 53 | 54 | -- run invariants 55 | case runAWQueryPureState (runChangedSegmentsInvariantsMap (allInvariants invars)) s of 56 | Nothing -> do 57 | tvar <- liftIO $ STM.atomically $ TMVar.newTMVar s 58 | pure . pure $ AWStatePureState tvar invars 59 | Just err -> pure . Left $ err 60 | where 61 | breakOnLeft :: (Monad m) => (s -> a -> s) -> s -> ConduitT (Either Text a) o m (Either Text s) 62 | breakOnLeft f = loop 63 | where 64 | loop !s = await >>= maybe (return $ Right s) go 65 | where 66 | go (Left err) = pure (Left err) 67 | go (Right a) = loop (f s a) 68 | applyToState :: SegmentsState ss -> WrappedEvent ss nn -> SegmentsState ss 69 | applyToState s e = snd $ runAWUpdatePureState (runWrappedEvent e) s invars 70 | 71 | 72 | runUpdateC :: forall ss firstN ns m. (ValidAcidWorldState AcidStatePureState ss, All (ValidEventName ss) (firstN ': ns), MonadIO m) => AWState AcidStatePureState ss -> EventC (firstN ': ns) -> m (Either AWException (NP Event (firstN ': ns), EventResult firstN, m (), m ())) 73 | runUpdateC awState ec = liftIO $ STM.atomically $ do 74 | s <- TMVar.takeTMVar (aWStatePureStateState awState) 75 | let (((!events, !eventResult), !invarsToRun), !s') = runAWUpdatePureState (runEventC ec) s (awStatePureStateInvariants awState) 76 | 77 | case runAWQueryPureState (runChangedSegmentsInvariantsMap invarsToRun) s' of 78 | Nothing -> do 79 | pure . Right $ (events, eventResult, (liftIO . STM.atomically $ TMVar.putTMVar (aWStatePureStateState awState) s'), (liftIO . STM.atomically $ TMVar.putTMVar (aWStatePureStateState awState) s)) 80 | Just errs -> do 81 | TMVar.putTMVar (aWStatePureStateState awState) s 82 | pure . Left $ errs 83 | runQuery awState q = do 84 | s <- liftIO $ STM.atomically $ TMVar.readTMVar (aWStatePureStateState awState) 85 | pure $ runAWQueryPureState q s 86 | liftQuery q = do 87 | s <- AWUpdatePureState . lift . lift $ St.get 88 | pure $ runAWQueryPureState q s 89 | 90 | 91 | runAWQueryPureState :: AWQuery AcidStatePureState ss a -> SegmentsState ss -> a 92 | runAWQueryPureState (AWQueryPureState q) s = Re.runReader q s 93 | 94 | runAWUpdatePureState :: AWUpdate AcidStatePureState ss a -> SegmentsState ss -> Invariants ss -> ((a, ChangedSegmentsInvariantsMap AcidStatePureState ss), SegmentsState ss) 95 | runAWUpdatePureState act s i = 96 | let stm = extractAWUpdatePureState act 97 | in St.runState (St.runStateT (Re.runReaderT stm i) HM.empty) s -------------------------------------------------------------------------------- /src/Acid/Core/Backend/Postgresql.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Acid.Core.Backend.Postgresql where 5 | import RIO 6 | import qualified RIO.List as L 7 | import Conduit 8 | 9 | import Database.PostgreSQL.Simple as PSQL 10 | import Database.PostgreSQL.Simple.ToField 11 | import Database.PostgreSQL.Simple.ToRow 12 | 13 | 14 | import Generics.SOP 15 | import Generics.SOP.NP 16 | import qualified Data.Vinyl.Derived as V 17 | import qualified Data.Vinyl.TypeLevel as V 18 | import Control.Arrow (left) 19 | 20 | import Acid.Core.Serialise.Abstract 21 | import Acid.Core.Serialise.Postgresql 22 | import Acid.Core.State 23 | import Acid.Core.Utils 24 | import Acid.Core.Backend.Abstract 25 | import Acid.Core.Segment 26 | 27 | data AcidWorldBackendPostgresql 28 | 29 | 30 | 31 | 32 | 33 | instance AcidWorldBackend AcidWorldBackendPostgresql where 34 | data AWBState AcidWorldBackendPostgresql = AWBStatePostgresql {awbStatePostgresqlConnection :: Connection} 35 | data AWBConfig AcidWorldBackendPostgresql = AWBConfigPostgresql {awvConfigPostgresqlConnectionConfig :: ConnectInfo} deriving Show 36 | type AWBSerialiseT AcidWorldBackendPostgresql = [PostgresRow] 37 | type AWBSerialiseConduitT AcidWorldBackendPostgresql = PostgresConduitT 38 | type AWBSerialiseSegmentT AcidWorldBackendPostgresql = (PostgresRow) 39 | initialiseBackend c _ = do 40 | p <- liftIO $ PSQL.connect (awvConfigPostgresqlConnectionConfig c) 41 | pure . pure $ AWBStatePostgresql p 42 | closeBackend s = liftIO $ close (awbStatePostgresqlConnection s) 43 | createCheckpointBackend s awu t = do 44 | st <- runQuery awu askStateNp 45 | void $ liftIO $ execute_ (awbStatePostgresqlConnection s) "update storableevent set eventCheckpointed = TRUE" 46 | insertCheckpoint s t st 47 | 48 | 49 | 50 | getInitialState defState s t = fmap (left AWExceptionSegmentDeserialisationError) $ queryLastCheckpointState defState s t 51 | 52 | loadEvents deserialiseConduit s _ = pure . pure $ LoadEventsConduit $ \restConduit -> liftIO $ 53 | runConduitRes $ 54 | sourceDatabase .| 55 | deserialiseConduit .| 56 | restConduit 57 | where 58 | sourceDatabase :: ConduitT i PostgresConduitT (ResourceT IO) () 59 | sourceDatabase = do 60 | -- the api for Postgresql-simple does not really allow composing a conduit from a fold or similar, though it should be easy enough to do with the lower level libpq api 61 | res <- liftIO $ query_ (awbStatePostgresqlConnection s) "select * from storableEvent where eventCheckpointed = FALSE ORDER BY id ASC" 62 | yieldMany $ res 63 | 64 | handleUpdateEventC serializer s awu _ ec prePersistHook postPersistHook = do 65 | eBind (runUpdateC awu ec) $ \(es, r, onSuccess, onFail) -> do 66 | stEs <- mkStorableEvents es 67 | ioRPre <- onException (prePersistHook r) onFail 68 | 69 | let rows = serializer stEs 70 | successIO <- toIO onSuccess 71 | failIO <- toIO onFail 72 | 73 | liftIO $ withTransaction (awbStatePostgresqlConnection s) $ do 74 | 75 | res <- executeMany (awbStatePostgresqlConnection s) "insert into storableEvent VALUES (?,?,?,?,?)" rows 76 | 77 | if (fromIntegral res) /= length rows 78 | then do 79 | failIO 80 | throwIO $ AWExceptionEventSerialisationError $ "Expected to write " <> showT (length rows) <> " but only wrote " <> showT res 81 | else successIO 82 | 83 | 84 | 85 | ioRPost <- postPersistHook r 86 | 87 | pure . Right $ (r, (ioRPre, ioRPost)) 88 | 89 | 90 | insertCheckpoint :: forall t sFields m. ( AcidSerialiseSegmentT t ~ (PostgresRow), MonadUnliftIO m, All (AcidSerialiseSegmentFieldConstraint t) sFields) => AWBState AcidWorldBackendPostgresql -> AcidSerialiseEventOptions t -> NP V.ElField sFields -> m () 91 | insertCheckpoint s t np = do 92 | 93 | let acts = cfoldMap_NP (Proxy :: Proxy (AcidSerialiseSegmentFieldConstraint t)) ((:[]) . insertSegment s t) np 94 | sequence_ acts 95 | 96 | 97 | insertSegment :: forall t m fs. ( AcidSerialiseSegmentT t ~ (PostgresRow), MonadUnliftIO m, AcidSerialiseSegmentFieldConstraint t fs) => AWBState AcidWorldBackendPostgresql -> AcidSerialiseEventOptions t -> V.ElField fs -> m () 98 | insertSegment s t (V.Field seg) = do 99 | 100 | runConduitRes $ 101 | serialiseSegment t seg .| 102 | sinkDatabase 103 | 104 | where 105 | sinkDatabase :: ConduitT (PostgresRow) o (ResourceT m) () 106 | sinkDatabase = awaitForever loop 107 | where 108 | loop :: (PostgresRow) -> ConduitT (PostgresRow) o (ResourceT m) () 109 | loop (PostgresRow a) = do 110 | let q = mconcat ["insert into ", fromString $ tableName (Proxy :: Proxy (V.Fst fs)), " values ( ", valueFill, ")"] 111 | void $ liftIO $ execute (awbStatePostgresqlConnection s) q rowActions 112 | 113 | where 114 | valueFill :: Query 115 | valueFill = fromString $ L.intercalate "," $ replicate (length rowActions) "?" 116 | rowActions :: [Action] 117 | rowActions = toRow a 118 | 119 | 120 | 121 | 122 | queryLastCheckpointState :: forall ss m t. (ValidSegmentsSerialise t ss, MonadUnliftIO m, AcidDeserialiseSegmentT t ~ PostgresConduitT) => SegmentsState ss -> AWBState AcidWorldBackendPostgresql -> AcidSerialiseEventOptions t -> m (Either Text (SegmentsState ss)) 123 | queryLastCheckpointState defState s t = (fmap . fmap) (npToSegmentsState) segsNpE 124 | 125 | where 126 | segsNpE :: m (Either Text (NP V.ElField (ToSegmentFields ss))) 127 | segsNpE = unComp $ sequence'_NP segsNp 128 | segsNp :: NP (( m :.: Either Text) :.: V.ElField) (ToSegmentFields ss) 129 | segsNp = cmap_NP (Proxy :: Proxy (SegmentFieldSerialise ss t)) readSegmentFromProxy proxyNp 130 | readSegmentFromProxy :: forall a b. (AcidSerialiseSegmentFieldConstraint t '(a, b), b ~ SegmentS a, HasSegment ss a) => Proxy '(a, b) -> ((m :.: Either Text) :.: V.ElField) '(a, b) 131 | readSegmentFromProxy _ = Comp $ fmap V.Field $ Comp $ readSegment (Proxy :: Proxy a) 132 | readSegment :: forall sName. (AcidSerialiseSegmentNameConstraint t sName, HasSegment ss sName) => Proxy sName -> m (Either Text (SegmentS sName)) 133 | readSegment ps = do 134 | 135 | res <- liftIO $ query_ (awbStatePostgresqlConnection s) (mconcat ["select * from ", fromString $ tableName ps]) 136 | if length res < 1 137 | then pure . Right $ getSegmentP ps defState 138 | else 139 | runResourceT $ runConduit $ 140 | yieldMany res .| deserialiseSegment t 141 | 142 | 143 | proxyNp :: NP Proxy (ToSegmentFields ss) 144 | proxyNp = pure_NP Proxy -------------------------------------------------------------------------------- /src/Acid/Core/Serialise/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Acid.Core.Serialise.JSON where 5 | 6 | import RIO 7 | import qualified RIO.HashMap as HM 8 | import qualified RIO.ByteString.Lazy as BL 9 | import qualified RIO.ByteString as BS 10 | import qualified RIO.Vector as V 11 | 12 | --import Control.Arrow (left) 13 | import Generics.SOP 14 | import Generics.SOP.NP 15 | 16 | 17 | import qualified Data.Aeson as Aeson 18 | import qualified Data.Aeson.Types as Aeson 19 | import Data.Aeson(FromJSON(..), ToJSON(..), Value(..)) 20 | import Acid.Core.Utils 21 | import Acid.Core.State 22 | import Acid.Core.Serialise.Abstract 23 | import Acid.Core.Serialise.JSON.Partial 24 | import Conduit 25 | 26 | data AcidSerialiserJSON 27 | 28 | 29 | 30 | 31 | instance AcidSerialiseEvent AcidSerialiserJSON where 32 | data AcidSerialiseEventOptions AcidSerialiserJSON = AcidSerialiserJSONOptions 33 | type AcidSerialiseParser AcidSerialiserJSON ss nn = PartialParserBS (WrappedEvent ss nn) 34 | type AcidSerialiseT AcidSerialiserJSON = BL.ByteString 35 | type AcidSerialiseConduitT AcidSerialiserJSON = BS.ByteString 36 | serialiserFileExtension _ = ".json" 37 | -- due to the constraints of json (single top level object) we have a choice between some kind of separation between events (newline) or to simply write out the event name followed by the event. we choose the latter because it should be more efficient from a parsing perspective, and it allows a common interface with other parsers (SafeCopy) 38 | serialiseStorableEvent :: forall ss nn n.(AcidSerialiseConstraint AcidSerialiserJSON ss n) => AcidSerialiseEventOptions AcidSerialiserJSON -> StorableEvent ss nn n -> AcidSerialiseT AcidSerialiserJSON 39 | serialiseStorableEvent _ se = addCRC $ Aeson.encode (toUniqueText (Proxy :: Proxy n)) <> (Aeson.encode se) 40 | deserialiseStorableEvent :: forall ss nn n. (AcidSerialiseConstraint AcidSerialiserJSON ss n) => AcidSerialiseEventOptions AcidSerialiserJSON -> AcidSerialiseT AcidSerialiserJSON -> (Either Text (StorableEvent ss nn n)) 41 | deserialiseStorableEvent _ t = consumeMatchAndParse (Proxy :: Proxy Text) (toUniqueText (Proxy :: Proxy n)) =<< checkAndConsumeCRC t 42 | makeDeserialiseParsers _ _ _ = pure makeJSONParsers 43 | deserialiseEventStream :: forall ss nn m. (Monad m) => AcidSerialiseEventOptions AcidSerialiserJSON -> AcidSerialiseParsers AcidSerialiserJSON ss nn -> (ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) ()) 44 | deserialiseEventStream _ ps = connectEitherConduit checkSumConduit $ 45 | deserialiseEventStreamWithPartialParser (findJSONParserForWrappedEvent ps) 46 | 47 | handleJSONParserResult :: JSONResult a -> Either Text (Either (PartialParserBS a) (BS.ByteString, a)) 48 | handleJSONParserResult (JSONResultFail err) = Left $ err 49 | handleJSONParserResult (JSONResultPartial p) = Right . Left $ (PartialParser $ \bs -> handleJSONParserResult $ p bs) 50 | handleJSONParserResult (JSONResultDone (bs, a)) = Right . Right $ (bs, a) 51 | 52 | jsonPartialParser :: (FromJSON a) => PartialParserBS a 53 | jsonPartialParser = PartialParser $ \t -> handleJSONParserResult $ eitherPartialDecode' t 54 | 55 | findJSONParserForWrappedEvent :: forall ss nn. AcidSerialiseParsers AcidSerialiserJSON ss nn -> PartialParserBS ( PartialParserBS (WrappedEvent ss nn)) 56 | findJSONParserForWrappedEvent ps = fmapPartialParser findJSONParser jsonPartialParser 57 | where 58 | findJSONParser :: Text -> Either Text (PartialParserBS (WrappedEvent ss nn)) 59 | findJSONParser n = do 60 | case HM.lookup n ps of 61 | Just p -> pure p 62 | Nothing -> Left $ "Could not find parser for event named " <> n 63 | 64 | 65 | class (ValidEventName ss n, All FromJSON (EventArgs n), All ToJSON (EventArgs n)) => CanSerialiseJSON ss n 66 | instance (ValidEventName ss n, All FromJSON (EventArgs n), All ToJSON (EventArgs n)) => CanSerialiseJSON ss n 67 | 68 | instance AcidSerialiseC AcidSerialiserJSON where 69 | type AcidSerialiseConstraintP AcidSerialiserJSON ss = CanSerialiseJSON ss 70 | 71 | instance (ToJSON seg, FromJSON seg) => AcidSerialiseSegment AcidSerialiserJSON seg where 72 | serialiseSegment _ seg = sourceLazy $ Aeson.encode seg 73 | deserialiseSegment _ = deserialiseWithPartialParserSink jsonPartialParser 74 | 75 | 76 | 77 | makeJSONParsers :: forall ss nn. (All (CanSerialiseJSON ss) nn) => AcidSerialiseParsers AcidSerialiserJSON ss nn 78 | makeJSONParsers = 79 | let (wres) = cfoldMap_NP (Proxy :: Proxy (CanSerialiseJSON ss)) (\p -> [toTaggedTuple p]) proxyRec 80 | in HM.fromList wres 81 | where 82 | proxyRec :: NP Proxy nn 83 | proxyRec = pure_NP Proxy 84 | toTaggedTuple :: (CanSerialiseJSON ss n) => Proxy n -> (Text, PartialParserBS (WrappedEvent ss nn)) 85 | toTaggedTuple p = (toUniqueText p, decodeWrappedEventJSON p) 86 | 87 | decodeWrappedEventJSON :: forall n ss nn. (CanSerialiseJSON ss n) => Proxy n -> PartialParserBS (WrappedEvent ss nn) 88 | decodeWrappedEventJSON _ = fmapPartialParser (pure . (WrappedEvent :: StorableEvent ss nn n -> WrappedEvent ss nn)) jsonPartialParser 89 | 90 | 91 | fromJSONEither :: FromJSON a => Value -> Either Text a 92 | fromJSONEither v = 93 | case Aeson.fromJSON v of 94 | (Aeson.Success a) -> pure a 95 | (Aeson.Error e) -> fail e 96 | 97 | 98 | 99 | instance (All ToJSON (EventArgs n)) => ToJSON (StorableEvent ss nn n) where 100 | toJSON (StorableEvent t ui (Event xs :: Event n)) = Object $ HM.fromList [ 101 | ("t", toJSON t), 102 | ("i", toJSON ui), 103 | ("a", toJSON xs)] 104 | 105 | instance (All ToJSON xs) => ToJSON (EventArgsContainer xs) where 106 | toJSON (EventArgsContainer np) = 107 | toJSON $ collapse_NP $ cmap_NP (Proxy :: Proxy ToJSON) (K . toJSON . unI) np 108 | 109 | 110 | instance (CanSerialiseJSON ss n, EventArgs n ~ xs) => FromJSON (StorableEvent ss nn n) where 111 | parseJSON = Aeson.withObject "WrappedEventT" $ \o -> do 112 | t <- o Aeson..: "t" 113 | uid <- o Aeson..: "i" 114 | args <- o Aeson..: "a" 115 | 116 | return $ StorableEvent t uid ((Event args) :: Event n) 117 | 118 | instance (All FromJSON xs) => FromJSON (EventArgsContainer xs) where 119 | parseJSON = Aeson.withArray "EventArgsContainer" $ \v -> fmap EventArgsContainer $ npIFromJSON (V.toList v) 120 | 121 | npIFromJSON :: forall xs. (All FromJSON xs) => [Value] -> Aeson.Parser (NP I xs) 122 | npIFromJSON [] = 123 | case sList :: SList xs of 124 | SNil -> pure Nil 125 | SCons -> fail "No values left but still expecting a type" 126 | npIFromJSON (v:vs) = 127 | case sList :: SList xs of 128 | SNil -> fail "More values than expected" 129 | SCons -> do 130 | r <- npIFromJSON vs 131 | a <- Aeson.parseJSON v 132 | pure $ I a :* r -------------------------------------------------------------------------------- /src/Acid/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | 4 | module Acid.Core where 5 | import RIO 6 | 7 | import Generics.SOP 8 | 9 | import Acid.Core.Utils 10 | import Acid.Core.Segment 11 | import Acid.Core.State 12 | import Acid.Core.Serialise 13 | import Acid.Core.Backend 14 | 15 | data AcidWorld ss nn t where 16 | AcidWorld :: ( 17 | AcidWorldBackend b 18 | , ValidAcidWorldState uMonad ss 19 | , AcidSerialiseEvent t 20 | , AcidSerialiseT t ~ AWBSerialiseT b 21 | , AcidSerialiseConduitT t ~ AWBSerialiseConduitT b 22 | , AcidSerialiseSegmentT t ~ AWBSerialiseSegmentT b 23 | , AcidDeserialiseSegmentT t ~ AWBDeserialiseSegmentT b 24 | , AcidSerialiseConstraintAll t ss nn 25 | , ValidEventNames ss nn 26 | , ValidSegmentsSerialise t ss 27 | ) => { 28 | acidWorldBackendConfig :: AWBConfig b, 29 | acidWorldStateConfig :: AWConfig uMonad ss, 30 | acidWorldBackendState :: AWBState b, 31 | acidWorldState :: AWState uMonad ss, 32 | acidWorldSerialiserOptions :: AcidSerialiseEventOptions t, 33 | acidWorldDefaultState :: SegmentsState ss, 34 | acidWorldInvariants :: Invariants ss 35 | } -> AcidWorld ss nn t 36 | 37 | 38 | 39 | openAcidWorld :: forall m ss nn b uMonad t. 40 | ( MonadUnliftIO m 41 | , PrimMonad m 42 | , MonadThrow m 43 | , AcidWorldBackend b 44 | , ValidAcidWorldState uMonad ss 45 | , AcidSerialiseEvent t 46 | , AcidSerialiseT t ~ AWBSerialiseT b 47 | , AcidSerialiseConduitT t ~ AWBSerialiseConduitT b 48 | , AcidSerialiseSegmentT t ~ AWBSerialiseSegmentT b 49 | , AcidDeserialiseSegmentT t ~ AWBDeserialiseSegmentT b 50 | , AcidSerialiseConstraintAll t ss nn 51 | , ValidEventNames ss nn 52 | , ValidSegmentsSerialise t ss 53 | ) => SegmentsState ss -> Invariants ss -> AWBConfig b -> AWConfig uMonad ss -> AcidSerialiseEventOptions t -> m (Either AWException (AcidWorld ss nn t)) 54 | openAcidWorld acidWorldDefaultState acidWorldInvariants acidWorldBackendConfig acidWorldStateConfig acidWorldSerialiserOptions = do 55 | eBind (initialiseBackend acidWorldBackendConfig acidWorldSerialiserOptions) $ \acidWorldBackendState -> do 56 | 57 | eBind (makeBackendHandles acidWorldBackendState) $ \handles -> do 58 | 59 | eAcidWorldState <- initialiseState acidWorldStateConfig handles acidWorldInvariants 60 | case eAcidWorldState of 61 | Left err -> do 62 | closeBackend acidWorldBackendState 63 | pure . Left $ err 64 | Right acidWorldState -> pure . pure $ AcidWorld{..} 65 | where 66 | makeBackendHandles :: AWBState b -> m (Either AWException (BackendHandles m ss nn)) 67 | makeBackendHandles acidWorldBackendState = do 68 | parsers <- makeDeserialiseParsers acidWorldSerialiserOptions (Proxy :: Proxy ss) (Proxy :: Proxy nn) 69 | (fmap . fmap) (\lEvents -> BackendHandles lEvents (getInitialState acidWorldDefaultState acidWorldBackendState acidWorldSerialiserOptions)) $ (loadEvents (deserialiseEventStream acidWorldSerialiserOptions parsers) acidWorldBackendState acidWorldSerialiserOptions) 70 | 71 | closeAcidWorld :: (MonadIO m) => AcidWorld ss nn t -> m () 72 | closeAcidWorld (AcidWorld {..}) = do 73 | closeBackend acidWorldBackendState 74 | closeState acidWorldState 75 | 76 | reopenAcidWorld :: (MonadUnliftIO m, PrimMonad m, MonadThrow m) => AcidWorld ss nn t -> m (Either AWException (AcidWorld ss nn t)) 77 | reopenAcidWorld (AcidWorld {..}) = do 78 | openAcidWorld acidWorldDefaultState acidWorldInvariants acidWorldBackendConfig acidWorldStateConfig acidWorldSerialiserOptions 79 | 80 | update :: forall ss nn n m t. (IsValidEvent ss nn n, MonadUnliftIO m, AcidSerialiseConstraint t ss n) => AcidWorld ss nn t -> Event n -> m (Either AWException (EventResult n)) 81 | update aw e = updateC aw (EventC e) 82 | 83 | updateWithIO :: forall ss nn n m t ioResPre ioResPost. (IsValidEvent ss nn n, MonadUnliftIO m, AcidSerialiseConstraint t ss n) => AcidWorld ss nn t -> Event n -> (EventResult n -> m ioResPre) -> (EventResult n -> m ioResPost) -> m (Either AWException (EventResult n, (ioResPre, ioResPost))) 84 | updateWithIO aw e = updateCWithIO aw (EventC e) 85 | 86 | updateC :: forall ss nn firstN ns m t. (All (IsValidEvent ss nn) (firstN ': ns), All (ValidEventName ss) (firstN ': ns), MonadUnliftIO m, AcidSerialiseConstraintAll t ss (firstN ': ns)) => AcidWorld ss nn t -> EventC (firstN ': ns) -> m (Either AWException (EventResult firstN)) 87 | updateC aw ec = (fmap . fmap) fst $ updateCWithIO aw ec (const $ pure ()) (const $ pure ()) 88 | 89 | updateCWithIO :: forall ss nn firstN ns m t ioResPre ioResPost. (All (IsValidEvent ss nn) (firstN ': ns), All (ValidEventName ss) (firstN ': ns), MonadUnliftIO m, AcidSerialiseConstraintAll t ss (firstN ': ns)) => AcidWorld ss nn t -> EventC (firstN ': ns) -> (EventResult firstN -> m ioResPre) -> (EventResult firstN -> m ioResPost) -> m (Either AWException (EventResult firstN, (ioResPre, ioResPost))) 90 | updateCWithIO (AcidWorld {..}) ec = handleUpdateEventC ((serialiseEventNP acidWorldSerialiserOptions) :: NP (StorableEvent ss nn) (firstN ': ns) -> AcidSerialiseT t) acidWorldBackendState acidWorldState acidWorldSerialiserOptions ec 91 | 92 | query ::forall ss nn t m a. MonadIO m => AcidWorld ss nn t -> (forall i. ValidAcidWorldState i ss => AWQuery i ss a) -> m a 93 | query (AcidWorld {..}) q = runQuery acidWorldState q 94 | 95 | 96 | createCheckpoint ::forall ss nn t m. (MonadUnliftIO m, MonadThrow m, PrimMonad m) => AcidWorld ss nn t -> m () 97 | createCheckpoint (AcidWorld {..}) = createCheckpointBackend acidWorldBackendState acidWorldState acidWorldSerialiserOptions 98 | {- 99 | AcidWorldBackend 100 | -} 101 | 102 | 103 | 104 | 105 | 106 | {- 107 | AcidWorld Inner monad 108 | -} 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | {- 129 | attempt at composing events 130 | instance (Eventable a, Eventable b) => Eventable (a, b) where 131 | type EventArgs (a, b) = '[(V.HList (EventArgs a), V.HList (EventArgs b))] 132 | type EventResult (a, b) = (EventResult a, EventResult b) 133 | type EventS (a, b) = (EventS a) V.++ (EventS b) 134 | --type EventC (a, b) = () 135 | runEvent _ args = do 136 | let (argsA, argsB) = rHead args 137 | res1 <- runEvent (Proxy :: Proxy a) argsA 138 | res2 <- runEvent (Proxy :: Proxy b) argsB 139 | return (res1, res2) 140 | rHead :: V.Rec V.Identity (a ': xs) -> a 141 | rHead (ir V.:& _) = V.getIdentity ir 142 | 143 | -} 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | -------------------------------------------------------------------------------- /src/Acid/Core/Serialise/SafeCopy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Acid.Core.Serialise.SafeCopy where 5 | 6 | import RIO 7 | import qualified RIO.HashMap as HM 8 | import qualified RIO.Text as T 9 | import qualified RIO.ByteString as BS 10 | import qualified RIO.ByteString.Lazy as BL 11 | 12 | import Control.Arrow (left) 13 | import Generics.SOP 14 | import Generics.SOP.NP 15 | import Data.SafeCopy 16 | import Data.SafeCopy.Internal hiding (Proxy) 17 | import Data.Serialize 18 | import qualified Data.UUID as UUID 19 | 20 | 21 | import Acid.Core.Utils 22 | import Acid.Core.State 23 | import Acid.Core.Serialise.Abstract 24 | import Conduit 25 | 26 | {- 27 | implementation of a json serialiser 28 | -} 29 | data AcidSerialiserSafeCopy 30 | 31 | 32 | 33 | instance AcidSerialiseEvent AcidSerialiserSafeCopy where 34 | data AcidSerialiseEventOptions AcidSerialiserSafeCopy = AcidSerialiserSafeCopyOptions 35 | type AcidSerialiseParser AcidSerialiserSafeCopy ss nn = PartialParserBS (WrappedEvent ss nn) 36 | type AcidSerialiseT AcidSerialiserSafeCopy = BL.ByteString 37 | type AcidSerialiseConduitT AcidSerialiserSafeCopy = BS.ByteString 38 | serialiserFileExtension _ = ".safecopy" 39 | serialiseStorableEvent o se = addCRC $ runPutLazy $ serialiseSafeCopyEvent o se 40 | deserialiseStorableEvent o t = (left (T.pack) . (runGetLazy (deserialiseSafeCopyEvent o))) =<< checkAndConsumeCRC t 41 | makeDeserialiseParsers _ _ _ = pure makeSafeCopyParsers 42 | deserialiseEventStream :: forall ss nn m. (Monad m) => AcidSerialiseEventOptions AcidSerialiserSafeCopy -> AcidSerialiseParsers AcidSerialiserSafeCopy ss nn -> (ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) ()) 43 | deserialiseEventStream _ ps = connectEitherConduit checkSumConduit $ 44 | 45 | deserialiseEventStreamWithPartialParser (findSafeCopyParserForWrappedEvent ps) 46 | 47 | 48 | safeCopyPartialParser :: (SafeCopy a) => PartialParserBS a 49 | safeCopyPartialParser = PartialParser $ \t -> handleDataDotSerializeParserResult $ runGetPartial safeGet t 50 | 51 | findSafeCopyParserForWrappedEvent :: forall ss nn. AcidSerialiseParsers AcidSerialiserSafeCopy ss nn -> PartialParserBS ( PartialParserBS (WrappedEvent ss nn)) 52 | findSafeCopyParserForWrappedEvent ps = fmapPartialParser findSafeCopyParser safeCopyPartialParser 53 | where 54 | findSafeCopyParser :: BS.ByteString -> Either Text (PartialParserBS (WrappedEvent ss nn)) 55 | findSafeCopyParser n = do 56 | let eName = (T.decodeUtf8' n) 57 | case eName of 58 | Left err -> Left $ "Could not decode event name" <> T.pack (show err) 59 | Right name -> 60 | case HM.lookup name ps of 61 | Just p -> pure p 62 | Nothing -> Left $ "Could not find parser for event named " <> name 63 | 64 | 65 | 66 | 67 | 68 | class (ValidEventName ss n, All SafeCopy (EventArgs n)) => CanSerialiseSafeCopy ss n 69 | instance (ValidEventName ss n, All SafeCopy (EventArgs n)) => CanSerialiseSafeCopy ss n 70 | 71 | instance AcidSerialiseC AcidSerialiserSafeCopy where 72 | type AcidSerialiseConstraintP AcidSerialiserSafeCopy ss = CanSerialiseSafeCopy ss 73 | 74 | instance (SafeCopy seg) => AcidSerialiseSegment AcidSerialiserSafeCopy seg where 75 | serialiseSegment _ seg = sourceLazy $ runPutLazy $ safePut seg 76 | deserialiseSegment :: forall m o. (Monad m) => AcidSerialiseEventOptions AcidSerialiserSafeCopy -> ConduitT BS.ByteString o m (Either Text seg) 77 | deserialiseSegment _ = deserialiseWithPartialParserSink safeCopyPartialParser 78 | 79 | 80 | 81 | 82 | makeSafeCopyParsers :: forall ss nn. (All (CanSerialiseSafeCopy ss) nn) => AcidSerialiseParsers AcidSerialiserSafeCopy ss nn 83 | makeSafeCopyParsers = 84 | let (wres) = cfoldMap_NP (Proxy :: Proxy (CanSerialiseSafeCopy ss)) (\p -> [toTaggedTuple p]) proxyRec 85 | in HM.fromList wres 86 | where 87 | proxyRec :: NP Proxy nn 88 | proxyRec = pure_NP Proxy 89 | toTaggedTuple :: (CanSerialiseSafeCopy ss n) => Proxy n -> (Text, PartialParserBS (WrappedEvent ss nn)) 90 | toTaggedTuple p = (toUniqueText p, decodeWrappedEventSafeCopy p) 91 | 92 | decodeWrappedEventSafeCopy :: forall n ss nn. (CanSerialiseSafeCopy ss n) => Proxy n -> PartialParserBS (WrappedEvent ss nn) 93 | decodeWrappedEventSafeCopy _ = fmapPartialParser (pure . (WrappedEvent :: StorableEvent ss nn n -> WrappedEvent ss nn)) safeCopyPartialParser 94 | 95 | 96 | 97 | 98 | 99 | 100 | serialiseSafeCopyEvent :: forall ss nn n. (CanSerialiseSafeCopy ss n) => AcidSerialiseEventOptions AcidSerialiserSafeCopy -> StorableEvent ss nn n -> Put 101 | serialiseSafeCopyEvent _ se = do 102 | safePut $ T.encodeUtf8 . toUniqueText $ (Proxy :: Proxy n) 103 | safePut $ se 104 | 105 | 106 | deserialiseSafeCopyEvent :: forall ss nn n. (CanSerialiseSafeCopy ss n) => AcidSerialiseEventOptions AcidSerialiserSafeCopy -> Get (StorableEvent ss nn n) 107 | deserialiseSafeCopyEvent _ = do 108 | (a :: Text) <- fmap decodeUtf8Lenient safeGet 109 | if a == toUniqueText (Proxy :: Proxy n) 110 | then safeGet 111 | else fail $ "Expected " <> T.unpack (toUniqueText (Proxy :: Proxy n)) <> " when consuming prefix, but got " <> show a 112 | 113 | 114 | 115 | 116 | instance (CanSerialiseSafeCopy ss n) => SafeCopy (StorableEvent ss nn n) where 117 | version = Version 0 118 | kind = Base 119 | errorTypeName _ = "StorableEvent ss nn " ++ (T.unpack $ toUniqueText (Proxy :: Proxy n)) 120 | putCopy (StorableEvent t ui (Event xs)) = contain $ do 121 | safePut $ t 122 | safePut $ ui 123 | safePut xs 124 | 125 | getCopy = contain $ do 126 | t <- safeGet 127 | ui <- safeGet 128 | args <- safeGet 129 | pure $ StorableEvent t ui ((Event args) :: Event n) 130 | 131 | 132 | instance SafeCopy EventId where 133 | version = Version 0 134 | kind = Base 135 | errorTypeName _ = "EventId" 136 | putCopy = contain . safePut . UUID.toByteString . uuidFromEventId 137 | getCopy = contain $ do 138 | bs <- safeGet 139 | case UUID.fromByteString bs of 140 | Nothing -> fail $ "Could not parse UUID from bytestring " <> show bs 141 | Just uuid -> pure . EventId $ uuid 142 | 143 | instance (All SafeCopy xs) => SafeCopy (EventArgsContainer xs) where 144 | version = Version 0 145 | kind = Base 146 | errorTypeName _ = "EventArgsContainer xs" 147 | putCopy (EventArgsContainer np) = contain $ do 148 | sequence_ $ cfoldMap_NP (Proxy :: Proxy SafeCopy) ((:[]) . safePut . unI) np 149 | getCopy = contain $ do 150 | np <- npIFromSafeCopy 151 | pure $ EventArgsContainer np 152 | 153 | npIFromSafeCopy :: forall xs. (All SafeCopy xs) => Get (NP I xs) 154 | npIFromSafeCopy = 155 | case sList :: SList xs of 156 | SNil -> pure $ Nil 157 | SCons -> do 158 | a <- safeGet 159 | r <- npIFromSafeCopy 160 | pure $ I a :* r 161 | -------------------------------------------------------------------------------- /src/Acid/Core/Serialise/Postgresql.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableSuperClasses #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Acid.Core.Serialise.Postgresql where 5 | 6 | 7 | import RIO 8 | import qualified RIO.HashMap as HM 9 | import qualified RIO.Text as T 10 | import qualified RIO.List.Partial as Partial 11 | 12 | import Generics.SOP 13 | import Generics.SOP.NP 14 | 15 | import Database.PostgreSQL.Simple 16 | import Database.PostgreSQL.Simple.ToField 17 | import Database.PostgreSQL.Simple.FromField 18 | import Database.PostgreSQL.Simple.ToRow 19 | import Database.PostgreSQL.Simple.Ok 20 | import Data.Aeson(ToJSON(..), FromJSON(..)) 21 | import qualified Data.Aeson.Types as Aeson 22 | import System.IO.Unsafe (unsafePerformIO) 23 | 24 | import Conduit 25 | 26 | import Acid.Core.Serialise.JSON() 27 | import Acid.Core.State 28 | import Acid.Core.Utils 29 | import Acid.Core.Serialise.Abstract 30 | 31 | data PostgresRow where 32 | PostgresRow :: ToRow a => a -> PostgresRow 33 | 34 | type PostgresConduitT = [(Field, Maybe ByteString)] 35 | 36 | instance ToRow PostgresRow where 37 | toRow (PostgresRow a) = toRow a 38 | 39 | 40 | storableEventCreateTable :: Query 41 | storableEventCreateTable = "CREATE TABLE storableevent (id SERIAL PRIMARY KEY, eventName Text NOT NULL, eventDate timestamptz NOT NULL, eventId uuid NOT NULL, eventArgs json NOT NULL, eventCheckpointed bool NOT NULL DEFAULT FALSE);" 42 | 43 | data AcidSerialiserPostgresql 44 | 45 | 46 | instance AcidSerialiseEvent AcidSerialiserPostgresql where 47 | data AcidSerialiseEventOptions AcidSerialiserPostgresql = AcidSerialiserPostgresqlOptions 48 | type AcidSerialiseT AcidSerialiserPostgresql = [PostgresRow] 49 | type AcidSerialiseConduitT AcidSerialiserPostgresql = PostgresConduitT 50 | type AcidSerialiseParser AcidSerialiserPostgresql ss nn = PostgresConduitT -> Conversion (WrappedEvent ss nn) 51 | tConversions _ = (undefined, undefined) 52 | 53 | 54 | serialiseStorableEvent _ n = [PostgresRow n] 55 | deserialiseStorableEvent = error "deserialiseStorableEvent" 56 | makeDeserialiseParsers _ _ _ = pure makePostgresParsers 57 | deserialiseEventStream :: forall ss nn m. (Monad m) => AcidSerialiseEventOptions AcidSerialiserPostgresql -> AcidSerialiseParsers AcidSerialiserPostgresql ss nn -> (ConduitT PostgresConduitT (Either Text (WrappedEvent ss nn)) (m) ()) 58 | deserialiseEventStream _ ps = awaitForever loop 59 | where 60 | loop :: PostgresConduitT -> ConduitT PostgresConduitT (Either Text (WrappedEvent ss nn)) m () 61 | loop fs = do 62 | en <- runConversionToEither (fromIdx fs 1) 63 | case en of 64 | Left err -> yield (Left err) >> awaitForever loop 65 | Right n -> 66 | case HM.lookup n ps of 67 | Nothing -> yield (Left $ "Could not find parser for event named " <> n) >> (awaitForever loop) 68 | Just p -> do 69 | we <- runConversionToEither (p fs) 70 | yield we >> (awaitForever loop) 71 | 72 | 73 | class (ValidEventName ss n, All FromJSON (EventArgs n), All ToJSON (EventArgs n)) => CanSerialisePostgresql ss n 74 | instance (ValidEventName ss n, All FromJSON (EventArgs n), All ToJSON (EventArgs n)) => CanSerialisePostgresql ss n 75 | 76 | instance AcidSerialiseC AcidSerialiserPostgresql where 77 | type AcidSerialiseConstraintP AcidSerialiserPostgresql ss = CanSerialisePostgresql ss 78 | 79 | instance (AcidSerialisePostgres a) => AcidSerialiseSegment AcidSerialiserPostgresql a where 80 | type AcidSerialiseSegmentT AcidSerialiserPostgresql = (PostgresRow) 81 | type AcidDeserialiseSegmentT AcidSerialiserPostgresql = PostgresConduitT 82 | serialiseSegment _ seg = yieldMany $ (toPostgresRows seg) 83 | 84 | deserialiseSegment _ = sinkList >>= \l -> runConversionToEither (fromPostgresConduitT l) 85 | 86 | tableName :: (ToUniqueText a) => Proxy a -> String 87 | tableName p = "app_" <> (T.unpack . T.toLower $ (toUniqueText p)) 88 | 89 | 90 | class AcidSerialisePostgres a where 91 | toPostgresRows :: a -> [PostgresRow] 92 | createTable :: Proxy a -> Query 93 | fromPostgresConduitT :: [PostgresConduitT] -> Conversion a 94 | 95 | 96 | runConversionToEither :: (Monad m) => Conversion a -> m (Either Text a) 97 | runConversionToEither c = do 98 | -- horrific but this is just a poc 99 | eC <- pure $ unsafePerformIO $ (runConversion c) (error "Attempt to access db connection in runConversionToEither") 100 | case eC of 101 | Errors es -> pure . Left . showT $ es 102 | Ok a -> pure . Right $ a 103 | 104 | 105 | instance FromField (Field, Maybe ByteString) where 106 | fromField f bs = pure (f, bs) 107 | 108 | 109 | 110 | 111 | makePostgresParsers :: forall ss nn. (All (CanSerialisePostgresql ss) nn) => AcidSerialiseParsers AcidSerialiserPostgresql ss nn 112 | makePostgresParsers = 113 | let (wres) = cfoldMap_NP (Proxy :: Proxy (CanSerialisePostgresql ss)) (\p -> [toTaggedTuple p]) proxyRec 114 | in HM.fromList wres 115 | where 116 | proxyRec :: NP Proxy nn 117 | proxyRec = pure_NP Proxy 118 | toTaggedTuple :: (CanSerialisePostgresql ss n) => Proxy n -> (Text, PostgresConduitT -> Conversion (WrappedEvent ss nn)) 119 | toTaggedTuple p = (toUniqueText p, decodeWrappedEventPostgres p) 120 | 121 | decodeWrappedEventPostgres :: forall n ss nn. (CanSerialisePostgresql ss n) => Proxy n -> PostgresConduitT -> Conversion (WrappedEvent ss nn) 122 | decodeWrappedEventPostgres _ fs = do 123 | (se :: StorableEvent ss nn n) <- fromFields fs 124 | pure $ WrappedEvent se 125 | 126 | class FromFields a where 127 | fromFields :: PostgresConduitT -> Conversion a 128 | 129 | 130 | fromIdx :: (FromField a) => PostgresConduitT -> Int -> Conversion a 131 | fromIdx fs i = 132 | let (f, bs) = fs Partial.!! i 133 | in fromField f bs 134 | 135 | instance (CanSerialisePostgresql ss n, EventArgs n ~ xs) => FromFields (StorableEvent ss nn n) where 136 | fromFields fs = do 137 | t <- fromIdx fs 2 138 | uid <- fromIdx fs 3 139 | jsonV <- fromIdx fs 4 140 | case Aeson.parseEither parseJSON jsonV of 141 | Left err -> conversionError $ AWExceptionEventDeserialisationError (T.pack err) 142 | Right args -> return $ StorableEvent t (EventId uid) ((Event args) :: Event n) 143 | 144 | 145 | {- deserialiseStorableEvent :: (AcidSerialiseConstraint t ss n) => AcidSerialiseEventOptions t -> AcidSerialiseT t -> (Either Text (StorableEvent ss nn n)) 146 | 147 | makeDeserialiseParsers :: (ValidEventNames ss nn, AcidSerialiseConstraintAll t ss nn) => AcidSerialiseEventOptions t -> Proxy ss -> Proxy nn -> AcidSerialiseParsers t ss nn 148 | deserialiseEventStream :: (Monad m) => AcidSerialiseEventOptions t -> AcidSerialiseParsers t ss nn -> (ConduitT (AcidSerialiseConduitT t) (Either Text (WrappedEvent ss nn)) (m) ()) 149 | -} 150 | 151 | 152 | instance ToField EventId where 153 | toField = toField . uuidFromEventId 154 | 155 | instance (All ToJSON (EventArgs n)) => ToRow (StorableEvent ss nn n) where 156 | toRow (StorableEvent t ui (Event xs :: Event n)) = 157 | [Plain "DEFAULT", toField (toUniqueText (Proxy :: Proxy n)), toField t, toField ui, toField $ toJSON xs] -------------------------------------------------------------------------------- /src/Acid/Core/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Acid.Core.Utils where 4 | 5 | import RIO 6 | import qualified RIO.Text as T 7 | import GHC.TypeLits 8 | import GHC.Exts 9 | import qualified Data.Vinyl as V 10 | import qualified Data.Vinyl.Functor as V 11 | import qualified Data.Vinyl.Curry as V 12 | import qualified Data.Vinyl.ARec as V 13 | import qualified Data.Vinyl.TypeLevel as V 14 | import Data.Proxy(Proxy(..)) 15 | 16 | import Generics.SOP.NP 17 | import qualified Generics.SOP as SOP 18 | import qualified Control.Concurrent.STM.TMVar as TMVar 19 | 20 | 21 | class ExtractFromNP (xs :: [*]) (x :: *) where 22 | extractFromNP :: NP a xs -> a x 23 | 24 | instance {-# OVERLAPPING #-} ExtractFromNP (x ': xs) x where 25 | extractFromNP ((:*) x _) = x 26 | 27 | instance {-# OVERLAPPABLE #-} (ExtractFromNP xs x) => ExtractFromNP (y ': xs) x where 28 | extractFromNP ((:*) _ rest) = extractFromNP rest 29 | 30 | 31 | withTMVarSafe :: (MonadUnliftIO m) => TMVar a -> (a -> m b) -> m b 32 | withTMVarSafe m io = do 33 | a <- liftIO . atomically $ TMVar.takeTMVar m 34 | b <- onException (io a) (liftIO . atomically $ TMVar.putTMVar m a) 35 | liftIO . atomically $ TMVar.putTMVar m a 36 | pure b 37 | 38 | 39 | modifyTMVar :: (MonadIO m) => TMVar a -> (a -> m (a, b)) -> m b 40 | modifyTMVar m io = do 41 | a <- liftIO $ atomically $ TMVar.takeTMVar m 42 | (a', b) <- io a 43 | liftIO $ atomically $ TMVar.putTMVar m a' 44 | pure b 45 | 46 | 47 | modifyTMVarWithOnException :: (MonadUnliftIO m) => TMVar a -> m a -> (a -> m (a, b)) -> m b 48 | modifyTMVarWithOnException m onExc io = do 49 | a <- liftIO $ atomically $ TMVar.takeTMVar m 50 | (a', b) <- onException (io a) (liftIO . atomically . TMVar.putTMVar m =<< onException onExc (liftIO . atomically $ TMVar.putTMVar m a)) 51 | liftIO $ atomically $ TMVar.putTMVar m a' 52 | pure b 53 | 54 | modifyTMVarSafe :: (MonadUnliftIO m) => TMVar a -> (a -> m (a, b)) -> m b 55 | modifyTMVarSafe m io = do 56 | a <- liftIO $ atomically $ TMVar.takeTMVar m 57 | (a', b) <- onException (io a) (liftIO . atomically $ TMVar.putTMVar m a) 58 | liftIO $ atomically $ TMVar.putTMVar m a' 59 | pure b 60 | 61 | 62 | 63 | eBind :: (Monad m) => m (Either a b) -> (b -> m (Either a c)) -> m (Either a c) 64 | eBind act f = do 65 | r <- act 66 | case r of 67 | Left e -> pure $ Left e 68 | Right b -> f b 69 | 70 | 71 | class ToUniqueText (a :: k) where 72 | toUniqueText :: Proxy a -> Text 73 | 74 | instance (KnownSymbol a) => ToUniqueText (a :: Symbol) where 75 | toUniqueText = T.pack . symbolVal 76 | 77 | showT :: (Show a) => a -> T.Text 78 | showT = utf8BuilderToText . displayShow 79 | 80 | showSymbol :: (KnownSymbol a) => proxy a -> T.Text 81 | showSymbol p = T.pack $ symbolVal p 82 | 83 | type family Sort (xs :: [Symbol]) where 84 | Sort '[] = '[] 85 | Sort (x ': xs) = Insert x (Sort xs) 86 | 87 | type family Insert x xs where 88 | Insert x '[] = x ': '[] 89 | Insert x (y ': ys) = Insert' (CmpSymbol x y) x y ys 90 | 91 | type family Insert' b x y ys where 92 | Insert' 'LT x y ys = x ': (y ': ys) 93 | Insert' _ x y ys = y ': Insert x ys 94 | 95 | 96 | 97 | type family Last (a :: [k]) :: k where 98 | Last '[] = TypeError ('Text "Expected a type level list with at least one element") 99 | Last '[a] = a 100 | Last (a ': xs) = Last xs 101 | 102 | type family First (a :: [k]) :: k where 103 | First '[] = TypeError ('Text "Expected a type level list with at least one element") 104 | First (a ': _) = a 105 | 106 | type family Union (a :: [k]) (b :: [k]) = (res :: [k]) where 107 | Union '[] b = b 108 | Union (a ': xs) b = a ': Union xs b 109 | 110 | type family Elem (a :: k) (b :: [k]) :: Bool where 111 | Elem a '[] = 'False 112 | Elem a (a ': xs) = 'True 113 | Elem a (b ': xs) = Elem a xs 114 | 115 | type family ElemOrErr (a :: k) (b :: [k]) :: Constraint where 116 | ElemOrErr a xs = IfOrErrC (Elem a xs) (( 117 | 'Text "Type " ':<>: 118 | 'ShowType a ':$$: 119 | 'Text "not found in the type level list: " ':<>: 120 | 'ShowType xs)) 121 | 122 | type family IfOrErrC (a :: Bool) (err :: ErrorMessage) :: Constraint where 123 | IfOrErrC 'True _ = () 124 | IfOrErrC 'False err = TypeError err 125 | 126 | class (Elem a b ~ 'True) => IsElem (a :: k) (b :: [k]) 127 | instance (Elem a b ~ 'True) => IsElem a b 128 | 129 | type family And (a :: Bool) (b :: Bool) :: Bool where 130 | And 'False a = 'False 131 | And 'True a = a 132 | And a 'False = 'False 133 | And a 'True = a 134 | And a a = a 135 | 136 | type family UniqueElementsWithErr (a :: [k]) :: Bool where 137 | UniqueElementsWithErr a = UniqueElementsWithErr' a a 138 | 139 | type family UniqueElementsWithErr' (a :: [k]) (b :: [k]) :: Bool where 140 | UniqueElementsWithErr' '[] _ = 'True 141 | UniqueElementsWithErr' (a ': xs) b = And (NotWithErr (Elem a xs) ( 142 | 'Text "Duplicate element found: " ':<>: 143 | 'ShowType a ':$$: 144 | 'Text " in type list: " ':<>: 'ShowType b 145 | )) (UniqueElementsWithErr' xs b) 146 | 147 | type family NotWithErr (a :: Bool) (err :: ErrorMessage) = (res :: Bool) where 148 | NotWithErr 'False _ = 'True 149 | NotWithErr 'True err = TypeError err 150 | 151 | 152 | npToVinylRec :: (forall a. f a -> g a) -> NP f xs -> V.Rec g xs 153 | npToVinylRec _ Nil = V.RNil 154 | npToVinylRec f ((:*) a restNp) = f a V.:& (npToVinylRec f restNp) 155 | 156 | vinylRecToNp :: (forall a. f a -> g a) -> V.Rec f xs -> NP g xs 157 | vinylRecToNp _ V.RNil = Nil 158 | vinylRecToNp f ((V.:&) a restRec) = f a :* (vinylRecToNp f restRec) 159 | 160 | npToVinylARec :: (V.NatToInt (V.RLength xs)) => (forall a. f a -> g a) -> NP f xs -> V.ARec g xs 161 | npToVinylARec f np = V.toARec $ npToVinylRec f np 162 | 163 | vinylARecToNp :: (V.RecApplicative xs, V.AllConstrained (V.IndexableField xs) xs) => (forall a. f a -> g a) -> V.ARec f xs -> NP g xs 164 | vinylARecToNp f arec = vinylRecToNp f $ V.fromARec arec 165 | 166 | 167 | npIToVinylHList :: NP SOP.I xs -> V.HList xs 168 | npIToVinylHList np = npToVinylRec (V.Identity . SOP.unI) np 169 | 170 | vinylHListToNpI :: V.HList xs -> NP SOP.I xs 171 | vinylHListToNpI hl = vinylRecToNp (SOP.I . V.getIdentity) hl 172 | 173 | -- steal these from vinyl 174 | type NPCurried ts a = V.Curried ts a 175 | type NPCurriedF f ts a = V.CurriedF f ts a 176 | 177 | class NPCurry ts where 178 | npCurry :: (NP f ts -> a) -> NPCurriedF f ts a 179 | npICurry :: (NP SOP.I ts -> a) -> NPCurried ts a 180 | 181 | 182 | instance NPCurry '[] where 183 | npCurry f = f Nil 184 | {-# INLINABLE npCurry #-} 185 | npICurry f = f Nil 186 | {-# INLINABLE npICurry #-} 187 | 188 | instance NPCurry ts => NPCurry (t ': ts) where 189 | npCurry f x = npCurry (\xs -> f (x :* xs)) 190 | {-# INLINABLE npCurry #-} 191 | npICurry f x = npICurry (\xs -> f (SOP.I x :* xs)) 192 | {-# INLINABLE npICurry #-} 193 | 194 | 195 | 196 | npUncurry :: NPCurriedF f ts a -> NP f ts -> a 197 | npUncurry x Nil = x 198 | npUncurry f (x :* xs) = npUncurry (f x) xs 199 | {-# INLINABLE npUncurry #-} 200 | 201 | npIUncurry :: NPCurried ts a -> NP SOP.I ts -> a 202 | npIUncurry x Nil = x 203 | npIUncurry f (SOP.I x :* xs) = npIUncurry (f x) xs 204 | {-# INLINABLE npIUncurry #-} 205 | -------------------------------------------------------------------------------- /src/Acid/Core/Serialise/CBOR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Acid.Core.Serialise.CBOR where 6 | 7 | 8 | {- 9 | implementation of a cbor serialiser 10 | -} 11 | import RIO 12 | import qualified RIO.HashMap as HM 13 | import qualified RIO.Text as T 14 | import qualified RIO.List as L 15 | 16 | import Acid.Core.Serialise.Abstract 17 | import qualified RIO.ByteString.Lazy as BL 18 | import qualified Data.ByteString.Lazy.Internal as BL 19 | import qualified RIO.ByteString as BS 20 | import qualified Codec.CBOR.Read as CBOR.Read 21 | import Codec.Serialise 22 | import Codec.Serialise.Encoding 23 | import Codec.Serialise.Decoding 24 | import Codec.CBOR.Write (toLazyByteString) 25 | import Generics.SOP 26 | import Generics.SOP.NP 27 | import qualified Data.UUID as UUID 28 | import Control.Arrow (left) 29 | import Control.Monad.ST 30 | import Conduit 31 | 32 | import Acid.Core.Utils 33 | import Acid.Core.State 34 | 35 | data AcidSerialiserCBOR 36 | 37 | type CBOREventParser ss nn = (IDecode RealWorld (WrappedEvent ss nn)) 38 | instance AcidSerialiseEvent AcidSerialiserCBOR where 39 | data AcidSerialiseEventOptions AcidSerialiserCBOR = AcidSerialiserCBOROptions 40 | type AcidSerialiseParser AcidSerialiserCBOR ss nn = CBOREventParser ss nn 41 | type AcidSerialiseT AcidSerialiserCBOR = BL.ByteString 42 | type AcidSerialiseConduitT AcidSerialiserCBOR = BS.ByteString 43 | serialiserFileExtension _ = ".cbor" 44 | serialiseStorableEvent o se = addCRC $ toLazyByteString $ serialiseCBOREvent o se 45 | deserialiseStorableEvent o t = (left (T.pack . show)) . decodeOrFail (deserialiseCBOREvent o) =<< checkAndConsumeCRC t 46 | makeDeserialiseParsers _ _ _ = makeCBORParsers 47 | deserialiseEventStream :: forall ss nn m. (MonadIO m) => AcidSerialiseEventOptions AcidSerialiserCBOR -> AcidSerialiseParsers AcidSerialiserCBOR ss nn -> (ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) ()) 48 | deserialiseEventStream _ ps = do 49 | pFinder <- liftIO $ stToIO (CBOR.Read.deserialiseIncremental $ findCBORParserForWrappedEventIO ps) 50 | connectEitherConduit checkSumConduit $ runLoop pFinder 51 | where 52 | runLoop :: IDecode RealWorld (CBOREventParser ss nn) -> ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) () 53 | runLoop pFinder = loop (Left pFinder) =<< await 54 | where 55 | loop :: (Either (IDecode RealWorld (CBOREventParser ss nn)) (CBOREventParser ss nn)) -> Maybe BS.ByteString -> ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) () 56 | loop (Left pfinderRes) t = do 57 | case pfinderRes of 58 | (CBOR.Read.Done bs _ eParser) -> loop (Right eParser) (Just bs) 59 | (CBOR.Read.Fail _ _ err) -> yield (Left . T.pack $ "Could not deserialise an event name for finding a parser: " <> show err) >> (loop (Left pFinder) =<< await) 60 | (CBOR.Read.Partial k) -> do 61 | case t of 62 | Nothing -> pure () -- no more values in the stream 63 | Just _ -> do 64 | nextRes <- liftIO . stToIO . k $ t 65 | loop (Left nextRes) =<< await 66 | loop (Right res) t = do 67 | case res of 68 | (CBOR.Read.Done bs _ e) -> yield (Right e) >> (if BS.null bs then (loop (Left pFinder)) =<< await else loop (Left pFinder) (Just bs)) 69 | (CBOR.Read.Fail _ _ err) -> yield (Left . T.pack . show $ err) >> (loop (Left pFinder) =<< await) 70 | (CBOR.Read.Partial k) -> do 71 | nextRes <- liftIO . stToIO . k $ t 72 | loop (Right nextRes) =<< await 73 | 74 | 75 | class (ValidEventName ss n, All Serialise (EventArgs n)) => CanSerialiseCBOR ss n 76 | instance (ValidEventName ss n, All Serialise (EventArgs n)) => CanSerialiseCBOR ss n 77 | 78 | 79 | instance AcidSerialiseC AcidSerialiserCBOR where 80 | type AcidSerialiseConstraintP AcidSerialiserCBOR ss = CanSerialiseCBOR ss 81 | 82 | 83 | instance (Serialise seg) => AcidSerialiseSegment AcidSerialiserCBOR seg where 84 | serialiseSegment _ seg = sourceLazy $ toLazyByteString $ encode seg 85 | deserialiseSegment _ = do 86 | sio <- liftIO $ stToIO deserialiseIncremental 87 | loop sio 88 | where 89 | loop :: MonadIO m => IDecode RealWorld seg -> ConduitT BS.ByteString o m (Either Text seg) 90 | loop res = 91 | case res of 92 | (CBOR.Read.Done _ _ x) -> pure . Right $ x 93 | (CBOR.Read.Fail _ _ err) -> pure $ Left (T.pack $ show err) 94 | (CBOR.Read.Partial k) -> loop =<< liftIO . stToIO . k =<< await 95 | 96 | 97 | findCBORParserForWrappedEventIO :: forall ss nn s. AcidSerialiseParsers AcidSerialiserCBOR ss nn -> Decoder s (CBOREventParser ss nn) 98 | findCBORParserForWrappedEventIO ps = do 99 | name <- decode 100 | case HM.lookup name ps of 101 | Nothing -> fail $ "Could not find parser for event named " <> (T.unpack name) 102 | Just p -> pure p 103 | 104 | 105 | 106 | makeCBORParsers :: forall ss nn m. (MonadIO m, All (CanSerialiseCBOR ss) nn) => m (AcidSerialiseParsers AcidSerialiserCBOR ss nn) 107 | makeCBORParsers = do 108 | wres <- sequence $ cfoldMap_NP (Proxy :: Proxy (CanSerialiseCBOR ss)) (\p -> [toTaggedTuple p]) proxyRec 109 | pure $ HM.fromList wres 110 | where 111 | proxyRec :: NP Proxy nn 112 | proxyRec = pure_NP Proxy 113 | toTaggedTuple :: (CanSerialiseCBOR ss n) => Proxy n -> m (Text, CBOREventParser ss nn) 114 | toTaggedTuple p = do 115 | r <-decodeWrappedEventCBOR p 116 | pure (toUniqueText p, r) 117 | 118 | 119 | decodePartial :: Decoder s a -> BS.ByteString -> ST s (Either Text (Maybe (BS.ByteString, a))) 120 | decodePartial decoder t = (supplyCurrentInput =<< CBOR.Read.deserialiseIncremental decoder) 121 | where 122 | supplyCurrentInput :: IDecode s (a) -> ST s (Either Text (Maybe (BS.ByteString, a))) 123 | supplyCurrentInput (CBOR.Read.Partial k) = handleEndOfCurrentInput =<< k (Just t) 124 | supplyCurrentInput a = handleEndOfCurrentInput a 125 | handleEndOfCurrentInput :: IDecode s a -> ST s (Either Text (Maybe (BS.ByteString, a))) 126 | handleEndOfCurrentInput (CBOR.Read.Done bs _ x) = pure $ Right (Just (bs, x)) 127 | handleEndOfCurrentInput (CBOR.Read.Partial _) = pure $ Right Nothing 128 | handleEndOfCurrentInput (CBOR.Read.Fail _ _ err) = pure $ Left (T.pack $ show err) 129 | 130 | 131 | 132 | decodeOrFail :: (forall s. Decoder s a) -> BL.ByteString -> Either CBOR.Read.DeserialiseFailure a 133 | decodeOrFail decoder bs0 = 134 | runST (supplyAllInput bs0 =<< CBOR.Read.deserialiseIncremental decoder) 135 | where 136 | supplyAllInput _bs (CBOR.Read.Done _ _ x) = return (Right x) 137 | supplyAllInput bs (CBOR.Read.Partial k) = 138 | case bs of 139 | BL.Chunk chunk bs' -> k (Just chunk) >>= supplyAllInput bs' 140 | BL.Empty -> k Nothing >>= supplyAllInput BL.Empty 141 | supplyAllInput _ (CBOR.Read.Fail _ _ exn) = return (Left exn) 142 | 143 | 144 | decodeWrappedEventCBOR ::forall m n ss nn. (MonadIO m, CanSerialiseCBOR ss n) => Proxy n -> m (CBOREventParser ss nn) 145 | decodeWrappedEventCBOR _ = liftIO . stToIO $ CBOR.Read.deserialiseIncremental doDeserialiseWrappedEvent 146 | where 147 | doDeserialiseWrappedEvent :: Decoder s (WrappedEvent ss nn) 148 | doDeserialiseWrappedEvent = do 149 | (se :: StorableEvent ss nn n) <- decode 150 | pure $ WrappedEvent se 151 | 152 | serialiseCBOREvent :: forall ss nn n. (CanSerialiseCBOR ss n) => AcidSerialiseEventOptions AcidSerialiserCBOR -> StorableEvent ss nn n -> Encoding 153 | serialiseCBOREvent _ se = encode (toUniqueText (Proxy :: Proxy n)) <> encode se 154 | 155 | 156 | 157 | deserialiseCBOREvent :: forall ss nn n s. (CanSerialiseCBOR ss n) => AcidSerialiseEventOptions AcidSerialiserCBOR -> Decoder s (StorableEvent ss nn n) 158 | deserialiseCBOREvent _ = do 159 | (a :: Text) <- decode 160 | if a == toUniqueText (Proxy :: Proxy n) 161 | then decode 162 | else fail $ "Expected " <> T.unpack (toUniqueText (Proxy :: Proxy n)) <> " when consuming prefix, but got " <> show a 163 | 164 | 165 | 166 | instance (CanSerialiseCBOR ss n) => Serialise (StorableEvent ss nn n) where 167 | encode (StorableEvent t ui (Event xs :: Event n)) = 168 | encodeListLen 4 <> 169 | encodeWord 0 <> 170 | encode t <> 171 | encode ui <> 172 | encode xs 173 | decode = do 174 | len <- decodeListLen 175 | tag <- decodeWord 176 | case (len, tag) of 177 | (4, 0) -> do 178 | t <- decode 179 | uid <- decode 180 | args <- decode 181 | pure $ StorableEvent t uid ((Event args) :: Event n) 182 | (_,_) -> fail $ "Expected (listLength, tag) of (4, 0)" <> "but got (" <> L.intercalate ", " [show len, show tag] <> ")" 183 | 184 | 185 | instance Serialise EventId where 186 | encode = encodeBytes . BL.toStrict . UUID.toByteString . uuidFromEventId 187 | decode = do 188 | bs <- fmap BL.fromStrict decodeBytes 189 | case UUID.fromByteString bs of 190 | Nothing -> fail $ "Could not parse UUID from bytestring " <> show bs 191 | Just uuid -> pure . EventId $ uuid 192 | 193 | instance (All Serialise xs) => Serialise (EventArgsContainer xs) where 194 | encode (EventArgsContainer np) = encodeListLenIndef <> 195 | cfoldMap_NP (Proxy :: Proxy Serialise) (encode . unI) np <> 196 | encodeBreak 197 | decode = do 198 | _ <- decodeListLenIndef 199 | np <- npIFromCBOR 200 | fin <- decodeBreakOr 201 | if fin 202 | then pure $ EventArgsContainer np 203 | else fail "Expected to find a break token to mark the end of ListLenIndef when decoding EventArgsContainer" 204 | 205 | npIFromCBOR :: forall s xs. (All Serialise xs) => Decoder s (NP I xs) 206 | npIFromCBOR = 207 | case sList :: SList xs of 208 | SNil -> pure $ Nil 209 | SCons -> do 210 | a <- decode 211 | r <- npIFromCBOR 212 | pure $ I a :* r -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # acid-world 2 | [acid-state](https://github.com/acid-state/acid-state) is a great package but it is missing some useful features. Acid-world is a further exploration of the design space in the direction of greater flexibility and usability (as in, a 'world' of different acid 'states'). In particular, acid-world takes advantage of the development of type level programming in Haskell in the last few years: most of the code in this package was simply impossible when acid-state was released. 3 | 4 | Like acid-state, the main persistence model used in acid-world is event logging combined with checkpoints. Marshalling of heterogenous data structures is handled in a type safe way using the excellent [generics-sop](http://hackage.haskell.org/package/generics-sop) and [vinyl](http://hackage.haskell.org/package/vinyl). 5 | 6 | This package is currently at the proof of concept stage and is not suitable for use in production. 7 | 8 | ## Features vs acid-state 9 | 10 | ### Multiple state segments 11 | Rather than providing a `State s` style environment with `s` defined as a single root type, acid-world allows you to work with multiple different types. This is achieved using type level lists and type level strings. Each type you want to use in your state is simply declared as a `Segment`, eg 12 | 13 | instance Segment "Users" where 14 | type SegmentS "Users" = HashMap Int User 15 | 16 | You can then write queries and updates that specifically operate on that segment, using the `HasSegment` class, eg 17 | 18 | -- `ss` is a type level list of available segments, like ["Users", "Addresses", "Comments"] 19 | insertUser :: (HasSegment ss "Users") => Int -> User -> AWUpdate ss User 20 | insertUser k u = do 21 | users <- askSegment (Proxy :: Proxy "Users") 22 | putSegment (Proxy :: Proxy "Users") (insert k u users) 23 | pure u 24 | 25 | This allows for much better separation of concerns than acid-state, as update and query functions only need to know about the segments that concern them. 26 | 27 | It also allows for something that is simply impossible in acid-state - libraries can define state segments and events of their own, and you can add them into your own instance of acid-world. It is also entirely possible to have multiple instances of acid-world open in the same app, addressing different parts of state, with different backends etc if desired. 28 | 29 | ### Multiple serialisation options 30 | Acid-world is structured to allow for multiple possible serialisation strategies and multiple possible backends. Serialisers and backends have to be using the same intermediate types (`ByteString` for example) to be used together. At present the main `FS` (file system) backend can be used with three different serialisers: CBOR, SafeCopy and JSON. The JSON serialiser produces utf-8 encoded files, so you can open them up and edit them by hand if so desired. 31 | 32 | ### Composable update events 33 | Acid-state models every event as a specific data type (produced by Template Haskell). Acid-world, on the other hand, has a single type class for events, and a single container. Instances look like 34 | 35 | instance Eventable "insertUser" where 36 | type EventArgs "insertUser" = '[Int, User] -- arguments this event takes 37 | type EventResult "insertUser" = User -- the result of the event 38 | type EventSegments "insertUser" = ["Users"] -- the segments this event needs to be able to run 39 | runEvent _ = toRunEvent {- provided by the package -} insertUser {- can be any function of the type Int -> User -> AWUpdate ss User -} 40 | 41 | Events themselves are simply a container that wraps up the event name (which ties it to the `Eventable` class) and a heterogenous list of the arguments. 42 | 43 | This allows for the definition of a type, `EventC`, that composes events together in a type safe way, and the whole composed event can be run atomically. 44 | 45 | [..] type EventArgs "insertAddress" = '[Text, Text, User] [..] 46 | 47 | composedEvent :: EventC '["insertAddress", "insertUser"] 48 | composedEvent = mkEvent (Proxy :: Proxy "insertAddress") "State College" "Pennsylvania" :<< mkEvent (Proxy :: Proxy "insertUser") 1 (User "Haskell" "Curry") 49 | 50 | 51 | ### User specified invariant checking as part of atomic updates 52 | Despite our best efforts, Haskell's type system cannot always capture all the invariants we would like to express. Acid-world provides for a single invariant function for every state segment, of the form `a -> Maybe Text` where `Just Text` is interpreted as an error message. You can, eg, restrict the number of users with `if HM.size a > 100 then Just "Only 100 users allowed!" else Nothing` . Invariants are guaranteed to be run every time a segment changes, prior to final persistence of the event. Future development may allow for a way to define invariants on parts of some segments (eg. the specific `(k,v)` change made to a HashMap). 53 | 54 | ### Database backends (eg Postgres) 55 | Some people like the idea of acid-state, but for whatever reason are required to use a relational database. Acid-world allows for this. In the current (rudimentary) PostgreSQL backend events are stored in a single events table, while checkpoints are stored in their own tables, one for each segment. 56 | 57 | ### Alternative persistence strategy for data (keyed maps) that won't fit into memory 58 | Perhaps the biggest pain point of acid-state is that it requires all data to be in memory all of the time. If you want transparent access to a Haskell type then this is effectively unavoidable. Various attempts have been made to provide an alternative to acid-state here, and this package includes another one (currently named, rather badly, `CacheState`). At present the implementation is fairly basic, but the idea uses a similar strategy to the rest of acid-world - state is separated out into segments, and updates and queries can operate on the segments that are relevant to them. 59 | 60 | The big difference with the rest of acid-world, though, is that the persistence is not event based. The strategy is more like that used by [VCache](http://hackage.haskell.org/package/vcache) (which sadly is not maintained) but a lot less sophisticated (at present at least). CacheState supports keyed maps (and single values, but a lot of the benefit is lost there). The idea is to provide an easy way to persist table like structures (currently HashMap, and more interestingly, [IxSet](https://hackage.haskell.org/package/ixset-typed). The spine (and with `IxSet`, the indexes) are kept in memory while the values themselves are not (depending on caching policy). This allows you to leverage, eg, the excellent indexing features of `IxSet` while addressing a much larger data set than could be held in memory. The current implementation uses LMDB as a persistence layer, but different backends (anything that can act as a key value store) could be implemented for this as well. 61 | 62 | After thinking about this a fair amount I'm not sure that any solution can do much better than this and still have any flavour of acid-state to it. If you aren't keeping any part of the data structure in memory then you pretty much just have a deserialisation wrapper around something like LMDB, or a database (if you want indexing). But I might be completely wrong - all suggestions and thoughts are welcome! 63 | 64 | ## Improvements vs acid-state 65 | 66 | ### 'Constant' memory usage 67 | Due to the way acid-state deserialises it can sometimes use massive amounts of memory when restoring state (I once encountered a situation where it used something like 20GB of memory to restore a state of around 1GB). Acid-world attempts to avoid this by deserialising in streams (using conduit), and therefore should never use much more memory than the state itself. 68 | 69 | ### No Template Haskell 70 | The most complicated user land class in acid-world is `Eventable`, which is really just a deconstructed function type definition and constraint. Template Haskell could be used to generate instances of Eventable, but it is not really necessary. Also, acid-world has no equivalent of the `makeAcidic` function - the design does not require a single place where everything is defined, aside from at a type level (the acid-world container is parameterised with type level lists of every event and every segment you want to use). 71 | 72 | ### Simpler file structure for persistence 73 | A simple quality of life improvement - acid-world stores a single events log and single file for each segment in a checkpoint. When a checkpoint occurs, a new dated folder is created containing the previous state. So you have something like: 74 | 75 | - current 76 | events.log.cbor 77 | - checkpoint 78 | Users.cbor 79 | Addresses.cbor 80 | - archive 81 | - 2018-08-04_11-22-44-238800_UTC 82 | events.log.cbor 83 | - checkpoint 84 | Users.cbor 85 | Address.cbor 86 | 87 | Every folder is a complete, restorable snapshot of the state. 88 | 89 | ### Partial write detection and correction 90 | Acid-world tags each event with a UUID, and writes out the UUID of the last persisted event to a separate file. It can therefore detect if a deserialisation error is the result of a partial write, and correct for this automatically (this feature is still under development). 91 | 92 | ## Future features 93 | 94 | ### Automatic checkpointing 95 | With various strategies (time / file size / number of events). 96 | 97 | ### Historic event querying (replays etc) 98 | All events are tagged with a UUID and a UTCTime. It would therefore be relatively easy to provide an api for reconstructing state up to a certain point in time, or to exclude specific events, or ranges of events, safely. 99 | 100 | ### Event notifications 101 | Events have type `Event (n :: Symbol)`. It will be easy enough to provide users with a way of registering pre and post event handlers of the type `Event n -> IO ()` or similar, specialised to individual events (so `Event "insertUser" -> IO ()`) that will be fired every time the event is issued. 102 | 103 | ### Compatibility with GHCJS 104 | Compiling with ghcjs and a localstorage backend to provide browser storage and/or a browser compatible remote backend 105 | 106 | ## The state of this code 107 | 108 | Rather than copying and pasting swathes of acid-state, this package has been pretty much written from scratch. The focus has been on producing a proof of concept, mainly on the type level (handling heteregenous lists with lots of class constraints and type synonyms is a bit finicky). Not much fine tuning has been done yet on exception handling / memory usage / performance, but the general structure of the package was designed from the start to put an emphasis on memory usage and performance: "\"premature optimization is the root of all evil\" is the root of all evil" as they say. 109 | 110 | -------------------------------------------------------------------------------- /acid-world.cabal: -------------------------------------------------------------------------------- 1 | name: acid-world 2 | version: 0.0.0.1 3 | synopsis: Expansion of acid state to cover multiple serialisers, multiple state objects and other useful functionality 4 | description: 5 | This package expands on the functionality of 6 | by providing multiple serialisation options, the ability to define multiple root states, an easier, TH-free interface, composable update events, user specified invariant checking as part of atomic updates, and other usability improvements. 7 | . 8 | Also included in this package is a key-value backed persistence layer for keyed maps, including indexed maps (eg ). The motivation for this is similar to that behind - easy persistence and querying of state that is too large to fit in memory. The implementation in this package is not as general as that in vcache, but is hopefully easier to work with for some use cases. 9 | 10 | homepage: http://github.com/matchwood/acid-world#readme 11 | license: BSD3 12 | license-file: LICENSE 13 | author: Matchwood 14 | maintainer: matchwood1@gmail.com 15 | category: Database 16 | build-type: Simple 17 | cabal-version: >= 1.24 18 | data-files: 19 | src/dataFiles/*.md 20 | 21 | library 22 | exposed-modules: 23 | Acid.World 24 | Acid.Core 25 | Acid.Core.Segment 26 | Acid.Core.Utils 27 | Acid.Core.Serialise 28 | Acid.Core.Serialise.Abstract 29 | Acid.Core.Serialise.JSON 30 | Acid.Core.Serialise.JSON.Partial 31 | Acid.Core.Serialise.CBOR 32 | Acid.Core.Serialise.SafeCopy 33 | Acid.Core.Serialise.Postgresql 34 | Acid.Core.Backend 35 | Acid.Core.Backend.Abstract 36 | Acid.Core.Backend.FS 37 | Acid.Core.Backend.Memory 38 | Acid.Core.Backend.Postgresql 39 | Acid.Core.State 40 | Acid.Core.State.Abstract 41 | Acid.Core.State.PureState 42 | Acid.Core.CacheState 43 | other-modules: 44 | Paths_acid_world 45 | build-depends: 46 | base, 47 | bytestring, 48 | rio, 49 | generics-sop, 50 | mtl, 51 | vinyl, 52 | aeson, 53 | stm, 54 | uuid, 55 | conduit, 56 | conduit-extra, 57 | serialise, 58 | cborg, 59 | safecopy, 60 | cereal, 61 | zlib, 62 | attoparsec, 63 | cryptonite, 64 | memory, 65 | crc, 66 | postgresql-simple, 67 | lmdb-simple, 68 | ixset-typed 69 | 70 | 71 | hs-source-dirs: src 72 | ghc-options: -Wall 73 | -Wcompat 74 | -Wincomplete-record-updates 75 | -Wincomplete-uni-patterns 76 | -Wredundant-constraints 77 | -Werror 78 | default-language: Haskell2010 79 | default-extensions: AutoDeriveTypeable 80 | BangPatterns 81 | BinaryLiterals 82 | ConstraintKinds 83 | DataKinds 84 | DefaultSignatures 85 | DeriveDataTypeable 86 | DeriveFoldable 87 | DeriveFunctor 88 | DeriveGeneric 89 | DeriveTraversable 90 | DoAndIfThenElse 91 | EmptyDataDecls 92 | ExistentialQuantification 93 | FlexibleContexts 94 | FlexibleInstances 95 | FunctionalDependencies 96 | GADTs 97 | GeneralizedNewtypeDeriving 98 | InstanceSigs 99 | KindSignatures 100 | LambdaCase 101 | MonadFailDesugaring 102 | MultiParamTypeClasses 103 | MultiWayIf 104 | NamedFieldPuns 105 | NoImplicitPrelude 106 | OverloadedStrings 107 | PartialTypeSignatures 108 | PatternGuards 109 | PolyKinds 110 | RankNTypes 111 | RecordWildCards 112 | ScopedTypeVariables 113 | StandaloneDeriving 114 | TupleSections 115 | TypeApplications 116 | TypeFamilies 117 | TypeOperators 118 | TypeSynonymInstances 119 | ViewPatterns 120 | 121 | test-suite acid-world-test 122 | type: exitcode-stdio-1.0 123 | hs-source-dirs: test 124 | shared 125 | main-is: Test.hs 126 | other-modules: Shared.TH 127 | Shared.App 128 | Shared.Schema 129 | ghc-options: -Wall 130 | -Wcompat 131 | -Wincomplete-record-updates 132 | -Wincomplete-uni-patterns 133 | -Wredundant-constraints 134 | -Werror 135 | -threaded 136 | -rtsopts 137 | -with-rtsopts=-N 138 | build-depends: rio 139 | , base 140 | , acid-world 141 | , QuickCheck 142 | , criterion 143 | , template-haskell 144 | , aeson 145 | , temporary 146 | , generics-sop 147 | , basic-sop 148 | , quickcheck-instances 149 | , ixset-typed 150 | , filepath 151 | , serialise 152 | , tasty 153 | , tasty-quickcheck 154 | , tasty-hunit 155 | , safecopy 156 | , bytestring 157 | , postgresql-simple 158 | , uuid 159 | , postgresql-libpq 160 | , deepseq 161 | 162 | default-language: Haskell2010 163 | default-extensions: AutoDeriveTypeable 164 | BangPatterns 165 | BinaryLiterals 166 | ConstraintKinds 167 | DataKinds 168 | DefaultSignatures 169 | DeriveDataTypeable 170 | DeriveFoldable 171 | DeriveFunctor 172 | DeriveGeneric 173 | DeriveTraversable 174 | DoAndIfThenElse 175 | EmptyDataDecls 176 | ExistentialQuantification 177 | FlexibleContexts 178 | FlexibleInstances 179 | FunctionalDependencies 180 | GADTs 181 | GeneralizedNewtypeDeriving 182 | InstanceSigs 183 | KindSignatures 184 | LambdaCase 185 | MonadFailDesugaring 186 | MultiParamTypeClasses 187 | MultiWayIf 188 | NamedFieldPuns 189 | NoImplicitPrelude 190 | OverloadedStrings 191 | PartialTypeSignatures 192 | PatternGuards 193 | PolyKinds 194 | RankNTypes 195 | RecordWildCards 196 | ScopedTypeVariables 197 | StandaloneDeriving 198 | TupleSections 199 | TypeApplications 200 | TypeFamilies 201 | TypeOperators 202 | TypeSynonymInstances 203 | ViewPatterns 204 | ghc-options: 205 | -O2 206 | 207 | benchmark acid-world-benchmark 208 | type: exitcode-stdio-1.0 209 | hs-source-dirs: benchmark 210 | shared 211 | main-is: Benchmark.hs 212 | other-modules: Shared.TH 213 | Shared.App 214 | Shared.Schema 215 | ghc-options: -Wall 216 | -Wcompat 217 | -Wincomplete-record-updates 218 | -Wincomplete-uni-patterns 219 | -Wredundant-constraints 220 | -Werror 221 | -threaded 222 | -rtsopts 223 | -with-rtsopts=-N 224 | build-depends: rio 225 | , base 226 | , acid-world 227 | , QuickCheck 228 | , criterion 229 | , template-haskell 230 | , aeson 231 | , temporary 232 | , generics-sop 233 | , basic-sop 234 | , quickcheck-instances 235 | , ixset-typed 236 | , filepath 237 | , serialise 238 | , safecopy 239 | , bytestring 240 | , postgresql-simple 241 | , uuid 242 | , postgresql-libpq 243 | , lmdb-simple 244 | 245 | 246 | default-language: Haskell2010 247 | default-extensions: AutoDeriveTypeable 248 | BangPatterns 249 | BinaryLiterals 250 | ConstraintKinds 251 | DataKinds 252 | DefaultSignatures 253 | DeriveDataTypeable 254 | DeriveFoldable 255 | DeriveFunctor 256 | DeriveGeneric 257 | DeriveTraversable 258 | DoAndIfThenElse 259 | EmptyDataDecls 260 | ExistentialQuantification 261 | FlexibleContexts 262 | FlexibleInstances 263 | FunctionalDependencies 264 | GADTs 265 | GeneralizedNewtypeDeriving 266 | InstanceSigs 267 | KindSignatures 268 | LambdaCase 269 | MonadFailDesugaring 270 | MultiParamTypeClasses 271 | MultiWayIf 272 | NamedFieldPuns 273 | NoImplicitPrelude 274 | OverloadedStrings 275 | PartialTypeSignatures 276 | PatternGuards 277 | PolyKinds 278 | RankNTypes 279 | RecordWildCards 280 | ScopedTypeVariables 281 | StandaloneDeriving 282 | TupleSections 283 | TypeApplications 284 | TypeFamilies 285 | TypeOperators 286 | TypeSynonymInstances 287 | ViewPatterns 288 | ghc-options: 289 | -O2 290 | source-repository head 291 | type: git 292 | location: https://github.com/matchwood/acid-world 293 | -------------------------------------------------------------------------------- /shared/Shared/App.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Shared.App ( 4 | module Shared.App, 5 | module Shared.Schema 6 | ) where 7 | 8 | import RIO 9 | import qualified RIO.ByteString as BS 10 | import qualified RIO.ByteString.Lazy as BL 11 | 12 | import Prelude(userError, putStrLn) 13 | import qualified RIO.Text as T 14 | import qualified RIO.Directory as Dir 15 | 16 | import Data.Proxy(Proxy(..)) 17 | import Test.QuickCheck.Instances() 18 | import Test.QuickCheck as QC 19 | import qualified System.IO.Temp as Temp 20 | import qualified System.FilePath as FilePath 21 | import Acid.World 22 | import Acid.Core.CacheState 23 | 24 | import qualified Database.PostgreSQL.Simple as PSQL 25 | import Shared.Schema 26 | import Data.Char(toLower) 27 | 28 | (^*) :: Int -> Int -> Int 29 | (^*) = (^) 30 | 31 | type AppValidSerialiserConstraint s = ( 32 | AcidSerialiseEvent s, 33 | AcidSerialiseConstraintAll s AppSegments AppEvents, 34 | AcidSerialiseT s ~ BL.ByteString, 35 | AcidSerialiseConduitT s ~ BS.ByteString, 36 | AcidSerialiseSegmentT s ~ BS.ByteString, 37 | AcidDeserialiseSegmentT s ~ BS.ByteString, 38 | AcidSerialiseConstraint s AppSegments "insertUser", 39 | AcidSerialiseConstraint s AppSegments "insertAddress", 40 | AcidSerialiseConstraint s AppSegments "insertPhonenumber", 41 | ValidSegmentsSerialise s AppSegments 42 | ) 43 | 44 | type AppValidBackendConstraint b = ( 45 | AcidWorldBackend b, 46 | AWBSerialiseT b ~ BL.ByteString, 47 | AWBSerialiseConduitT b ~ BS.ByteString, 48 | AWBSerialiseSegmentT b ~ BS.ByteString, 49 | AWBDeserialiseSegmentT b ~ BS.ByteString 50 | 51 | ) 52 | 53 | 54 | defaultAppSerialiser :: AppValidSerialiser 55 | defaultAppSerialiser = AppValidSerialiser AcidSerialiserJSONOptions 56 | 57 | allSerialisers :: [AppValidSerialiser] 58 | allSerialisers = [ 59 | AppValidSerialiser AcidSerialiserJSONOptions 60 | , AppValidSerialiser AcidSerialiserCBOROptions 61 | , AppValidSerialiser AcidSerialiserSafeCopyOptions 62 | ] 63 | 64 | 65 | persistentBackends :: [AppValidBackend] 66 | persistentBackends = [ 67 | fsBackend 68 | ] 69 | 70 | fsBackend :: AppValidBackend 71 | fsBackend = AppValidBackend $ \t -> AWBConfigFS t True 72 | 73 | persistentBackendsWithGzip :: [AppValidBackend] 74 | persistentBackendsWithGzip = [ 75 | AppValidBackend $ \t -> AWBConfigFS t False 76 | , AppValidBackend $ \t -> AWBConfigFS t True 77 | ] 78 | 79 | ephemeralBackends :: [AppValidBackend] 80 | ephemeralBackends = [AppValidBackend $ const AWBConfigMemory] 81 | 82 | allBackends :: [AppValidBackend] 83 | allBackends = persistentBackends ++ ephemeralBackends 84 | 85 | data AppValidSerialiser where 86 | AppValidSerialiser :: (AppValidSerialiserConstraint s) => AcidSerialiseEventOptions s -> AppValidSerialiser 87 | data AppValidBackend where 88 | AppValidBackend :: (AppValidBackendConstraint b) => (FilePath -> (AWBConfig b)) -> AppValidBackend 89 | 90 | 91 | topLevelTestDir :: FilePath 92 | topLevelTestDir = "./tmp" 93 | 94 | topLevelStoredStateDir :: FilePath 95 | topLevelStoredStateDir = "./var" 96 | 97 | instance NFData (AcidWorld a n t) where 98 | rnf _ = () 99 | 100 | 101 | 102 | type AppSegments = '["Users", "Addresses", "Phonenumbers"] 103 | 104 | type CAppSegments = '["UsersHM", "AddressesHM", "PhonenumbersHM", "UsersCS"] 105 | 106 | type AppEvents = '["insertUser", "insertAddress", "insertPhonenumber"] 107 | 108 | type AppAW s = AcidWorld AppSegments AppEvents s 109 | 110 | type Middleware s = IO (AppAW s) -> IO (AppAW s) 111 | 112 | 113 | mkTempDir :: IO (FilePath) 114 | mkTempDir = do 115 | tmpP <- Dir.makeAbsolute topLevelTestDir 116 | Dir.createDirectoryIfMissing True tmpP 117 | liftIO $ Temp.createTempDirectory tmpP "test" 118 | 119 | 120 | 121 | type ValidAppAcidSerialise s b = ( 122 | AcidSerialiseT s ~ AWBSerialiseT b 123 | , AcidSerialiseConduitT s ~ AWBSerialiseConduitT b 124 | , AcidSerialiseSegmentT s ~ AWBSerialiseSegmentT b 125 | , AcidDeserialiseSegmentT s ~ AWBDeserialiseSegmentT b 126 | ) 127 | 128 | type ValidAppAcidSerialiseBS s b = ( 129 | ValidAppAcidSerialise s b 130 | , AWBSerialiseT b ~ BL.ByteString 131 | 132 | 133 | ) 134 | openAppAcidWorldRestoreState :: (ValidAppAcidSerialise s AcidWorldBackendFS, AcidSerialiseEvent s, AcidSerialiseConstraintAll s AppSegments AppEvents, ValidSegmentsSerialise s AppSegments) => AcidSerialiseEventOptions s -> String -> IO (AppAW s) 135 | openAppAcidWorldRestoreState opts s = do 136 | t <- mkTempDir 137 | let fsConfig = AWBConfigFS t True 138 | let e = topLevelStoredStateDir <> "/" <> "testState" <> "/" <> s 139 | copyDirectory e t 140 | aw <- throwEither $ openAcidWorld defaultSegmentsState emptyInvariants fsConfig AWConfigPureState opts 141 | -- this is to force the internal state 142 | i <- query aw fetchUsersStats 143 | putStrLn $ T.unpack . utf8BuilderToText $ "Opened aw with " <> displayShow i 144 | pure aw 145 | 146 | openAppAcidWorldFresh :: (ValidAppAcidSerialise s b, AcidWorldBackend b, AcidSerialiseEvent s, AcidSerialiseConstraintAll s AppSegments AppEvents, ValidSegmentsSerialise s AppSegments) => (FilePath -> AWBConfig b) -> (AcidSerialiseEventOptions s) -> IO (AppAW s) 147 | openAppAcidWorldFresh bConf opts = openAppAcidWorldFreshWithInvariants bConf opts emptyInvariants 148 | 149 | openAppAcidWorldFreshWithInvariants :: (ValidAppAcidSerialise s b, AcidWorldBackend b, AcidSerialiseEvent s, AcidSerialiseConstraintAll s AppSegments AppEvents, ValidSegmentsSerialise s AppSegments) => (FilePath -> AWBConfig b) -> (AcidSerialiseEventOptions s) -> Invariants AppSegments -> IO (AppAW s) 150 | openAppAcidWorldFreshWithInvariants bConf opts invars = do 151 | td <- mkTempDir 152 | throwEither $ openAcidWorld defaultSegmentsState invars (bConf td) AWConfigPureState opts 153 | 154 | 155 | type UseGzip = Bool 156 | openAppAcidWorldFreshFS :: (ValidAppAcidSerialise s AcidWorldBackendFS, AcidSerialiseEvent s, AcidSerialiseConstraintAll s AppSegments AppEvents, ValidSegmentsSerialise s AppSegments) => (AcidSerialiseEventOptions s) -> UseGzip -> IO (AppAW s) 157 | openAppAcidWorldFreshFS opts useGzip = do 158 | openAppAcidWorldFresh (\td -> AWBConfigFS td useGzip) opts 159 | 160 | 161 | openAcidWorldPostgresWithInvariants :: String -> Invariants AppSegments -> IO (AppAW AcidSerialiserPostgresql) 162 | openAcidWorldPostgresWithInvariants testNameOrig invars = do 163 | let testName = map toLower testNameOrig 164 | let setupConf = PSQL.defaultConnectInfo { 165 | PSQL.connectUser = "acid_world_test", 166 | PSQL.connectPassword = "acid_world_test", 167 | PSQL.connectDatabase = "postgres" 168 | } 169 | conn <- PSQL.connect setupConf 170 | let testDbName = "acid_world_test_" ++ testName 171 | createQ = mconcat ["CREATE DATABASE ", fromString testDbName, " WITH OWNER = acid_world_test ENCODING = 'UTF8' TABLESPACE = pg_default LC_COLLATE = 'en_GB.UTF-8' LC_CTYPE = 'en_GB.UTF-8' CONNECTION LIMIT = -1;" ] 172 | _ <- PSQL.execute_ conn $ mconcat ["DROP DATABASE IF EXISTS ", fromString testDbName , ";"] 173 | 174 | _ <- PSQL.execute_ conn createQ 175 | _ <- PSQL.execute_ conn $ mconcat ["GRANT CONNECT, TEMPORARY ON DATABASE ", fromString testDbName, " TO public;"] 176 | _ <- PSQL.execute_ conn $ mconcat ["GRANT ALL ON DATABASE ", fromString testDbName, " TO acid_world_test;"] 177 | PSQL.close conn 178 | let conf = setupConf {PSQL.connectDatabase = testDbName} 179 | conn2 <- PSQL.connect conf 180 | _ <- PSQL.execute_ conn2 storableEventCreateTable 181 | _ <- PSQL.execute_ conn2 $ createTable (Proxy :: Proxy UserIxSet) 182 | _ <- PSQL.execute_ conn2 $ createTable (Proxy :: Proxy AddressIxSet) 183 | _ <- PSQL.execute_ conn2 $ createTable (Proxy :: Proxy PhonenumberIxSet) 184 | 185 | PSQL.close conn2 186 | 187 | 188 | throwEither $ openAcidWorld defaultSegmentsState invars (AWBConfigPostgresql conf) AWConfigPureState AcidSerialiserPostgresqlOptions 189 | 190 | 191 | 192 | closeAndReopen :: Middleware s 193 | closeAndReopen = reopenAcidWorldMiddleware . closeAcidWorldMiddleware 194 | 195 | closeAcidWorldMiddleware :: Middleware s 196 | closeAcidWorldMiddleware iAw = do 197 | aw <- iAw 198 | closeAcidWorld aw 199 | pure aw 200 | 201 | reopenAcidWorldMiddleware :: Middleware s 202 | reopenAcidWorldMiddleware iAw = iAw >>= throwEither . reopenAcidWorld 203 | 204 | 205 | insertUsers :: AcidSerialiseConstraint s AppSegments "insertUser" => Int -> Middleware s 206 | insertUsers i iAw = do 207 | aw <- iAw 208 | us <- QC.generate $ generateUsers i 209 | mapM_ (runInsertUser aw) us 210 | pure aw 211 | 212 | 213 | runInsertUser :: AcidSerialiseConstraint s AppSegments "insertUser" => AppAW s -> User -> IO User 214 | runInsertUser aw u = throwEither $ update aw (mkEvent (Proxy :: Proxy ("insertUser")) u) 215 | 216 | runInsertUserC :: AcidSerialiseConstraintAll s AppSegments '["insertPhonenumber", "insertUser"] => AppAW s -> (User -> Event "insertPhonenumber") -> User -> IO Phonenumber 217 | runInsertUserC aw mkNumber u = throwEither $ updateC aw $ (mkNumber :<< (EventC $ mkEvent (Proxy :: Proxy ("insertUser")) u)) 218 | 219 | 220 | 221 | runInsertAddress :: AcidSerialiseConstraint s AppSegments "insertAddress" => AppAW s -> Address -> IO Address 222 | runInsertAddress aw u = throwEither $ update aw (mkEvent (Proxy :: Proxy ("insertAddress")) u) 223 | 224 | runInsertPhonenumber :: AcidSerialiseConstraint s AppSegments "insertPhonenumber" => AppAW s -> Phonenumber -> IO Phonenumber 225 | runInsertPhonenumber aw u = throwEither $ update aw (mkEvent (Proxy :: Proxy ("insertPhonenumber")) u) 226 | 227 | 228 | throwEither :: Exception e => IO (Either e a) -> IO a 229 | throwEither act = do 230 | res <- act 231 | case res of 232 | Right a -> pure a 233 | Left e -> throwM e 234 | 235 | throwUserError :: String -> IO a 236 | throwUserError = throwIO . userError 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | copyDirectory :: FilePath -> FilePath -> IO () 248 | copyDirectory oldO newO = do 249 | old <- Dir.makeAbsolute oldO 250 | new <- Dir.makeAbsolute newO 251 | testExist <- Dir.doesDirectoryExist old 252 | when (not testExist) (throwIO $ userError $ "Source directory " <> old <> " does not exist") 253 | 254 | allFiles <- getAbsDirectoryContentsRecursive old 255 | let ts = map (\f -> (f, toNewPath old new f)) allFiles 256 | void $ mapM (uncurry copyOldToNew) ts 257 | return () 258 | 259 | where 260 | toNewPath :: FilePath -> FilePath -> FilePath -> FilePath 261 | toNewPath old new file = new <> "/" <> FilePath.makeRelative old file 262 | copyOldToNew :: FilePath -> FilePath -> IO () 263 | copyOldToNew oldF newF = do 264 | Dir.createDirectoryIfMissing True (FilePath.takeDirectory newF) 265 | Dir.copyFile oldF newF 266 | 267 | getAbsDirectoryContentsRecursive :: FilePath -> IO [FilePath] 268 | getAbsDirectoryContentsRecursive dirPath = do 269 | names <- Dir.getDirectoryContents dirPath 270 | let properNames = filter (`notElem` [".", ".."]) names 271 | absoluteNames <- mapM (Dir.canonicalizePath . (dirPath FilePath.)) properNames 272 | paths <- forM absoluteNames $ \fPath -> do 273 | isDirectory <- Dir.doesDirectoryExist fPath 274 | if isDirectory 275 | then getAbsDirectoryContentsRecursive fPath 276 | else return [fPath] 277 | return $ concat paths 278 | 279 | 280 | 281 | 282 | {- 283 | 284 | Cache state 285 | -} 286 | 287 | 288 | openCacheStateFresh :: CacheMode -> IO (Either AWException (CacheState CAppSegments)) 289 | openCacheStateFresh cm = do 290 | t <- mkTempDir 291 | openCacheState t cm 292 | 293 | runInsertUserHM :: CacheState CAppSegments -> User -> IO () 294 | runInsertUserHM cs u = runUpdateCS cs (insertC (Proxy :: Proxy "UsersHM") (userId u) u) 295 | 296 | runInsertUserCS :: CacheState CAppSegments -> User -> IO () 297 | runInsertUserCS cs u = runUpdateCS cs (insertC (Proxy :: Proxy "UsersCS") (userId u) u) -------------------------------------------------------------------------------- /shared/Shared/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Shared.Schema where 5 | 6 | import RIO 7 | import qualified RIO.HashMap as HM 8 | import qualified RIO.Text as T 9 | 10 | import qualified RIO.Time as Time 11 | 12 | import Data.Proxy(Proxy(..)) 13 | import Test.QuickCheck.Arbitrary 14 | import Test.QuickCheck.Instances() 15 | import Test.QuickCheck as QC 16 | import qualified Generics.SOP as SOP 17 | import qualified Generics.SOP.Arbitrary as SOP 18 | import qualified Data.Aeson as Aeson 19 | import qualified Data.Aeson.Types as Aeson 20 | import qualified Data.IxSet.Typed as IxSet 21 | import Acid.World 22 | import Codec.Serialise 23 | import Data.SafeCopy 24 | import Acid.Core.CacheState 25 | 26 | import qualified Database.PostgreSQL.Simple.ToRow as PSQL 27 | import qualified Database.PostgreSQL.Simple.ToField as PSQL 28 | import qualified Database.PostgreSQL.Simple.FromField as PSQL 29 | 30 | instance (Serialise b, IxSet.Indexable a b) => Serialise (IxSet.IxSet a b) where 31 | encode = encode . IxSet.toList 32 | decode = fmap IxSet.fromList $ decode 33 | 34 | instance (Aeson.ToJSON b) => Aeson.ToJSON (IxSet.IxSet a b) where 35 | toJSON = Aeson.toJSON . IxSet.toList 36 | 37 | instance (Aeson.FromJSON b, IxSet.Indexable a b) => Aeson.FromJSON (IxSet.IxSet a b) where 38 | parseJSON v = fmap IxSet.fromList $ Aeson.parseJSON v 39 | 40 | 41 | data User = User { 42 | userId :: !Int, 43 | userFirstName :: !Text, 44 | userLastName :: !Text, 45 | userComments :: [Text], 46 | userOtherInformation :: Text, 47 | userCreated :: !(Maybe Time.UTCTime), 48 | userDisabled :: !Bool 49 | } deriving (Eq, Show, Generic, Ord) 50 | 51 | instance PSQL.ToField [Text] where 52 | toField = PSQL.toField . Aeson.toJSON 53 | 54 | instance PSQL.FromField [Text] where 55 | fromField f bs = do 56 | v <- PSQL.fromField f bs 57 | case Aeson.parseEither Aeson.parseJSON v of 58 | Left err -> PSQL.conversionError $ AWExceptionEventDeserialisationError (T.pack err) 59 | Right ts -> pure ts 60 | 61 | instance PSQL.ToRow User 62 | instance (IxSet.Indexable a User) => AcidSerialisePostgres (IxSet.IxSet a User) where 63 | toPostgresRows a = map PostgresRow (IxSet.toList a) 64 | createTable _ = mconcat ["CREATE TABLE ", fromString (tableName (Proxy :: Proxy "Users")) ," (userId integer NOT NULL, userFirstName Text NOT NULL, userLastName Text NOT NULL, userComments json NOT NULL, userOtherInformation Text NOT NULL, userCreated timestamptz, userDisabled bool);"] 65 | fromPostgresConduitT ts = fmap IxSet.fromList $ sequence $ map fromFields ts 66 | 67 | 68 | instance FromFields User where 69 | fromFields fs = do 70 | userId <- fromIdx fs 0 71 | userFirstName <- fromIdx fs 1 72 | userLastName <- fromIdx fs 2 73 | userComments <- fromIdx fs 3 74 | userOtherInformation <- fromIdx fs 4 75 | userCreated <- fromIdx fs 5 76 | userDisabled <- fromIdx fs 6 77 | pure $ User{..} 78 | 79 | 80 | 81 | instance Serialise User 82 | 83 | type UserIxs = '[Int, Maybe Time.UTCTime, Bool] 84 | type UserIxSet = IxSet.IxSet UserIxs User 85 | instance IxSet.Indexable UserIxs User where 86 | indices = IxSet.ixList 87 | (IxSet.ixFun $ (:[]) . userId ) 88 | (IxSet.ixFun $ (:[]) . userCreated ) 89 | (IxSet.ixFun $ (:[]) . userDisabled ) 90 | 91 | type UserCSIxSet = IxSet.IxSet UserIxs (CValIxs UserIxs User) 92 | 93 | 94 | instance Aeson.ToJSON User 95 | instance Aeson.FromJSON User 96 | instance SOP.Generic User 97 | instance Arbitrary User where arbitrary = SOP.garbitrary 98 | instance NFData User 99 | 100 | instance Segment "Users" where 101 | type SegmentS "Users" = UserIxSet 102 | defaultState _ = IxSet.empty 103 | 104 | instance Segment "UsersHM" where 105 | type SegmentS "UsersHM" = HM.HashMap Int (CVal User) 106 | defaultState _ = HM.empty 107 | 108 | instance SegmentC "UsersHM" 109 | 110 | instance Segment "UsersCS" where 111 | type SegmentS "UsersCS" = UserCSIxSet 112 | defaultState _ = IxSet.empty 113 | 114 | instance SegmentC "UsersCS" 115 | 116 | instance IxsetPrimaryKeyClass (IxSet.IxSet UserIxs (CValIxs UserIxs User)) where 117 | type IxsetPrimaryKey UserCSIxSet = Int 118 | 119 | 120 | insertUser :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Users") => User -> AWUpdate i ss User 121 | insertUser a = do 122 | ls <- getSegment (Proxy :: Proxy "Users") 123 | let newLs = IxSet.insert a ls 124 | putSegment (Proxy :: Proxy "Users") newLs 125 | return a 126 | 127 | instance Eventable "insertUser" where 128 | type EventArgs "insertUser" = '[User] 129 | type EventResult "insertUser" = User 130 | type EventSegments "insertUser" = '["Users"] 131 | runEvent _ = toRunEvent insertUser 132 | 133 | insertUserWithBoolReturn :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Users") => User -> AWUpdate i ss Bool 134 | insertUserWithBoolReturn a = do 135 | u <- insertUser a 136 | return $ userDisabled u 137 | 138 | instance Eventable "insertUserWithBoolReturn" where 139 | type EventArgs "insertUserWithBoolReturn" = '[User] 140 | type EventResult "insertUserWithBoolReturn" = Bool 141 | type EventSegments "insertUserWithBoolReturn" = '["Users"] 142 | runEvent _ = toRunEvent insertUserWithBoolReturn 143 | 144 | fetchUsers :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Users") => AWQuery i ss [User] 145 | fetchUsers = fmap IxSet.toList $ askSegment (Proxy :: Proxy "Users") 146 | 147 | fetchUsersStats :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Users") => AWQuery i ss Int 148 | fetchUsersStats = fmap IxSet.size $ askSegment (Proxy :: Proxy "Users") 149 | 150 | 151 | generateUserIO :: IO User 152 | generateUserIO = QC.generate arbitrary 153 | 154 | generateUsers :: Int -> Gen [User] 155 | generateUsers i = do 156 | us <- sequence $ replicate i (arbitrary) 157 | pure $ map (\(u, uid) -> u{userId = uid}) $ zip us [1..] 158 | 159 | 160 | 161 | 162 | data Address = Address { 163 | addressId :: !Int, 164 | addressFirst :: !Text, 165 | addressCountry :: !Text 166 | } deriving (Eq, Show, Generic, Ord) 167 | 168 | instance PSQL.ToRow Address 169 | instance (IxSet.Indexable a Address) => AcidSerialisePostgres (IxSet.IxSet a Address) where 170 | toPostgresRows a = map PostgresRow (IxSet.toList a) 171 | createTable _ = mconcat ["CREATE TABLE ", fromString (tableName (Proxy :: Proxy "Addresses")) ," (addressId integer NOT NULL, addressFirst Text NOT NULL, addressCountry Text NOT NULL);"] 172 | fromPostgresConduitT ts = fmap IxSet.fromList $ sequence $ map fromFields ts 173 | 174 | 175 | instance FromFields Address where 176 | fromFields fs = do 177 | addressId <- fromIdx fs 0 178 | addressFirst <- fromIdx fs 1 179 | addressCountry <- fromIdx fs 2 180 | pure $ Address{..} 181 | 182 | 183 | instance Serialise Address 184 | 185 | type AddressIxs = '[Int, Text] 186 | type AddressIxSet = IxSet.IxSet AddressIxs Address 187 | instance IxSet.Indexable AddressIxs Address where 188 | indices = IxSet.ixList 189 | (IxSet.ixFun $ (:[]) . addressId ) 190 | (IxSet.ixFun $ (:[]) . addressCountry ) 191 | 192 | instance Aeson.ToJSON Address 193 | instance Aeson.FromJSON Address 194 | instance SOP.Generic Address 195 | instance Arbitrary Address where arbitrary = SOP.garbitrary 196 | instance NFData Address 197 | 198 | instance Segment "Addresses" where 199 | type SegmentS "Addresses" = AddressIxSet 200 | defaultState _ = IxSet.empty 201 | 202 | 203 | instance Segment "AddressesHM" where 204 | type SegmentS "AddressesHM" = HM.HashMap Int (CVal Address) 205 | defaultState _ = HM.empty 206 | 207 | instance SegmentC "AddressesHM" 208 | 209 | 210 | insertAddress :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Addresses") => Address -> AWUpdate i ss Address 211 | insertAddress a = do 212 | ls <- getSegment (Proxy :: Proxy "Addresses") 213 | let newLs = IxSet.insert a ls 214 | putSegment (Proxy :: Proxy "Addresses") newLs 215 | return a 216 | 217 | instance Eventable "insertAddress" where 218 | type EventArgs "insertAddress" = '[Address] 219 | type EventResult "insertAddress" = Address 220 | type EventSegments "insertAddress" = '["Addresses"] 221 | runEvent _ = toRunEvent insertAddress 222 | 223 | 224 | 225 | fetchAddresses :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Addresses") => AWQuery i ss [Address] 226 | fetchAddresses = fmap IxSet.toList $ askSegment (Proxy :: Proxy "Addresses") 227 | 228 | fetchAddressesStats :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Addresses") => AWQuery i ss Int 229 | fetchAddressesStats = fmap IxSet.size $ askSegment (Proxy :: Proxy "Addresses") 230 | 231 | generateAddresses :: Int -> Gen [Address] 232 | generateAddresses i = do 233 | us <- sequence $ replicate i (arbitrary) 234 | pure $ map (\(u, uid) -> u{addressId = uid}) $ zip us [1..] 235 | 236 | 237 | data Phonenumber = Phonenumber { 238 | phonenumberId :: !Int, 239 | phonenumberNumber :: !Text, 240 | phonenumberCallingCode :: !Int, 241 | phonenumberIsCell :: !Bool 242 | } deriving (Eq, Show, Generic, Ord) 243 | 244 | instance PSQL.ToRow Phonenumber 245 | instance (IxSet.Indexable a Phonenumber) => AcidSerialisePostgres (IxSet.IxSet a Phonenumber) where 246 | toPostgresRows a = map PostgresRow (IxSet.toList a) 247 | createTable _ = mconcat ["CREATE TABLE ", fromString (tableName (Proxy :: Proxy "Phonenumbers")) ," (phonenumberId integer NOT NULL, phonenumberNumber Text NOT NULL, phonenumberCallingCode integer NOT NULL, phonenumberIsCell bool);"] 248 | fromPostgresConduitT ts = fmap IxSet.fromList $ sequence $ map fromFields ts 249 | 250 | instance FromFields Phonenumber where 251 | fromFields fs = do 252 | phonenumberId <- fromIdx fs 0 253 | phonenumberNumber <- fromIdx fs 1 254 | phonenumberCallingCode <- fromIdx fs 2 255 | phonenumberIsCell <- fromIdx fs 3 256 | pure $ Phonenumber{..} 257 | 258 | instance Serialise Phonenumber 259 | 260 | type PhonenumberIxs = '[Int, Int, Bool] 261 | type PhonenumberIxSet = IxSet.IxSet PhonenumberIxs Phonenumber 262 | instance IxSet.Indexable PhonenumberIxs Phonenumber where 263 | indices = IxSet.ixList 264 | (IxSet.ixFun $ (:[]) . phonenumberId ) 265 | (IxSet.ixFun $ (:[]) . phonenumberCallingCode ) 266 | (IxSet.ixFun $ (:[]) . phonenumberIsCell ) 267 | 268 | instance Aeson.ToJSON Phonenumber 269 | instance Aeson.FromJSON Phonenumber 270 | instance SOP.Generic Phonenumber 271 | instance Arbitrary Phonenumber where arbitrary = SOP.garbitrary 272 | instance NFData Phonenumber 273 | 274 | instance Segment "Phonenumbers" where 275 | type SegmentS "Phonenumbers" = PhonenumberIxSet 276 | defaultState _ = IxSet.empty 277 | 278 | instance Segment "PhonenumbersHM" where 279 | type SegmentS "PhonenumbersHM" = HM.HashMap Int (CVal Phonenumber) 280 | defaultState _ = HM.empty 281 | 282 | instance SegmentC "PhonenumbersHM" 283 | 284 | insertPhonenumber :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Phonenumbers") => Phonenumber -> AWUpdate i ss Phonenumber 285 | insertPhonenumber a = do 286 | ls <- getSegment (Proxy :: Proxy "Phonenumbers") 287 | let newLs = IxSet.insert a ls 288 | putSegment (Proxy :: Proxy "Phonenumbers") newLs 289 | return a 290 | 291 | instance Eventable "insertPhonenumber" where 292 | type EventArgs "insertPhonenumber" = '[Phonenumber] 293 | type EventResult "insertPhonenumber" = Phonenumber 294 | type EventSegments "insertPhonenumber" = '["Phonenumbers"] 295 | runEvent _ = toRunEvent insertPhonenumber 296 | 297 | 298 | 299 | fetchPhonenumbers :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Phonenumbers") => AWQuery i ss [Phonenumber] 300 | fetchPhonenumbers = fmap IxSet.toList $ askSegment (Proxy :: Proxy "Phonenumbers") 301 | 302 | fetchPhonenumbersStats :: (ValidAcidWorldState i ss, HasSegmentAndInvar ss "Phonenumbers") => AWQuery i ss Int 303 | fetchPhonenumbersStats = fmap IxSet.size $ askSegment (Proxy :: Proxy "Phonenumbers") 304 | 305 | 306 | 307 | generatePhonenumbers :: Int -> Gen [Phonenumber] 308 | generatePhonenumbers i = do 309 | us <- sequence $ replicate i (arbitrary) 310 | pure $ map (\(u, uid) -> u{phonenumberId = uid}) $ zip us [1..] 311 | 312 | 313 | deriveSafeCopy 0 'base ''User 314 | deriveSafeCopy 0 'base ''Address 315 | deriveSafeCopy 0 'base ''Phonenumber -------------------------------------------------------------------------------- /src/Acid/Core/State/Abstract.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE UndecidableSuperClasses #-} 4 | 5 | module Acid.Core.State.Abstract where 6 | import RIO 7 | import qualified RIO.Text as T 8 | import qualified RIO.List as L 9 | import qualified RIO.Time as Time 10 | 11 | import qualified RIO.HashMap as HM 12 | 13 | import Generics.SOP 14 | import Generics.SOP.NP 15 | import GHC.TypeLits 16 | 17 | 18 | import qualified Data.UUID as UUID 19 | import qualified Data.UUID.V4 as UUID 20 | 21 | import Acid.Core.Segment 22 | import Acid.Core.Utils 23 | import Data.Aeson(FromJSON(..), ToJSON(..)) 24 | import Conduit 25 | 26 | import qualified Data.Vinyl as V 27 | import qualified Data.Vinyl.TypeLevel as V 28 | 29 | 30 | 31 | {- 32 | the main definition of an state managing strategy 33 | -} 34 | 35 | data AWException = 36 | AWExceptionInvariantsViolated [(Text, Text)] 37 | | AWExceptionEventSerialisationError Text 38 | | AWExceptionEventDeserialisationError Text 39 | | AWExceptionSegmentDeserialisationError Text 40 | | AWExceptionCheckpointError Text 41 | deriving (Eq, Show, Typeable) 42 | instance Exception AWException 43 | 44 | data Invariant ss s where 45 | Invariant :: HasSegment ss s => (SegmentS s -> (Maybe Text)) -> Invariant ss s 46 | 47 | runInvariant :: forall i ss s. (AcidWorldState i, Functor (AWQuery i ss)) => Invariant ss s -> AWQuery i ss (Maybe Text) 48 | runInvariant (Invariant f) = fmap f $ askSegment (Proxy :: Proxy s) 49 | 50 | newtype Invariants ss = Invariants {invariantsFieldRec :: V.AFieldRec (ToInvariantFields ss ss)} 51 | 52 | class (V.KnownField a, (V.Snd a) ~ Maybe (Invariant ss (V.Fst a))) => KnownInvariantField ss a 53 | instance (V.KnownField a, (V.Snd a) ~ Maybe (Invariant ss (V.Fst a))) => KnownInvariantField ss a 54 | 55 | type ValidInvariantNames ss = 56 | ( V.AllFields (ToInvariantFields ss ss) 57 | , V.AllConstrained (KnownInvariantField ss) (ToInvariantFields ss ss) 58 | , V.NatToInt (V.RLength (ToInvariantFields ss ss)) 59 | , UniqueElementsWithErr ss ~ 'True 60 | ) 61 | 62 | 63 | 64 | 65 | 66 | makeEmptyInvariant :: forall ss a. KnownInvariantField ss a => Proxy ss -> V.ElField '(V.Fst a, (V.Snd a)) 67 | makeEmptyInvariant _ = (V.Label :: V.Label (V.Fst a)) V.=: Nothing 68 | 69 | emptyInvariants :: forall ss. ValidInvariantNames ss => Invariants ss 70 | emptyInvariants = Invariants $ V.toARec $ V.rpureConstrained (Proxy :: Proxy (KnownInvariantField ss)) (makeEmptyInvariant (Proxy :: Proxy ss)) 71 | 72 | type family ToInvariantFields (allSS :: [Symbol]) (ss :: [Symbol]) = (iFields :: [(Symbol, *)]) where 73 | ToInvariantFields _ '[] = '[] 74 | ToInvariantFields allSS (s ': ss) = '(s, Maybe (Invariant allSS s)) ': ToInvariantFields allSS ss 75 | 76 | 77 | class (V.HasField V.ARec s (ToInvariantFields ss ss) (Maybe (Invariant ss s)), KnownSymbol s) => HasInvariant ss s 78 | instance (V.HasField V.ARec s (ToInvariantFields ss ss) (Maybe (Invariant ss s)), KnownSymbol s) => HasInvariant ss s 79 | 80 | class ( 81 | All (HasInvariant ss) ss) 82 | => ValidInvariants ss 83 | instance ( 84 | All (HasInvariant ss) ss) 85 | => ValidInvariants ss 86 | 87 | class (HasSegment ss s, HasInvariant ss s) => HasSegmentAndInvar ss s 88 | instance (HasSegment ss s, HasInvariant ss s) => HasSegmentAndInvar ss s 89 | 90 | getInvariantP :: forall s ss. (HasInvariant ss s) => Invariants ss -> Maybe (Invariant ss s) 91 | getInvariantP (Invariants fr) = V.getField $ V.rgetf (V.Label :: V.Label s) fr 92 | 93 | putInvariantP :: forall s ss. (HasInvariant ss s) => Maybe (Invariant ss s) -> Invariants ss -> Invariants ss 94 | putInvariantP invar (Invariants fr) = Invariants $ V.rputf (V.Label :: V.Label s) invar fr 95 | 96 | type ValidSegmentsAndInvar ss = (ValidSegments ss, ValidInvariants ss) 97 | 98 | 99 | type ChangedSegmentsInvariantsMap i ss = HM.HashMap Text (AWQuery i ss (Maybe Text)) 100 | 101 | allInvariants :: forall ss i. (All (HasInvariant ss) ss, AcidWorldState i, Functor (AWQuery i ss)) => Invariants ss -> ChangedSegmentsInvariantsMap i ss 102 | allInvariants invars = HM.fromList $ cfoldMap_NP (Proxy :: Proxy (HasInvariant ss)) mInsertInvar npInvars 103 | where 104 | mInsertInvar :: forall s. (HasInvariant ss s) => Proxy s -> [(Text, AWQuery i ss (Maybe Text))] 105 | mInsertInvar ps = 106 | case getInvariantP invars of 107 | Nothing -> [] 108 | Just (i :: Invariant ss s) -> [(toUniqueText ps, runInvariant i)] 109 | npInvars :: NP Proxy ss 110 | npInvars = pure_NP Proxy 111 | 112 | 113 | registerChangedSegment :: forall ss s i. (HasSegment ss s, AcidWorldState i, Functor (AWQuery i ss)) => Invariant ss s -> ChangedSegmentsInvariantsMap i ss -> ChangedSegmentsInvariantsMap i ss 114 | registerChangedSegment i = HM.insert (toUniqueText (Proxy :: Proxy s)) (runInvariant i) 115 | 116 | runChangedSegmentsInvariantsMap :: forall i ss. ValidAcidWorldState i ss => ChangedSegmentsInvariantsMap i ss -> AWQuery i ss (Maybe AWException) 117 | runChangedSegmentsInvariantsMap hm = (fmap . fmap) AWExceptionInvariantsViolated $ foldM doRunInvariant Nothing (HM.toList hm) 118 | where 119 | doRunInvariant ::(Maybe [(Text, Text)]) -> (Text, AWQuery i ss (Maybe Text)) -> AWQuery i ss (Maybe [(Text, Text)]) 120 | doRunInvariant res (k, act) = do 121 | r <- act 122 | case r of 123 | Nothing -> pure res 124 | Just err -> 125 | case res of 126 | Nothing -> pure . Just $ [(k, err)] 127 | Just errs -> pure . Just $ errs ++ [(k, err)] 128 | 129 | 130 | 131 | 132 | 133 | 134 | class AcidWorldState (i :: *) where 135 | data AWState i (ss :: [Symbol]) 136 | data AWConfig i (ss :: [Symbol]) 137 | data AWUpdate i (ss :: [Symbol]) a 138 | data AWQuery i (ss :: [Symbol]) a 139 | initialiseState :: (MonadIO z, ValidSegmentsAndInvar ss) => AWConfig i ss -> (BackendHandles z ss nn) -> Invariants ss -> z (Either AWException (AWState i ss)) 140 | closeState :: (MonadIO z) => AWState i ss -> z () 141 | closeState _ = pure () 142 | getSegment :: (HasSegment ss s) => Proxy s -> AWUpdate i ss (SegmentS s) 143 | putSegment :: (HasSegment ss s, HasInvariant ss s, ValidSegmentsAndInvar ss ) => Proxy s -> (SegmentS s) -> AWUpdate i ss () 144 | askSegment :: (HasSegment ss s) => Proxy s -> AWQuery i ss (SegmentS s) 145 | runUpdateC :: (ValidSegmentsAndInvar ss, All (ValidEventName ss) (firstN ': ns), MonadIO m) => AWState i ss -> EventC (firstN ': ns) -> m (Either AWException (NP Event (firstN ': ns), EventResult firstN, m (), m ())) 146 | runQuery :: (MonadIO m) => AWState i ss -> AWQuery i ss a -> m a 147 | liftQuery :: AWQuery i ss a -> AWUpdate i ss a 148 | 149 | 150 | 151 | type HasSegmentsAndInvars allSegmentNames segmentNames = V.AllConstrained (HasSegmentAndInvar allSegmentNames) segmentNames 152 | 153 | 154 | 155 | class ( AcidWorldState i 156 | , Monad (AWUpdate i ss) 157 | , Monad (AWQuery i ss) 158 | , ValidSegmentsAndInvar ss) 159 | => ValidAcidWorldState i ss 160 | instance ( AcidWorldState i 161 | , Monad (AWUpdate i ss) 162 | , Monad (AWQuery i ss) 163 | , ValidSegmentsAndInvar ss) 164 | => ValidAcidWorldState i ss 165 | 166 | 167 | 168 | askStateNp :: forall i ss. (ValidAcidWorldState i ss) => AWQuery i ss (NP V.ElField (ToSegmentFields ss)) 169 | askStateNp = sequence'_NP segsNp 170 | where 171 | segsNp :: NP (AWQuery i ss :.: V.ElField) (ToSegmentFields ss) 172 | segsNp = cmap_NP (Proxy :: Proxy (SegmentFetching ss)) askSegmentFromProxy proxyNp 173 | askSegmentFromProxy :: forall sField. (SegmentFetching ss sField) => Proxy sField -> (AWQuery i ss :.: V.ElField) sField 174 | askSegmentFromProxy _ = Comp $ fmap V.Field $ askSegment (Proxy :: Proxy (V.Fst sField)) 175 | proxyNp :: NP Proxy (ToSegmentFields ss) 176 | proxyNp = pure_NP Proxy 177 | 178 | askSegmentsState :: forall i ss. (ValidAcidWorldState i ss) => AWQuery i ss (SegmentsState ss) 179 | askSegmentsState = fmap npToSegmentsState askStateNp 180 | 181 | 182 | -- this structure allows the inner monad code to run something wrapped up in the backend monad 183 | data LoadEventsConduit m ss nn where 184 | LoadEventsConduit :: forall m ss nn. (forall a. ConduitT (Either Text (WrappedEvent ss nn)) Void (ResourceT IO) a -> m a) -> LoadEventsConduit m ss nn 185 | 186 | runLoadEventsConduit :: LoadEventsConduit m ss nn -> ConduitT (Either Text (WrappedEvent ss nn)) Void (ResourceT IO) a -> m a 187 | runLoadEventsConduit (LoadEventsConduit f) = f 188 | 189 | data BackendHandles m ss nn = BackendHandles { 190 | bhLoadEvents :: MonadIO m => LoadEventsConduit m ss nn, 191 | bhGetInitialState :: MonadIO m => m ((Either AWException (SegmentsState ss))) 192 | } 193 | 194 | 195 | 196 | {- 197 | Events and basic event utilities 198 | -} 199 | 200 | -- this is like a monad, except for the type change (eg pure :: a -> m '[a]) 201 | data EventC :: [k] -> * where 202 | EventC :: Event n -> EventC '[n] 203 | (:<<) :: (EventResult firstN -> Event n) -> EventC (firstN ': ns) -> EventC (n ': (firstN ': ns)) 204 | 205 | runEventC :: forall ss firstN ns i. (All (ValidEventName ss) (firstN ': ns), ValidAcidWorldState i ss) => EventC (firstN ': ns) -> AWUpdate i ss (NP Event (firstN ': ns), EventResult firstN) 206 | runEventC (EventC (e@(Event xs) :: Event n)) = do 207 | r <- runEvent (Proxy :: Proxy n) xs 208 | pure (e :* Nil, r) 209 | runEventC ((:<<) f ec) = do 210 | (npRest, r) <- runEventC ec 211 | case f r of 212 | (e@(Event xs) :: Event n) -> do 213 | fr <- runEvent (Proxy :: Proxy n) xs 214 | pure (e :* npRest, fr) 215 | 216 | 217 | 218 | class (Eventable n, HasSegmentsAndInvars ss (EventSegments n)) => ValidEventName ss (n :: Symbol) 219 | instance (Eventable n, HasSegmentsAndInvars ss (EventSegments n)) => ValidEventName ss n 220 | 221 | class (ElemOrErr n nn, Eventable n, HasSegmentsAndInvars ss (EventSegments n)) => IsValidEvent ss nn (n :: Symbol) 222 | instance (ElemOrErr n nn, Eventable n, HasSegmentsAndInvars ss (EventSegments n)) => IsValidEvent ss nn n 223 | 224 | 225 | 226 | type ValidEventNames ss nn = (All (ValidEventName ss) nn, UniqueElementsWithErr nn ~ 'True) 227 | 228 | 229 | 230 | 231 | 232 | -- representing the relationship between n xs and r 233 | type EventableR n xs r = 234 | (Eventable n, EventArgs n ~ xs, EventResult n ~ r) 235 | 236 | 237 | 238 | class (ToUniqueText n, SListI (EventArgs n), All Eq (EventArgs n), All Show (EventArgs n)) => Eventable (n :: k) where 239 | type EventArgs n :: [*] 240 | type EventResult n :: * 241 | type EventSegments n :: [Symbol] 242 | runEvent :: (ValidAcidWorldState i ss, HasSegmentsAndInvars ss (EventSegments n)) => Proxy n -> EventArgsContainer (EventArgs n) -> AWUpdate i ss (EventResult n) 243 | 244 | 245 | 246 | newtype EventArgsContainer xs = EventArgsContainer {eventArgsContainerNp :: NP I xs} 247 | 248 | instance (All Show xs) => Show (EventArgsContainer xs) where 249 | show (EventArgsContainer np) = L.intercalate ", " $ cfoldMap_NP (Proxy :: Proxy Show) ((:[]) . show . unI) np 250 | 251 | instance (All Eq xs) => Eq (EventArgsContainer xs) where 252 | (==) (EventArgsContainer np1) (EventArgsContainer np2) = and . collapse_NP $ czipWith_NP (Proxy :: Proxy Eq) (\ia ib -> K $ ia == ib) np1 np2 253 | 254 | 255 | 256 | 257 | newtype EventId = EventId{uuidFromEventId :: UUID.UUID} deriving(Show, Eq, ToJSON, FromJSON) 258 | 259 | 260 | 261 | eventIdToText :: EventId -> Text 262 | eventIdToText = UUID.toText . uuidFromEventId 263 | 264 | eventIdFromText :: Text -> Either Text EventId 265 | eventIdFromText bs = 266 | case UUID.fromText bs of 267 | Nothing -> Left $ "Could not parse event id from Text: " <> bs 268 | Just u -> pure . EventId $ u 269 | 270 | data Event (n :: k) where 271 | Event :: (Eventable n, EventArgs n ~ xs, All Eq xs, All Show xs) => EventArgsContainer xs -> Event n 272 | 273 | 274 | instance Show (Event n) where 275 | show (Event c) = "Event :: " ++ (T.unpack $ toUniqueText (Proxy :: Proxy n)) ++ "\n with args::" ++ show c 276 | 277 | 278 | instance Eq (Event n) where 279 | (==) (Event c) (Event c1) = c == c1 280 | 281 | 282 | toRunEvent :: NPCurried ts a -> EventArgsContainer ts -> a 283 | toRunEvent f = npIUncurry f . eventArgsContainerNp 284 | 285 | mkEvent :: forall n xs r. (NPCurry xs, EventableR n xs r) => Proxy n -> NPCurried xs (Event n) 286 | mkEvent _ = npICurry (Event . EventArgsContainer :: NP I xs -> Event n) 287 | 288 | 289 | data StorableEvent ss nn n = StorableEvent { 290 | storableEventTime :: Time.UTCTime, 291 | storableEventId :: EventId, 292 | storableEventEvent :: Event n 293 | } deriving (Eq, Show) 294 | 295 | 296 | extractLastEventId :: (SListI ns) => NP (StorableEvent ss nn) ns -> Maybe EventId 297 | extractLastEventId np = L.lastMaybe $ extractEventIds np 298 | 299 | 300 | extractEventIds :: (SListI ns) => NP (StorableEvent ss nn) ns -> [EventId] 301 | extractEventIds np = collapse_NP $ map_NP (K .storableEventId) np 302 | 303 | mkStorableEvents :: forall m ns ss nn. (MonadIO m, SListI ns) => NP Event ns -> m (NP (StorableEvent ss nn) ns) 304 | mkStorableEvents np = sequence'_NP stCompNp 305 | where 306 | stCompNp :: NP (m :.: StorableEvent ss nn) ns 307 | stCompNp = map_NP (Comp . mkStorableEvent) np 308 | 309 | mkStorableEvent :: (MonadIO m) => Event n -> m (StorableEvent ss nn n) 310 | mkStorableEvent e = do 311 | t <- Time.getCurrentTime 312 | uuid <- liftIO $ UUID.nextRandom 313 | return $ StorableEvent t (EventId uuid) e 314 | 315 | 316 | wrappedEventId :: WrappedEvent ss nn -> EventId 317 | wrappedEventId (WrappedEvent s) = storableEventId s 318 | 319 | 320 | data WrappedEvent ss nn where 321 | WrappedEvent :: (HasSegmentsAndInvars ss (EventSegments n)) => StorableEvent ss nn n -> WrappedEvent ss nn 322 | 323 | instance Show (WrappedEvent ss nn) where 324 | show (WrappedEvent se) = "WrappedEvent: " <> show se 325 | 326 | runWrappedEvent :: ValidAcidWorldState i ss => WrappedEvent ss e -> AWUpdate i ss () 327 | runWrappedEvent (WrappedEvent (StorableEvent _ _ (Event xs :: Event n))) = void $ runEvent (Proxy :: Proxy n) xs 328 | 329 | 330 | 331 | 332 | -------------------------------------------------------------------------------- /src/Acid/Core/Serialise/Abstract.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Acid.Core.Serialise.Abstract where 5 | 6 | 7 | import RIO 8 | import qualified RIO.HashMap as HM 9 | import qualified RIO.Text as T 10 | import qualified RIO.ByteString as BS 11 | import qualified RIO.ByteString.Lazy as BL 12 | import qualified Data.ByteString.Lazy.Char8 as Char8L 13 | import qualified Data.ByteString.Char8 as Char8 14 | import Text.Printf (printf) 15 | import Generics.SOP 16 | import GHC.TypeLits 17 | import GHC.Exts (Constraint) 18 | 19 | import Data.Proxy(Proxy(..)) 20 | 21 | import Acid.Core.Segment 22 | import Acid.Core.Utils 23 | import Acid.Core.State 24 | 25 | import Data.Typeable 26 | import qualified Data.Vinyl.TypeLevel as V 27 | import Control.Arrow (left) 28 | import Conduit 29 | import qualified Data.Digest.CRC as CRC 30 | import qualified Data.Digest.CRC32 as CRC 31 | import Data.Serialize 32 | import Data.Bits 33 | import qualified RIO.Vector.Unboxed.Partial as VUnboxedPartial 34 | 35 | 36 | import Text.Read (readEither) 37 | {- 38 | 39 | This is a fiddly setup. The issue is that we want to abstract serialisation in a context where we are parsing to constrained types. The general approach is to construct a text indexed map of parsers specialised to a specific type and serialise the text key along with the event data 40 | -} 41 | class (Semigroup (AcidSerialiseT t), Monoid (AcidSerialiseT t)) => AcidSerialiseEvent (t :: k) where 42 | data AcidSerialiseEventOptions t :: * 43 | type AcidSerialiseT t :: * 44 | type AcidSerialiseConduitT t :: * 45 | type AcidSerialiseParser t (ss :: [Symbol]) (nn :: [Symbol]) :: * 46 | serialiserFileExtension :: AcidSerialiseEventOptions t -> FilePath 47 | serialiserFileExtension _ = ".log" 48 | tConversions :: AcidSerialiseEventOptions t -> (AcidSerialiseT t -> AcidSerialiseConduitT t, AcidSerialiseConduitT t -> AcidSerialiseT t) 49 | default tConversions :: (AcidSerialiseT t ~ BL.ByteString, AcidSerialiseConduitT t ~ BS.ByteString) => AcidSerialiseEventOptions t -> (AcidSerialiseT t -> AcidSerialiseConduitT t, AcidSerialiseConduitT t -> AcidSerialiseT t) 50 | tConversions _ = (BL.toStrict, BL.fromStrict) 51 | serialiserName :: Proxy t -> Text 52 | default serialiserName :: (Typeable t) => Proxy t -> Text 53 | 54 | serialiserName p = T.pack $ (showsTypeRep . typeRep $ p) "" 55 | serialiseStorableEvent :: (AcidSerialiseConstraint t ss n) => AcidSerialiseEventOptions t -> StorableEvent ss nn n -> AcidSerialiseT t 56 | -- @todo we don't actually use this anywhere - perhaps just remove it? 57 | deserialiseStorableEvent :: (AcidSerialiseConstraint t ss n) => AcidSerialiseEventOptions t -> AcidSerialiseT t -> (Either Text (StorableEvent ss nn n)) 58 | 59 | makeDeserialiseParsers :: (ValidEventNames ss nn, AcidSerialiseConstraintAll t ss nn, MonadIO m) => AcidSerialiseEventOptions t -> Proxy ss -> Proxy nn -> m (AcidSerialiseParsers t ss nn) 60 | deserialiseEventStream :: (MonadIO m) => AcidSerialiseEventOptions t -> AcidSerialiseParsers t ss nn -> (ConduitT (AcidSerialiseConduitT t) (Either Text (WrappedEvent ss nn)) (m) ()) 61 | 62 | toConduitType :: (AcidSerialiseEvent t) => AcidSerialiseEventOptions t -> AcidSerialiseT t -> AcidSerialiseConduitT t 63 | toConduitType = fst . tConversions 64 | 65 | fromConduitType :: (AcidSerialiseEvent t) => AcidSerialiseEventOptions t -> AcidSerialiseConduitT t -> AcidSerialiseT t 66 | fromConduitType = snd . tConversions 67 | 68 | 69 | serialiseEventNP :: (AcidSerialiseEvent t, AcidSerialiseConstraintAll t ss ns) => AcidSerialiseEventOptions t -> NP (StorableEvent ss nn) ns -> AcidSerialiseT t 70 | serialiseEventNP _ Nil = mempty 71 | serialiseEventNP t ((:*) se restNp) = serialiseEventNP t restNp <> serialiseStorableEvent t se 72 | 73 | class AcidSerialiseSegment (t :: k) seg where 74 | type AcidSerialiseSegmentT t :: * 75 | type AcidSerialiseSegmentT t = AcidSerialiseConduitT t 76 | type AcidDeserialiseSegmentT t :: * 77 | type AcidDeserialiseSegmentT t = AcidSerialiseConduitT t 78 | serialiseSegment :: (Monad m) => AcidSerialiseEventOptions t -> seg -> ConduitT i (AcidSerialiseSegmentT t) m () 79 | -- because of this https://github.com/well-typed/cborg/issues/156 the cbor partial deserialiser has to run in STT or IO, IO seems cleaner 80 | deserialiseSegment :: (MonadIO m) => AcidSerialiseEventOptions t -> ConduitT (AcidDeserialiseSegmentT t) o m (Either Text seg) 81 | 82 | 83 | 84 | -- we are manually serialising to a fixed width utf8 string here so that for serialisers like json the resulting file is still readable as utf8 85 | 86 | addCRC :: BL.ByteString -> BL.ByteString 87 | addCRC content = 88 | Char8L.pack (printf "%019d" contentLength) <> 89 | Char8L.pack (printf "%010d" contentHash) <> 90 | content 91 | where 92 | contentLength :: Word64 93 | contentLength = fromIntegral $ BL.length content 94 | contentHash :: Word32 95 | contentHash = CRC.crc32 $ lazyCRCDigest content 96 | 97 | checkAndConsumeCRC :: BL.ByteString -> Either Text BL.ByteString 98 | checkAndConsumeCRC b = do 99 | r <- left T.pack $ runGetLazy getWithCheckSumLazy b 100 | checkCRCLazy r 101 | 102 | checkCRCLazy :: (CRC.CRC32, BL.ByteString) -> Either Text BL.ByteString 103 | checkCRCLazy (check, content) = 104 | let h = lazyCRCDigest content 105 | in if check == h 106 | then pure content 107 | else Left $ "Lazy bytestring failed checksum when reading: expected " <> showT check <> " but got " <> showT h 108 | 109 | checkCRCStrict :: (CRC.CRC32, BS.ByteString) -> Either Text BS.ByteString 110 | checkCRCStrict (check, content) = 111 | if check == CRC.digest content 112 | then pure content 113 | else Left $ "Lazy bytestring failed checksum when reading" 114 | 115 | 116 | getWithCheckSumLazy :: Get (CRC.CRC32, BL.ByteString) 117 | getWithCheckSumLazy = do 118 | contentLength <- getWord64CharPadded 119 | contentChecksum <- getWord32CharPadded 120 | content <- getLazyByteString_fast (fromIntegral contentLength) 121 | pure (CRC.CRC32 contentChecksum, content) 122 | 123 | 124 | getWithCheckSumStrict :: Get (CRC.CRC32, BS.ByteString) 125 | getWithCheckSumStrict = do 126 | contentLength <- getWord64CharPadded 127 | contentChecksum <- getWord32CharPadded 128 | content <- getBytes (fromIntegral contentLength) 129 | pure (CRC.CRC32 contentChecksum, content) 130 | 131 | getWord64CharPadded :: Get Word64 132 | getWord64CharPadded = do 133 | b <- getBytes 19 134 | let s = Char8.unpack b 135 | case readEither s of 136 | Left err -> fail $ "Could not read Word64 from " <> s <> " : " <> err 137 | Right a -> pure a 138 | 139 | getWord32CharPadded :: Get Word32 140 | getWord32CharPadded = do 141 | b <- getBytes 10 142 | let s = Char8.unpack b 143 | case readEither s of 144 | Left err -> fail $ "Could not read Word64 from " <> s <> " : " <> err 145 | Right a -> pure a 146 | 147 | 148 | 149 | -- this is directly copied from acid-state 150 | -- | Read a lazy bytestring WITHOUT any copying or concatenation. 151 | getLazyByteString_fast :: Int -> Get BL.ByteString 152 | getLazyByteString_fast = worker 0 [] 153 | where 154 | worker counter acc n = do 155 | remain <- remaining 156 | if n > remain then do 157 | chunk <- getBytes remain 158 | _ <- ensure 1 159 | worker (counter + remain) (chunk:acc) (n-remain) 160 | else do 161 | chunk <- getBytes n 162 | return $ BL.fromChunks (reverse $ chunk:acc) 163 | 164 | 165 | handleDataDotSerializeParserResult :: Result a -> Either Text (Either (PartialParserBS a) (BS.ByteString, a)) 166 | handleDataDotSerializeParserResult (Fail err _) = Left . T.pack $ err 167 | handleDataDotSerializeParserResult (Partial p) = Right . Left $ (PartialParser $ \bs -> handleDataDotSerializeParserResult $ p bs) 168 | handleDataDotSerializeParserResult (Done a bs) = Right . Right $ (bs, a) 169 | 170 | connectEitherConduit :: forall a b c d m. (Monad m) => ConduitT a (Either b c) m () -> ConduitT c (Either b d) m () -> ConduitT a (Either b d) m () 171 | connectEitherConduit origCond eCond = origCond .| passCond 172 | where 173 | passCond :: ConduitT (Either b c) (Either b d) m () 174 | passCond = awaitForever loop 175 | where 176 | loop :: (Either b c) -> ConduitT (Either b c) (Either b d) m () 177 | loop (Left b) = yield $ Left b 178 | loop (Right d) = yieldMany [d] .| eCond 179 | 180 | checkSumConduit :: (Monad m) => ConduitT BS.ByteString (Either Text BS.ByteString) m () 181 | checkSumConduit = deserialiseWithPartialParserTransformer $ fmapPartialParser checkCRCStrict $ 182 | (PartialParser $ \t -> (handleDataDotSerializeParserResult $ runGetPartial getWithCheckSumStrict t)) 183 | 184 | lazyCRCDigest :: BL.ByteString -> CRC.CRC32 185 | lazyCRCDigest = updateDigest32Lazy CRC.initCRC 186 | 187 | updateDigest32Lazy :: CRC.CRC32 -> BL.ByteString -> CRC.CRC32 188 | updateDigest32Lazy crc = xorFinal . BL.foldl go crc 189 | where 190 | xorFinal (CRC.CRC32 x) = CRC.CRC32 (x `xor` 0xffffffff) 191 | go (CRC.CRC32 crc') b8 = 192 | let idx = fromIntegral (crc' `xor` b32) .&. 0xff 193 | b32 = fromIntegral b8 194 | in CRC.CRC32 (((crc' `shiftR` 8) .&. 0x00ffffff) `xor` (CRC.crcTable VUnboxedPartial.! idx)) 195 | 196 | 197 | class AcidSerialiseC t where 198 | type AcidSerialiseConstraintP t (ss :: [Symbol]) :: Symbol -> Constraint 199 | 200 | type AcidSerialiseConstraintAll t ss nn = All (AcidSerialiseConstraintP t ss) nn 201 | type AcidSerialiseConstraint t ss n = AcidSerialiseConstraintP t ss n 202 | 203 | 204 | class (AcidSerialiseSegment t (SegmentS fieldName), Segment fieldName) => AcidSerialiseSegmentNameConstraint t fieldName 205 | instance (AcidSerialiseSegment t (SegmentS fieldName), Segment fieldName) => AcidSerialiseSegmentNameConstraint t fieldName 206 | 207 | 208 | class (AcidSerialiseSegment t (V.Snd field), Segment (V.Fst field), KnownSymbol (V.Fst field)) => AcidSerialiseSegmentFieldConstraint t field 209 | instance (AcidSerialiseSegment t (V.Snd field), Segment (V.Fst field), KnownSymbol (V.Fst field)) => AcidSerialiseSegmentFieldConstraint t field 210 | 211 | 212 | 213 | 214 | class (SegmentFetching ss sField, AcidSerialiseSegmentFieldConstraint t sField) => SegmentFieldSerialise ss t sField 215 | instance (SegmentFetching ss sField, AcidSerialiseSegmentFieldConstraint t sField) => SegmentFieldSerialise ss t sField 216 | 217 | type ValidSegmentsSerialise t ss = (All (SegmentFieldSerialise ss t) (ToSegmentFields ss), All (AcidSerialiseSegmentFieldConstraint t) (ToSegmentFields ss), ValidSegments ss) 218 | 219 | 220 | 221 | type AcidSerialiseParsers t ss nn = HM.HashMap Text (AcidSerialiseParser t ss nn) 222 | 223 | newtype PartialParser s a = PartialParser {extractPartialParser :: (s -> Either Text (Either (PartialParser s a) (s, a)))} 224 | 225 | runPartialParser :: PartialParser s a -> s -> Either Text (Either (PartialParser s a) (s, a)) 226 | runPartialParser = extractPartialParser 227 | 228 | runOrErrorPartialParser :: PartialParser s a -> s -> Either Text a 229 | runOrErrorPartialParser pa s = do 230 | aRes <- runPartialParser pa s 231 | case aRes of 232 | Left _ -> Left $ "Not enough input for partial parser to consume" 233 | Right (_, a) -> pure a 234 | 235 | consumeAndRunPartialParser :: PartialParser s a -> PartialParser s b -> s -> Either Text b 236 | consumeAndRunPartialParser pa pb s = do 237 | aRes <- runPartialParser pa s 238 | case aRes of 239 | Left _ -> Left $ "Not enough input for partial parser to consume" 240 | Right (s2, _) -> runOrErrorPartialParser pb s2 241 | 242 | type PartialParserBS a = PartialParser BS.ByteString a 243 | 244 | fmapPartialParser :: (a -> Either Text b) -> PartialParser s a -> PartialParser s b 245 | fmapPartialParser f p = PartialParser $ \t -> do 246 | res <- runPartialParser p t 247 | case res of 248 | (Left newP) -> pure (Left $ fmapPartialParser f newP) 249 | (Right (s, a)) -> do 250 | b <- f a 251 | pure $ Right (s, b) 252 | 253 | deserialiseEventStreamWithPartialParser :: forall ss nn m. (Monad m) => PartialParserBS (PartialParserBS (WrappedEvent ss nn)) -> (ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) ()) 254 | deserialiseEventStreamWithPartialParser initialParser = awaitForever (loop (Left initialParser)) 255 | where 256 | loop :: (Either (PartialParserBS (PartialParserBS (WrappedEvent ss nn))) (PartialParserBS (WrappedEvent ss nn))) -> BS.ByteString -> ConduitT BS.ByteString (Either Text (WrappedEvent ss nn)) (m) () 257 | loop (Left p) t = do 258 | case runPartialParser p t of 259 | Left err -> yield (Left err) >> awaitForever (loop (Left p)) 260 | Right (Left newParser) -> do 261 | mt <- await 262 | case mt of 263 | Nothing -> yield $ Left $ "Unexpected end of conduit values when still looking for parser" 264 | Just nt -> loop (Left newParser) nt 265 | Right (Right (bs, foundP)) -> (loop (Right foundP) bs) 266 | loop (Right p) t = 267 | case runPartialParser p t of 268 | Left err -> yield (Left err) >> awaitForever (loop (Left initialParser)) 269 | Right (Left newParser) -> do 270 | mt <- await 271 | case mt of 272 | Nothing -> yield $ Left $ "Unexpected end of conduit values when named event has only been partially parsed" 273 | Just nt -> loop (Right newParser) nt 274 | Right (Right (bs, e)) -> yield (Right e) >> (if BS.null bs then awaitForever (loop (Left initialParser)) else loop (Left initialParser) bs) 275 | -- @todo we may need some strictness annotations here - I'm not 100% sure how strictness works with conduit 276 | deserialiseWithPartialParserSink :: forall a o m. (Monad m) => PartialParserBS a -> ConduitT BS.ByteString o m (Either Text a) 277 | deserialiseWithPartialParserSink origParser = await >>= loop origParser 278 | where 279 | loop :: PartialParserBS a -> Maybe BS.ByteString -> ConduitT BS.ByteString o m (Either Text a) 280 | loop _ Nothing = pure . Left $ "No values received in conduit when trying to parse segment" 281 | loop p (Just t) = do 282 | case runPartialParser p t of 283 | Left err -> pure $ Left err 284 | Right (Left newParser) -> await >>= loop newParser 285 | Right (Right (_, a)) -> pure $ Right a 286 | 287 | 288 | deserialiseWithPartialParserTransformer :: forall a m. (Monad m) => PartialParserBS a -> ConduitT BS.ByteString (Either Text a) m () 289 | deserialiseWithPartialParserTransformer origParser = awaitForever $ loop origParser 290 | where 291 | loop :: PartialParserBS a -> BS.ByteString -> ConduitT BS.ByteString (Either Text a) m () 292 | loop p t = do 293 | case runPartialParser p t of 294 | Left err -> yield (Left err) >> awaitForever (loop origParser) 295 | Right (Left newParser) -> awaitForever $ loop newParser 296 | Right (Right (bs, a)) -> yield (Right a) >> (if BS.null bs then awaitForever (loop origParser) else loop origParser bs) 297 | 298 | 299 | {- 300 | this is a helper function for deserialising a single wrapped event - at the moment it is really just used for testing serialisation 301 | -} 302 | deserialiseWrappedEvent :: forall t ss m (nn :: [Symbol]). (AcidSerialiseEvent t, ValidEventNames ss nn, AcidSerialiseConstraintAll t ss nn, MonadIO m) => AcidSerialiseEventOptions t -> AcidSerialiseT t -> m (Either Text (WrappedEvent ss nn)) 303 | deserialiseWrappedEvent o s = do 304 | ps <- makeDeserialiseParsers o (Proxy :: Proxy ss) (Proxy :: Proxy nn) 305 | deserialiseWrappedEventWithParsers o ps (toConduitType o s) 306 | 307 | deserialiseWrappedEventWithParsers :: (AcidSerialiseEvent t, MonadIO m) => AcidSerialiseEventOptions t -> AcidSerialiseParsers t ss nn -> AcidSerialiseConduitT t -> m (Either Text (WrappedEvent ss nn)) 308 | deserialiseWrappedEventWithParsers o ps s = do 309 | res <- runConduit $ yieldMany [s] .| (deserialiseEventStream o ps) .| sinkList 310 | pure $ 311 | case res of 312 | [] -> Left $ "Expected to deserialise one event, got none" 313 | [Left err] -> Left $ err 314 | [Right a] -> Right $ a 315 | xs -> Left $ "Expected to deserialise one event, got " <> (T.pack (show (length xs))) -------------------------------------------------------------------------------- /src/Acid/Core/Backend/FS.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Acid.Core.Backend.FS where 5 | import RIO 6 | import qualified RIO.Text as T 7 | import System.IO (openBinaryFile, IOMode(..), SeekMode(..)) 8 | import qualified RIO.Directory as Dir 9 | import qualified RIO.ByteString as BS 10 | import qualified RIO.ByteString.Lazy as BL 11 | import qualified RIO.Time as Time 12 | 13 | import qualified Control.Concurrent.STM.TMVar as TMVar 14 | import qualified Control.Concurrent.STM as STM 15 | 16 | import Data.Proxy(Proxy(..)) 17 | 18 | 19 | import Generics.SOP 20 | import Generics.SOP.NP 21 | import qualified Data.Vinyl.Derived as V 22 | import qualified Data.Vinyl.TypeLevel as V 23 | 24 | import Acid.Core.State 25 | import Acid.Core.Utils 26 | import Acid.Core.Segment 27 | import Acid.Core.Backend.Abstract 28 | import Acid.Core.Serialise.Abstract 29 | import Conduit 30 | import Data.Conduit.Zlib 31 | import Control.Arrow (left) 32 | import qualified Crypto.Hash as Hash 33 | import qualified Data.ByteArray.Encoding as BA 34 | import qualified Data.ByteArray as BA 35 | import Paths_acid_world (getDataFileName) 36 | 37 | 38 | 39 | data AcidWorldBackendFS 40 | 41 | sha256 :: BL.ByteString -> Hash.Digest Hash.SHA256 42 | sha256 = Hash.hashlazy 43 | 44 | 45 | -- @todo all writing needs to be move to a separate thread 46 | 47 | 48 | instance AcidWorldBackend AcidWorldBackendFS where 49 | data AWBState AcidWorldBackendFS = AWBStateFS { 50 | aWBStateFSConfig :: AWBConfig AcidWorldBackendFS, 51 | aWBStateFSEventsHandle :: TMVar.TMVar (Handle, Handle) 52 | } 53 | data AWBConfig AcidWorldBackendFS = AWBConfigFS { 54 | aWBConfigFSStateDir :: FilePath, 55 | aWBConfigGzip :: Bool 56 | } 57 | backendConfigInfo c = "Gzip: " <> showT (aWBConfigGzip c) 58 | type AWBSerialiseT AcidWorldBackendFS = BL.ByteString 59 | type AWBSerialiseConduitT AcidWorldBackendFS = BS.ByteString 60 | initialiseBackend c t = do 61 | stateP <- Dir.makeAbsolute (aWBConfigFSStateDir c) 62 | let finalConf = c{aWBConfigFSStateDir = stateP} 63 | 64 | -- @todo handle previous folder when restoring after failed checkpoint 65 | 66 | recoverFromPartialCheckpoint finalConf t 67 | 68 | -- create an archive directory for later 69 | hdls <- startOrResumeCurrentEventsLog finalConf t 70 | 71 | hdlV <- liftIO $ STM.atomically $ newTMVar hdls 72 | pure . pure $ AWBStateFS finalConf hdlV 73 | createCheckpointBackend s awu t = do 74 | 75 | 76 | let currentS = currentStateFolder (aWBStateFSConfig s) 77 | previousS = previousStateFolder (aWBStateFSConfig s) 78 | 79 | -- at present we can only recover from this when initialising 80 | whenM (Dir.doesDirectoryExist previousS) $ throwM (AWExceptionCheckpointError "Last checkpoint did not complete, no more checkpoints can be created until that one has been restore, which can be done by closing and reopening acid world") 81 | 82 | -- @todo add some exception handling here and possible recoveries - particularly for when there is already an uncompleted checkpoint! 83 | -- close the current events log and return current state - as soon as this completes updates can start runnning again 84 | let restoreCurrent = do 85 | whenM (Dir.doesDirectoryExist previousS) $ do 86 | Dir.removeDirectoryRecursive currentS 87 | Dir.renameDirectory previousS currentS 88 | startOrResumeCurrentEventsLog (aWBStateFSConfig s) t 89 | 90 | 91 | sToWrite <- modifyTMVarWithOnException (aWBStateFSEventsHandle s) restoreCurrent $ \(eHdl, cHdl) -> do 92 | st <- runQuery awu askStateNp 93 | 94 | liftIO $ hClose eHdl 95 | liftIO $ hClose cHdl 96 | 97 | -- move the current state directory 98 | Dir.renameDirectory currentS previousS 99 | 100 | -- start a new log in a new current folder 101 | hdl' <- startOrResumeCurrentEventsLog (aWBStateFSConfig s) t 102 | 103 | pure (hdl', st) 104 | writeCheckpoint s t sToWrite 105 | -- at this point the current state directory contains everything needed, so we can archive the previous state 106 | now <- Time.getCurrentTime 107 | let archiveS = archiveStateFolder (aWBStateFSConfig s) 108 | Dir.createDirectoryIfMissing True archiveS 109 | let newArchivePath = archiveS <> "/" <> Time.formatTime Time.defaultTimeLocale archiveTimeFormat now 110 | Dir.renameDirectory previousS newArchivePath 111 | 112 | getInitialState defState s t = do 113 | let cpFolder = currentCheckpointFolder (aWBStateFSConfig $ s) 114 | doesExist <- Dir.doesDirectoryExist cpFolder 115 | if doesExist 116 | then do 117 | let middleware = if (aWBConfigGzip . aWBStateFSConfig $ s) then ungzip else awaitForever $ yield 118 | fmap (left AWExceptionSegmentDeserialisationError) $ readLastCheckpointState middleware defState s t cpFolder 119 | else pure . pure $ defState 120 | 121 | closeBackend s = modifyTMVar (aWBStateFSEventsHandle s) $ \(eHdl, cHdl) -> do 122 | liftIO $ hClose eHdl 123 | liftIO $ hClose cHdl 124 | pure (error "AcidWorldBackendFS has been closed", ()) 125 | 126 | loadEvents deserialiseConduit s _ = do 127 | expectedLastEventId <- liftIO $ withTMVarSafe (aWBStateFSEventsHandle s) $ \(_, cHdl) -> do 128 | liftIO $ hSeek cHdl AbsoluteSeek 0 129 | empty <- hIsEOF cHdl 130 | if empty 131 | then pure . Right $ Nothing 132 | else fmap ((fmap Just . eventIdFromText) . decodeUtf8Lenient) $ BS.hGetLine cHdl 133 | 134 | case expectedLastEventId of 135 | Left err -> pure . Left $ AWExceptionEventSerialisationError err 136 | Right lastEventId -> pure . Right $ LoadEventsConduit $ \restConduit -> liftIO $ 137 | withTMVarSafe (aWBStateFSEventsHandle s) $ \(eHdl, _) -> runConduitRes $ 138 | sourceHandle eHdl .| 139 | deserialiseConduit .| 140 | checkLastEventIdConduit lastEventId .| 141 | restConduit 142 | 143 | where 144 | checkLastEventIdConduit :: Maybe EventId -> (ConduitT (Either Text (WrappedEvent ss nn)) (Either Text (WrappedEvent ss nn)) (ResourceT IO) ()) 145 | checkLastEventIdConduit inEId = await >>= (\f -> await >>= loop inEId f) 146 | where 147 | loop :: Maybe EventId -> Maybe (Either Text (WrappedEvent ss nn)) -> Maybe (Either Text (WrappedEvent ss nn)) -> (ConduitT (Either Text (WrappedEvent ss nn)) (Either Text (WrappedEvent ss nn)) (ResourceT IO) ()) 148 | loop Nothing Nothing _ = pure () 149 | loop (Just eId) Nothing _ = yield (Left $ "Expected event with id " <> showT eId <> " to be the last entry in this log but it was never encountered - it looks like the event log has been truncated") 150 | loop Nothing (Just _) _ = 151 | -- @essential @todo we encountered an event/parse failures (or multiple events/errors?) for events that weren't fully persisted - anything after this point should be thrown away with a logWarn (@log) and the events file itself should be truncated to this point - this is a recoverable error but we need to implement the recovery, so for now we just fail. 152 | 153 | yield (Left $ "Encountered event that was not fully persisted - recovery is possible but has not yet been implemented") 154 | 155 | loop e (Just we1) (Just we2) = yield we1 >> await >>= loop e (Just we2) 156 | loop (Just _) (Just (Left err)) Nothing = yield (Left err) -- the last entry is already an error 157 | -- this is the last entry 158 | loop (Just eId) (Just (Right we)) Nothing = 159 | if eId == wrappedEventId we 160 | then yield $ Right we 161 | else yield (Left $ "Events log check failed - expected final event with id " <> showT eId <> " but got " <> showT (wrappedEventId we)) 162 | -- @todo restrict the IO actions? also think a bit more about bracketing here and possible error scenarios 163 | 164 | 165 | handleUpdateEventC serializer s awu _ ec prePersistHook postPersistHook = withTMVarSafe (aWBStateFSEventsHandle s) $ \(eHdl, cHdl) -> do 166 | eBind (runUpdateC awu ec) $ \(es, r, onSuccess, onFail) -> do 167 | stEs <- mkStorableEvents es 168 | 169 | case extractLastEventId stEs of 170 | Nothing -> onFail >> (pure . Left $ AWExceptionEventSerialisationError "Could not extract event id, this can only happen if the passed eventC contains no events") 171 | Just lastEventId -> do 172 | ioRPre <- onException (prePersistHook r) onFail 173 | 174 | (flip onException) onFail $ do 175 | BL.hPut eHdl $ serializer stEs 176 | hFlush eHdl 177 | -- write over the check 178 | liftIO $ hSeek cHdl AbsoluteSeek 0 179 | BS.hPut cHdl (encodeUtf8 $ eventIdToText lastEventId) 180 | hFlush cHdl 181 | onSuccess 182 | 183 | -- at this point the event has been definitively written 184 | ioRPost <- (postPersistHook r) 185 | 186 | pure . Right $ (r, (ioRPre, ioRPost)) 187 | 188 | 189 | startOrResumeCurrentEventsLog :: (MonadIO m, AcidSerialiseEvent t) => AWBConfig AcidWorldBackendFS -> AcidSerialiseEventOptions t -> m (Handle, Handle) 190 | startOrResumeCurrentEventsLog c t = do 191 | readmeP <- getStateFolderReadme 192 | Dir.copyFile readmeP ((aWBConfigFSStateDir c) <> "/README.md") 193 | let currentS = currentStateFolder c 194 | Dir.createDirectoryIfMissing True currentS 195 | Dir.copyFile readmeP (currentS <> "/README.md") 196 | let eventPath = makeEventPathWith currentS t 197 | eventCPath = makeEventsCheckPathWith currentS t 198 | -- at the moment this is fragile with respect to exceptions 199 | eHandle <- liftIO $ openBinaryFile eventPath ReadWriteMode 200 | cHandle <- liftIO $ openBinaryFile eventCPath ReadWriteMode 201 | pure (eHandle, cHandle) 202 | 203 | 204 | writeCheckpoint :: forall t sFields m. (AcidSerialiseEvent t, AcidSerialiseSegmentT t ~ BS.ByteString, MonadUnliftIO m, MonadThrow m, PrimMonad m, All (AcidSerialiseSegmentFieldConstraint t) sFields) => AWBState AcidWorldBackendFS -> AcidSerialiseEventOptions t -> NP V.ElField sFields -> m () 205 | writeCheckpoint s t np = do 206 | let cpFolderFinal = currentCheckpointFolder (aWBStateFSConfig $ s) 207 | cpFolderTemp = cpFolderFinal <> ".temp" 208 | Dir.createDirectoryIfMissing True cpFolderTemp 209 | 210 | let middleware = if (aWBConfigGzip . aWBStateFSConfig $ s) then gzip else awaitForever $ yield 211 | let acts = cfoldMap_NP (Proxy :: Proxy (AcidSerialiseSegmentFieldConstraint t)) ((:[]) . writeSegment middleware s t cpFolderTemp) np 212 | mapConcurrently_ id acts 213 | 214 | Dir.renameDirectory cpFolderTemp cpFolderFinal 215 | 216 | writeSegment :: forall t m fs. (AcidSerialiseEvent t, AcidSerialiseSegmentT t ~ BS.ByteString, MonadUnliftIO m, MonadThrow m, AcidSerialiseSegmentFieldConstraint t fs) => ConduitT ByteString ByteString (ResourceT m) () -> AWBState AcidWorldBackendFS -> AcidSerialiseEventOptions t -> FilePath -> V.ElField fs -> m () 217 | writeSegment middleware s t dir (V.Field seg) = do 218 | 219 | let pp = (Proxy :: Proxy (V.Fst fs)) 220 | segPath = makeSegmentPath dir (aWBStateFSConfig $ s) pp t 221 | segCheckPath = makeSegmentCheckPath dir (aWBStateFSConfig $ s) pp t 222 | 223 | -- we simultaneously write out the segment file and the calculated segment hash file, and check them afterwards to verify consistency of the write 224 | _ <- 225 | runConduitRes $ 226 | serialiseSegment t seg .| 227 | middleware .| 228 | sequenceSinks [(sinkFileCautious segPath), (sha256Transformer .| sinkFileCautious segCheckPath)] 229 | 230 | res <- getSegmentHashes segPath segCheckPath 231 | case res of 232 | Left err -> throwM $ AWExceptionEventSerialisationError $ prettySegment pp <> "Error when checking segment write: " <> err 233 | Right (hash, checkHash) -> when (hash /= checkHash) $ 234 | throwM $ AWExceptionEventSerialisationError $ prettySegment pp <> "Segment check hash did not match written segment file - corruption occurred while writing" 235 | 236 | recoverFromPartialCheckpoint :: (MonadUnliftIO m, AcidSerialiseEvent t) => AWBConfig AcidWorldBackendFS -> AcidSerialiseEventOptions t -> m () 237 | recoverFromPartialCheckpoint c t = do 238 | -- @todo check that this recovers from all possible states (missing current log etc) 239 | let partialN = "/partial" 240 | restoreN = "/restore" 241 | recoveredN = "/recovered" 242 | previousS = previousStateFolder c 243 | currentS = currentStateFolder c 244 | partialS = previousS <> partialN -- where the old 'current' state lives 245 | restoreS = previousS <> restoreN -- for the eventlogs in 'previous' 246 | 247 | whenM (Dir.doesDirectoryExist previousS) $ do 248 | 249 | whenM (Dir.doesDirectoryExist currentS) $ Dir.renameDirectory currentS partialS 250 | -- we move the previous logs and check to a temporary folder 251 | let previousEventsLogP = makeEventPathWith previousS t 252 | previousEventsLogCheckP = makeEventsCheckPathWith previousS t 253 | restoreEventsLogP = makeEventPathWith restoreS t 254 | restoreEventsLogCheckP = makeEventsCheckPathWith restoreS t 255 | partialEventsLogP = makeEventPathWith partialS t 256 | partialEventsLogCheckP = makeEventsCheckPathWith partialS t 257 | 258 | Dir.createDirectoryIfMissing False restoreS 259 | 260 | whenM (Dir.doesFileExist previousEventsLogP) $ Dir.renameFile previousEventsLogP restoreEventsLogP 261 | whenM (Dir.doesFileExist previousEventsLogCheckP) $ Dir.renameFile previousEventsLogCheckP restoreEventsLogCheckP 262 | 263 | -- create the new events log by appending the 'current' log (in 'partial') to the 'previous' log (in 'restore') 264 | runConduitRes $ 265 | yieldMany [restoreEventsLogP, partialEventsLogP] .| 266 | awaitForever sourceFile .| 267 | sinkFileCautious previousEventsLogP 268 | -- if we did actually have a new event check then copy it, else use the old 269 | checkFileToCopy <- do 270 | hasContent <- do 271 | d <- Dir.doesFileExist partialEventsLogCheckP 272 | if d 273 | then fmap (not . BL.null) $ BL.readFile partialEventsLogCheckP 274 | else pure False 275 | if hasContent then pure $ partialEventsLogCheckP else pure $ restoreEventsLogCheckP 276 | Dir.copyFile checkFileToCopy previousEventsLogCheckP 277 | -- rename the 'previous' folder as the 'current' folder - this signals that restoration is complete 278 | Dir.renameDirectory previousS currentS 279 | -- we can delete these but for safety we just move them to another folder 280 | let recoveredS = currentS <> recoveredN 281 | whenM (Dir.doesDirectoryExist $ currentS <> partialN) $ do 282 | Dir.createDirectoryIfMissing False recoveredS 283 | Dir.renameDirectory (currentS <> partialN) (recoveredS <> partialN) 284 | whenM (Dir.doesDirectoryExist $ currentS <> restoreN) $ do 285 | Dir.createDirectoryIfMissing False recoveredS 286 | Dir.renameDirectory (currentS <> restoreN) (recoveredS <> restoreN) 287 | 288 | 289 | 290 | 291 | 292 | readLastCheckpointState :: forall ss m t. (AcidSerialiseEvent t, ValidSegmentsSerialise t ss, MonadUnliftIO m, AcidDeserialiseSegmentT t ~ BS.ByteString) => ConduitT ByteString ByteString (ResourceT m) () -> SegmentsState ss -> AWBState AcidWorldBackendFS -> AcidSerialiseEventOptions t -> FilePath -> m (Either Text (SegmentsState ss)) 293 | readLastCheckpointState middleware defState s t dir = (fmap . fmap) (npToSegmentsState) segsNpE 294 | 295 | where 296 | segsNpE :: m (Either Text (NP V.ElField (ToSegmentFields ss))) 297 | segsNpE = runConcurrently $ unComp $ sequence'_NP segsNp 298 | segsNp :: NP ((Concurrently m :.: Either Text) :.: V.ElField) (ToSegmentFields ss) 299 | segsNp = cmap_NP (Proxy :: Proxy (SegmentFieldSerialise ss t)) readSegmentFromProxy proxyNp 300 | readSegmentFromProxy :: forall a b. (AcidSerialiseSegmentFieldConstraint t '(a, b), b ~ SegmentS a, HasSegment ss a) => Proxy '(a, b) -> ((Concurrently m :.: Either Text) :.: V.ElField) '(a, b) 301 | readSegmentFromProxy _ = Comp $ fmap V.Field $ Comp $ readSegment (Proxy :: Proxy a) 302 | readSegment :: forall sName. (AcidSerialiseSegmentNameConstraint t sName, HasSegment ss sName) => Proxy sName -> Concurrently m (Either Text (SegmentS sName)) 303 | readSegment ps = Concurrently $ do 304 | let segPath = makeSegmentPath dir (aWBStateFSConfig $ s) ps t 305 | segCheckPath = makeSegmentCheckPath dir (aWBStateFSConfig $ s) ps t 306 | 307 | (segPathExists, segCheckPathExists) <- do 308 | a <- Dir.doesFileExist segPath 309 | b <- Dir.doesFileExist segCheckPath 310 | pure (a, b) 311 | 312 | case (segPathExists, segCheckPathExists) of 313 | (False, False) -> pure . Right $ getSegmentP ps defState 314 | (True, False) -> pure . Left $ prettySegment ps <> "Segment check file could not be found at " <> showT segCheckPath <> ". If you are confident that your segment file contains the correct data then you can fix this error by manually creating a segment check file at that path with the output of `sha256sum "<> showT segPath <> "`" 315 | (False, True) -> pure . Left $ prettySegment ps <> "Segment file missing at " <> showT segPath <> ". This is almost certainly due to some kind of data corruption. To clear this error you can delete the check file at " <> showT segCheckPath <> " but that will revert the system to using the default state defined for this segment" 316 | (True, True) -> do 317 | eBind (getSegmentHashes segPath segCheckPath) $ \(hash, checkHash) -> do 318 | if hash /= checkHash 319 | then pure . Left $ "Invalid checkpoint - check file (" <> showT segCheckPath <> ": " <> showT checkHash <> ") did not match hash of segment file" <> "(" <> showT segPath <> ": " <> showT hash <> ")" <> " when reading segment *" <> toUniqueText ps <> "*" 320 | else runResourceT $ runConduit $ 321 | (sourceFile segPath) .| 322 | middleware .| 323 | deserialiseSegment t 324 | 325 | proxyNp :: NP Proxy (ToSegmentFields ss) 326 | proxyNp = pure_NP Proxy 327 | 328 | 329 | getSegmentHashes :: (MonadUnliftIO m) => FilePath -> FilePath -> m (Either Text (Hash.Digest Hash.SHA256, Hash.Digest Hash.SHA256)) 330 | getSegmentHashes sp scp = do 331 | eBind (readSha256FromFile scp) $ \hb -> do 332 | ha <- sha256ForFile sp 333 | pure . pure $ (ha, hb) 334 | 335 | 336 | 337 | sha256Transformer :: forall m. (Monad m) => ConduitT BS.ByteString BS.ByteString m () 338 | sha256Transformer = await >>= loop (Hash.hashInit) 339 | where 340 | loop :: Hash.Context Hash.SHA256 -> Maybe (BS.ByteString) -> ConduitT BS.ByteString BS.ByteString m () 341 | loop ctx (Just bs) = await >>= loop (Hash.hashUpdate ctx bs) 342 | loop ctx (Nothing) = yield (BA.convertToBase BA.Base16 (Hash.hashFinalize ctx)) 343 | 344 | 345 | sha256Sink ::(Monad m) => ConduitT BS.ByteString o m (Hash.Digest Hash.SHA256) 346 | sha256Sink = fmap Hash.hashFinalize $ foldlC Hash.hashUpdate Hash.hashInit 347 | 348 | sha256ForFile :: (MonadUnliftIO m) => FilePath -> m (Hash.Digest Hash.SHA256) 349 | sha256ForFile fp = runConduitRes $ 350 | sourceFile fp .| sha256Sink 351 | 352 | readSha256FromFile :: (MonadUnliftIO m) => FilePath -> m (Either Text (Hash.Digest Hash.SHA256)) 353 | readSha256FromFile fp = do 354 | bs <- fmap (BA.convertFromBase BA.Base16) $ BS.readFile fp 355 | case bs of 356 | Left e -> pure . Left $ "Could not convert file contents to Base16 Bytes from " <> showT fp <> ": " <> T.pack e 357 | Right (b :: BA.Bytes) -> 358 | case Hash.digestFromByteString b of 359 | Nothing -> pure . Left $ "Could not read sha256 digest from " <> showT fp 360 | Just a -> pure . pure $ a 361 | 362 | currentStateFolder :: AWBConfig AcidWorldBackendFS -> FilePath 363 | currentStateFolder c = (aWBConfigFSStateDir $ c) <> "/current" 364 | 365 | previousStateFolder :: AWBConfig AcidWorldBackendFS -> FilePath 366 | previousStateFolder c = (aWBConfigFSStateDir $ c) <> "/previous" 367 | 368 | archiveTimeFormat :: String 369 | archiveTimeFormat = "%0Y-%m-%d_%H-%M-%S-%6q_UTC" 370 | 371 | archiveStateFolder :: AWBConfig AcidWorldBackendFS -> FilePath 372 | archiveStateFolder c = (aWBConfigFSStateDir c) <> "/archive" 373 | 374 | 375 | currentCheckpointFolder :: AWBConfig AcidWorldBackendFS -> FilePath 376 | currentCheckpointFolder c = currentStateFolder c <> "/checkpoint" 377 | 378 | makeSegmentPath :: (Segment sName, AcidSerialiseEvent t) => FilePath -> AWBConfig AcidWorldBackendFS -> Proxy sName -> AcidSerialiseEventOptions t -> FilePath 379 | makeSegmentPath cFolder c ps t = cFolder <> "/" <> T.unpack (toUniqueText ps) <> serialiserFileExtension t <> if aWBConfigGzip c then ".gz" else "" 380 | 381 | makeSegmentCheckPath :: (Segment sName, AcidSerialiseEvent t) => FilePath -> AWBConfig AcidWorldBackendFS -> Proxy sName -> AcidSerialiseEventOptions t -> FilePath 382 | makeSegmentCheckPath dir c ps t = makeSegmentPath dir c ps t <> ".check" 383 | 384 | 385 | 386 | makeEventPathWith :: AcidSerialiseEvent t => FilePath -> AcidSerialiseEventOptions t -> FilePath 387 | makeEventPathWith stateFolder t = stateFolder <> "/" <> "events" <> serialiserFileExtension t 388 | 389 | makeEventsCheckPathWith :: AcidSerialiseEvent t => FilePath -> AcidSerialiseEventOptions t -> FilePath 390 | makeEventsCheckPathWith stateFolder t = makeEventPathWith stateFolder t <> ".check" 391 | 392 | getStateFolderReadme :: (MonadIO m) => m FilePath 393 | getStateFolderReadme = liftIO $ getDataFileName "src/dataFiles/stateFolderReadMe.md" -------------------------------------------------------------------------------- /src/Acid/Core/CacheState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Acid.Core.CacheState where 5 | 6 | import RIO 7 | import qualified RIO.HashMap as HM 8 | import qualified RIO.ByteString.Lazy as BL 9 | import qualified RIO.ByteString as BS 10 | import qualified RIO.Text as T 11 | import Database.LMDB.Simple 12 | import qualified Control.Concurrent.STM as STM 13 | import qualified Control.Monad.State.Strict as St 14 | import Generics.SOP 15 | import Generics.SOP.NP 16 | import Codec.Serialise 17 | import Codec.Serialise.Encoding 18 | import Codec.Serialise.Decoding 19 | import qualified Data.Vinyl.TypeLevel as V 20 | import qualified Data.Vinyl.Derived as V 21 | import qualified Data.Vinyl as V 22 | import qualified Control.Concurrent.STM.TMVar as TMVar 23 | 24 | import GHC.TypeLits 25 | import Data.Coerce 26 | 27 | import qualified Database.LMDB.Simple.Extra as LMDB 28 | import Acid.Core.State.Abstract 29 | import Acid.Core.Utils 30 | import Acid.Core.Segment 31 | import qualified Control.Monad.Reader as Re 32 | 33 | import qualified Data.IxSet.Typed as IxSet 34 | 35 | 36 | data CacheMode = 37 | CacheModeNone 38 | | CacheModeAll 39 | deriving (Eq, Show) 40 | 41 | data SegmentCacheMode = 42 | SegmentCacheModeGlobal 43 | | SegmentCacheModeNone 44 | | SegmentCacheModeAll 45 | deriving (Eq, Show) 46 | 47 | class (CacheMap (SegmentS segmentName), Segment segmentName) => SegmentC segmentName where 48 | segmentCacheMode :: Proxy segmentName -> SegmentCacheMode 49 | segmentCacheMode _ = SegmentCacheModeGlobal 50 | 51 | class (SegmentC segmentName) => ValidCSegment segmentName 52 | instance (SegmentC segmentName) => ValidCSegment segmentName 53 | 54 | 55 | class (V.KnownField a, SegmentC (V.Fst a), SegmentDb (V.Fst a) ~ (V.Snd a)) => KnownSegmentDBField a 56 | instance (V.KnownField a, SegmentC (V.Fst a), SegmentDb (V.Fst a) ~ (V.Snd a)) => KnownSegmentDBField a 57 | 58 | class (CacheMap (V.Snd sf), SegmentC (V.Fst sf), KnownSymbol (V.Fst sf), SegmentFetching ss sf) => ValidCSegmentField ss sf 59 | instance (CacheMap (V.Snd sf), SegmentC (V.Fst sf), KnownSymbol (V.Fst sf), SegmentFetching ss sf) => ValidCSegmentField ss sf 60 | 61 | class (KnownSegmentDBField sf, ValidCSegment (V.Fst sf)) => ValidDBSegmentField ss sf 62 | instance (KnownSegmentDBField sf, ValidCSegment (V.Fst sf)) => ValidDBSegmentField ss sf 63 | 64 | type ValidSegmentsCacheState ss = 65 | (All ValidCSegment ss, 66 | ValidSegmentNames ss, 67 | V.NatToInt (V.RLength (ToSegmentDBFields ss)), 68 | ValidSegments ss, 69 | All (ValidCSegmentField ss) (ToSegmentFields ss), 70 | All (ValidDBSegmentField ss) (ToSegmentDBFields ss) 71 | ) 72 | 73 | class (V.HasField V.ARec s (ToSegmentDBFields segmentNames) (SegmentDb s), KnownSymbol s) => HasSegmentDb segmentNames s 74 | instance (V.HasField V.ARec s (ToSegmentDBFields segmentNames) (SegmentDb s), KnownSymbol s) => HasSegmentDb segmentNames s 75 | 76 | newtype SegmentDb s = SegmentDb {segmentDbDatabase :: (CacheMode, Database (CDBMapKey (SegmentS s)) (CDBMapValue (SegmentS s)))} 77 | 78 | type family ToSegmentDBFields (segmentNames :: [Symbol]) = (segmentFields :: [(Symbol, *)]) where 79 | ToSegmentDBFields '[] = '[] 80 | ToSegmentDBFields (s ': ss) = '(s, SegmentDb s) ': ToSegmentDBFields ss 81 | 82 | newtype SegmentsDb segmentNames = SegmentsDb {segmentsDbFieldRec :: V.AFieldRec (ToSegmentDBFields segmentNames)} 83 | 84 | getSegmentDbP :: forall s ss. (HasSegmentDb ss s) => Proxy s -> SegmentsDb ss -> SegmentDb s 85 | getSegmentDbP _ (SegmentsDb fr) = V.getField $ V.rgetf (V.Label :: V.Label s) fr 86 | 87 | npToSegmentsDb :: forall ss. (ValidSegmentsCacheState ss) => NP V.ElField (ToSegmentDBFields ss) -> SegmentsDb ss 88 | npToSegmentsDb np = SegmentsDb $ (npToVinylARec id np) 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | class (Serialise (CDBMapKey a), Serialise (CDBMapValue a)) => CacheMap a where 98 | type CMapKey a 99 | type CMapValue a 100 | type CMapExpanded a 101 | type CDBMapKey a 102 | type CDBMapKey a = CMapKey a 103 | type CDBMapValue a 104 | type CDBMapValue a = CMapValue a 105 | insertMapC :: CacheMode -> CMapKey a -> CMapValue a -> Database (CDBMapKey a) (CDBMapValue a) -> a -> Transaction ReadWrite (a) 106 | expandMap :: Database (CDBMapKey a) (CDBMapValue a) -> a -> Transaction ReadOnly (CMapExpanded a) 107 | restoreMapC :: CacheMode -> Database (CDBMapKey a) (CDBMapValue a) -> Transaction ReadOnly a 108 | lookupMapC :: CMapKey a -> Database (CDBMapKey a) (CDBMapValue a) -> a -> Transaction ReadOnly (Maybe (CMapValue a)) 109 | 110 | data CVal a = 111 | CVal !a 112 | | CValRef 113 | 114 | toCachedCVal :: CacheMode -> v -> CVal v 115 | toCachedCVal CacheModeAll v = CVal v 116 | toCachedCVal CacheModeNone _ = CValRef 117 | 118 | expandCVal :: (Serialise k, Serialise v) => Database k v -> k -> (CVal v) -> Transaction ReadOnly v 119 | expandCVal _ _ (CVal a) = pure a 120 | expandCVal db k CValRef = do 121 | mV <- get db k 122 | case mV of 123 | Nothing -> throwIO $ AWExceptionSegmentDeserialisationError "Database did not contain value for key" 124 | Just v -> pure v 125 | 126 | {- cacheable single values -} 127 | 128 | instance (Serialise a) => CacheMap (I (CVal a)) where 129 | type CMapKey (I (CVal a)) = () 130 | type CMapValue (I (CVal a)) = a 131 | type CMapExpanded (I (CVal a)) = a 132 | type CDBMapKey (I (CVal a)) = ByteString 133 | 134 | insertMapC cm _ v db _ = do 135 | put db "key" (Just v) 136 | let !cval = toCachedCVal cm v 137 | pure $ I cval 138 | expandMap db (I cv) = expandCVal db "key" cv 139 | restoreMapC cm db = 140 | case cm of 141 | CacheModeNone -> pure $ I CValRef 142 | CacheModeAll -> do 143 | vs <- LMDB.elems db 144 | -- @todo in the absence of a maintenance db to check on whether this is a restore or an initialisation it is not possible to implement this properly 145 | case vs of 146 | [v] -> pure . I . CVal $ v 147 | _ -> pure . I $ CValRef 148 | lookupMapC _ db (I cVal) = fmap Just $ expandCVal db "key" cVal 149 | 150 | 151 | {- cacheable hashmaps -} 152 | 153 | 154 | 155 | instance (Serialise k, Serialise v, Eq k, Hashable k) => CacheMap (HM.HashMap k (CVal v)) where 156 | type CMapKey (HM.HashMap k (CVal v)) = k 157 | type CMapValue (HM.HashMap k (CVal v)) = v 158 | type CMapExpanded (HM.HashMap k (CVal v)) = HM.HashMap k v 159 | insertMapC cm k v db hm = do 160 | put db k (Just v) 161 | let !cval = toCachedCVal cm v 162 | pure $ HM.insert k cval hm 163 | expandMap db hm = sequence $ HM.mapWithKey (expandCVal db) hm 164 | restoreMapC cm db = 165 | case cm of 166 | CacheModeNone -> do 167 | ks <- LMDB.keys db 168 | pure $ HM.fromList $ (map (\k -> (k, CValRef))) ks 169 | CacheModeAll -> do 170 | kvs <- LMDB.toList db 171 | pure $ HM.fromList $ (map (\(k,v) -> (k, CVal v))) kvs 172 | lookupMapC k db hm = maybe (pure Nothing) (fmap Just . expandCVal db k) (HM.lookup k hm) 173 | 174 | 175 | 176 | 177 | {- cacheable IxSets -} 178 | 179 | 180 | class IxsetPrimaryKeyClass a where 181 | type IxsetPrimaryKey a 182 | 183 | type IxsetPrimaryKeyT ixs v = IxsetPrimaryKey (IxSet.IxSet ixs (CValIxs ixs v)) 184 | 185 | type GetPrimaryKey ixs v = ( 186 | IxSet.Indexable ixs v, 187 | ExtractFromNP ixs (IxsetPrimaryKeyT ixs v), 188 | IxSet.IsIndexOf (IxsetPrimaryKeyT ixs v) ixs 189 | ) 190 | 191 | getPrimaryKey :: forall ixs v. (GetPrimaryKey ixs v) => CValIxs ixs v -> Either Text (IxsetPrimaryKeyT ixs v) 192 | getPrimaryKey (CValIxs v) = 193 | let (IxSet.Ix _ f) = IxSet.access (IxSet.indices :: IxSet.IxList ixs v) 194 | in case f v of 195 | [ix] -> Right ix 196 | [] -> Left "Expected single primary key, got none" 197 | _ -> Left "Expected single primary key, got more than one" 198 | getPrimaryKey (CValIxsRef np) = 199 | case extractFromNP np of 200 | [ix] -> Right ix 201 | [] -> Left "Expected single primary key, got none" 202 | _ -> Left "Expected single primary key, got more than one" 203 | 204 | data CValIxs ixs a = 205 | CValIxs !a 206 | -- for performance reasons it would be better to use a V.ARec here maybe (but with what keys...?) 207 | | CValIxsRef !(NP [] ixs) 208 | 209 | instance (GetPrimaryKey ixs a) => Eq (CValIxs ixs a) where 210 | (==) = (==) `on` getPrimaryKey 211 | 212 | instance (GetPrimaryKey ixs a) => Ord (CValIxs ixs a) where 213 | compare = compare `on` getPrimaryKey 214 | 215 | instance (All Serialise xs) => Serialise (NP [] xs) where 216 | encode np = encodeListLenIndef <> 217 | cfoldMap_NP (Proxy :: Proxy Serialise) (encode) np <> 218 | encodeBreak 219 | decode = do 220 | _ <- decodeListLenIndef 221 | np <- npListFromCBOR 222 | fin <- decodeBreakOr 223 | if fin 224 | then pure $ np 225 | else fail "Expected to find a break token to mark the end of ListLenIndef when decoding NP [] xs" 226 | 227 | npListFromCBOR :: forall s xs. (All Serialise xs) => Decoder s (NP [] xs) 228 | npListFromCBOR = 229 | case sList :: SList xs of 230 | SNil -> pure $ Nil 231 | SCons -> do 232 | a <- decode 233 | r <- npListFromCBOR 234 | pure $ a :* r 235 | 236 | 237 | 238 | type CIndexable ixs a = ( 239 | IxSet.Indexable ixs a, All Ord ixs, All (ExtractFromNP ixs) ixs, 240 | GetPrimaryKey ixs a 241 | 242 | ) 243 | 244 | instance (CIndexable ixs a) => IxSet.Indexable ixs (CValIxs ixs a) where 245 | indices = transformIndices IxSet.indices 246 | 247 | transformIndices :: forall ixs a es. (All Ord ixs, All (ExtractFromNP es) ixs) => IxSet.IxList ixs a -> IxSet.IxList ixs (CValIxs es a) 248 | transformIndices IxSet.Nil = IxSet.Nil 249 | transformIndices ((IxSet.:::) ix ilist) = IxSet.ixFun (wrappedIxFun ix) IxSet.::: transformIndices ilist 250 | where 251 | wrappedIxFun :: (ExtractFromNP es ix) => IxSet.Ix ix a -> CValIxs es a -> [ix] 252 | wrappedIxFun (IxSet.Ix _ f) (CValIxs a) = f a 253 | wrappedIxFun _ (CValIxsRef np) = extractFromNP np 254 | 255 | 256 | ixsetIdxsKeyPrefix :: ByteString 257 | ixsetIdxsKeyPrefix = "ixs____" 258 | 259 | 260 | indexableToIndexes :: IxSet.Indexable ixs a => a -> NP [] ixs 261 | indexableToIndexes a = buildNp IxSet.indices a 262 | where 263 | buildNp :: IxSet.IxList ixs a -> a -> NP [] ixs 264 | buildNp IxSet.Nil _ = Nil 265 | buildNp ((IxSet.:::) (IxSet.Ix _ f) ilist) aa = f aa :* (buildNp ilist aa) 266 | 267 | instance (CIndexable ixs v, All Serialise ixs, Serialise (IxsetPrimaryKey (IxSet.IxSet ixs (CValIxs ixs v))), Serialise v) => CacheMap (IxSet.IxSet ixs (CValIxs ixs v)) where 268 | type CMapKey (IxSet.IxSet ixs (CValIxs ixs v)) = IxsetPrimaryKey (IxSet.IxSet ixs (CValIxs ixs v)) 269 | type CMapValue (IxSet.IxSet ixs (CValIxs ixs v)) = v 270 | type CDBMapKey (IxSet.IxSet ixs (CValIxs ixs v)) = ByteString 271 | type CDBMapValue (IxSet.IxSet ixs (CValIxs ixs v)) = ByteString 272 | type CMapExpanded (IxSet.IxSet ixs (CValIxs ixs v)) = IxSet.IxSet ixs v 273 | insertMapC cm k v db ixset = do 274 | let pKey = BL.toStrict $ serialise k 275 | put db pKey (Just (BL.toStrict $ serialise v)) 276 | let !inds = indexableToIndexes v :: NP [] ixs 277 | !cval = toCachedCValIxs cm v inds 278 | put db (ixsetIdxsKeyPrefix <> pKey) (Just (BL.toStrict . serialise $ inds)) 279 | pure $ IxSet.updateIx k cval ixset 280 | restoreMapC cm db = 281 | case cm of 282 | CacheModeNone -> do 283 | kvs <- LMDB.toList db 284 | -- restrict to index keys 285 | let kvsr = filter (BS.isPrefixOf ixsetIdxsKeyPrefix . fst) kvs 286 | vs <- mapM deserialiseIxRef kvsr 287 | pure $ IxSet.fromList vs 288 | CacheModeAll -> do 289 | kvs <- LMDB.toList db 290 | -- restrict to value keys 291 | let kvsr = filter (not . BS.isPrefixOf ixsetIdxsKeyPrefix . fst) kvs 292 | vs <- mapM deserialiseIxVal kvsr 293 | pure $ IxSet.fromList vs 294 | where 295 | deserialiseIxVal :: (ByteString, ByteString) -> Transaction ReadOnly (CValIxs ixs v) 296 | deserialiseIxVal (_, bsV) = do 297 | case deserialiseOrFail (BL.fromStrict bsV) of 298 | Left err -> throwIO $ AWExceptionSegmentDeserialisationError ("Could not deserialise value: " <> showT err) 299 | Right v -> pure $ CValIxs v 300 | 301 | deserialiseIxRef :: (ByteString, ByteString) -> Transaction ReadOnly (CValIxs ixs v) 302 | deserialiseIxRef (_, bsV) = do 303 | case deserialiseOrFail (BL.fromStrict bsV) of 304 | Left err -> throwIO $ AWExceptionSegmentDeserialisationError ("Could not deserialise indexes: " <> showT err) 305 | Right np -> pure $ CValIxsRef np 306 | 307 | expandMap db ixset = do 308 | expanded <- mapM (expandCValIxs db) $ IxSet.toList ixset 309 | pure $ IxSet.fromList expanded 310 | where 311 | 312 | 313 | lookupMapC k db ixset = maybe (pure Nothing) (fmap Just . expandCValIxs db) (IxSet.getOne $ IxSet.getEQ k ixset) 314 | 315 | toCachedCValIxs :: CacheMode -> v -> NP [] ixs -> CValIxs ixs v 316 | toCachedCValIxs CacheModeAll !v _ = CValIxs v 317 | toCachedCValIxs CacheModeNone _ !ixs = CValIxsRef ixs 318 | 319 | expandCValIxs :: (GetPrimaryKey ixs v, Serialise (IxsetPrimaryKeyT ixs v), Serialise v) => Database ByteString ByteString -> (CValIxs ixs v) -> Transaction ReadOnly v 320 | expandCValIxs _ (CValIxs a) = pure a 321 | expandCValIxs db cValIx@(CValIxsRef _) = do 322 | case getPrimaryKey cValIx of 323 | Left err -> throwIO $ AWExceptionSegmentDeserialisationError ("CValIxsRef did not contain primary key: " <> err) 324 | Right pk -> do 325 | mBs <- get db (BL.toStrict . serialise $ pk) 326 | case mBs of 327 | Nothing -> throwIO $ AWExceptionSegmentDeserialisationError "Database did not contain value for key" 328 | Just bs -> do 329 | case deserialiseOrFail (BL.fromStrict bs) of 330 | Left err -> throwIO $ AWExceptionSegmentDeserialisationError ("Could not deserialise when expanding: " <> showT err) 331 | Right v -> pure v 332 | 333 | 334 | {- the cache state itself-} 335 | 336 | data CacheState ss = CacheState { 337 | cacheStatePath :: FilePath, 338 | cacheStateCacheMode :: CacheMode, 339 | cacheState :: TMVar (SegmentsState ss, Environment ReadWrite, SegmentsDb ss) 340 | } 341 | 342 | 343 | newtype CUpdate ss a = CUpdate {extractCUpdate :: Re.ReaderT (SegmentsDb ss, CacheMode) (St.StateT (SegmentsState ss) (Transaction ReadWrite)) a} 344 | deriving (Functor, Applicative, Monad) 345 | 346 | newtype CQuery ss a = CQuery {extractCQuery :: Re.ReaderT (SegmentsDb ss, SegmentsState ss) (Transaction ReadOnly) a} 347 | deriving (Functor, Applicative, Monad) 348 | 349 | 350 | openCacheState :: (ValidSegmentsCacheState ss, MonadIO m) => FilePath -> CacheMode -> m (Either AWException (CacheState ss)) 351 | openCacheState fp cm = do 352 | env <- liftIO $ openEnvironment fp (defaultLimits{maxDatabases = 200, mapSize = 1024 * 1024 * 1000}) 353 | eBind (getSegmentDbs cm env) $ \dbs -> do 354 | eBind (restoreSegments cm env ) $ \segs -> do 355 | csVar <- liftIO $ STM.atomically $ newTMVar (segs, env, dbs) 356 | pure . pure $ CacheState fp cm csVar 357 | 358 | 359 | closeCacheState :: (MonadUnliftIO m) => CacheState ss -> m () 360 | closeCacheState cs = do 361 | (a, env, b) <- liftIO $ atomically $ TMVar.takeTMVar (cacheState cs) 362 | onException (liftIO $ closeEnvironment env) (liftIO . atomically $ TMVar.putTMVar (cacheState cs) (a, env, b)) 363 | liftIO $ atomically $ TMVar.putTMVar (cacheState cs) (error "Environment has been closed", error "Environment has been closed", error "Environment has been closed") 364 | 365 | 366 | reopenCacheState :: (ValidSegmentsCacheState ss, MonadIO m) => CacheState ss -> m (Either AWException (CacheState ss)) 367 | reopenCacheState cs = openCacheState (cacheStatePath cs) (cacheStateCacheMode cs) 368 | 369 | 370 | getSegmentDbs :: forall m ss. (MonadIO m, ValidSegmentsCacheState ss) => CacheMode -> Environment ReadWrite -> m (Either AWException (SegmentsDb ss)) 371 | getSegmentDbs cm env = (fmap . fmap) (npToSegmentsDb) segsNpE 372 | where 373 | segsNpE :: m (Either AWException (NP V.ElField (ToSegmentDBFields ss))) 374 | segsNpE = unComp $ sequence'_NP segsNp 375 | segsNp :: NP ((m :.: Either AWException) :.: V.ElField) (ToSegmentDBFields ss) 376 | segsNp = cmap_NP (Proxy :: Proxy (ValidDBSegmentField ss)) restoreSegmentFromProxy proxyNp 377 | 378 | restoreSegmentFromProxy :: forall a b . (ValidDBSegmentField ss '(a, b), b ~ SegmentDb a) => Proxy '(a, b) -> ((m :.: Either AWException) :.: V.ElField) '(a, b) 379 | restoreSegmentFromProxy _ = Comp $ fmap V.Field $ Comp $ restoreSegment (Proxy :: Proxy a) 380 | restoreSegment :: ValidCSegment sName => Proxy sName -> m (Either AWException (SegmentDb sName)) 381 | restoreSegment ps = liftIO $ fmap Right $ transaction env (fmap (\s -> SegmentDb (getCacheModePure cm ps, s)) $ getSegmentDbTrans ps) 382 | proxyNp :: NP Proxy (ToSegmentDBFields ss) 383 | proxyNp = pure_NP Proxy 384 | getSegmentDbTrans :: ValidCSegment segmentName => Proxy segmentName -> Transaction ReadWrite (Database k v) 385 | getSegmentDbTrans ps = getDatabase (Just . T.unpack $ toUniqueText ps) 386 | -- @todo note that we are not using the default state for the SegmentS at the moment, because we don't have a way to determine between empty segments and new segments (we should track this in our own lmdb admin table) 387 | restoreSegments :: forall m ss. (MonadIO m, ValidSegmentsCacheState ss) => CacheMode -> Environment ReadWrite -> m (Either AWException (SegmentsState ss)) 388 | restoreSegments cm env = (fmap . fmap) (npToSegmentsState) segsNpE 389 | where 390 | segsNpE :: m (Either AWException (NP V.ElField (ToSegmentFields ss))) 391 | segsNpE = unComp $ sequence'_NP segsNp 392 | segsNp :: NP ((m :.: Either AWException) :.: V.ElField) (ToSegmentFields ss) 393 | segsNp = cmap_NP (Proxy :: Proxy (ValidCSegmentField ss)) restoreSegmentFromProxy proxyNp 394 | 395 | restoreSegmentFromProxy :: forall a b . (ValidCSegmentField ss '(a, b), b ~ SegmentS a) => Proxy '(a, b) -> ((m :.: Either AWException) :.: V.ElField) '(a, b) 396 | restoreSegmentFromProxy _ = Comp $ fmap V.Field $ Comp $ restoreSegment (Proxy :: Proxy a) 397 | restoreSegment :: ValidCSegment sName => Proxy sName -> m (Either AWException (SegmentS sName)) 398 | restoreSegment ps = liftIO $ fmap Right $ transaction env (restoreSegmentTrans ps) 399 | proxyNp :: NP Proxy (ToSegmentFields ss) 400 | proxyNp = pure_NP Proxy 401 | 402 | restoreSegmentTrans :: ValidCSegment sName => Proxy sName -> Transaction ReadOnly (SegmentS sName) 403 | restoreSegmentTrans ps = do 404 | db <- getDatabase (Just . T.unpack $ toUniqueText ps) 405 | restoreMapC (getCacheModePure cm ps) db 406 | 407 | 408 | getSegmentDb :: (HasSegmentDb ss segmentName) => Proxy segmentName -> CUpdate ss (SegmentDb segmentName) 409 | getSegmentDb ps = CUpdate $ (fmap $ getSegmentDbP ps . fst) ask 410 | 411 | getSegmentC :: (HasSegment ss segmentName) => Proxy segmentName -> CUpdate ss (SegmentS segmentName) 412 | getSegmentC ps = CUpdate $ getSegmentP ps `fmap` St.get 413 | 414 | askSegmentDb :: (HasSegmentDb ss segmentName) => Proxy segmentName -> CQuery ss (SegmentDb segmentName) 415 | askSegmentDb ps = CQuery $ (fmap $ getSegmentDbP ps . fst) ask 416 | 417 | askSegmentC :: (HasSegment ss segmentName) => Proxy segmentName -> CQuery ss (SegmentS segmentName) 418 | askSegmentC ps = CQuery $ (fmap $ getSegmentP ps . snd) ask 419 | 420 | 421 | putSegmentC :: (HasSegment ss segmentName) => Proxy segmentName -> SegmentS segmentName -> CUpdate ss () 422 | putSegmentC ps seg = CUpdate $ St.modify' (putSegmentP ps seg) 423 | 424 | 425 | insertC :: (ValidCSegment segmentName, HasSegment ss segmentName, HasSegmentDb ss segmentName) => Proxy segmentName -> CMapKey (SegmentS segmentName) -> CMapValue (SegmentS segmentName) -> CUpdate ss () 426 | insertC ps k v = do 427 | (cm, db) <- fmap segmentDbDatabase $ getSegmentDb ps 428 | seg <- getSegmentC ps 429 | newSeg <- CUpdate . lift . lift $ insertMapC cm k v db seg 430 | putSegmentC ps newSeg 431 | 432 | insertManyC :: (ValidCSegment segmentName, HasSegment ss segmentName, HasSegmentDb ss segmentName) => Proxy segmentName -> [(CMapKey (SegmentS segmentName), CMapValue (SegmentS segmentName))] -> CUpdate ss () 433 | insertManyC ps vs = do 434 | (cm, db) <- fmap segmentDbDatabase $ getSegmentDb ps 435 | seg <- getSegmentC ps 436 | newSeg <- CUpdate . lift . lift $ foldM (\is (k, v) -> insertMapC cm k v db is) seg vs 437 | putSegmentC ps newSeg 438 | 439 | 440 | lookupC :: (ValidCSegment segmentName, HasSegment ss segmentName, HasSegmentDb ss segmentName) => Proxy segmentName -> CMapKey (SegmentS segmentName) -> CQuery ss (Maybe (CMapValue (SegmentS segmentName))) 441 | lookupC ps k = do 442 | (_, db) <- fmap segmentDbDatabase $ askSegmentDb ps 443 | seg <- askSegmentC ps 444 | CQuery . lift $ lookupMapC k db seg 445 | 446 | getCacheModePure :: (SegmentC segmentName) => CacheMode -> Proxy segmentName -> CacheMode 447 | getCacheModePure gcm ps = 448 | case segmentCacheMode ps of 449 | SegmentCacheModeGlobal -> gcm 450 | SegmentCacheModeAll -> CacheModeAll 451 | SegmentCacheModeNone -> CacheModeNone 452 | 453 | 454 | 455 | fetchMapC :: (ValidCSegment segmentName, HasSegment ss segmentName, HasSegmentDb ss segmentName) => Proxy segmentName -> CQuery ss (CMapExpanded (SegmentS segmentName)) 456 | fetchMapC ps = fetchMapCWith ps id 457 | 458 | 459 | 460 | fetchMapCWith :: (ValidCSegment segmentName, HasSegment ss segmentName, HasSegmentDb ss segmentName) => Proxy segmentName -> (SegmentS segmentName -> SegmentS segmentName) -> CQuery ss (CMapExpanded (SegmentS segmentName)) 461 | fetchMapCWith ps f = do 462 | (_, db) <- fmap segmentDbDatabase $ askSegmentDb ps 463 | seg <- askSegmentC ps 464 | CQuery . lift $ expandMap db (f seg) 465 | 466 | 467 | liftQueryCS :: CQuery ss a -> CUpdate ss a 468 | liftQueryCS cq = do 469 | segs <- CUpdate St.get 470 | (dbs, _) <- CUpdate ask 471 | let roTrans = Re.runReaderT (extractCQuery cq) (dbs, segs) 472 | -- we are coercing from a ReadOnly to a ReadWrite transaction - this should be fine, because any ReadOnly transaction can also be run in a ReadWrite environment 473 | CUpdate . lift . lift $ coerce roTrans 474 | 475 | runUpdateCS :: (MonadUnliftIO m) => CacheState ss -> CUpdate ss a -> m a 476 | runUpdateCS cs act = 477 | modifyTMVarSafe (cacheState cs) $ \(segS, env, dbs) -> do 478 | (a, segS') <- liftIO $ transaction env (St.runStateT (Re.runReaderT (extractCUpdate act) (dbs, cacheStateCacheMode cs)) segS) 479 | pure ((segS', env, dbs), a) 480 | 481 | 482 | runQueryCS :: (MonadUnliftIO m) => CacheState ss -> CQuery ss a -> m a 483 | runQueryCS cs act = 484 | withTMVarSafe (cacheState cs) $ \(segS, env, dbs) -> do 485 | liftIO $ transaction env (Re.runReaderT (extractCQuery act) (dbs, segS)) 486 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Shared.App 4 | 5 | import RIO 6 | import qualified RIO.Text as T 7 | import qualified RIO.Time as Time 8 | import qualified RIO.HashMap as HM 9 | import qualified RIO.List as L 10 | import qualified RIO.Directory as Dir 11 | 12 | import Data.Proxy(Proxy(..)) 13 | import Acid.World 14 | import Test.Tasty 15 | import Test.Tasty.QuickCheck 16 | import Test.Tasty.HUnit 17 | 18 | import qualified Data.IxSet.Typed as IxSet 19 | 20 | import qualified Test.QuickCheck as QC 21 | import qualified Test.QuickCheck.Property as QCP 22 | import Control.Concurrent 23 | import GHC.Stats 24 | import System.Mem 25 | import Text.Printf 26 | import qualified RIO.List.Partial as L.Partial 27 | 28 | import Acid.Core.CacheState 29 | 30 | withBackends :: (AppValidBackend -> AppValidSerialiser -> [TestTree]) -> [(AppValidBackend, [AppValidSerialiser])] -> [TestTree] 31 | withBackends f os = 32 | (flip map) os $ \(b@(AppValidBackend (bc :: (FilePath -> AWBConfig b))), ss) -> 33 | testGroup ("Backend: " <> (T.unpack . backendName $ (Proxy :: Proxy b)) <> ", " <> T.unpack (backendConfigInfo (bc "*TMPDIR*"))) $ 34 | (flip map) ss $ \(o@(AppValidSerialiser (_ :: AcidSerialiseEventOptions s))) -> 35 | testGroup ("Serialiser: " <> (T.unpack . serialiserName $ (Proxy :: Proxy s))) $ 36 | f b o 37 | 38 | backendsWithSerialisers :: [AppValidBackend] -> [AppValidSerialiser] -> [(AppValidBackend, [AppValidSerialiser])] 39 | backendsWithSerialisers bs ser = map (\b -> (b, ser)) bs 40 | 41 | 42 | backendsWithAllSerialisers :: [AppValidBackend] -> [(AppValidBackend, [AppValidSerialiser])] 43 | backendsWithAllSerialisers bs = backendsWithSerialisers bs allSerialisers 44 | 45 | 46 | main :: IO () 47 | main = do 48 | defaultMain tests 49 | 50 | tests :: TestTree 51 | tests = testGroup "Tests" $ 52 | map serialiserTests allSerialisers ++ 53 | withBackends ephemeralBackendSerialiserTests (backendsWithAllSerialisers allBackends) ++ 54 | withBackends persistentBackendSerialiserTests (backendsWithAllSerialisers persistentBackendsWithGzip) ++ 55 | withBackends persistentBackendConstraintTests (backendsWithSerialisers persistentBackends [defaultAppSerialiser]) ++ 56 | fsSpecificTests (\t -> AWBConfigFS t True) defaultAppSerialiser ++ 57 | [postgresSpecificTests] ++ 58 | [cacheStateSpecificTests [CacheModeNone, CacheModeAll], 59 | testCaseSteps "cacheMemoryUsage" (unit_cacheMemoryUsage) 60 | ] 61 | 62 | 63 | 64 | serialiserTests :: AppValidSerialiser-> TestTree 65 | serialiserTests (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = 66 | testGroup ("Serialiser: " <> (T.unpack . serialiserName $ (Proxy :: Proxy s))) [ 67 | testProperty "serialiseEventEqualDeserialise" $ prop_serialiseEventEqualDeserialise o 68 | , testProperty "serialiseWrappedEventEqualDeserialise" $ prop_serialiseWrappedEventEqualDeserialise o 69 | ] 70 | 71 | ephemeralBackendSerialiserTests :: AppValidBackend -> AppValidSerialiser -> [TestTree] 72 | ephemeralBackendSerialiserTests (AppValidBackend (bConf :: FilePath -> (AWBConfig b))) (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = [ 73 | testCaseSteps "insertAndFetchState" $ unit_insertAndFetchState bConf o 74 | ] 75 | 76 | 77 | persistentBackendSerialiserTests :: AppValidBackend -> AppValidSerialiser -> [TestTree] 78 | persistentBackendSerialiserTests (AppValidBackend (bConf :: FilePath -> (AWBConfig b))) (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = [ 79 | testCaseSteps "insertAndRestoreState" $ unit_insertAndRestoreState bConf o, 80 | testCaseSteps "checkpointAndRestoreState" $ unit_checkpointAndRestoreState bConf o, 81 | testCaseSteps "partialCheckpointAndRestore" $ unit_partialCheckpointAndRestore bConf o, 82 | testCaseSteps "compositionOfEventsState" $ unit_compositionOfEventsState bConf o 83 | 84 | ] 85 | 86 | 87 | persistentBackendConstraintTests :: AppValidBackend -> AppValidSerialiser -> [TestTree] 88 | persistentBackendConstraintTests (AppValidBackend (bConf :: FilePath -> (AWBConfig b))) (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = [ 89 | testCaseSteps "validAppConstraintsOnRunEvent" $ unit_validAppConstraintsOnRunEvent bConf o 90 | , testCaseSteps "validAppConstraintsOnRestore" $ unit_validAppConstraintsOnRestore bConf o 91 | 92 | ] 93 | fsSpecificTests :: (FilePath -> (AWBConfig AcidWorldBackendFS)) -> AppValidSerialiser -> [TestTree] 94 | fsSpecificTests bConf (AppValidSerialiser (o :: AcidSerialiseEventOptions s)) = [ 95 | testCaseSteps "defaultSegmentUsedOnRestore" $ unit_defaultSegmentUsedOnRestore bConf o 96 | 97 | ] 98 | 99 | postgresSpecificTests :: TestTree 100 | postgresSpecificTests = 101 | testGroup ("Backend: Postgresql") [ 102 | testCaseSteps "insertAndRestoreState" $ unit_insertAndRestoreStatePostgres 103 | ] 104 | 105 | cacheStateSpecificTests :: [CacheMode] -> TestTree 106 | cacheStateSpecificTests cms = 107 | testGroup ("CacheState: ") $ (flip map) cms $ \cm -> 108 | testGroup ("CacheMode: " <> show cm) [ 109 | testCaseSteps "insertAndRestoreState" $ unit_insertAndRestoreStateCacheState cm 110 | ] 111 | 112 | 113 | 114 | genStorableEvent :: QC.Gen (StorableEvent AppSegments AppEvents "insertUser") 115 | genStorableEvent = do 116 | t <- QC.arbitrary 117 | eId <- QC.arbitrary 118 | u <- QC.arbitrary 119 | let e = mkEvent (Proxy :: Proxy ("insertUser")) u 120 | return $ StorableEvent t (EventId eId) e 121 | 122 | 123 | prop_serialiseEventEqualDeserialise :: forall s. AppValidSerialiserConstraint s => AcidSerialiseEventOptions s -> QC.Property 124 | prop_serialiseEventEqualDeserialise o = forAll genStorableEvent $ \e -> 125 | let serialised = serialiseStorableEvent o e 126 | deserialisedE = deserialiseStorableEvent o serialised 127 | in case deserialisedE of 128 | Left r -> property $ QCP.failed {QCP.reason = T.unpack $ "Error encountered when deserialising: " <> r <> showT ((serialised))} 129 | Right e' -> e === e' 130 | 131 | 132 | prop_serialiseWrappedEventEqualDeserialise :: forall s. AppValidSerialiserConstraint s => AcidSerialiseEventOptions s -> QC.Property 133 | prop_serialiseWrappedEventEqualDeserialise o = forAll genStorableEvent $ \e -> ioProperty $ do 134 | let serialised = serialiseStorableEvent o e 135 | deserialisedE <- deserialiseWrappedEvent o serialised 136 | case deserialisedE of 137 | Left r -> pure $ property $ QCP.failed{QCP.reason = T.unpack $ "Error encountered when deserialising: " <> r} 138 | (Right (e' :: WrappedEvent AppSegments AppEvents)) -> pure $ show (WrappedEvent e) === show e' 139 | 140 | 141 | 142 | unit_insertAndFetchState :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 143 | unit_insertAndFetchState b o step = do 144 | us <- QC.generate $ generateUsers 100 145 | step "Opening acid world" 146 | aw <- openAppAcidWorldFresh b o 147 | step "Inserting users" 148 | mapM_ (runInsertUser aw) us 149 | step "Fetching users" 150 | us2 <- query aw fetchUsers 151 | assertBool "Fetched user list did not match inserted users" (us == us2) 152 | 153 | 154 | unit_insertAndRestoreState :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 155 | unit_insertAndRestoreState b o step = do 156 | allUs <- QC.generate $ generateUsers 2000 157 | let (us, us2) = L.splitAt 1000 allUs 158 | step "Opening acid world" 159 | aw <- openAppAcidWorldFresh b o 160 | step "Inserting users" 161 | mapM_ (runInsertUser aw) us 162 | step "Closing acid world" 163 | closeAcidWorld aw 164 | step "Reopening acid world" 165 | aw2 <- reopenAcidWorldMiddleware (pure aw) 166 | step "Inserting second set of users" 167 | mapM_ (runInsertUser aw2) us2 168 | step "Closing acid world" 169 | closeAcidWorld aw2 170 | step "Reopening acid world" 171 | aw3 <- reopenAcidWorldMiddleware (pure aw2) 172 | step "Fetching users" 173 | us3 <- query aw3 fetchUsers 174 | step $ "Fetched users: " ++ (show . length $ us3) 175 | 176 | assertBool "Fetched user list did not match inserted users" (L.sort (us ++ us2) == L.sort us3) 177 | 178 | unit_checkpointAndRestoreState :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 179 | unit_checkpointAndRestoreState b o step = do 180 | (us1, us2) <- fmap (L.splitAt 500) $ QC.generate $ generateUsers 1000 181 | (ps1, ps2) <- fmap (L.splitAt 500) $ QC.generate $ generatePhonenumbers 1000 182 | (as1, as2) <- fmap (L.splitAt 500) $ QC.generate $ generateAddresses 1000 183 | step "Opening acid world" 184 | aw1 <- openAppAcidWorldFresh b o 185 | step "Inserting records" 186 | mapM_ (runInsertUser aw1) us1 187 | mapM_ (runInsertPhonenumber aw1) ps1 188 | mapM_ (runInsertAddress aw1) as1 189 | step "Creating checkpoint" 190 | createCheckpoint aw1 191 | step "Closing and reopening acid world" 192 | closeAcidWorld aw1 193 | 194 | aw2 <- reopenAcidWorldMiddleware (pure aw1) 195 | usf1 <- query aw2 fetchUsers 196 | psf1 <- query aw2 fetchPhonenumbers 197 | asf1 <- query aw2 fetchAddresses 198 | assertBool "Fetched record list did not match inserted records" $ 199 | (L.sort us1 == L.sort usf1) && 200 | (L.sort ps1 == L.sort psf1) && 201 | (L.sort as1 == L.sort asf1) 202 | 203 | step "Inserting more records" 204 | mapM_ (runInsertUser aw2) us2 205 | mapM_ (runInsertPhonenumber aw2) ps2 206 | mapM_ (runInsertAddress aw2) as2 207 | step "Closing and reopening acid world" 208 | closeAcidWorld aw2 209 | 210 | aw3 <- reopenAcidWorldMiddleware (pure aw2) 211 | usf2 <- query aw3 fetchUsers 212 | psf2 <- query aw3 fetchPhonenumbers 213 | asf2 <- query aw3 fetchAddresses 214 | assertBool "Fetched record list did not match inserted records after second reopen" $ 215 | (L.sort (us1 ++ us2) == L.sort usf2) && 216 | (L.sort (ps1 ++ ps2) == L.sort psf2) && 217 | (L.sort (as1 ++ as2) == L.sort asf2) 218 | 219 | step "Creating checkpoint" 220 | createCheckpoint aw3 221 | step "Closing and reopening acid world" 222 | 223 | closeAcidWorld aw3 224 | 225 | aw4 <- reopenAcidWorldMiddleware (pure aw3) 226 | usf3 <- query aw4 fetchUsers 227 | psf3 <- query aw4 fetchPhonenumbers 228 | asf3 <- query aw4 fetchAddresses 229 | 230 | assertBool "Fetched record list did not match inserted records after second reopen" $ 231 | (L.sort (us1 ++ us2) == L.sort usf3) && 232 | (L.sort (ps1 ++ ps2) == L.sort psf3) && 233 | (L.sort (as1 ++ as2) == L.sort asf3) 234 | 235 | 236 | -- we should improve this test to look at partial checkpoints on top of successful ones etc, and for a wide variety of async interruption timings (as exception and failure recovery improves in the code itself) 237 | unit_partialCheckpointAndRestore :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 238 | unit_partialCheckpointAndRestore b o step = do 239 | (us1, us2) <- fmap (L.splitAt 500) $ QC.generate $ generateUsers 1000 240 | 241 | step "Opening acid world" 242 | aw1 <- openAppAcidWorldFresh b o 243 | step "Inserting records" 244 | mapM_ (runInsertUser aw1) us1 245 | step "Creating checkpoint" 246 | 247 | tId <- forkIO (createCheckpoint aw1) 248 | RIO.threadDelay 20 -- the timing here at present has to be while the checkpoint is being written for this test to succeed 249 | killThread tId 250 | 251 | step "Inserting more records" 252 | mapM_ (runInsertUser aw1) us2 253 | 254 | step "Closing and reopening acid world" 255 | closeAcidWorld aw1 256 | aw2 <- reopenAcidWorldMiddleware (pure aw1) 257 | usf1 <- query aw2 fetchUsers 258 | assertBool "Fetched record list did not match inserted records" $ 259 | (L.sort (us1 ++ us2) == L.sort usf1) 260 | 261 | unit_compositionOfEventsState :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 262 | unit_compositionOfEventsState b o step = do 263 | us <- QC.generate $ generateUsers 1000 264 | step "Opening acid world" 265 | aw <- openAppAcidWorldFresh b o 266 | step "Inserting users with phonenumbers" 267 | mapM_ (runInsertUserC aw userToPhoneNumber) us 268 | usF <- query aw fetchUsers 269 | ps <- query aw fetchPhonenumbers 270 | assertBool "Expected equal number of users and pns" (length usF == length ps) 271 | assertBool "Expected equal ids for every pair of user/numbers" (and $ map (\(u, p) -> userId u == phonenumberId p ) (zip usF ps)) 272 | where 273 | userToPhoneNumber :: User -> Event "insertPhonenumber" 274 | userToPhoneNumber u = (mkEvent (Proxy :: Proxy ("insertPhonenumber")) $ Phonenumber (userId u) "asdf" 24 False) 275 | 276 | 277 | 278 | unit_validAppConstraintsOnRunEvent :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 279 | unit_validAppConstraintsOnRunEvent b o step = do 280 | step "Opening acid world" 281 | aw <- openAppAcidWorldFreshWithInvariants b o unitInvariants 282 | step "Inserting users" 283 | us <- QC.generate $ generateUsers 1000 284 | mapM_ (runInsertUser aw) us 285 | 286 | step "Inserting invalid user" 287 | u <- QC.generate arbitrary 288 | 289 | res <- update aw (mkEvent (Proxy :: Proxy ("insertUser")) u{userId = 1500, userDisabled = False}) 290 | us2 <- query aw fetchUsers 291 | assertEqual "Expected update to fail" (Left (AWExceptionInvariantsViolated [("Users", userInvariantFailureMessage)])) res 292 | assertBool "Fetched user list did not match inserted users" (L.sort us == L.sort us2) 293 | 294 | where 295 | unitInvariants :: Invariants AppSegments 296 | unitInvariants = putInvariantP (Just userInvariant) emptyInvariants 297 | userInvariant :: Invariant AppSegments "Users" 298 | userInvariant = Invariant $ \ixset -> 299 | if (IxSet.size . IxSet.getEQ False . IxSet.getGT (1400 :: Int) $ ixset) > 0 300 | then pure userInvariantFailureMessage 301 | else Nothing 302 | userInvariantFailureMessage :: Text 303 | userInvariantFailureMessage = "All users with an id > 1400 must be enabled" 304 | 305 | unit_validAppConstraintsOnRestore :: forall b s. (AppValidBackendConstraint b, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig b) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 306 | unit_validAppConstraintsOnRestore b o step = do 307 | step "Opening acid world" 308 | aw <- openAppAcidWorldFresh b o 309 | step "Inserting users" 310 | us <- QC.generate $ generateUsers 1000 311 | mapM_ (runInsertUser aw) us 312 | step "Creating checkpoint" 313 | createCheckpoint aw 314 | step "Closing acid world" 315 | closeAcidWorld aw 316 | 317 | step "Reopening acid world with new invariant" 318 | res <- reopenAcidWorld aw{acidWorldInvariants = unitInvariants} 319 | case res of 320 | Left err -> assertEqual "Expected open from checkpoint to fail" ((AWExceptionInvariantsViolated [("Users", userInvariantFailureMessage)])) err 321 | Right _ -> assertFailure "Expected to get an error when opening acid world, but opened successfully" 322 | 323 | where 324 | unitInvariants :: Invariants AppSegments 325 | unitInvariants = putInvariantP (Just userInvariant) emptyInvariants 326 | userInvariant :: Invariant AppSegments "Users" 327 | userInvariant = Invariant $ \ixset -> 328 | if (IxSet.size ixset) > 800 329 | then pure userInvariantFailureMessage 330 | else Nothing 331 | userInvariantFailureMessage :: Text 332 | userInvariantFailureMessage = "Only 800 users are allowed in this segment" 333 | 334 | 335 | unit_defaultSegmentUsedOnRestore :: forall s. (AppValidBackendConstraint AcidWorldBackendFS, AppValidSerialiserConstraint s) => (FilePath -> AWBConfig AcidWorldBackendFS) -> AcidSerialiseEventOptions s -> (String -> IO ()) -> Assertion 336 | unit_defaultSegmentUsedOnRestore b o step = do 337 | 338 | td <- mkTempDir 339 | let conf = b td 340 | 341 | us <- QC.generate $ generateUsers 1000 342 | allPs <- QC.generate $ generatePhonenumbers 1000 343 | let (ps, ps2) = (take 500 allPs, drop 500 allPs) 344 | 345 | step "Opening acid world" 346 | aw <- throwEither $ openAcidWorld (unitDefaultState ps) emptyInvariants conf AWConfigPureState o 347 | 348 | step "Inserting records" 349 | mapM_ (runInsertUser aw) us 350 | mapM_ (runInsertPhonenumber aw) ps2 351 | ps3 <- query aw fetchPhonenumbers 352 | assertBool "Fetched phonenumber list did not match default ++ inserted phonenumbers" (L.sort allPs == L.sort ps3) 353 | 354 | step "Creating checkpoint" 355 | createCheckpoint aw 356 | step "Closing acid world" 357 | closeAcidWorld aw 358 | --delete pn checkpoint 359 | let pp = (Proxy :: Proxy "Phonenumbers") 360 | cpFolder = currentCheckpointFolder conf 361 | segPath = makeSegmentPath cpFolder conf pp o 362 | segCheckPatch = makeSegmentCheckPath cpFolder conf pp o 363 | segPathTemp = segPath <> ".temp" 364 | 365 | step "Moving segment and reopening" 366 | 367 | Dir.renameFile segPath segPathTemp 368 | res <- reopenAcidWorld aw 369 | assertErrorPrefix (AWExceptionSegmentDeserialisationError $ (prettySegment pp) <> "Segment file missing at") res 370 | 371 | step "Replacing segment, removing segment check and reopening" 372 | 373 | Dir.renameFile segPathTemp segPath 374 | Dir.renameFile segCheckPatch (segCheckPatch <> ".deleted") 375 | res2 <- reopenAcidWorld aw 376 | assertErrorPrefix (AWExceptionSegmentDeserialisationError $ (prettySegment pp) <> "Segment check file could not be found at") res2 377 | 378 | Dir.renameFile segPath (segPath <> ".deleted") 379 | 380 | step "Removing segment and check and reopening" 381 | 382 | 383 | aw2 <- throwEither $ reopenAcidWorld aw 384 | ps4 <- query aw2 fetchPhonenumbers 385 | us2 <- query aw2 fetchUsers 386 | assertBool "Fetched phonenumber list did not match default phonenumber state" (L.sort ps == L.sort ps4) 387 | assertBool "Fetched user list did not match inserted users" (L.sort us == L.sort us2) 388 | 389 | where 390 | unitDefaultState :: [Phonenumber] -> SegmentsState AppSegments 391 | unitDefaultState ps = 392 | putSegmentP (Proxy :: Proxy "Phonenumbers") (IxSet.fromList ps) defaultSegmentsState 393 | 394 | 395 | unit_insertAndRestoreStatePostgres :: (String -> IO ()) -> Assertion 396 | unit_insertAndRestoreStatePostgres step = do 397 | 398 | step "Opening acid world" 399 | aw <- openAcidWorldPostgresWithInvariants "unit_insertAndRestoreStatePostgres" emptyInvariants 400 | us <- QC.generate $ generateUsers 1000 401 | 402 | 403 | step "Inserting records" 404 | mapM_ (runInsertUser aw) us 405 | 406 | usf <- query aw fetchUsers 407 | 408 | assertBool "Fetched user list did not match inserted user list" (L.sort us == L.sort usf) 409 | step "Closing and reopening" 410 | closeAcidWorld aw 411 | aw2 <- throwEither $ reopenAcidWorld aw 412 | usf1 <- query aw2 fetchUsers 413 | step "Fetching new user list" 414 | assertBool "Fetched user list did not match inserted user list after restore" (L.sort us == L.sort usf1) 415 | 416 | step "Checkpointing and reopening" 417 | createCheckpoint aw2 418 | closeAcidWorld aw2 419 | 420 | aw3 <- throwEither $ reopenAcidWorld aw2 421 | usf2 <- query aw3 fetchUsers 422 | let upairs = zip (L.sort us) (L.sort usf2) 423 | -- fix times (postgres in this implement is less precise) 424 | fixPair (a, b) = 425 | case (userCreated a, userCreated b) of 426 | (Just at, Just bt) -> 427 | if (Time.diffUTCTime at bt < 0.01 && Time.diffUTCTime at bt > -0.01) 428 | then (a, b{userCreated = userCreated a}) 429 | else (a, b) 430 | (_, _) -> (a, b) 431 | upairsFixed = map fixPair upairs 432 | (usFixed, usFixed2) = L.unzip upairsFixed 433 | -- fix for when when generated texts contains \NUL (see https://github.com/lpsmith/postgresql-simple/issues/223) 434 | usFixedFinally = map fixUser usFixed 435 | --void $ sequence $ map (\(a, b) -> when (a /= b) $ traceM ("Hot equal \n" <> showT a <> "\n" <> showT b)) (zip usFixedFinally usFixed2) 436 | 437 | assertBool "Fetched user list did not match inserted user list after checkpoint restore" (L.sort usFixedFinally == L.sort usFixed2) 438 | 439 | where 440 | fixUser :: User -> User 441 | fixUser u = u { 442 | userFirstName = fixText (userFirstName u), 443 | userLastName = fixText (userLastName u), 444 | userOtherInformation = fixText (userOtherInformation u) 445 | -- not necessary for userComments because they are stored as json, which doesn't have this problem 446 | } 447 | fixText :: Text -> Text 448 | fixText = T.takeWhile ((/=) '\NUL') 449 | 450 | 451 | 452 | unit_insertAndRestoreStateCacheState :: CacheMode -> (String -> IO ()) -> Assertion 453 | unit_insertAndRestoreStateCacheState cm step = runInBoundThread $ do -- closeCacheState needs to be run in a bound thread 454 | 455 | step "Opening cache state" 456 | cs <- throwEither $ openCacheStateFresh cm 457 | us <- QC.generate $ generateUsers 500 458 | ps <- QC.generate $ generatePhonenumbers 500 459 | 460 | usCS <- QC.generate $ generateUsers 500 461 | step "Insert recs into HM" 462 | runUpdateCS cs (insertManyC (Proxy :: Proxy "UsersHM") $ map (\u -> (userId u, u)) us) 463 | runUpdateCS cs (insertManyC (Proxy :: Proxy "PhonenumbersHM") $ map (\p -> (phonenumberId p, p)) ps) 464 | 465 | step "Insert users into CS" 466 | runUpdateCS cs (insertManyC (Proxy :: Proxy "UsersCS") $ map (\u -> (userId u, u)) usCS) 467 | 468 | step "Fetch users" 469 | us2 <- runQueryCS cs (fetchMapC (Proxy :: Proxy "UsersHM")) 470 | ps2 <- runQueryCS cs (fetchMapC (Proxy :: Proxy "PhonenumbersHM")) 471 | us2CS <- runQueryCS cs (fetchMapC (Proxy :: Proxy "UsersCS")) 472 | assertBool "Fetched hm user list did not match inserted user list" (L.sort us == L.sort (HM.elems us2)) 473 | assertBool "Fetched hm pn list did not match inserted pn list" (L.sort ps == L.sort (HM.elems ps2)) 474 | assertBool "Fetched cs user list did not match inserted user list" (L.sort usCS == L.sort (IxSet.toList us2CS)) 475 | step "Close cache state" 476 | closeCacheState cs 477 | 478 | step "Reopen cache state" 479 | cs2 <- throwEither $ reopenCacheState cs 480 | us3 <- runQueryCS cs2 (fetchMapC (Proxy :: Proxy "UsersHM")) 481 | ps3 <- runQueryCS cs2 (fetchMapC (Proxy :: Proxy "PhonenumbersHM")) 482 | us3CS <- runQueryCS cs2 (fetchMapC (Proxy :: Proxy "UsersCS")) 483 | assertBool "Fetched hm user list after restore did not match inserted user list" (L.sort us == L.sort (HM.elems us3)) 484 | assertBool "Fetched pn user list after restore did not match inserted pn list" (L.sort ps == L.sort (HM.elems ps3)) 485 | assertBool "Fetched cs user list after restore did not match inserted user list" (L.sort usCS == L.sort (IxSet.toList us3CS)) 486 | step "Fetch users with idx query" 487 | 488 | us4CS <- runQueryCS cs2 (fetchMapCWith (Proxy :: Proxy "UsersCS") (IxSet.getGT (250 :: Int) . IxSet.getEQ (False))) 489 | 490 | assertBool "Queried cs list did not match inserted user with list filter" (L.sort (filter (\User{..} -> userId > 250 && userDisabled == False) usCS) == L.sort (IxSet.toList us4CS)) 491 | 492 | -- fetch a couple of users 493 | step "Lookup a few random users" 494 | uIds <- QC.generate . sequence $ replicate 10 (choose (1, 500)) 495 | mapM_ (testFetchUser cs2 usCS) uIds 496 | where 497 | testFetchUser :: CacheState CAppSegments -> [User] -> Int -> Assertion 498 | testFetchUser cs us i = do 499 | u1 <- runQueryCS cs (lookupC (Proxy :: Proxy "UsersCS") i) 500 | assertBool ("Fetched user with id " <> show i <> " did not match inserted user") (isJust u1 && u1 == L.find ((==) i . userId) us) 501 | 502 | 503 | -- this isn't really a test at the moment, just a way of manually looking at memory usage 504 | 505 | -- ./runTest.sh -p '$0 ~ /cacheMemoryUsage/' +RTS -T -RTS 506 | unit_cacheMemoryUsage :: (String -> IO ()) -> Assertion 507 | unit_cacheMemoryUsage step = do 508 | en <- getRTSStatsEnabled 509 | if en 510 | then do 511 | step "Insert users into CS" 512 | runInBoundThread $ insertManyUsersCS step CacheModeAll 513 | else do 514 | step "RTS stats not enabled" 515 | 516 | 517 | insertManyUsersCS :: (String -> IO ()) -> CacheMode -> IO () 518 | insertManyUsersCS step cm = do 519 | us <- fmap force $ QC.generate $ generateUsers (100000) 520 | cs <- throwEither $ openCacheStateFresh cm 521 | runUpdateCS cs (insertManyC (Proxy :: Proxy "UsersCS") $ map (\u -> (userId u, u)) us) 522 | --cs2 <- throwEither $ reopenCacheState cs 523 | let cs2 = cs 524 | performGC 525 | stats1 <- getRTSStats 526 | step $ "Current memory usage: " <> formatMem (gcdetails_mem_in_use_bytes . gc $ stats1) 527 | hm <- runQueryCS cs2 (fetchMapCWith (Proxy :: Proxy "UsersCS") (IxSet.getLT (0 :: Int))) 528 | step $ "hm has n without keys" <> show (IxSet.size hm) 529 | 530 | --hm <- runQueryCS cs2 (fetchMapCWith (Proxy :: Proxy "UsersHM") (HM.filterWithKey (\k _ -> k < 0))) 531 | --step $ "hm has n without keys" <> show (HM.size hm) 532 | 533 | 534 | 535 | 536 | formatMem :: Word64 -> String 537 | formatMem = humanReadableBytes . fromIntegral 538 | 539 | humanReadableBytes :: Integer -> String 540 | humanReadableBytes size | null pairs = printf "%.0fZiB" (size'/1024^(7 :: Integer)) 541 | | otherwise = if unit=="" then printf "%dB" size 542 | else printf "%.1f%sB" n unit 543 | where 544 | (n, unit) = L.Partial.head pairs 545 | pairs = dropWhile ((1024<).abs.fst) 546 | (zip (map ((size'/).(1024^)) ([0..] :: [Integer])) units) :: [(Double, String)] 547 | size' = fromIntegral size 548 | units = ["","Ki","Mi","Gi","Ti","Pi","Ei","Zi"] 549 | 550 | 551 | 552 | assertErrorPrefix :: AWException -> Either AWException a -> Assertion 553 | assertErrorPrefix e (Right _) = assertFailure $ "Expected an exception like " <> show e <> " but got a success" 554 | assertErrorPrefix (AWExceptionInvariantsViolated ts) (Left (AWExceptionInvariantsViolated ts2)) = assertEqualPrefix (showT ts) (showT ts2) 555 | assertErrorPrefix (AWExceptionEventSerialisationError ts) (Left (AWExceptionEventSerialisationError ts2)) = assertEqualPrefix ts ts2 556 | assertErrorPrefix (AWExceptionEventDeserialisationError ts) (Left (AWExceptionEventDeserialisationError ts2)) = assertEqualPrefix ts ts2 557 | assertErrorPrefix (AWExceptionSegmentDeserialisationError ts) (Left (AWExceptionSegmentDeserialisationError ts2)) = assertEqualPrefix ts ts2 558 | assertErrorPrefix e (Left e2) = assertEqual "Expected matching exception constructors" e e2 559 | 560 | assertEqualPrefix :: Text -> Text -> Assertion 561 | assertEqualPrefix t t' = assertEqual "Expected matching error message prefixes " t (T.take (T.length t) t') --------------------------------------------------------------------------------