acid-state 0.15.2 → 0.16.1.4
raw patch · 38 files changed
Files
- CHANGELOG.md +67/−0
- acid-state.cabal +76/−47
- examples/CheckpointCutsEvent.hs +4/−6
- examples/HelloDatabase.hs +0/−1
- examples/HelloWorld.hs +1/−3
- examples/HelloWorldNoTH.hs +4/−9
- examples/KeyValue.hs +0/−5
- examples/KeyValueNoTH.hs +2/−8
- examples/MonadStateConstraint.hs +1/−3
- examples/ParameterisedState.hs +0/−5
- examples/Proxy.hs +8/−10
- examples/RemoteClient.hs +5/−3
- examples/RemoteCommon.hs +1/−3
- examples/RemoteServer.hs +5/−3
- examples/SlowCheckpoint.hs +3/−3
- examples/StressTest.hs +0/−4
- examples/StressTestNoTH.hs +3/−8
- examples/errors/ChangeState.hs +2/−2
- examples/errors/ChangeVersion.hs +1/−1
- examples/errors/Exceptions.hs +5/−6
- examples/errors/RemoveEvent.hs +1/−4
- src-unix/FileIO.hs +16/−8
- src/Data/Acid/Abstract.hs +2/−26
- src/Data/Acid/Common.hs +4/−4
- src/Data/Acid/Core.hs +4/−18
- src/Data/Acid/Local.hs +3/−4
- src/Data/Acid/Log.hs +44/−28
- src/Data/Acid/Memory.hs +6/−6
- src/Data/Acid/Memory/Pure.hs +8/−13
- src/Data/Acid/Remote.hs +100/−32
- src/Data/Acid/Repair.hs +1/−1
- src/Data/Acid/TemplateHaskell.hs +58/−54
- test-state/OldStateTest1/events-0000000681.log +0/−0
- test-state/OldStateTest2/events-0000000149.log +0/−0
- test-state/OldStateTest3/events-0000000100.log +0/−0
- test/Data/Acid/KeyValueStateMachine.hs +4/−4
- test/Data/Acid/StateMachineTest.hs +24/−2
- test/Data/Acid/TemplateHaskellSpec.hs +6/−15
CHANGELOG.md view
@@ -1,3 +1,70 @@+0.16.1.4+=========++_Andreas Abel, 2025-08-27_++- Drop support for GHC 7+- Tested with GHC 8.2 - 9.14.1-alpha1++0.16.1.3+========++_Andreas Abel, 2023-08-03_++- Support template-haskell-2.21+ ([#162](https://github.com/acid-state/acid-state/pull/162))+- Tested with GHC 7.8 - 9.8.1-alpha1++0.16.1.2+========++_Andreas Abel, 2023-04-06_++- Support unix-2.8+- Tested with GHC 7.8 - 9.6.1++0.16.1.1+========++_Andreas Abel, 2022-06-01_++- Adapt to changes in hedgehog-1.1 related to barbies+- Support mtl-2.3+- Tested with GHC 7.8 - 9.2.3++0.16.1+======++_David Fox, 2022-02-18_++ - Support GHC-9.0.2, template-haskell 2.18++0.16.0.1+========++_Jeremy Shaw, 2020-05-19_++0.16.0+======++_Jeremy Shaw, 2019-11-14_++ - support network-3.x and ghc-8.8.1+ - Fix tests+ ([#131](https://github.com/acid-state/acid-state/pull/131))+ - Haddock documentation fixes+ - Update build dependency constraints++0.15.2+======++ - adds acid-state-repair recovery tool+ ([#126](https://github.com/acid-state/acid-state/pull/16))+ - parameterize the underlying serialization library+ ([#96](https://github.com/acid-state/acid-state/pull/96))+ - support safecopy-0.10, which supports GHC.Generics+ ([#128](https://github.com/acid-state/acid-state/pull/128))+ 0.15.0 ======
acid-state.cabal view
@@ -1,5 +1,6 @@+Cabal-version: 1.18 Name: acid-state-Version: 0.15.2+Version: 0.16.1.4 Synopsis: Add ACID guarantees to any serializable Haskell data structure. Description: Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage: https://github.com/acid-state/acid-state@@ -9,10 +10,28 @@ -- Copyright: Category: Database Build-type: Simple-Cabal-version: >=1.10-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.3-Extra-source-files:++tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ -- cabal-3.12 cannot install dependency system-filepath any more in the GHC 8.0 environment+ -- https://github.com/haskell/cabal/issues/10379+ -- GHC == 8.0.2++Extra-doc-files: CHANGELOG.md+Extra-source-files: test-state/OldStateTest1/*.log test-state/OldStateTest1/*.version test-state/OldStateTest2/*.log@@ -27,42 +46,44 @@ flag skip-state-machine-test description: If enabled, do not build/run the state-machine test default: False- manual: True+ manual: False Library- Exposed-Modules: Data.Acid,- Data.Acid.Archive,- Data.Acid.Common,- Data.Acid.Local, Data.Acid.Memory,- Data.Acid.Memory.Pure, Data.Acid.Remote,- Data.Acid.Advanced,- Data.Acid.Log, Data.Acid.CRC,- Data.Acid.Abstract, Data.Acid.Core,+ Exposed-Modules: Data.Acid+ Data.Acid.Archive+ Data.Acid.Common+ Data.Acid.Local Data.Acid.Memory+ Data.Acid.Memory.Pure Data.Acid.Remote+ Data.Acid.Advanced+ Data.Acid.Log Data.Acid.CRC+ Data.Acid.Abstract Data.Acid.Core Data.Acid.TemplateHaskell Data.Acid.Repair - Other-modules: Paths_acid_state,+ Other-modules: Paths_acid_state FileIO - Build-depends: array,- base >= 4.5.1.0 && < 5,- bytestring >= 0.10.2,- cereal >= 0.4.1.0,- containers,- safecopy >= 0.6 && < 0.11,- stm >= 2.4,- directory,- filelock,- filepath,- mtl,- network < 2.9,- template-haskell,- th-expand-syns+ -- Lower bounds taken from GHC 8.0 / LTS 7.0+ Build-depends: array >= 0.5.1.1+ , base >= 4.9 && < 5+ , bytestring >= 0.10.8.0+ , cereal >= 0.5.3.0+ , containers >= 0.5.7.1+ , safecopy >= 0.6 && < 0.11+ , stm >= 2.4+ , directory >= 1.2.6.2+ , filelock >= 0.1.0.1+ , filepath >= 1.4.1.0+ , mtl >= 2.2.1+ , network >= 2.6.3.1 && < 3.3+ , network-bsd+ , template-haskell >= 2.11.0.0 && < 2.25+ , th-expand-syns >= 0.4.0.0 if os(windows)- Build-depends: Win32+ Build-depends: Win32 >= 2.3.1.1 else- Build-depends: unix+ Build-depends: unix >= 2.7.2.0 Hs-Source-Dirs: src/ @@ -72,7 +93,13 @@ Hs-Source-Dirs: src-unix/ default-language: Haskell2010- GHC-Options: -fwarn-unused-imports -fwarn-unused-binds+ GHC-Options: -Wall+ -Wcompat+ -Wno-dodgy-imports+ -Wno-missing-signatures+ -Wno-name-shadowing+ -Wno-unused-do-bind+ -Wno-unused-matches executable acid-state-repair hs-source-dirs: repair@@ -91,7 +118,6 @@ , acid-state , deepseq , hspec- , hspec-discover , mtl , safecopy , template-haskell@@ -116,6 +142,7 @@ other-modules: Data.Acid.KeyValueStateMachine Data.Acid.StateMachineTest default-language: Haskell2010+ default-extensions: TypeOperators if flag(skip-state-machine-test) buildable: False@@ -174,32 +201,34 @@ directory, system-fileio == 0.3.*, system-filepath,- criterion >= 1.0.0.0 && < 1.6,+ -- perRunEnv was added in criterion-1.2.0.0+ criterion >= 1.2.0.0 && < 1.7, mtl, base, acid-state default-language: Haskell2010 default-extensions:- PatternGuards+ -- keep this list alphabetically sorted!+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances GADTs- StandaloneDeriving MultiParamTypeClasses- ScopedTypeVariables- FlexibleInstances- TypeFamilies- TypeOperators- FlexibleContexts NoImplicitPrelude- EmptyDataDecls- DataKinds NoMonomorphismRestriction+ OverloadedStrings+ PatternGuards RankNTypes- ConstraintKinds- DefaultSignatures- TupleSections+ ScopedTypeVariables+ StandaloneDeriving TemplateHaskell- OverloadedStrings- DeriveDataTypeable+ TupleSections+ TypeFamilies+ TypeOperators ghc-options: -O2
examples/CheckpointCutsEvent.hs view
@@ -14,7 +14,6 @@ files should contain 10 checkpoints each. -}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -22,12 +21,11 @@ -- import Control.Concurrent import Control.Applicative-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad+import Control.Monad.State ( get, put ) import Data.Acid-import Data.List+import Data.List ( sort ) import Data.SafeCopy-import Data.Typeable import System.Directory import System.Environment @@ -35,7 +33,7 @@ -- The Haskell structure that we want to encapsulate newtype Counter = Counter { unCounter :: Integer }- deriving (Show, Typeable)+ deriving (Show) $(deriveSafeCopy 0 'base ''Counter)
examples/HelloDatabase.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}
examples/HelloWorld.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,14 +7,13 @@ import Control.Monad.State import Data.Acid import Data.SafeCopy-import Data.Typeable import System.Environment ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data HelloWorldState = HelloWorldState String- deriving (Show, Typeable)+ deriving (Show) $(deriveSafeCopy 0 'base ''HelloWorldState)
examples/HelloWorldNoTH.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -7,18 +6,17 @@ import Data.Acid import Data.Acid.Advanced -import Control.Monad.Reader-import Control.Monad.State+import Control.Monad+import Control.Monad.Reader (ask)+import Control.Monad.State (put) import Data.SafeCopy import System.Environment -import Data.Typeable- ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data HelloWorldState = HelloWorldState String- deriving (Show, Typeable)+ deriving (Show) instance SafeCopy HelloWorldState where putCopy (HelloWorldState state) = contain $ safePut state@@ -56,8 +54,6 @@ data WriteState = WriteState String data QueryState = QueryState --deriving instance Typeable WriteState instance SafeCopy WriteState where putCopy (WriteState st) = contain $ safePut st getCopy = contain $ liftM WriteState safeGet@@ -66,7 +62,6 @@ type MethodState WriteState = HelloWorldState instance UpdateEvent WriteState -deriving instance Typeable QueryState instance SafeCopy QueryState where putCopy QueryState = contain $ return () getCopy = contain $ return QueryState
examples/KeyValue.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -11,13 +10,10 @@ import Control.Monad.Reader import Control.Monad.State import Data.SafeCopy-import Network import System.Environment import System.Exit import System.IO -import Data.Typeable- import qualified Data.Map as Map ------------------------------------------------------@@ -27,7 +23,6 @@ type Value = String data KeyValue = KeyValue !(Map.Map Key Value)- deriving (Typeable) $(deriveSafeCopy 0 'base ''KeyValue)
examples/KeyValueNoTH.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -8,14 +7,13 @@ import Data.Acid.Advanced import Control.Applicative-import Control.Monad.Reader+import Control.Monad+import Control.Monad.Reader (ask) import qualified Control.Monad.State as State import Data.SafeCopy import System.Environment import System.IO -import Data.Typeable- import qualified Data.Map as Map ------------------------------------------------------@@ -25,7 +23,6 @@ type Value = String data KeyValue = KeyValue !(Map.Map Key Value)- deriving (Typeable) instance SafeCopy KeyValue where putCopy (KeyValue state) = contain $ safePut state@@ -73,8 +70,6 @@ data InsertKey = InsertKey Key Value data LookupKey = LookupKey Key --deriving instance Typeable InsertKey instance SafeCopy InsertKey where putCopy (InsertKey key value) = contain $ safePut key >> safePut value getCopy = contain $ InsertKey <$> safeGet <*> safeGet@@ -83,7 +78,6 @@ type MethodState InsertKey = KeyValue instance UpdateEvent InsertKey -deriving instance Typeable LookupKey instance SafeCopy LookupKey where putCopy (LookupKey key) = contain $ safePut key getCopy = contain $ LookupKey <$> safeGet
examples/MonadStateConstraint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}@@ -9,14 +8,13 @@ import Control.Monad.State import Data.Acid import Data.SafeCopy-import Data.Typeable import System.Environment ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data HelloWorldState = HelloWorldState String- deriving (Show, Typeable)+ deriving (Show) $(deriveSafeCopy 0 'base ''HelloWorldState)
examples/ParameterisedState.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}@@ -28,10 +27,6 @@ newtype Store k = Store { store :: Map.Map k (Entry k) } deriving (Eq, Generic)--#if __GLASGOW_HASKELL__ <= 708-deriving instance Typeable1 Store-#endif instance (Ord k, Serialize k, SafeCopy k, Typeable k) => SafeCopy (Store k) instance (Ord k, Serialize k) => Serialize (Store k)
examples/Proxy.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,20 +7,17 @@ import Data.Acid.Advanced (scheduleUpdate) import Data.Acid.Remote -import Control.Monad.Reader-import Control.Monad.State+import Control.Monad+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put) import Data.SafeCopy-import Network import System.Environment import System.IO -import Data.Typeable- ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data ProxyStressState = StressState !Int- deriving (Typeable) $(deriveSafeCopy 0 'base ''ProxyStressState) @@ -45,17 +41,19 @@ openLocal = openLocalState (StressState 0) openRemote :: String -> IO (AcidState ProxyStressState)-openRemote socket = openRemoteState skipAuthenticationPerform "localhost" (UnixSocket socket)+openRemote socket = openRemoteState skipAuthenticationPerform "localhost" port +port = 6303+ main :: IO () main = do args <- getArgs case args of ["server", socket] -> do acid <- openLocal- acidServer skipAuthenticationCheck (UnixSocket socket) acid+ acidServer skipAuthenticationCheck port acid ["proxy", from, to] -> do acid <- openRemote from- acidServer skipAuthenticationCheck (UnixSocket to) acid+ acidServer skipAuthenticationCheck port acid ["query", socket] -> do acid <- openRemote socket n <- query acid QueryState
examples/RemoteClient.hs view
@@ -1,10 +1,10 @@ module RemoteClient (main) where -import Control.Monad.Reader+import Control.Monad import Data.Acid import Data.Acid.Advanced import Data.Acid.Remote-import Network+import Network.Socket (SockAddr(..)) import RemoteCommon import System.Environment import System.IO@@ -13,7 +13,9 @@ -- This is how AcidState is used: open :: IO (AcidState StressState)-open = openRemoteState skipAuthenticationPerform "localhost" (PortNumber 8080)+open = openRemoteState skipAuthenticationPerform "localhost" 8080+-- on Unixy systems we could use a Unix Domain Socket+-- open = openRemoteStateSockAddr skipAuthenticationPerform (SockAddrUnix "remote.socket") main :: IO () main = do args <- getArgs
examples/RemoteCommon.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,12 +7,11 @@ import Control.Monad.State import Data.Acid import Data.SafeCopy-import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate -data StressState = StressState !Int deriving (Typeable)+data StressState = StressState !Int $(deriveSafeCopy 0 'base ''StressState)
examples/RemoteServer.hs view
@@ -2,10 +2,12 @@ import Control.Exception (bracket) import Data.Acid (closeAcidState, openLocalState)-import Data.Acid.Remote (acidServer, skipAuthenticationCheck)-import Network (PortID (..))+import Data.Acid.Remote (acidServer, acidServerSockAddr, skipAuthenticationCheck) import RemoteCommon (StressState (..))+import Network.Socket (SockAddr(..)) main :: IO () main = bracket (openLocalState $ StressState 0)- closeAcidState $ acidServer skipAuthenticationCheck (PortNumber 8080)+ closeAcidState $ acidServer skipAuthenticationCheck 8080+-- on Unixy systems we could use a Unix Domain Socket+-- closeAcidState $ acidServerSockAddr skipAuthenticationCheck (SockAddrUnix "remote.socket")
examples/SlowCheckpoint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -10,8 +9,9 @@ import Data.Acid import Control.Concurrent-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put) import Data.SafeCopy import Data.Time import System.Directory
examples/StressTest.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,13 +12,10 @@ import System.Environment import System.IO -import Data.Typeable- ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data StressState = StressState !Int- deriving (Typeable) $(deriveSafeCopy 0 'base ''StressState)
examples/StressTestNoTH.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -7,19 +6,17 @@ import Data.Acid import Data.Acid.Advanced -import Control.Monad.Reader-import Control.Monad.State+import Control.Monad+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put) import Data.SafeCopy import System.Environment import System.IO -import Data.Typeable- ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data StressState = StressState !Int- deriving (Typeable) instance SafeCopy StressState where putCopy (StressState state) = contain $ safePut state@@ -65,7 +62,6 @@ data PokeState = PokeState data QueryState = QueryState -deriving instance Typeable PokeState instance SafeCopy PokeState where putCopy PokeState = contain $ return () getCopy = contain $ return PokeState@@ -74,7 +70,6 @@ type MethodState PokeState = StressState instance UpdateEvent PokeState -deriving instance Typeable QueryState instance SafeCopy QueryState where putCopy QueryState = contain $ return () getCopy = contain $ return QueryState
examples/errors/ChangeState.hs view
@@ -6,7 +6,7 @@ import Data.Acid import Control.Exception-import Control.Monad.State+import Control.Monad import Data.SafeCopy import System.Directory import System.Environment@@ -56,7 +56,7 @@ putStrLn "ChangeState done" where hdl (ErrorCall msg)- | "Could not parse saved checkpoint due to the following error: too few bytes\nFrom:\tChangeState.SecondState:\n\tdemandInput\n\n" `isSuffixOf` msg + | "Could not parse saved checkpoint due to the following error: too few bytes\nFrom:\tChangeState.SecondState:\n\tdemandInput\n\n" `isSuffixOf` msg = putStrLn $ "Caught error: " ++ msg hdl e = throwIO e
examples/errors/ChangeVersion.hs view
@@ -6,7 +6,7 @@ import Data.Acid import Control.Exception-import Control.Monad.State+import Control.Monad import Data.SafeCopy import System.Directory import System.Environment
examples/errors/Exceptions.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -7,13 +7,12 @@ import Data.Acid import Data.Acid.Local (createCheckpointAndClose) -import Control.Monad.State+import Control.Monad+import Control.Monad.State ( get, put ) import Data.SafeCopy import System.Directory import System.Environment -import Data.Typeable- import Control.Exception import Prelude hiding (catch) @@ -21,7 +20,7 @@ -- The Haskell structure that we want to encapsulate data MyState = MyState Integer- deriving (Show, Typeable)+ deriving (Show) $(deriveSafeCopy 0 'base ''MyState) @@ -29,7 +28,7 @@ -- The transaction we will execute over the state. failEvent :: Update MyState ()-failEvent = fail "fail!"+failEvent = pure $ error "fail!" errorEvent :: Update MyState () errorEvent = error "error!"
examples/errors/RemoveEvent.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -6,13 +5,11 @@ import Data.Acid -import Control.Monad.State+import Control.Monad import Data.SafeCopy import System.Directory import System.Environment import Data.List (isSuffixOf)--import Data.Typeable import Control.Exception import Prelude hiding (catch)
src-unix/FileIO.hs view
@@ -1,13 +1,17 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}+ module FileIO(FHandle,open,write,flush,close) where-import System.Posix(Fd(Fd),- openFd,- fdWriteBuf,- closeFd,- OpenMode(WriteOnly),- defaultFileFlags,- stdFileMode- )++import System.Posix+ ( Fd(Fd), openFd, fdWriteBuf, closeFd+ , OpenMode(WriteOnly)+#if MIN_VERSION_unix(2,8,0)+ , OpenFileFlags(creat)+#endif+ , defaultFileFlags+ , stdFileMode+ ) import Data.Word(Word8,Word32) import Foreign(Ptr) import Foreign.C(CInt(..))@@ -16,7 +20,11 @@ -- should handle opening flags correctly open :: FilePath -> IO FHandle+#if !MIN_VERSION_unix(2,8,0) open filename = fmap FHandle $ openFd filename WriteOnly (Just stdFileMode) defaultFileFlags+#else+open filename = fmap FHandle $ openFd filename WriteOnly defaultFileFlags{ creat = Just stdFileMode }+#endif write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32 write (FHandle fd) data' length = fmap fromIntegral $ fdWriteBuf fd data' $ fromIntegral length
src/Data/Acid/Abstract.hs view
@@ -18,18 +18,10 @@ import Data.ByteString.Lazy ( ByteString ) import Control.Monad ( void ) import Control.Monad.Trans ( MonadIO(liftIO) )-#if __GLASGOW_HASKELL__ >= 707 import Data.Typeable ( Typeable, gcast, typeOf )-#else-import Data.Typeable ( Typeable1, gcast1, typeOf1 )-#endif data AnyState st where-#if __GLASGOW_HASKELL__ >= 707 AnyState :: Typeable sub_st => sub_st st -> AnyState st-#else- AnyState :: Typeable1 sub_st => sub_st st -> AnyState st-#endif -- Haddock doesn't get the types right on its own. {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)@@ -83,7 +75,7 @@ -- scheduleUpdate acid EventB -- @ scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event))-scheduleUpdate = _scheduleUpdate -- Redirection to make Haddock happy.+scheduleUpdate acid = _scheduleUpdate acid -- Redirection to make Haddock happy. -- | Schedule multiple Update events and wait for them to be durable, but -- throw away their results. This is useful for importing existing@@ -110,20 +102,15 @@ -- | Issue a Query event and wait for its result. Events may be issued in parallel. query :: QueryEvent event => AcidState (EventState event) -> event -> IO (EventResult event)-query = _query -- Redirection to make Haddock happy.+query acid = _query acid -- Redirection to make Haddock happy. -- | Same as 'query' but lifted into any monad capable of doing IO. query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) query' acidState event = liftIO (query acidState event) -#if __GLASGOW_HASKELL__ >= 707 mkAnyState :: Typeable sub_st => sub_st st -> AnyState st-#else-mkAnyState :: Typeable1 sub_st => sub_st st -> AnyState st-#endif mkAnyState = AnyState -#if __GLASGOW_HASKELL__ >= 707 downcast :: (Typeable sub, Typeable st) => AcidState st -> sub st downcast AcidState{acidSubState = AnyState sub} = r@@ -133,14 +120,3 @@ _ -> error $ "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r)-#else-downcast :: Typeable1 sub => AcidState st -> sub st-downcast AcidState{acidSubState = AnyState sub}- = r- where- r = case gcast1 (Just sub) of- Just (Just x) -> x- _ ->- error $- "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r)-#endif
src/Data/Acid/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} ----------------------------------------------------------------------------- -- |@@ -13,10 +14,9 @@ import Data.Acid.Core -import Control.Monad.State-import Control.Monad.Reader-import Control.Applicative-+import Control.Monad+import Control.Monad.State (MonadState, get, State)+import Control.Monad.Reader (MonadReader, Reader, runReader) class IsAcidic st where acidEvents :: [Event st]
src/Data/Acid/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs, DeriveDataTypeable, TypeFamilies,+{-# LANGUAGE CPP, GADTs, TypeFamilies, FlexibleContexts, BangPatterns, DefaultSignatures, ScopedTypeVariables #-} -----------------------------------------------------------------------------@@ -51,24 +51,18 @@ import Control.Monad ( liftM ) import Control.Monad.State ( State, runState ) import qualified Data.Map as Map+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.ByteString.Lazy as Lazy ( ByteString ) import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack ) import Data.Serialize ( runPutLazy, runGetLazy ) import Data.SafeCopy ( SafeCopy, safeGet, safePut ) -import Data.Typeable ( Typeable, TypeRep, typeRepTyCon, typeOf )+import Data.Typeable ( Typeable, TypeRep, typeRepTyCon, typeOf, tyConModule ) import Unsafe.Coerce ( unsafeCoerce ) -#if MIN_VERSION_base(4,5,0)-import Data.Typeable ( tyConModule )-#else-import Data.Typeable.Internal ( tyConModule )-#endif--#if MIN_VERSION_base(4,4,0)- -- in base >= 4.4 the Show instance for TypeRep no longer provides a -- fully qualified name. But we have old data around that expects the -- FQN. So we will recreate the old naming system for newer versions@@ -77,14 +71,6 @@ showQualifiedTypeRep :: TypeRep -> String showQualifiedTypeRep tr = tyConModule con ++ "." ++ show tr where con = typeRepTyCon tr--#else--showQualifiedTypeRep :: TypeRep -> String-showQualifiedTypeRep tr = show tr--#endif- -- | Interface for (de)serialising values of type @a@. --
src/Data/Acid/Local.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Local@@ -41,7 +41,6 @@ import Control.Exception ( onException, evaluate, Exception, throwIO ) import Control.Monad.State ( runState ) import Control.Monad ( join )-import Control.Applicative ( (<$>), (<*>) ) import Data.ByteString.Lazy ( ByteString ) import qualified Data.ByteString.Lazy as Lazy ( length ) @@ -74,9 +73,9 @@ , localEvents :: FileLog (Tagged ByteString) , localCheckpoints :: FileLog (Checkpoint st) , localLock :: FileLock- } deriving (Typeable)+ } -newtype StateIsLocked = StateIsLocked FilePath deriving (Show, Typeable)+newtype StateIsLocked = StateIsLocked FilePath deriving (Show) instance Exception StateIsLocked
src/Data/Acid/Log.hs view
@@ -1,6 +1,7 @@--- A log is a stack of entries that supports efficient pushing of--- new entries and fetching of old. It can be considered an--- extendible array of entries.+{-# LANGUAGE CPP #-}++-- | A log is a stack of entries that supports efficient pushing of new entries+-- and fetching of old. It can be considered an extendible array of entries. -- module Data.Acid.Log ( FileLog(..)@@ -35,9 +36,11 @@ import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict import qualified Data.ByteString.Unsafe as Strict-import Data.List+import Data.List ( (\\), stripPrefix, sort ) import Data.Maybe-import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ( (<>) )+#endif import Text.Printf ( printf ) import Paths_acid_state ( version )@@ -122,7 +125,8 @@ sequence_ actions yield --- Repack a lazy bytestring into larger blocks that can be efficiently written to disk.+-- | Repack a lazy bytestring into larger blocks that can be efficiently written+-- to disk. repack :: Lazy.ByteString -> [Strict.ByteString] repack = worker where@@ -164,9 +168,9 @@ cutFileLog fLog return () --- Read all durable entries younger than the given EntryId.--- Note that entries written during or after this call won't--- be included in the returned list.+-- | Read all durable entries younger than the given 'EntryId'. Note that+-- entries written during or after this call won't be included in the returned+-- list. readEntriesFrom :: FileLog object -> EntryId -> IO [object] readEntriesFrom fLog youngestEntry = do -- Cut the log so we can read written entries without interfering@@ -191,7 +195,8 @@ rangeStart (firstEntryId, _path) = firstEntryId identifier = logIdentifier fLog --- Obliterate log entries younger than or equal to the EventId. Very unsafe, can't be undone+-- | Obliterate log entries younger than or equal to the 'EntryId'. Very unsafe,+-- can't be undone rollbackTo :: LogKey object -> EntryId -> IO () rollbackTo identifier youngestEntry = do logFiles <- findLogFiles identifier@@ -209,8 +214,10 @@ hClose pathHandle loop (reverse sorted) --- Obliterate log entries as long as the filterFn returns True.-rollbackWhile :: LogKey object -> (object -> Bool) -> IO ()+-- | Obliterate log entries as long as the filter function returns @True@.+rollbackWhile :: LogKey object+ -> (object -> Bool) -- ^ the filter function+ -> IO () rollbackWhile identifier filterFn = do logFiles <- findLogFiles identifier let sorted = sort logFiles@@ -229,9 +236,15 @@ hClose pathHandle loop (reverse sorted) --- Filter out log files that are outside the min_entry/max_entry range.--- minEntryId <= x < maxEntryId-filterLogFiles :: Maybe EntryId -> Maybe EntryId -> [(EntryId, FilePath)] -> [(EntryId, FilePath)]+-- | Filter out log files that are outside the min_entry/max_entry range.+--+-- minEntryId <= x < maxEntryId+filterLogFiles+ :: Maybe EntryId+ -- ^ minEntryId+ -> Maybe EntryId+ -- ^ maxEntryId+ -> [(EntryId, FilePath)] -> [(EntryId, FilePath)] filterLogFiles minEntryIdMb maxEntryIdMb logFiles = worker logFiles where worker [] = []@@ -253,14 +266,14 @@ Just maxEntryId -> (< maxEntryId) rangeStart (firstEntryId, _path) = firstEntryId --- Move all log files that do not contain entries equal or higher than the given entryId--- into an Archive/ directory.+-- | Move all log files that do not contain entries equal or higher than the+-- given entryId into an @Archive/@ directory. archiveFileLog :: FileLog object -> EntryId -> IO () archiveFileLog fLog entryId = do logFiles <- findLogFiles (logIdentifier fLog) let sorted = sort logFiles- relevant = filterLogFiles Nothing (Just entryId) sorted \\- filterLogFiles (Just entryId) (Just (entryId+1)) sorted+ relevant = filterLogFiles Nothing (Just entryId) sorted+ \\ filterLogFiles (Just entryId) (Just (entryId+1)) sorted createDirectoryIfMissing True archiveDir forM_ relevant $ \(_startEntry, logFilePath) ->@@ -287,11 +300,14 @@ where key = logIdentifier fLog --- Finds the newest entry in the log. Doesn't work on open logs.--- Do not use after the log has been opened.--- Implementation: Search the newest log files first. Once a file--- containing at least one valid entry is found,--- return the last entry in that file.+-- | Finds the newest entry in the log. Doesn't work on open logs. Do not use+-- after the log has been opened.+--+-- Implementation:+--+-- - Search the newest log files first.+-- - Once a file containing at least one valid entry is found, return the last+-- entry in that file. newestEntry :: LogKey object -> IO (Maybe object) newestEntry identifier = do logFiles <- findLogFiles identifier@@ -313,9 +329,9 @@ lastEntry entry (Fail msg) = error $ "Data.Acid.Log: " <> msg lastEntry _ (Next entry next) = lastEntry entry next --- Schedule a new log entry. This call does not block--- The given IO action runs once the object is durable. The IO action--- blocks the serialization of events so it should be swift.+-- | Schedule a new log entry. This call does not block. The given IO action+-- runs once the object is durable. The IO action blocks the serialization of+-- events so it should be swift. pushEntry :: FileLog object -> object -> IO () -> IO () pushEntry fLog object finally = atomically $ do tid <- readTVar (logNextEntryId fLog)@@ -326,7 +342,7 @@ encoded = Lazy.fromChunks [ Strict.copy $ Lazy.toStrict $ serialiserEncode (logSerialiser (logIdentifier fLog)) object ] --- The given IO action is executed once all previous entries are durable.+-- | The given IO action is executed once all previous entries are durable. pushAction :: FileLog object -> IO () -> IO () pushAction fLog finally = atomically $ do (entries, actions) <- readTVar (logQueue fLog)
src/Data/Acid/Memory.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory@@ -8,6 +8,7 @@ -- Portability : non-portable (uses GHC extensions) -- -- AcidState container without a transaction log. Mostly used for testing.+-- Supports Atomicity, Consistency and Isolation, but not Durability. -- module Data.Acid.Memory@@ -21,7 +22,6 @@ import Control.Concurrent ( newEmptyMVar, putMVar, MVar ) import Control.Monad.State ( runState ) import Data.ByteString.Lazy ( ByteString )-import Data.Typeable ( Typeable ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) @@ -41,9 +41,10 @@ data MemoryState st = MemoryState { localCore :: Core st , localCopy :: IORef st- } deriving (Typeable)+ } --- | Create an AcidState given an initial value.+-- | Create an 'AcidState' given an initial value. The state is kept only in+-- memory, so it is not durable. openMemoryState :: (IsAcidic st) => st -- ^ Initial state value. -> IO (AcidState st)@@ -53,8 +54,7 @@ return $ toAcidState MemoryState { localCore = core, localCopy = ref } --- | Issue an Update event and return immediately. The event is not durable--- before the MVar has been filled but the order of events is honored.+-- | Issue an Update event and return immediately. The order of events is honored. -- The behavior in case of exceptions is exactly the same as for 'update'. -- -- If EventA is scheduled before EventB, EventA /will/ be executed before EventB:
src/Data/Acid/Memory/Pure.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory.Pure@@ -9,6 +9,11 @@ -- -- AcidState container without a transaction log. Mostly used for testing. --+-- This module consists of internal implementation details for+-- "Data.Acid.Memory". You should not normally need to import it. Call+-- 'Data.Acid.Memory.openMemoryState' and thereafter use the API from+-- "Data.Acid" instead.+-- module Data.Acid.Memory.Pure ( IsAcidic(..)@@ -35,18 +40,8 @@ import Control.Monad.State import Control.Monad.Reader -{-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)- guarantees.-- [@Atomicity@] State changes are all-or-nothing. This is what you'd expect of any state- variable in Haskell and AcidState doesn't change that.-- [@Consistency@] No event or set of events will break your data invariants.-- [@Isolation@] Transactions cannot interfere with each other even when issued in parallel.-- [@Durability@] Successful transaction are guaranteed to survive system failure (both- hardware and software).+{-| Pure state value used internally. This is not the same as+ 'Data.Acid.AcidState' from "Data.Acid". -} data AcidState st = AcidState { localMethods :: MethodMap st
src/Data/Acid/Remote.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, RecordWildCards, ScopedTypeVariables #-}+{-# LANGUAGE CPP, RankNTypes, RecordWildCards, ScopedTypeVariables #-} ----------------------------------------------------------------------------- {- | Module : Data.Acid.Remote@@ -25,7 +25,7 @@ 'openRemoteState' and 'acidServer' communicate over an unencrypted socket. If you need an encrypted connection, see @acid-state-tls@. -On Unix®-like systems you can use 'UnixSocket' to create a socket file for+On Unix®-like systems you can use 'SockAddrUnix' to create a socket file for local communication between the client and server. Access can be controlled by setting the permissions of the parent directory containing the socket file.@@ -33,7 +33,7 @@ It is also possible to perform some simple authentication using 'sharedSecretCheck' and 'sharedSecretPerform'. Keep in mind that secrets will be sent in plain-text if you do not use-@acid-state-tls@. If you are using a 'UnixSocket' additional+@acid-state-tls@. If you are using a 'SockAddrUnix' additional authentication may not be required, so you can use 'skipAuthenticationCheck' and 'skipAuthenticationPerform'. @@ -78,8 +78,10 @@ ( -- * Server/Client acidServer+ , acidServerSockAddr , acidServer' , openRemoteState+ , openRemoteStateSockAddr -- * Authentication , skipAuthenticationCheck , skipAuthenticationPerform@@ -99,7 +101,7 @@ import Control.Concurrent.STM.TQueue import Control.Exception ( AsyncException(ThreadKilled) , Exception(fromException), IOException, Handler(..)- , SomeException, catch, catches, throw )+ , SomeException, catch, catches, throw, bracketOnError ) import Control.Exception ( throwIO, finally ) import Control.Monad ( forever, liftM, join, when ) import Control.Concurrent ( ThreadId, forkIO, threadDelay, killThread, myThreadId )@@ -108,20 +110,21 @@ import Data.Acid.Abstract import Data.Acid.Core import Data.Acid.Common+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import qualified Data.ByteString as Strict import Data.ByteString.Char8 ( pack ) import qualified Data.ByteString.Lazy as Lazy import Data.IORef ( newIORef, readIORef, writeIORef ) import Data.Serialize import Data.Set ( Set, member )-import Data.Typeable ( Typeable ) import GHC.IO.Exception ( IOErrorType(..) )-import Network ( HostName, PortID(..), connectTo, listenOn, withSocketsDo )-import Network.Socket ( Socket, accept, sClose )-import Network.Socket.ByteString ( recv, sendAll )+import Network.BSD ( PortNumber, getProtocolNumber, getHostByName, hostAddress )+import Network.Socket+import Network.Socket.ByteString as NSB ( recv, sendAll ) import System.Directory ( removeFile )-import System.IO ( Handle, hPrint, hFlush, hClose, stderr )+import System.IO ( Handle, hPrint, hFlush, hClose, stderr, IOMode(..) ) import System.IO.Error ( ioeGetErrorType, isFullError, isDoesNotExistError ) debugStrLn :: String -> IO ()@@ -143,7 +146,7 @@ | AcidStateClosed | SerializeError String | AuthenticationError String- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) instance Exception AcidRemoteException -- | create a 'CommChannel' from a 'Handle'. The 'Handle' should be@@ -163,8 +166,8 @@ socketToCommChannel :: Socket -> CommChannel socketToCommChannel socket = CommChannel { ccPut = sendAll socket- , ccGetSome = recv socket- , ccClose = sClose socket+ , ccGetSome = NSB.recv socket+ , ccClose = close socket } {- | skip server-side authentication checking entirely. -}@@ -207,32 +210,67 @@ then return () else throwIO (AuthenticationError "shared secret authentication failed.") -{- | Accept connections on @port@ and handle requests using the given 'AcidState'.+{- | Accept connections on @sockAddr@ and handle requests using the given 'AcidState'. This call doesn't return. - On Unix®-like systems you can use 'UnixSocket' to communicate- using a socket file. To control access, you can set the permissions of- the parent directory which contains the socket file.-- see also: 'openRemoteState' and 'sharedSecretCheck'.+ see also: 'acidServer', 'openRemoteState' and 'sharedSecretCheck'. -}-acidServer :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'- -> PortID -- ^ Port to listen on+acidServerSockAddr :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'+ -> SockAddr -- ^ SockAddr to listen on -> AcidState st -- ^ state to serve -> IO ()-acidServer checkAuth port acidState- = withSocketsDo $- do listenSocket <- listenOn port+acidServerSockAddr checkAuth sockAddr acidState+ = do listenSocket <- listenOn sockAddr (acidServer' checkAuth listenSocket acidState) `finally` (cleanup listenSocket) where cleanup socket =- do sClose socket- case port of+ do close socket #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)- UnixSocket path -> removeFile path+ case sockAddr of+ (SockAddrUnix path) -> removeFile path+ _ -> pure () #endif- _ -> return () ++{- | Accept connections on @port@ and handle requests using the given 'AcidState'.+ This call doesn't return.++ see also: 'acidServerSockAddr', 'openRemoteState' and 'sharedSecretCheck'.+ -}+acidServer :: (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'+ -> PortNumber -- ^ Port to listen on+ -> AcidState st -- ^ state to serve+ -> IO ()+acidServer checkAuth port acidState+ = acidServerSockAddr checkAuth (SockAddrInet port 0) acidState++listenOn :: SockAddr -> IO Socket+listenOn sockAddr = do+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+ proto <- case sockAddr of+ (SockAddrUnix {}) -> pure 0+ _ -> getProtocolNumber "tcp"+#else+ proto <- getProtocolNumber "tcp"+#endif+ bracketOnError+ (socket af Stream proto)+ close+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ bind sock sockAddr+ listen sock maxListenQueue+ return sock+ )++ where+ af = case sockAddr of+ (SockAddrInet {}) -> AF_INET+ (SockAddrInet6 {}) -> AF_INET6+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+ (SockAddrUnix {}) -> AF_UNIX+#endif+ {- | Works the same way as 'acidServer', but uses pre-binded socket @listenSocket@. Can be useful when fine-tuning of socket binding parameters is needed@@ -338,23 +376,53 @@ writeChan chan (return Acknowledgement) data RemoteState st = RemoteState (Command -> IO (MVar Response)) (IO ())- deriving (Typeable) {- | Connect to an acid-state server which is sharing an 'AcidState'. -} openRemoteState :: IsAcidic st => (CommChannel -> IO ()) -- ^ authentication function, see 'sharedSecretPerform'- -> HostName -- ^ remote host to connect to (ignored when 'PortID' is 'UnixSocket')- -> PortID -- ^ remote port to connect to+ -> HostName -- ^ remote host to connect to+ -> PortNumber -- ^ remote port to connect to -> IO (AcidState st)-openRemoteState performAuthorization host port+openRemoteState performAuthorization host port =+ do he <- getHostByName host+ openRemoteStateSockAddr performAuthorization (SockAddrInet port (hostAddress he))++{- | Connect to an acid-state server which is sharing an 'AcidState'. -}+openRemoteStateSockAddr :: IsAcidic st =>+ (CommChannel -> IO ()) -- ^ authentication function, see 'sharedSecretPerform'+ -> SockAddr -- ^ remote SockAddr to connect to+ -> IO (AcidState st)+openRemoteStateSockAddr performAuthorization sockAddr = withSocketsDo $ do processRemoteState reconnect where+ af :: Family+ af = case sockAddr of+ (SockAddrInet {}) -> AF_INET+ (SockAddrInet6 {}) -> AF_INET6+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+ (SockAddrUnix {}) -> AF_UNIX+#endif+ -- | reconnect reconnect :: IO CommChannel reconnect = (do debugStrLn "Reconnecting."- handle <- connectTo host port+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+ proto <- case sockAddr of+ (SockAddrUnix {}) -> pure 0+ _ -> getProtocolNumber "tcp"+#else+ proto <- getProtocolNumber "tcp"+#endif+ handle <- bracketOnError+ (socket af Stream proto)+ close -- only done if there's an error+ (\sock -> do+ connect sock sockAddr+ socketToHandle sock ReadWriteMode+ )+ let cc = handleToCommChannel handle performAuthorization cc debugStrLn "Reconnected."
src/Data/Acid/Repair.hs view
@@ -11,7 +11,7 @@ import Data.Acid.Log (LogKey) import qualified Data.Acid.Log as Log import qualified Data.ByteString.Lazy as Lazy-import Data.List+import Data.List (sort) import System.Directory import System.FilePath.Posix import System.IO (hClose, openTempFile)
src/Data/Acid/TemplateHaskell.hs view
@@ -14,12 +14,17 @@ import Data.SafeCopy import Data.Typeable import Data.Char+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))-import Control.Applicative+#endif import Control.Monad import Control.Monad.State (MonadState) import Control.Monad.Reader (MonadReader) +#if !MIN_VERSION_template_haskell(2,17,0)+type TyVarBndrUnit = TyVarBndr+#endif+ {-| Create the control structures required for acid states using Template Haskell. @@ -80,24 +85,32 @@ case stateInfo of TyConI tycon ->case tycon of-#if MIN_VERSION_template_haskell(2,11,0)+ DataD _cxt _name tyvars _kind constructors _derivs+#if MIN_VERSION_template_haskell(2,21,0)+ -> makeAcidic' ss eventNames stateName (map void tyvars) constructors #else- DataD _cxt _name tyvars constructors _derivs-#endif -> makeAcidic' ss eventNames stateName tyvars constructors-#if MIN_VERSION_template_haskell(2,11,0)+#endif+ NewtypeD _cxt _name tyvars _kind constructor _derivs+#if MIN_VERSION_template_haskell(2,21,0)+ -> makeAcidic' ss eventNames stateName (map void tyvars) [constructor] #else- NewtypeD _cxt _name tyvars constructor _derivs-#endif -> makeAcidic' ss eventNames stateName tyvars [constructor]+#endif+ TySynD _name tyvars _ty+#if MIN_VERSION_template_haskell(2,21,0)+ -> makeAcidic' ss eventNames stateName (map void tyvars) []+#else -> makeAcidic' ss eventNames stateName tyvars []+#endif+ _ -> error "Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported." _ -> error "Data.Acid.TemplateHaskell: Given state is not a type." -makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]+makeAcidic' :: SerialiserSpec -> [Name] -> Name -> [TyVarBndrUnit] -> [Con] -> Q [Dec] makeAcidic' ss eventNames stateName tyvars constructors = do events <- sequence [ makeEvent ss eventName | eventName <- eventNames ] acidic <- makeIsAcidic ss eventNames stateName tyvars constructors@@ -132,11 +145,7 @@ getEventType eventName = do eventInfo <- reify eventName case eventInfo of-#if MIN_VERSION_template_haskell(2,11,0) VarI _name eventType _decl-#else- VarI _name eventType _decl _fixity-#endif -> expandSyns eventType _ -> error $ "Data.Acid.TemplateHaskell: Events must be functions: " ++ show eventName @@ -197,11 +206,11 @@ -- -- In this case we have to rename 'x' to the actual state we're going to -- use. This is done by 'renameState'.-eventCxts :: Type -- ^ State type- -> [TyVarBndr] -- ^ type variables that will be used for the State type in the IsAcidic instance- -> Name -- ^ 'Name' of the event- -> Type -- ^ 'Type' of the event- -> [Pred] -- ^ extra context to add to 'IsAcidic' instance+eventCxts :: Type -- ^ State type+ -> [TyVarBndrUnit] -- ^ type variables that will be used for the State type in the IsAcidic instance+ -> Name -- ^ 'Name' of the event+ -> Type -- ^ 'Type' of the event+ -> [Pred] -- ^ extra context to add to 'IsAcidic' instance eventCxts targetStateType targetTyVars eventName eventType = let TypeAnalysis { context = cxt, stateType } = analyseType eventName eventType@@ -215,20 +224,22 @@ where -- | rename the type variables in a Pred unify :: [(Name, Name)] -> Pred -> Pred-#if MIN_VERSION_template_haskell(2,10,0) unify table p = rename p table p -- in 2.10.0: type Pred = Type-#else- unify table p@(ClassP n tys) = ClassP n (map (rename p table) tys)- unify table p@(EqualP a b) = EqualP (rename p table a) (rename p table b)-#endif -- | rename the type variables in a Type rename :: Pred -> [(Name, Name)] -> Type -> Type rename pred table t@(ForallT tyvarbndrs cxt typ) = -- this is probably wrong? I don't think acid-state can really handle this type anyway.. ForallT (map renameTyVar tyvarbndrs) (map (unify table) cxt) (rename pred table typ) where+#if MIN_VERSION_template_haskell(2,17,0)+ renameTyVar :: TyVarBndr a -> TyVarBndr a+ renameTyVar (PlainTV name ann) = PlainTV (renameName pred table name) ann+ renameTyVar (KindedTV name k ann) = KindedTV (renameName pred table name) k ann+#else+ renameTyVar :: TyVarBndr -> TyVarBndr renameTyVar (PlainTV name) = PlainTV (renameName pred table name) renameTyVar (KindedTV name k) = KindedTV (renameName pred table name) k+#endif rename pred table (VarT n) = VarT $ renameName pred table n rename pred table (AppT a b) = AppT (rename pred table a) (rename pred table b) rename pred table (SigT a k) = SigT (rename pred table a) k@@ -258,12 +269,7 @@ renameState :: Type -> Type -> Cxt -> Cxt renameState tfrom tto cxt = map renamePred cxt where-#if MIN_VERSION_template_haskell(2,10,0) renamePred p = renameType p -- in 2.10.0: type Pred = Type-#else- renamePred (ClassP n tys) = ClassP n (map renameType tys)- renamePred (EqualP a b) = EqualP (renameType a) (renameType b)-#endif renameType n | n == tfrom = tto renameType (AppT a b) = AppT (renameType a) (renameType b) renameType (SigT a k) = SigT (renameType a) k@@ -297,20 +303,16 @@ , pprint stateType ] ---data MyUpdateEvent = MyUpdateEvent Arg1 Arg2--- deriving (Typeable)+-- data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 makeEventDataType :: Name -> Type -> DecQ makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ]-#if MIN_VERSION_template_haskell(2,12,0)- cxt = [derivClause Nothing [conT ''Typeable]]-#elif MIN_VERSION_template_haskell(2,11,0)- cxt = mapM conT [''Typeable]-#else- cxt = [''Typeable]-#endif+ cxt = [] case args of-#if MIN_VERSION_template_haskell(2,11,0)+#if MIN_VERSION_template_haskell(2,21,0)+ [_] -> newtypeD (return []) eventStructName (map (BndrReq <$) tyvars) Nothing con cxt+ _ -> dataD (return []) eventStructName (map (BndrReq <$) tyvars) Nothing [con] cxt+#elif MIN_VERSION_template_haskell(2,11,0) [_] -> newtypeD (return []) eventStructName tyvars Nothing con cxt _ -> dataD (return []) eventStructName tyvars Nothing [con] cxt #else@@ -373,7 +375,10 @@ instanceD instanceContext (return ty)-#if __GLASGOW_HASKELL__ >= 707+#if MIN_VERSION_template_haskell(2,15,0)+ [ tySynInstD $ tySynEqn Nothing (conT ''MethodResult `appT` structType) (return resultType)+ , tySynInstD $ tySynEqn Nothing (conT ''MethodState `appT` structType) (return stateType)+#elif __GLASGOW_HASKELL__ >= 707 [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType)) , tySynInstD ''MethodState (tySynEqn [structType] (return stateType)) #else@@ -397,7 +402,7 @@ eventStructName = toStructName eventName data TypeAnalysis = TypeAnalysis- { tyvars :: [TyVarBndr]+ { tyvars :: [TyVarBndrUnit] , context :: Cxt , argumentTypes :: [Type] , stateType :: Type@@ -408,7 +413,6 @@ analyseType :: Name -> Type -> TypeAnalysis analyseType eventName t = go [] [] [] t where-#if MIN_VERSION_template_haskell(2,10,0) getMonadReader :: Cxt -> Name -> [(Type, Type)] getMonadReader cxt m = do constraint@(AppT (AppT (ConT c) x) m') <- cxt@@ -420,20 +424,7 @@ constraint@(AppT (AppT (ConT c) x) m') <- cxt guard (c == ''MonadState && m' == VarT m) return (constraint, x)-#else- getMonadReader :: Cxt -> Name -> [(Pred, Type)]- getMonadReader cxt m = do- constraint@(ClassP c [x, m']) <- cxt- guard (c == ''MonadReader && m' == VarT m)- return (constraint, x) - getMonadState :: Cxt -> Name -> [(Pred, Type)]- getMonadState cxt m = do- constraint@(ClassP c [x, m']) <- cxt- guard (c == ''MonadState && m' == VarT m)- return (constraint, x)-#endif- -- a -> b go tyvars cxt args (AppT (AppT ArrowT a) b) = go tyvars cxt (args ++ [a]) b@@ -452,7 +443,11 @@ } -- (...) => a go tyvars cxt args (ForallT tyvars2 cxt2 a)- = go (tyvars ++ tyvars2) (cxt ++ cxt2) args a+#if MIN_VERSION_template_haskell(2,17,0)+ = go (tyvars ++ fmap void tyvars2) (cxt ++ cxt2) args a+#else+ = go (tyvars ++ tyvars2) (cxt ++ cxt2) args a+#endif -- (MonadState state m) => ... -> m result -- (MonadReader state m) => ... -> m result go tyvars' cxt argumentTypes (AppT (VarT m) resultType)@@ -486,12 +481,21 @@ findTyVars _ = [] -- | extract the 'Name' from a 'TyVarBndr'+#if MIN_VERSION_template_haskell(2,17,0)+tyVarBndrName :: TyVarBndr a -> Name+tyVarBndrName (PlainTV n _) = n+tyVarBndrName (KindedTV n _ _) = n++allTyVarBndrNames :: [TyVarBndr a] -> [Name]+allTyVarBndrNames tyvars = map tyVarBndrName tyvars+#else tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV n) = n tyVarBndrName (KindedTV n _) = n allTyVarBndrNames :: [TyVarBndr] -> [Name] allTyVarBndrNames tyvars = map tyVarBndrName tyvars+#endif -- | Convert the 'Name' of the event function into the name of the -- corresponding data constructor.
+ test-state/OldStateTest1/events-0000000681.log view
+ test-state/OldStateTest2/events-0000000149.log view
+ test-state/OldStateTest3/events-0000000100.log view
test/Data/Acid/KeyValueStateMachine.hs view
@@ -10,13 +10,13 @@ import Control.DeepSeq import Control.Exception-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Reader ( ask )+import Control.Monad.State ( get, put ) import Data.Acid import Data.Acid.StateMachineTest import Data.SafeCopy import qualified Data.Map as Map-import Data.Typeable import GHC.Generics import Hedgehog import qualified Hedgehog.Gen as Gen@@ -27,7 +27,7 @@ type Value = String data KeyValue = KeyValue !(Map.Map Key Value)- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) $(deriveSafeCopy 0 'base ''KeyValue)
test/Data/Acid/StateMachineTest.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}@@ -40,8 +41,8 @@ import Control.DeepSeq import Control.Exception (Exception, IOException, throw, catch, try, evaluate)-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.State ( State, evalState, execState ) import qualified Data.Acid as Acid import qualified Data.Acid.Common as Common import qualified Data.Acid.Core as Core@@ -177,8 +178,15 @@ data Open s (v :: * -> *) = Open s deriving Show +#if MIN_VERSION_hedgehog(1,1,0)+instance FunctorB (Open s) where+ bmap _ (Open s) = Open s+instance TraversableB (Open s) where+ btraverse _ (Open s) = pure (Open s)+#else instance HTraversable (Open s) where htraverse _ (Open s) = pure (Open s)+#endif -- | Command to open the state, given the interface to use and a -- generator for possible initial state values.@@ -202,8 +210,15 @@ data WithState s (v :: * -> *) = WithState String (Var (Opaque (Acid.AcidState s)) v) deriving (Show) +#if MIN_VERSION_hedgehog(1,1,0)+instance FunctorB (WithState s) where+ bmap k (WithState l v) = WithState l (bmap k v)+instance TraversableB (WithState s) where+ btraverse k (WithState l v) = WithState l <$> btraverse k v+#else instance HTraversable (WithState s) where htraverse k (WithState l v) = WithState l <$> htraverse k v+#endif genWithState :: Applicative g => String -> Model s v -> Maybe (g (WithState s v)) genWithState l model = pure . WithState l <$> modelHandle model@@ -256,8 +271,15 @@ data AcidCommand s e (v :: * -> *) = AcidCommand e (Var (Opaque (Acid.AcidState s)) v) deriving (Show) +#if MIN_VERSION_hedgehog(1,1,0)+instance FunctorB (AcidCommand s e) where+ bmap k (AcidCommand e s) = AcidCommand e (bmap k s)+instance TraversableB (AcidCommand s e) where+ btraverse k (AcidCommand e s) = AcidCommand e <$> btraverse k s+#else instance HTraversable (AcidCommand s e) where htraverse k (AcidCommand e s) = AcidCommand e <$> htraverse k s+#endif -- | Translate an acid-state update into a command that executes the -- update, given a generator of inputs. If the update fails, the
test/Data/Acid/TemplateHaskellSpec.hs view
@@ -11,7 +11,6 @@ import Test.Hspec hiding (context) import Data.SafeCopy (SafeCopy)-import Data.Typeable (Typeable) import Control.DeepSeq (force) import Control.Exception (evaluate) import Language.Haskell.TH@@ -105,15 +104,10 @@ `shouldBe` TypeAnalysis { tyvars = [] , context =-#if MIN_VERSION_template_haskell(2,10,0) [ ConT ''MonadReader `AppT` ConT ''Int `AppT` VarT m ]-#else- [ ClassP ''MonadReader [ConT ''Int, VarT m]- ]-#endif , argumentTypes = [ConT ''Int] , stateType = ConT ''Int , resultType = VarT m `AppT` TupleT 0@@ -144,27 +138,24 @@ let x = mkName "x" it "accepts constrained type variables in the state" $ do- let binders = [PlainTV (mkName "x")]+ let binders :: [TyVarBndrUnit]+#if MIN_VERSION_template_haskell(2,17,0)+ binders = [PlainTV (mkName "x") ()]+#else+ binders = [PlainTV (mkName "x")]+#endif stateType = ConT ''Maybe `AppT` VarT x eventType <- runQ [t| forall a. (Ord a) => Int -> Query (Maybe a) Int|] eventCxts stateType binders name eventType `shouldBe`-#if MIN_VERSION_template_haskell(2,10,0) [ConT ''Ord `AppT` VarT x]-#else- [ClassP ''Ord [VarT x]]-#endif it "can rename a polymorphic state" $ do eventType <- runQ [t| forall r m. (MonadReader r m, Ord r) => Int -> m Char |] eventCxts stateType binders name eventType `shouldBe`-#if MIN_VERSION_template_haskell(2,10,0) [ConT ''Ord `AppT` ConT ''Char]-#else- [ClassP ''Ord [ConT ''Char]]-#endif quoteShouldBe :: (Eq a, Show a) => Q a -> Q [a] -> Expectation