acid-state-0.14.2/0000755000000000000000000000000012756631253012014 5ustar0000000000000000acid-state-0.14.2/acid-state.cabal0000644000000000000000000000565512756631253015031 0ustar0000000000000000Name: acid-state Version: 0.14.2 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: http://acid-state.seize.it/ License: PublicDomain Author: David Himmelstrup Maintainer: Lemmih -- 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.1 Extra-source-files: CHANGELOG.md examples/*.hs examples/errors/*.hs src-win32/*.hs src-unix/*.hs Source-repository head type: git location: https://github.com/acid-state/acid-state Library Exposed-Modules: Data.Acid, 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 Other-modules: Data.Acid.Archive, Paths_acid_state, Data.Acid.TemplateHaskell, Data.Acid.Common, FileIO Build-depends: array, base >= 4 && < 5, bytestring >= 0.10.2, cereal >= 0.4.1.0, containers, extensible-exceptions, safecopy >= 0.6, stm >= 2.4, directory, filepath, mtl, network, template-haskell if os(windows) Build-depends: Win32 else Build-depends: unix Hs-Source-Dirs: src/ if os(windows) Hs-Source-Dirs: src-win32/ else Hs-Source-Dirs: src-unix/ default-language: Haskell2010 GHC-Options: -fwarn-unused-imports -fwarn-unused-binds benchmark loading-benchmark type: exitcode-stdio-1.0 hs-source-dirs: benchmarks/loading main-is: Benchmark.hs other-modules: Benchmark.FileSystem Benchmark.Model Benchmark.Prelude build-depends: random, directory, system-fileio == 0.3.*, system-filepath, criterion >= 0.8 && < 1.2, mtl, base, acid-state default-language: Haskell2010 default-extensions: PatternGuards GADTs StandaloneDeriving MultiParamTypeClasses ScopedTypeVariables FlexibleInstances TypeFamilies TypeOperators FlexibleContexts NoImplicitPrelude EmptyDataDecls DataKinds NoMonomorphismRestriction RankNTypes ConstraintKinds DefaultSignatures TupleSections TemplateHaskell OverloadedStrings DeriveDataTypeable ghc-options: -O2 acid-state-0.14.2/CHANGELOG.md0000644000000000000000000000154712756631253013634 0ustar00000000000000000.14.2 ====== - createCheckpoint now cuts a new events file (bug #74) 0.14.1 ====== - fix bug in archiveLog that resulted in logs being moved prematurely (bug #22) - tweaks for GHC 8.0.x, template-haskell 2.11.x - fix compilation of benchmarks 0.14.0 ====== - fixes for cereal 0.5 while maintaining cereal 0.4 compatibility. IMPORTANT: cereal 0.5 / safecopy 0.9 change the serialization format of Float/Double. Migration should be performed automatically on old data. However, you should be aware that once you upgrade to safecopy 0.9 / cereal 0.5, your data will be migrated and not readable by older versions of your application which are compiled against safecopy 0.8 / cereal 0.4. - additional fixes for TH and kinded type variables [https://github.com/acid-state/acid-state/pull/56](https://github.com/acid-state/acid-state/pull/56) acid-state-0.14.2/Setup.hs0000644000000000000000000000005612756631253013451 0ustar0000000000000000import Distribution.Simple main = defaultMain acid-state-0.14.2/benchmarks/0000755000000000000000000000000012756631253014131 5ustar0000000000000000acid-state-0.14.2/benchmarks/loading/0000755000000000000000000000000012756631253015546 5ustar0000000000000000acid-state-0.14.2/benchmarks/loading/Benchmark.hs0000644000000000000000000000430712756631253020000 0ustar0000000000000000 import Benchmark.Prelude import Criterion.Main import qualified Data.Acid as Acid import qualified Benchmark.FileSystem as FS import qualified Benchmark.Model as Model; import Benchmark.Model (Model) import qualified System.Random as Random main :: IO () main = do workingPath <- do workingPath <- FS.getTemporaryDirectory rndStr <- replicateM 16 $ Random.randomRIO ('a', 'z') return $ workingPath <> "acid-state" <> "benchmarks" <> "loading" <> FS.decodeString rndStr putStrLn $ "Working under the following temporary directory: " ++ FS.encodeString workingPath FS.removeTreeIfExists workingPath FS.createTree workingPath defaultMain =<< sequence [ prepareBenchmarksGroup workingPath $ 100, prepareBenchmarksGroup workingPath $ 200, prepareBenchmarksGroup workingPath $ 300, prepareBenchmarksGroup workingPath $ 400 ] prepareBenchmarksGroup :: FS.FilePath -> Int -> IO Benchmark prepareBenchmarksGroup workingPath size = do putStrLn $ "Preparing instances for size " ++ show size let workingPath' = workingPath <> (FS.decodeString $ show size) logsInstancePath = workingPath' <> "logs-instance" checkpointInstancePath = workingPath' <> "checkpoint-instance" FS.createTree logsInstancePath FS.createTree checkpointInstancePath putStrLn "Initializing" inst <- initialize checkpointInstancePath size putStrLn "Copying" FS.copy checkpointInstancePath logsInstancePath FS.removeFile $ logsInstancePath <> "open.lock" putStrLn "Checkpointing" Acid.createCheckpoint inst putStrLn "Closing" Acid.closeAcidState inst return $ bgroup (show size) [ bench "From Logs" $ nfIO $ load logsInstancePath >>= Acid.closeAcidState, bench "From Checkpoint" $ nfIO $ load checkpointInstancePath >>= Acid.closeAcidState ] load :: FS.FilePath -> IO (Acid.AcidState Model) load path = Acid.openLocalStateFrom (FS.encodeString path) mempty initialize :: FS.FilePath -> Int -> IO (Acid.AcidState Model) initialize path size = do inst <- Acid.openLocalStateFrom (FS.encodeString path) mempty let values = replicate size $ replicate 100 $ replicate 100 1 mapM_ (Acid.update inst . Model.Insert) values return inst acid-state-0.14.2/benchmarks/loading/Benchmark/0000755000000000000000000000000012756631253017440 5ustar0000000000000000acid-state-0.14.2/benchmarks/loading/Benchmark/FileSystem.hs0000644000000000000000000000263112756631253022062 0ustar0000000000000000module Benchmark.FileSystem ( copy, removeTreeIfExists, exists, getTemporaryDirectory, module Filesystem, module Filesystem.Path.CurrentOS ) where import Benchmark.Prelude hiding (stripPrefix, last) import Filesystem.Path.CurrentOS import Filesystem import qualified System.Directory as Directory import Debug.Trace import qualified Data.List as List removeTreeIfExists :: FilePath -> IO () removeTreeIfExists path = removeTree path `catch` \e -> case e of _ | isDoesNotExistError e -> return () | otherwise -> throwIO e exists :: FilePath -> IO Bool exists path = do isDir <- isDirectory path isFile <- isFile path return $ isDir || isFile getTemporaryDirectory :: IO FilePath getTemporaryDirectory = Directory.getTemporaryDirectory >>= return . decodeString copy :: FilePath -> FilePath -> IO () copy from to = do isDir <- isDirectory from if isDir then copyDirectory from to else copyFile from to copyDirectory :: FilePath -> FilePath -> IO () copyDirectory path path' = do members <- listDirectory path let members' = do member <- members let relative = fromMaybe (error "Unexpectedly empty member path") $ last member return $ path' <> relative sequence_ $ zipWith copy members members' last :: FilePath -> Maybe FilePath last p = case splitDirectories p of [] -> Nothing l -> Just $ List.last l acid-state-0.14.2/benchmarks/loading/Benchmark/Model.hs0000644000000000000000000000035012756631253021032 0ustar0000000000000000module Benchmark.Model where import Benchmark.Prelude hiding (insert) import qualified Data.Acid as Acid type Model = [[[Int]]] insert :: [[Int]] -> Acid.Update Model () insert = modify . (:) Acid.makeAcidic ''Model ['insert] acid-state-0.14.2/benchmarks/loading/Benchmark/Prelude.hs0000644000000000000000000000243312756631253021376 0ustar0000000000000000module Benchmark.Prelude ( module Prelude, module Control.Monad, module Control.Applicative, module Control.Arrow, module Data.Monoid, module Data.Foldable, module Data.Traversable, module Data.Maybe, module Data.List, module Data.Data, -- mtl module Control.Monad.State, module Control.Monad.Reader, -- exceptions module Control.Exception, module System.IO.Error, ) where import Prelude hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath) import Control.Monad hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) import Control.Applicative import Control.Arrow import Data.Monoid import Data.Foldable import Data.Traversable import Data.Maybe import Data.List hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') import Data.Data -- mtl import Control.Monad.State hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) import Control.Monad.Reader hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) -- exceptions import Control.Exception import System.IO.Error acid-state-0.14.2/examples/0000755000000000000000000000000012756631253013632 5ustar0000000000000000acid-state-0.14.2/examples/CheckpointCutsEvent.hs0000644000000000000000000000314612756631253020122 0ustar0000000000000000{- This example is mostly just to test that this bug is fixed: https://github.com/acid-state/acid-state/issues/73 At the end of a run, the checkpoint file should contain a single checkpoint and the event file should be empty. The old checkpoints and events should be in the Archive directory. In the Acrhive directory, each checkpoint file should contain one checkpoint, and each event file should contain 10 events. If you comment out the 'createArchive' line below, then the checkpoint files should contain 10 checkpoints each. -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main (main) where -- import Control.Concurrent import Control.Monad.Reader import Control.Monad.State import Data.Acid import Data.SafeCopy import Data.Typeable import System.Environment ------------------------------------------------------ -- The Haskell structure that we want to encapsulate newtype Counter = Counter { unCounter :: Integer } deriving (Show, Typeable) $(deriveSafeCopy 0 'base ''Counter) incCounter :: Update Counter Integer incCounter = do (Counter c) <- get let c' = succ c put (Counter c') return c' $(makeAcidic ''Counter ['incCounter]) main :: IO () main = do acid <- openLocalState (Counter 0) replicateM_ 10 $ do is <- replicateM 10 (update acid IncCounter) print is createCheckpoint acid createArchive acid closeAcidState acid acid-state-0.14.2/examples/HelloDatabase.hs0000644000000000000000000000260012756631253016654 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Control.Monad.Reader (ask) import Control.Monad.State (get, put) import Data.SafeCopy import System.Environment (getArgs) type Message = String data Database = Database [Message] $(deriveSafeCopy 0 'base ''Database) -- Transactions are defined to run in either the 'Update' monad -- or the 'Query' monad. addMessage :: Message -> Update Database () addMessage msg = do Database messages <- get put $ Database (msg:messages) viewMessages :: Int -> Query Database [Message] viewMessages limit = do Database messages <- ask return $ take limit messages -- This will define @ViewMessage@ and @AddMessage@ for us. $(makeAcidic ''Database ['addMessage, 'viewMessages]) main :: IO () main = do args <- getArgs database <- openLocalStateFrom "myDatabase/" (Database ["Welcome to the acid-state database."]) if null args then do messages <- query database (ViewMessages 10) putStrLn "Last 10 messages:" mapM_ putStrLn [ " " ++ message | message <- messages ] else do update database (AddMessage (unwords args)) putStrLn "Your message has been added to the database." acid-state-0.14.2/examples/HelloWorld.hs0000644000000000000000000000260612756631253016245 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.Monad.Reader 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) $(deriveSafeCopy 0 'base ''HelloWorldState) ------------------------------------------------------ -- The transaction we will execute over the state. writeState :: String -> Update HelloWorldState () writeState newValue = put (HelloWorldState newValue) queryState :: Query HelloWorldState String queryState = do HelloWorldState string <- ask return string $(makeAcidic ''HelloWorldState ['writeState, 'queryState]) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do acid <- openLocalState (HelloWorldState "Hello world") args <- getArgs if null args then do string <- query acid QueryState putStrLn $ "The state is: " ++ string else do update acid (WriteState (unwords args)) putStrLn "The state has been modified!" acid-state-0.14.2/examples/HelloWorldNoTH.hs0000644000000000000000000000501312756631253016771 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Advanced import Control.Monad.Reader import Control.Monad.State import Data.SafeCopy import System.Environment import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data HelloWorldState = HelloWorldState String deriving (Show, Typeable) instance SafeCopy HelloWorldState where putCopy (HelloWorldState state) = contain $ safePut state getCopy = contain $ liftM HelloWorldState safeGet ------------------------------------------------------ -- The transaction we will execute over the state. writeState :: String -> Update HelloWorldState () writeState newValue = put (HelloWorldState newValue) queryState :: Query HelloWorldState String queryState = do HelloWorldState string <- ask return string ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do acid <- openLocalState (HelloWorldState "Hello world") args <- getArgs if null args then do string <- query acid QueryState putStrLn $ "The state is: " ++ string else do update acid (WriteState (unwords args)) putStrLn "The state has been modified!" ------------------------------------------------------ -- The gritty details. These things may be done with -- Template Haskell in the future. 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 instance Method WriteState where type MethodResult WriteState = () type MethodState WriteState = HelloWorldState instance UpdateEvent WriteState deriving instance Typeable QueryState instance SafeCopy QueryState where putCopy QueryState = contain $ return () getCopy = contain $ return QueryState instance Method QueryState where type MethodResult QueryState = String type MethodState QueryState = HelloWorldState instance QueryEvent QueryState instance IsAcidic HelloWorldState where acidEvents = [ UpdateEvent (\(WriteState newState) -> writeState newState) , QueryEvent (\QueryState -> queryState) ] acid-state-0.14.2/examples/KeyValue.hs0000644000000000000000000000375712756631253015727 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Remote import Control.Applicative 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 ------------------------------------------------------ -- The Haskell structure that we want to encapsulate type Key = String type Value = String data KeyValue = KeyValue !(Map.Map Key Value) deriving (Typeable) $(deriveSafeCopy 0 'base ''KeyValue) ------------------------------------------------------ -- The transaction we will execute over the state. insertKey :: Key -> Value -> Update KeyValue () insertKey key value = do KeyValue m <- get put (KeyValue (Map.insert key value m)) lookupKey :: Key -> Query KeyValue (Maybe Value) lookupKey key = do KeyValue m <- ask return (Map.lookup key m) $(makeAcidic ''KeyValue ['insertKey, 'lookupKey]) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do args <- getArgs acid <- openLocalState (KeyValue Map.empty) case args of [key] -> do mbKey <- query acid (LookupKey key) case mbKey of Nothing -> putStrLn $ key ++ " has no associated value." Just value -> putStrLn $ key ++ " = " ++ value [key,val] -> do update acid (InsertKey key val) putStrLn "Done." _ -> do putStrLn "Usage:" putStrLn " key Lookup the value of 'key'." putStrLn " key value Set the value of 'key' to 'value'." closeAcidState acid acid-state-0.14.2/examples/KeyValueNoTH.hs0000644000000000000000000000605712756631253016454 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Advanced import Control.Applicative import Control.Monad.Reader 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 ------------------------------------------------------ -- The Haskell structure that we want to encapsulate type Key = String type Value = String data KeyValue = KeyValue !(Map.Map Key Value) deriving (Typeable) instance SafeCopy KeyValue where putCopy (KeyValue state) = contain $ safePut state getCopy = contain $ liftM KeyValue safeGet ------------------------------------------------------ -- The transaction we will execute over the state. insertKey :: Key -> Value -> Update KeyValue () insertKey key value = do KeyValue m <- State.get State.put (KeyValue (Map.insert key value m)) lookupKey :: Key -> Query KeyValue (Maybe Value) lookupKey key = do KeyValue m <- ask return (Map.lookup key m) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do acid <- openLocalState (KeyValue Map.empty) args <- getArgs case args of [key] -> do mbKey <- query acid (LookupKey key) case mbKey of Nothing -> putStrLn $ key ++ " has no associated value." Just value -> putStrLn $ key ++ " = " ++ value [key,val] -> do update acid (InsertKey key val) putStrLn "Done." _ -> do putStrLn "Usage:" putStrLn " key Lookup the value of 'key'." putStrLn " key value Set the value of 'key' to 'value'." closeAcidState acid ------------------------------------------------------ -- The gritty details. These things may be done with -- Template Haskell in the future. 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 instance Method InsertKey where type MethodResult InsertKey = () 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 instance Method LookupKey where type MethodResult LookupKey = Maybe Value type MethodState LookupKey = KeyValue instance QueryEvent LookupKey instance IsAcidic KeyValue where acidEvents = [ UpdateEvent (\(InsertKey key value) -> insertKey key value) , QueryEvent (\(LookupKey key) -> lookupKey key) ] acid-state-0.14.2/examples/MultipleCheckpoint.hs0000644000000000000000000000463412756631253020000 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Control.Concurrent import Control.Monad.State import Data.SafeCopy import Data.Time import System.IO ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data SlowCheckpoint = SlowCheckpoint Int Int $(deriveSafeCopy 0 'base ''SlowCheckpoint) ------------------------------------------------------ -- The transaction we will execute over the state. -- This transaction adds a very computationally heavy entry -- into our state. However, since the state is lazy, the -- chunk will not be forced until we create a checkpoint. -- Computing 'last [0..100000000]' takes roughly 2 seconds -- on my machine. XXX Lemmih, 2011-04-26 setComputationallyHeavyData :: Update SlowCheckpoint () setComputationallyHeavyData = do SlowCheckpoint _slow tick <- get put $ SlowCheckpoint (last [0..100000000]) tick tick :: Update SlowCheckpoint Int tick = do SlowCheckpoint slow tick <- get put $ SlowCheckpoint slow (tick+1) return tick $(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick]) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do acid <- openLocalStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0) doTick acid createCheckpoint acid doTick acid createCheckpoint acid doTick acid createCheckpoint acid createArchive acid pure () {- update acid SetComputationallyHeavyData forkIO $ do putStrLn "Seriazing checkpoint..." t <- timeIt $ createCheckpoint acid t <- timeIt $ createCheckpoint acid putStrLn $ "Checkpoint created in: " ++ show t replicateM_ 20 $ do doTick acid threadDelay (10^5) -} -- threadDelay (10^6) -- tick <- update acid Tick -- threadDelay (10^6) -- createArchive acid doTick acid = do tick <- update acid Tick putStrLn $ "Tick: " ++ show tick timeIt action = do t1 <- getCurrentTime ret <- action t2 <- getCurrentTime return (diffUTCTime t2 t1) acid-state-0.14.2/examples/Proxy.hs0000644000000000000000000000603712756631253015315 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Advanced (scheduleUpdate) import Data.Acid.Remote import Control.Monad.Reader import Control.Monad.State 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) ------------------------------------------------------ -- The transaction we will execute over the state. pokeState :: Update ProxyStressState () pokeState = do StressState i <- get put (StressState (i+1)) queryState :: Query ProxyStressState Int queryState = do StressState i <- ask return i clearState :: Update ProxyStressState () clearState = put $ StressState 0 $(makeAcidic ''ProxyStressState ['pokeState, 'queryState, 'clearState]) openLocal :: IO (AcidState ProxyStressState) openLocal = openLocalState (StressState 0) openRemote :: String -> IO (AcidState ProxyStressState) openRemote socket = openRemoteState skipAuthenticationPerform "localhost" (UnixSocket socket) main :: IO () main = do args <- getArgs case args of ["server", socket] -> do acid <- openLocal acidServer skipAuthenticationCheck (UnixSocket socket) acid ["proxy", from, to] -> do acid <- openRemote from acidServer skipAuthenticationCheck (UnixSocket to) acid ["query", socket] -> do acid <- openRemote socket n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke", socket] -> do acid <- openRemote socket putStr "Issuing 100k transactions... " hFlush stdout replicateM_ (100000-1) (scheduleUpdate acid PokeState) update acid PokeState putStrLn "Done" ["clear", socket] -> do acid <- openRemote socket update acid ClearState createCheckpoint acid ["checkpoint", socket] -> do acid <- openRemote socket createCheckpoint acid _ -> do putStrLn "Commands:" putStrLn " server socket Start a new server instance." putStrLn " proxy from to Pipe events between 'from' and 'to'." putStrLn " query socket Prints out the current state." putStrLn " poke socket Spawn 100k transactions." putStrLn " clear socket Reset the state and write a checkpoint." putStrLn " checkpoint socket Create a new checkpoint." acid-state-0.14.2/examples/RemoteClient.hs0000644000000000000000000000276012756631253016565 0ustar0000000000000000module Main (main) where import Control.Monad.Reader import Data.Acid import Data.Acid.Advanced import Data.Acid.Remote import Network import RemoteCommon import System.Environment import System.IO ------------------------------------------------------ -- This is how AcidState is used: open :: IO (AcidState StressState) open = openRemoteState skipAuthenticationPerform "localhost" (PortNumber 8080) main :: IO () main = do args <- getArgs case args of ["checkpoint"] -> do acid <- open createCheckpoint acid ["query"] -> do acid <- open n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] -> do acid <- open putStr "Issuing 100k transactions... " hFlush stdout replicateM_ (100000-1) (scheduleUpdate acid PokeState) update acid PokeState putStrLn "Done" ["clear"] -> do acid <- open update acid ClearState createCheckpoint acid _ -> do putStrLn "Commands:" putStrLn " query Prints out the current state." putStrLn " poke Spawn 100k transactions." putStrLn " checkpoint Create a new checkpoint." acid-state-0.14.2/examples/RemoteCommon.hs0000644000000000000000000000170212756631253016572 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module RemoteCommon where import Control.Monad.Reader 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) $(deriveSafeCopy 0 'base ''StressState) ------------------------------------------------------ -- The transaction we will execute over the state. pokeState :: Update StressState () pokeState = do StressState i <- get put (StressState (i+1)) queryState :: Query StressState Int queryState = do StressState i <- ask return i clearState :: Update StressState () clearState = put $ StressState 0 $(makeAcidic ''StressState ['pokeState, 'queryState, 'clearState]) acid-state-0.14.2/examples/RemoteServer.hs0000644000000000000000000000070012756631253016605 0ustar0000000000000000module Main where import Control.Exception (bracket) import Data.Acid (closeAcidState, openLocalState) import Data.Acid.Remote (acidServer, skipAuthenticationCheck) import Network (PortID (..)) import RemoteCommon (StressState (..)) main :: IO () main = bracket (openLocalState $ StressState 0) closeAcidState $ acidServer skipAuthenticationCheck (PortNumber 8080) acid-state-0.14.2/examples/SlowCheckpoint.hs0000644000000000000000000000467412756631253017135 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Control.Concurrent import Control.Monad.State import Data.SafeCopy import Data.Time import System.IO ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data SlowCheckpoint = SlowCheckpoint Int Int $(deriveSafeCopy 0 'base ''SlowCheckpoint) ------------------------------------------------------ -- The transaction we will execute over the state. -- This transaction adds a very computationally heavy entry -- into our state. However, since the state is lazy, the -- chunk will not be forced until we create a checkpoint. -- Computing 'last [0..100000000]' takes roughly 2 seconds -- on my machine. XXX Lemmih, 2011-04-26 setComputationallyHeavyData :: Update SlowCheckpoint () setComputationallyHeavyData = do SlowCheckpoint _slow tick <- get put $ SlowCheckpoint (last [0..100000000]) tick tick :: Update SlowCheckpoint Int tick = do SlowCheckpoint slow tick <- get put $ SlowCheckpoint slow (tick+1) return tick $(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick]) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do acid <- openLocalStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0) putStrLn "This example illustrates that the state is still accessible while" putStrLn "a checkpoint is being serialized. This is an important property when" putStrLn "the size of a checkpoint reaches several hundred megabytes." putStrLn "If you don't see any ticks while the checkpoint is being created, something" putStrLn "has gone awry." putStrLn "" doTick acid update acid SetComputationallyHeavyData forkIO $ do putStrLn "Seriazing checkpoint..." t <- timeIt $ createCheckpoint acid putStrLn $ "Checkpoint created in: " ++ show t replicateM_ 20 $ do doTick acid threadDelay (10^5) doTick acid = do tick <- update acid Tick putStrLn $ "Tick: " ++ show tick timeIt action = do t1 <- getCurrentTime ret <- action t2 <- getCurrentTime return (diffUTCTime t2 t1) acid-state-0.14.2/examples/StressTest.hs0000644000000000000000000000403112756631253016307 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Advanced (groupUpdates) import Control.Monad.Reader import Control.Monad.State 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) $(deriveSafeCopy 0 'base ''StressState) ------------------------------------------------------ -- The transaction we will execute over the state. pokeState :: Update StressState () pokeState = do StressState i <- get put (StressState (i+1)) queryState :: Query StressState Int queryState = do StressState i <- ask return i clearState :: Update StressState () clearState = put $ StressState 0 $(makeAcidic ''StressState ['pokeState, 'queryState, 'clearState]) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do args <- getArgs acid <- openLocalState (StressState 0) case args of ["checkpoint"] -> createCheckpoint acid ["query"] -> do n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] -> do putStr "Issuing 100k transactions... " hFlush stdout groupUpdates acid (replicate 100000 PokeState) putStrLn "Done" ["clear"] -> do update acid ClearState createCheckpoint acid _ -> do putStrLn "Commands:" putStrLn " query Prints out the current state." putStrLn " poke Spawn 100k transactions." putStrLn " checkpoint Create a new checkpoint." acid-state-0.14.2/examples/StressTestNoTH.hs0000644000000000000000000000552312756631253017047 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Advanced import Control.Monad.Reader import Control.Monad.State 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 getCopy = contain $ liftM StressState safeGet ------------------------------------------------------ -- The transaction we will execute over the state. pokeState :: Update StressState () pokeState = do StressState i <- get put (StressState (i+1)) queryState :: Query StressState Int queryState = do StressState i <- ask return i ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do args <- getArgs acid <- openLocalState (StressState 0) case args of ["checkpoint"] -> createCheckpoint acid ["query"] -> do n <- query acid QueryState putStrLn $ "State value: " ++ show n ["poke"] -> do putStr "Issuing 100k transactions... " hFlush stdout groupUpdates acid (replicate 100000 PokeState) putStrLn "Done" _ -> do putStrLn "Commands:" putStrLn " query Prints out the current state." putStrLn " poke Spawn 100k transactions." putStrLn " checkpoint Create a new checkpoint." ------------------------------------------------------ -- The gritty details. These things may be done with -- Template Haskell in the future. data PokeState = PokeState data QueryState = QueryState deriving instance Typeable PokeState instance SafeCopy PokeState where putCopy PokeState = contain $ return () getCopy = contain $ return PokeState instance Method PokeState where type MethodResult PokeState = () type MethodState PokeState = StressState instance UpdateEvent PokeState deriving instance Typeable QueryState instance SafeCopy QueryState where putCopy QueryState = contain $ return () getCopy = contain $ return QueryState instance Method QueryState where type MethodResult QueryState = Int type MethodState QueryState = StressState instance QueryEvent QueryState instance IsAcidic StressState where acidEvents = [ UpdateEvent (\PokeState -> pokeState) , QueryEvent (\QueryState -> queryState) ] acid-state-0.14.2/examples/errors/0000755000000000000000000000000012756631253015146 5ustar0000000000000000acid-state-0.14.2/examples/errors/ChangeState.hs0000644000000000000000000000325312756631253017673 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Control.Monad.State import Data.SafeCopy import System.Environment import Data.Typeable import Control.Exception import Prelude hiding (catch) import qualified Data.Text as Text ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data FirstState = FirstState String deriving (Show) data SecondState = SecondState Text.Text deriving (Show) $(deriveSafeCopy 0 'base ''FirstState) $(deriveSafeCopy 0 'base ''SecondState) ------------------------------------------------------ -- The transaction we will execute over the state. $(makeAcidic ''FirstState []) $(makeAcidic ''SecondState []) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do putStrLn "This example simulates what happens when you modify your state type" putStrLn "without telling AcidState how to migrate from the old version to the new." putStrLn "Hopefully this program will fail with a readable error message." putStrLn "" firstAcid <- openLocalStateFrom "state/ChangeState" (FirstState "first state") createCheckpoint firstAcid closeAcidState firstAcid secondAcid <- openLocalStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used")) closeAcidState secondAcid putStrLn "If you see this message then something has gone wrong!" acid-state-0.14.2/examples/errors/Exceptions.hs0000644000000000000000000000465412756631253017634 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Data.Acid.Local (createCheckpointAndClose) import Control.Monad.State import Data.SafeCopy import System.Environment import Data.Typeable import Control.Exception import Prelude hiding (catch) ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data MyState = MyState Integer deriving (Show, Typeable) $(deriveSafeCopy 0 'base ''MyState) ------------------------------------------------------ -- The transaction we will execute over the state. failEvent :: Update MyState () failEvent = fail "fail!" errorEvent :: Update MyState () errorEvent = error "error!" stateError :: Update MyState () stateError = put (error "state error!") stateNestedError1 :: Update MyState () stateNestedError1 = put (MyState (error "nested state error (1)")) stateNestedError2 :: Integer -> Update MyState () stateNestedError2 n = put (MyState n) tick :: Update MyState Integer tick = do MyState n <- get put $ MyState (n+1) return n $(makeAcidic ''MyState [ 'failEvent , 'errorEvent , 'stateError , 'stateNestedError1 , 'stateNestedError2 , 'tick ]) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do acid <- openLocalStateFrom "state/Exceptions" (MyState 0) args <- getArgs case args of ["1"] -> update acid (undefined :: FailEvent) ["2"] -> update acid FailEvent ["3"] -> update acid ErrorEvent ["4"] -> update acid StateError ["5"] -> update acid StateNestedError1 ["6"] -> update acid (StateNestedError2 (error "nested state error (2)")) _ -> do putStrLn "Call with [123456] to test error scenarios." putStrLn "If the tick doesn't get stuck, everything is fine." n <- update acid Tick putStrLn $ "Tick: " ++ show n `catch` \e -> do putStrLn $ "Caught exception: " ++ show (e:: SomeException) createCheckpointAndClose acid acid-state-0.14.2/examples/errors/RemoveEvent.hs0000644000000000000000000000310612756631253017741 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where import Data.Acid import Control.Monad.State import Data.SafeCopy import System.Environment import Data.Typeable import Control.Exception import Prelude hiding (catch) ------------------------------------------------------ -- The Haskell structure that we want to encapsulate data FirstState = FirstState deriving (Show) data SecondState = SecondState deriving (Show) $(deriveSafeCopy 0 'base ''FirstState) $(deriveSafeCopy 0 'base ''SecondState) ------------------------------------------------------ -- The transaction we will execute over the state. firstEvent :: Update FirstState () firstEvent = return () $(makeAcidic ''FirstState ['firstEvent]) $(makeAcidic ''SecondState []) ------------------------------------------------------ -- This is how AcidState is used: main :: IO () main = do putStrLn "This example simulates what happens when you remove an event" putStrLn "that is required to replay the journal." putStrLn "Hopefully this program will fail with a readable error message." putStrLn "" firstAcid <- openLocalStateFrom "state/RemoveEvent" FirstState update firstAcid FirstEvent closeAcidState firstAcid secondAcid <- openLocalStateFrom "state/RemoveEvent" SecondState closeAcidState secondAcid putStrLn "If you see this message then something has gone wrong!" acid-state-0.14.2/src/0000755000000000000000000000000012756631253012603 5ustar0000000000000000acid-state-0.14.2/src/Data/0000755000000000000000000000000012756631253013454 5ustar0000000000000000acid-state-0.14.2/src/Data/Acid.hs0000644000000000000000000000147112756631253014653 0ustar0000000000000000----------------------------------------------------------------------------- {- | Module : Data.Acid Copyright : PublicDomain Maintainer : lemmih@gmail.com Portability : non-portable (uses GHC extensions) AcidState container using a transaction log on disk. To see how it all fits together, have a look at these example . -} module Data.Acid ( AcidState , openLocalState , openLocalStateFrom , closeAcidState , createCheckpoint , createArchive , update , query , EventResult , EventState , UpdateEvent , QueryEvent , Update , Query , IsAcidic , makeAcidic , liftQuery ) where import Data.Acid.Local import Data.Acid.Common import Data.Acid.Abstract import Data.Acid.TemplateHaskell acid-state-0.14.2/src/Data/Acid/0000755000000000000000000000000012756631253014314 5ustar0000000000000000acid-state-0.14.2/src/Data/Acid/Abstract.hs0000644000000000000000000001357412756631253016425 0ustar0000000000000000{-# LANGUAGE RankNTypes, TypeFamilies, GADTs, CPP #-} module Data.Acid.Abstract ( AcidState(..) , scheduleUpdate , groupUpdates , update , update' , query , query' , mkAnyState , downcast ) where import Data.Acid.Common import Data.Acid.Core import Control.Concurrent ( MVar, takeMVar ) 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) 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 unexpected system shutdowns (both those caused by hardware and software). -} data AcidState st = AcidState { _scheduleUpdate :: forall event. (UpdateEvent event, EventState event ~ st) => event -> IO (MVar (EventResult event)) , scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString) , _query :: forall event. (QueryEvent event, EventState event ~ st) => event -> IO (EventResult event) , queryCold :: Tagged ByteString -> IO ByteString , -- | Take a snapshot of the state and save it to disk. Creating checkpoints -- makes it faster to resume AcidStates and you're free to create them as -- often or seldom as fits your needs. Transactions can run concurrently -- with this call. -- -- This call will not return until the operation has succeeded. createCheckpoint :: IO () -- | Move all log files that are no longer necessary for state restoration into the 'Archive' -- folder in the state directory. This folder can then be backed up or thrown out as you see fit. -- Reverting to a state before the last checkpoint will not be possible if the 'Archive' folder -- has been thrown out. -- -- This method is idempotent and does not block the normal operation of the AcidState. , createArchive :: IO () , -- | Close an AcidState and associated resources. -- Any subsequent usage of the AcidState will throw an exception. closeAcidState :: IO () , acidSubState :: AnyState st } -- | 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. -- 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: -- -- @ --do scheduleUpdate acid EventA -- scheduleUpdate acid EventB -- @ scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleUpdate = _scheduleUpdate -- 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 -- datasets into an AcidState. groupUpdates :: UpdateEvent event => AcidState (EventState event) -> [event] -> IO () groupUpdates acidState events = go events where go [] = return () go [x] = void $ update acidState x go (x:xs) = scheduleUpdate acidState x >> go xs -- | Issue an Update event and wait for its result. Once this call returns, you are -- guaranteed that the changes to the state are durable. Events may be issued in -- parallel. -- -- It's a run-time error to issue events that aren't supported by the AcidState. update :: UpdateEvent event => AcidState (EventState event) -> event -> IO (EventResult event) update acidState event = takeMVar =<< scheduleUpdate acidState event -- | Same as 'update' but lifted into any monad capable of doing IO. update' :: (UpdateEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) update' acidState event = liftIO (update acidState event) -- | 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. -- | 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 where r = case gcast (Just sub) of Just (Just x) -> x _ -> error $ "Data.Acid: 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: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r) #endif acid-state-0.14.2/src/Data/Acid/Advanced.hs0000644000000000000000000000077512756631253016366 0ustar0000000000000000----------------------------------------------------------------------------- {- | Module : Data.Acid.Advanced Copyright : PublicDomain Maintainer : lemmih@gmail.com Portability : non-portable (uses GHC extensions) Home of the more specialized functions. -} module Data.Acid.Advanced ( scheduleUpdate , groupUpdates , update' , query' , Method(..) , IsAcidic(..) , Event(..) ) where import Data.Acid.Abstract import Data.Acid.Core import Data.Acid.Common acid-state-0.14.2/src/Data/Acid/Archive.hs0000644000000000000000000000571212756631253016236 0ustar0000000000000000{-# LANGUAGE DoAndIfThenElse #-} {- Format: |content length| crc16 | content | |8 bytes | 2 bytes | n bytes | -} module Data.Acid.Archive ( Entry , Entries(..) , putEntries , packEntries , readEntries , entriesToList , entriesToListNoFail ) where import Data.Acid.CRC import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Builder import Data.Monoid import Data.Serialize.Get hiding (Result (..)) import qualified Data.Serialize.Get as Serialize type Entry = Lazy.ByteString data Entries = Done | Next Entry Entries | Fail String deriving (Show) entriesToList :: Entries -> [Entry] entriesToList Done = [] entriesToList (Next entry next) = entry : entriesToList next entriesToList (Fail msg) = error msg entriesToListNoFail :: Entries -> [Entry] entriesToListNoFail Done = [] entriesToListNoFail (Next entry next) = entry : entriesToListNoFail next entriesToListNoFail Fail{} = [] putEntry :: Entry -> Builder putEntry content = word64LE contentLength !<> word16LE contentHash !<> lazyByteString content where contentLength = fromIntegral $ Lazy.length content contentHash = crc16 content a !<> b = let c = a <> b in c `seq` c putEntries :: [Entry] -> Builder putEntries = mconcat . map putEntry packEntries :: [Entry] -> Lazy.ByteString packEntries = toLazyByteString . putEntries readEntries :: Lazy.ByteString -> Entries readEntries bs = worker (Lazy.toChunks bs) where worker [] = Done worker (x:xs) = check (runGetPartial readEntry x) xs check result more = case result of Serialize.Done entry rest | Strict.null rest -> Next entry (worker more) | otherwise -> Next entry (worker (rest:more)) Serialize.Fail msg _ -> Fail msg Serialize.Partial cont -> case more of [] -> check (cont Strict.empty) [] (x:xs) -> check (cont x) xs readEntry :: Get Entry readEntry = do contentLength <- getWord64le contentChecksum <-getWord16le content <- getLazyByteString_fast (fromIntegral contentLength) if crc16 content /= contentChecksum then fail "Invalid hash" else return content -- | Read a lazy bytestring WITHOUT any copying or concatenation. getLazyByteString_fast :: Int -> Get Lazy.ByteString getLazyByteString_fast = worker 0 [] where worker counter acc n = do rem <- remaining if n > rem then do chunk <- getBytes rem _ <- ensure 1 worker (counter + rem) (chunk:acc) (n-rem) else do chunk <- getBytes n return $ Lazy.fromChunks (reverse $ chunk:acc) acid-state-0.14.2/src/Data/Acid/Common.hs0000644000000000000000000000575712756631253016116 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Common -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- Common structures used by the various backends (local, memory). -- module Data.Acid.Common where import Data.Acid.Core import Control.Monad.State import Control.Monad.Reader import Data.ByteString.Lazy ( ByteString ) import Data.SafeCopy import Data.Serialize ( Get, runGet, runGetLazy ) import Control.Applicative import qualified Data.ByteString as Strict -- Silly fix for bug in cereal-0.3.3.0's version of runGetLazy. runGetLazyFix :: Get a -> ByteString -> Either String a runGetLazyFix getter inp = case runGet getter Strict.empty of Left _msg -> runGetLazy getter inp Right val -> Right val class (SafeCopy st) => IsAcidic st where acidEvents :: [Event st] -- ^ List of events capable of updating or querying the state. -- | Context monad for Update events. newtype Update st a = Update { unUpdate :: State st a } deriving (Monad, Functor, MonadState st) -- mtl pre-2.0 doesn't have these instances to newtype-derive, but they're -- simple enough. instance Applicative (Update st) where pure = return (<*>) = ap -- | Context monad for Query events. newtype Query st a = Query { unQuery :: Reader st a } deriving (Monad, Functor, MonadReader st) instance Applicative (Query st) where pure = return (<*>) = ap -- | Run a query in the Update Monad. liftQuery :: Query st a -> Update st a liftQuery query = do st <- get return (runReader (unQuery query) st) -- | Events return the same thing as Methods. The exact type of 'EventResult' -- depends on the event. type EventResult ev = MethodResult ev type EventState ev = MethodState ev -- | We distinguish between events that modify the state and those that do not. -- -- UpdateEvents are executed in a MonadState context and have to be serialized -- to disk before they are considered durable. -- -- QueryEvents are executed in a MonadReader context and obviously do not have -- to be serialized to disk. data Event st where UpdateEvent :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> Event (EventState ev) QueryEvent :: QueryEvent ev => (ev -> Query (EventState ev) (EventResult ev)) -> Event (EventState ev) -- | All UpdateEvents are also Methods. class Method ev => UpdateEvent ev -- | All QueryEvents are also Methods. class Method ev => QueryEvent ev eventsToMethods :: [Event st] -> [MethodContainer st] eventsToMethods = map worker where worker :: Event st -> MethodContainer st worker (UpdateEvent fn) = Method (unUpdate . fn) worker (QueryEvent fn) = Method (\ev -> do st <- get return (runReader (unQuery $ fn ev) st) ) acid-state-0.14.2/src/Data/Acid/Core.hs0000644000000000000000000002052212756631253015541 0ustar0000000000000000{-# LANGUAGE CPP, GADTs, DeriveDataTypeable, TypeFamilies, FlexibleContexts, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Core -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- Low-level controls for transaction-based state changes. This module defines -- structures and tools for running state modifiers indexed either by an Method -- or a serialized Method. This module should rarely be used directly although -- the 'Method' class is needed when defining events manually. -- -- The term \'Event\' is loosely used for transactions with ACID guarantees. -- \'Method\' is loosely used for state operations without ACID guarantees -- module Data.Acid.Core ( Core(coreMethods) , Method(..) , MethodContainer(..) , Tagged , mkCore , closeCore , closeCore' , modifyCoreState , modifyCoreState_ , withCoreState , lookupHotMethod , lookupColdMethod , runHotMethod , runColdMethod , MethodMap , mkMethodMap ) where import Control.Concurrent ( MVar, newMVar, withMVar , modifyMVar, modifyMVar_ ) import Control.Monad ( liftM ) import Control.Monad.State ( State, runState ) import qualified Data.Map as Map 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, typeOf ) import Unsafe.Coerce ( unsafeCoerce ) #if MIN_VERSION_base(4,4,0) import Data.Typeable.Internal ( TypeRep (..), tyConModule ) -- 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 -- of base. We could do something better, but happstack-state is -- end-of-life anyway. showQualifiedTypeRep :: TypeRep -> String showQualifiedTypeRep tr = tyConModule con ++ "." ++ show tr where con = extractTypeRepCon tr #if MIN_VERSION_base(4,8,0) extractTypeRepCon (TypeRep _ c _ _) = c #else extractTypeRepCon (TypeRep _ c _) = c #endif #else showQualifiedTypeRep :: TypeRep -> String showQualifiedTypeRep tr = show tr #endif -- | The basic Method class. Each Method has an indexed result type -- and a unique tag. class ( Typeable ev, SafeCopy ev , Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => Method ev where type MethodResult ev type MethodState ev methodTag :: ev -> Tag methodTag ev = Lazy.pack (showQualifiedTypeRep (typeOf ev)) -- | The control structure at the very center of acid-state. -- This module provides access to a mutable state through -- methods. No efforts towards durability, checkpointing or -- sharding happens at this level. -- Important things to keep in mind in this module: -- * We don't distinguish between updates and queries. -- * We allow direct access to the core state as well -- as through events. data Core st = Core { coreState :: MVar st , coreMethods :: MethodMap st } -- | Construct a new Core using an initial state and a list of Methods. mkCore :: [MethodContainer st] -- ^ List of methods capable of modifying the state. -> st -- ^ Initial state value. -> IO (Core st) mkCore methods initialValue = do mvar <- newMVar initialValue return Core{ coreState = mvar , coreMethods = mkMethodMap methods } -- | Mark Core as closed. Any subsequent use will throw an exception. closeCore :: Core st -> IO () closeCore core = closeCore' core (\_st -> return ()) -- | Access the state and then mark the Core as closed. Any subsequent use -- will throw an exception. closeCore' :: Core st -> (st -> IO ()) -> IO () closeCore' core action = modifyMVar_ (coreState core) $ \st -> do action st return errorMsg where errorMsg = error "Access failure: Core closed." -- | Modify the state component. The resulting state is ensured to be in -- WHNF. modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a modifyCoreState core action = modifyMVar (coreState core) $ \st -> do (!st', a) <- action st return (st', a) -- | Modify the state component. The resulting state is ensured to be in -- WHNF. modifyCoreState_ :: Core st -> (st -> IO st) -> IO () modifyCoreState_ core action = modifyMVar_ (coreState core) $ \st -> do !st' <- action st return st' -- | Access the state component. withCoreState :: Core st -> (st -> IO a) -> IO a withCoreState core = withMVar (coreState core) -- | Execute a method as given by a type identifier and an encoded string. -- The exact format of the encoded string depends on the type identifier. -- Results are encoded and type tagged before they're handed back out. -- This function is used when running events from a log-file or from another -- server. Events that originate locally are most likely executed with -- the faster 'runHotMethod'. runColdMethod :: Core st -> Tagged Lazy.ByteString -> IO Lazy.ByteString runColdMethod core taggedMethod = modifyCoreState core $ \st -> do let (a, st') = runState (lookupColdMethod core taggedMethod) st return ( st', a) -- | Find the state action that corresponds to a tagged and serialized method. lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> State st Lazy.ByteString lookupColdMethod core (storedMethodTag, methodContent) = case Map.lookup storedMethodTag (coreMethods core) of Nothing -> missingMethod storedMethodTag Just (Method method) -> liftM (runPutLazy . safePut) (method (lazyDecode methodContent)) lazyDecode :: SafeCopy a => Lazy.ByteString -> a lazyDecode inp = case runGetLazy safeGet inp of Left msg -> error msg Right val -> val missingMethod :: Tag -> a missingMethod tag = error msg where msg = "This method is required but not available: " ++ show (Lazy.unpack tag) ++ ". Did you perhaps remove it before creating a checkpoint?" -- | Apply an in-memory method to the state. runHotMethod :: Method method => Core (MethodState method) -> method -> IO (MethodResult method) runHotMethod core method = modifyCoreState core $ \st -> do let (a, st') = runState (lookupHotMethod (coreMethods core) method) st return ( st', a) -- | Find the state action that corresponds to an in-memory method. lookupHotMethod :: Method method => MethodMap (MethodState method) -> method -> State (MethodState method) (MethodResult method) lookupHotMethod methodMap method = case Map.lookup (methodTag method) methodMap of Nothing -> missingMethod (methodTag method) Just (Method methodHandler) -> -- If the methodTag doesn't index the right methodHandler then we're in deep -- trouble. Luckly, it would take deliberate malevolence for that to happen. unsafeCoerce methodHandler method -- | Method tags must be unique and are most commonly generated automatically. type Tag = Lazy.ByteString type Tagged a = (Tag, a) -- | Method container structure that hides the exact type of the method. data MethodContainer st where Method :: (Method method) => (method -> State (MethodState method) (MethodResult method)) -> MethodContainer (MethodState method) -- | Collection of Methods indexed by a Tag. type MethodMap st = Map.Map Tag (MethodContainer st) -- | Construct a 'MethodMap' from a list of Methods using their associated tag. mkMethodMap :: [MethodContainer st] -> MethodMap st mkMethodMap methods = Map.fromList [ (methodType method, method) | method <- methods ] where -- A little bit of ugliness is required to access the methodTags. methodType :: MethodContainer st -> Tag methodType m = case m of Method fn -> let ev :: (ev -> State st res) -> ev ev _ = undefined in methodTag (ev fn) acid-state-0.14.2/src/Data/Acid/CRC.hs0000644000000000000000000000574312756631253015270 0ustar0000000000000000{- CRC16 checksum inspired by http://hackage.haskell.org/package/crc16-table As of 2011-04-13, this module is about 20x faster than crc16-table. -} module Data.Acid.CRC ( crc16 ) where import Data.Word ( Word16 ) import Data.Array.Unboxed ( UArray, listArray ) import Data.Array.Base ( unsafeAt ) import Data.Bits ( Bits(..) ) import qualified Data.ByteString.Lazy as Lazy ( ByteString, foldl' ) tableList :: [Word16] tableList = [0x00000,0x01189,0x02312,0x0329B,0x04624,0x057AD,0x06536,0x074BF, 0x08C48,0x09DC1,0x0AF5A,0x0BED3,0x0CA6C,0x0DBE5,0x0E97E,0x0F8F7, 0x01081,0x00108,0x03393,0x0221A,0x056A5,0x0472C,0x075B7,0x0643E, 0x09CC9,0x08D40,0x0BFDB,0x0AE52,0x0DAED,0x0CB64,0x0F9FF,0x0E876, 0x02102,0x0308B,0x00210,0x01399,0x06726,0x076AF,0x04434,0x055BD, 0x0AD4A,0x0BCC3,0x08E58,0x09FD1,0x0EB6E,0x0FAE7,0x0C87C,0x0D9F5, 0x03183,0x0200A,0x01291,0x00318,0x077A7,0x0662E,0x054B5,0x0453C, 0x0BDCB,0x0AC42,0x09ED9,0x08F50,0x0FBEF,0x0EA66,0x0D8FD,0x0C974, 0x04204,0x0538D,0x06116,0x0709F,0x00420,0x015A9,0x02732,0x036BB, 0x0CE4C,0x0DFC5,0x0ED5E,0x0FCD7,0x08868,0x099E1,0x0AB7A,0x0BAF3, 0x05285,0x0430C,0x07197,0x0601E,0x014A1,0x00528,0x037B3,0x0263A, 0x0DECD,0x0CF44,0x0FDDF,0x0EC56,0x098E9,0x08960,0x0BBFB,0x0AA72, 0x06306,0x0728F,0x04014,0x0519D,0x02522,0x034AB,0x00630,0x017B9, 0x0EF4E,0x0FEC7,0x0CC5C,0x0DDD5,0x0A96A,0x0B8E3,0x08A78,0x09BF1, 0x07387,0x0620E,0x05095,0x0411C,0x035A3,0x0242A,0x016B1,0x00738, 0x0FFCF,0x0EE46,0x0DCDD,0x0CD54,0x0B9EB,0x0A862,0x09AF9,0x08B70, 0x08408,0x09581,0x0A71A,0x0B693,0x0C22C,0x0D3A5,0x0E13E,0x0F0B7, 0x00840,0x019C9,0x02B52,0x03ADB,0x04E64,0x05FED,0x06D76,0x07CFF, 0x09489,0x08500,0x0B79B,0x0A612,0x0D2AD,0x0C324,0x0F1BF,0x0E036, 0x018C1,0x00948,0x03BD3,0x02A5A,0x05EE5,0x04F6C,0x07DF7,0x06C7E, 0x0A50A,0x0B483,0x08618,0x09791,0x0E32E,0x0F2A7,0x0C03C,0x0D1B5, 0x02942,0x038CB,0x00A50,0x01BD9,0x06F66,0x07EEF,0x04C74,0x05DFD, 0x0B58B,0x0A402,0x09699,0x08710,0x0F3AF,0x0E226,0x0D0BD,0x0C134, 0x039C3,0x0284A,0x01AD1,0x00B58,0x07FE7,0x06E6E,0x05CF5,0x04D7C, 0x0C60C,0x0D785,0x0E51E,0x0F497,0x08028,0x091A1,0x0A33A,0x0B2B3, 0x04A44,0x05BCD,0x06956,0x078DF,0x00C60,0x01DE9,0x02F72,0x03EFB, 0x0D68D,0x0C704,0x0F59F,0x0E416,0x090A9,0x08120,0x0B3BB,0x0A232, 0x05AC5,0x04B4C,0x079D7,0x0685E,0x01CE1,0x00D68,0x03FF3,0x02E7A, 0x0E70E,0x0F687,0x0C41C,0x0D595,0x0A12A,0x0B0A3,0x08238,0x093B1, 0x06B46,0x07ACF,0x04854,0x059DD,0x02D62,0x03CEB,0x00E70,0x01FF9, 0x0F78F,0x0E606,0x0D49D,0x0C514,0x0B1AB,0x0A022,0x092B9,0x08330, 0x07BC7,0x06A4E,0x058D5,0x0495C,0x03DE3,0x02C6A,0x01EF1,0x00F78] table :: UArray Word16 Word16 table = listArray (0,255) tableList crc16 :: Lazy.ByteString -> Word16 crc16 = table `seq` complement . Lazy.foldl' worker 0xFFFF where worker acc x = (acc `shiftR` 8) `xor` (table `unsafeAt` idx) where idx = fromIntegral ((acc `xor` fromIntegral x) .&. 0xFF) acid-state-0.14.2/src/Data/Acid/Local.hs0000644000000000000000000004146312756631253015712 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Local -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- AcidState container using a transaction log on disk. The term \'Event\' is -- loosely used for transactions with ACID guarantees. \'Method\' is loosely -- used for state operations without ACID guarantees (see "Data.Acid.Core"). -- module Data.Acid.Local ( openLocalState , openLocalStateFrom , prepareLocalState , prepareLocalStateFrom , scheduleLocalUpdate' , scheduleLocalColdUpdate' , createCheckpointAndClose , LocalState(..) , Checkpoint(..) ) where import Data.Acid.Log as Log import Data.Acid.Core import Data.Acid.Common import Data.Acid.Abstract import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) import Control.Exception ( onException, evaluate ) 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 ) import Data.Serialize ( runPutLazy, runGetLazy ) import Data.SafeCopy ( SafeCopy(..), safeGet, safePut , primitive, contain ) import Data.Typeable ( Typeable, typeOf ) import Data.IORef import System.FilePath ( () ) import FileIO ( obtainPrefixLock, releasePrefixLock, PrefixLock ) {-| 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). -} data LocalState st = LocalState { localCore :: Core st , localCopy :: IORef st , localEvents :: FileLog (Tagged ByteString) , localCheckpoints :: FileLog Checkpoint , localLock :: PrefixLock } deriving (Typeable) -- | 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. -- 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: -- -- @ --do scheduleUpdate acid EventA -- scheduleUpdate acid EventB -- @ scheduleLocalUpdate :: UpdateEvent event => LocalState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleLocalUpdate acidState event = do mvar <- newEmptyMVar let encoded = runPutLazy (safePut event) -- It is important that we encode the event now so that we can catch -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs) evaluate (Lazy.length encoded) modifyCoreState_ (localCore acidState) $ \st -> do let !(result, !st') = runState hotMethod st -- Schedule the log entry. Very important that it happens when 'localCore' is locked -- to ensure that events are logged in the same order that they are executed. pushEntry (localEvents acidState) (methodTag event, encoded) $ do writeIORef (localCopy acidState) st' putMVar mvar result return st' return mvar where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event -- | Same as scheduleLocalUpdate but does not immediately change the localCopy -- and return the result mvar - returns an IO action to do this instead. Take -- care to run actions of multiple Updates in the correct order as otherwise -- Queries will operate on outdated state. scheduleLocalUpdate' :: UpdateEvent event => LocalState (EventState event) -> event -> MVar (EventResult event) -> IO (IO ()) scheduleLocalUpdate' acidState event mvar = do let encoded = runPutLazy (safePut event) -- It is important that we encode the event now so that we can catch -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs) evaluate (Lazy.length encoded) act <- modifyCoreState (localCore acidState) $ \st -> do let !(result, !st') = runState hotMethod st -- Schedule the log entry. Very important that it happens when 'localCore' is locked -- to ensure that events are logged in the same order that they are executed. pushEntry (localEvents acidState) (methodTag event, encoded) $ return () let action = do writeIORef (localCopy acidState) st' putMVar mvar result return (st', action) -- this is the action to update state for queries and release the -- result into the supplied mvar return act where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event scheduleLocalColdUpdate :: LocalState st -> Tagged ByteString -> IO (MVar ByteString) scheduleLocalColdUpdate acidState event = do mvar <- newEmptyMVar modifyCoreState_ (localCore acidState) $ \st -> do let !(result, !st') = runState coldMethod st -- Schedule the log entry. Very important that it happens when 'localCore' is locked -- to ensure that events are logged in the same order that they are executed. pushEntry (localEvents acidState) event $ do writeIORef (localCopy acidState) st' putMVar mvar result return st' return mvar where coldMethod = lookupColdMethod (localCore acidState) event -- | Same as scheduleLocalColdUpdate but does not immediately change the -- localCopy and return the result mvar - returns an IO action to do this -- instead. Take care to run actions of multiple Updates in the correct order as -- otherwise Queries will operate on outdated state. scheduleLocalColdUpdate' :: LocalState st -> Tagged ByteString -> MVar ByteString -> IO (IO ()) scheduleLocalColdUpdate' acidState event mvar = do act <- modifyCoreState (localCore acidState) $ \st -> do let !(result, !st') = runState coldMethod st -- Schedule the log entry. Very important that it happens when 'localCore' is locked -- to ensure that events are logged in the same order that they are executed. pushEntry (localEvents acidState) event $ return () let action = do writeIORef (localCopy acidState) st' putMVar mvar result return (st', action) return act where coldMethod = lookupColdMethod (localCore acidState) event -- | Issue a Query event and wait for its result. Events may be issued in parallel. localQuery :: QueryEvent event => LocalState (EventState event) -> event -> IO (EventResult event) localQuery acidState event = do st <- readIORef (localCopy acidState) let (result, _st) = runState hotMethod st return result where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event -- Whoa, a buttload of refactoring is needed here. 2011-11-02 localQueryCold :: LocalState st -> Tagged ByteString -> IO ByteString localQueryCold acidState event = do st <- readIORef (localCopy acidState) let (result, _st) = runState coldMethod st return result where coldMethod = lookupColdMethod (localCore acidState) event -- | Take a snapshot of the state and save it to disk. Creating checkpoints -- makes it faster to resume AcidStates and you're free to create them as -- often or seldom as fits your needs. Transactions can run concurrently -- with this call. -- -- This call will not return until the operation has succeeded. createLocalCheckpoint :: SafeCopy st => LocalState st -> IO () createLocalCheckpoint acidState = do cutFileLog (localEvents acidState) mvar <- newEmptyMVar withCoreState (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) pushAction (localEvents acidState) $ do let encoded = runPutLazy (safePut st) pushEntry (localCheckpoints acidState) (Checkpoint eventId encoded) (putMVar mvar ()) takeMVar mvar -- | Save a snapshot to disk and close the AcidState as a single atomic -- action. This is useful when you want to make sure that no events -- are saved to disk after a checkpoint. createCheckpointAndClose :: (SafeCopy st, Typeable st) => AcidState st -> IO () createCheckpointAndClose abstract_state = do mvar <- newEmptyMVar closeCore' (localCore acidState) $ \st -> do eventId <- askCurrentEntryId (localEvents acidState) pushAction (localEvents acidState) $ pushEntry (localCheckpoints acidState) (Checkpoint eventId (runPutLazy (safePut st))) (putMVar mvar ()) takeMVar mvar closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) releasePrefixLock (localLock acidState) where acidState = downcast abstract_state data Checkpoint = Checkpoint EntryId ByteString instance SafeCopy Checkpoint where kind = primitive putCopy (Checkpoint eventEntryId content) = contain $ do safePut eventEntryId safePut content getCopy = contain $ Checkpoint <$> safeGet <*> safeGet -- | Create an AcidState given an initial value. -- -- This will create or resume a log found in the \"state\/[typeOf state]\/\" directory. openLocalState :: (Typeable st, IsAcidic st) => st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (AcidState st) openLocalState initialState = openLocalStateFrom ("state" show (typeOf initialState)) initialState -- | Create an AcidState given an initial value. -- -- This will create or resume a log found in the \"state\/[typeOf state]\/\" directory. -- The most recent checkpoint will be loaded immediately but the AcidState will not be opened -- until the returned function is executed. prepareLocalState :: (Typeable st, IsAcidic st) => st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (IO (AcidState st)) prepareLocalState initialState = prepareLocalStateFrom ("state" show (typeOf initialState)) initialState -- | Create an AcidState given a log directory and an initial value. -- -- This will create or resume a log found in @directory@. -- Running two AcidState's from the same directory is an error -- but will not result in dataloss. openLocalStateFrom :: (IsAcidic st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (AcidState st) openLocalStateFrom directory initialState = join $ resumeLocalStateFrom directory initialState False -- | Create an AcidState given an initial value. -- -- This will create or resume a log found in @directory@. -- The most recent checkpoint will be loaded immediately but the AcidState will not be opened -- until the returned function is executed. prepareLocalStateFrom :: (IsAcidic st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> IO (IO (AcidState st)) prepareLocalStateFrom directory initialState = resumeLocalStateFrom directory initialState True resumeLocalStateFrom :: (IsAcidic st) => FilePath -- ^ Location of the checkpoint and transaction files. -> st -- ^ Initial state value. This value is only used if no checkpoint is -- found. -> Bool -- ^ True => load checkpoint before acquiring the lock. -> IO (IO (AcidState st)) resumeLocalStateFrom directory initialState delayLocking = case delayLocking of True -> do (n, st) <- loadCheckpoint return $ do lock <- obtainPrefixLock lockFile replayEvents lock n st False -> do lock <- obtainPrefixLock lockFile (n, st) <- loadCheckpoint `onException` releasePrefixLock lock return $ do replayEvents lock n st where lockFile = directory "open" eventsLogKey = LogKey { logDirectory = directory , logPrefix = "events" } checkpointsLogKey = LogKey { logDirectory = directory , logPrefix = "checkpoints" } loadCheckpoint = do mbLastCheckpoint <- Log.newestEntry checkpointsLogKey case mbLastCheckpoint of Nothing -> return (0, initialState) Just (Checkpoint eventCutOff content) -> do case runGetLazy safeGet content of Left msg -> checkpointRestoreError msg Right val -> return (eventCutOff, val) replayEvents lock n st = do core <- mkCore (eventsToMethods acidEvents) st eventsLog <- openFileLog eventsLogKey events <- readEntriesFrom eventsLog n mapM_ (runColdMethod core) events ensureLeastEntryId eventsLog n checkpointsLog <- openFileLog checkpointsLogKey stateCopy <- newIORef undefined withCoreState core (writeIORef stateCopy) return $ toAcidState LocalState { localCore = core , localCopy = stateCopy , localEvents = eventsLog , localCheckpoints = checkpointsLog , localLock = lock } checkpointRestoreError msg = error $ "Could not parse saved checkpoint due to the following error: " ++ msg -- | Close an AcidState and associated logs. -- Any subsequent usage of the AcidState will throw an exception. closeLocalState :: LocalState st -> IO () closeLocalState acidState = do closeCore (localCore acidState) closeFileLog (localEvents acidState) closeFileLog (localCheckpoints acidState) releasePrefixLock (localLock acidState) createLocalArchive :: LocalState st -> IO () createLocalArchive state = do -- We need to look at the last checkpoint saved to disk. Since checkpoints can be written -- in parallel with this call, we can't guarantee that the checkpoint we get really is the -- last one but that's alright. currentCheckpointId <- cutFileLog (localCheckpoints state) -- 'currentCheckpointId' is the ID of the next checkpoint that will be written to disk. -- 'currentCheckpointId-1' must then be the ID of a checkpoint on disk (or -1, of course). let durableCheckpointId = currentCheckpointId-1 checkpoints <- readEntriesFrom (localCheckpoints state) durableCheckpointId case checkpoints of [] -> return () (Checkpoint entryId _content : _) -> do -- 'entryId' is the lowest entryId that didn't contribute to the checkpoint. -- 'archiveFileLog' moves all files that are lower than this entryId to the archive. archiveFileLog (localEvents state) entryId -- In the same style as above, we archive all log files that came before the log file -- which contains our checkpoint. archiveFileLog (localCheckpoints state) durableCheckpointId toAcidState :: IsAcidic st => LocalState st -> AcidState st toAcidState local = AcidState { _scheduleUpdate = scheduleLocalUpdate local , scheduleColdUpdate = scheduleLocalColdUpdate local , _query = localQuery local , queryCold = localQueryCold local , createCheckpoint = createLocalCheckpoint local , createArchive = createLocalArchive local , closeAcidState = closeLocalState local , acidSubState = mkAnyState local } acid-state-0.14.2/src/Data/Acid/Log.hs0000644000000000000000000003271712756631253015403 0ustar0000000000000000-- 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(..) , LogKey(..) , EntryId , openFileLog , closeFileLog , pushEntry , pushAction , ensureLeastEntryId , readEntriesFrom , rollbackTo , rollbackWhile , newestEntry , askCurrentEntryId , cutFileLog , archiveFileLog ) where import Data.Acid.Archive as Archive import System.Directory import System.FilePath import System.IO import FileIO import Foreign.Ptr import Control.Monad import Control.Concurrent import Control.Concurrent.STM 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.Maybe import qualified Data.Serialize.Get as Get import qualified Data.Serialize.Put as Put import Data.SafeCopy ( safePut, safeGet, SafeCopy ) import Text.Printf ( printf ) import Paths_acid_state ( version ) import Data.Version ( showVersion ) import Control.Exception ( handle, IOException ) type EntryId = Int data FileLog object = FileLog { logIdentifier :: LogKey object , logCurrent :: MVar FHandle -- Handle , logNextEntryId :: TVar EntryId , logQueue :: TVar ([Lazy.ByteString], [IO ()]) , logThreads :: [ThreadId] } data LogKey object = LogKey { logDirectory :: FilePath , logPrefix :: String } formatLogFile :: String -> EntryId -> String formatLogFile = printf "%s-%010d.log" findLogFiles :: LogKey object -> IO [(EntryId, FilePath)] findLogFiles identifier = do createDirectoryIfMissing True (logDirectory identifier) files <- getDirectoryContents (logDirectory identifier) return [ (tid, logDirectory identifier file) | file <- files , logFile <- maybeToList (stripPrefix (logPrefix identifier ++ "-") file) , (tid, ".log") <- reads logFile ] saveVersionFile :: LogKey object -> IO () saveVersionFile key = do exist <- doesFileExist versionFile unless exist $ writeFile versionFile (showVersion version) where versionFile = logDirectory key logPrefix key <.> "version" openFileLog :: LogKey object -> IO (FileLog object) openFileLog identifier = do logFiles <- findLogFiles identifier saveVersionFile identifier currentState <- newEmptyMVar queue <- newTVarIO ([], []) nextEntryRef <- newTVarIO 0 tid1 <- myThreadId tid2 <- forkIO $ fileWriter currentState queue tid1 let fLog = FileLog { logIdentifier = identifier , logCurrent = currentState , logNextEntryId = nextEntryRef , logQueue = queue , logThreads = [tid2] } if null logFiles then do let currentEntryId = 0 handle <- open (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) putMVar currentState handle else do let (lastFileEntryId, lastFilePath) = maximum logFiles entries <- readEntities lastFilePath let currentEntryId = lastFileEntryId + length entries atomically $ writeTVar nextEntryRef currentEntryId handle <- open (logDirectory identifier formatLogFile (logPrefix identifier) currentEntryId) putMVar currentState handle return fLog fileWriter :: MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> ThreadId -> IO () fileWriter currentState queue parentTid = forever $ do (entries, actions) <- atomically $ do (entries, actions) <- readTVar queue when (null entries && null actions) retry writeTVar queue ([], []) return (reverse entries, reverse actions) handle (\e -> throwTo parentTid (e :: IOException)) $ withMVar currentState $ \fd -> do let arch = Archive.packEntries entries writeToDisk fd (repack arch) sequence_ actions yield -- Repack a lazy bytestring into larger blocks that can be efficiently written to disk. repack :: Lazy.ByteString -> [Strict.ByteString] repack = worker where worker bs | Lazy.null bs = [] | otherwise = Strict.concat (Lazy.toChunks (Lazy.take blockSize bs)) : worker (Lazy.drop blockSize bs) blockSize = 4*1024 writeToDisk :: FHandle -> [Strict.ByteString] -> IO () writeToDisk _ [] = return () writeToDisk handle xs = do mapM_ worker xs flush handle where worker bs = do let len = Strict.length bs count <- Strict.unsafeUseAsCString bs $ \ptr -> write handle (castPtr ptr) (fromIntegral len) when (fromIntegral count < len) $ worker (Strict.drop (fromIntegral count) bs) closeFileLog :: FileLog object -> IO () closeFileLog fLog = modifyMVar_ (logCurrent fLog) $ \handle -> do close handle _ <- forkIO $ forM_ (logThreads fLog) killThread return $ error "FileLog has been closed" readEntities :: FilePath -> IO [Lazy.ByteString] readEntities path = do archive <- Lazy.readFile path return $ worker (Archive.readEntries archive) where worker Done = [] worker (Next entry next) = entry : worker next worker (Fail msg) = error msg ensureLeastEntryId :: FileLog object -> EntryId -> IO () ensureLeastEntryId fLog youngestEntry = do atomically $ do entryId <- readTVar (logNextEntryId fLog) writeTVar (logNextEntryId fLog) (max entryId youngestEntry) 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. readEntriesFrom :: SafeCopy object => FileLog object -> EntryId -> IO [object] readEntriesFrom fLog youngestEntry = do -- Cut the log so we can read written entries without interfering -- with the writing of new entries. entryCap <- cutFileLog fLog -- We're interested in these entries: youngestEntry <= x < entryCap. logFiles <- findLogFiles (logIdentifier fLog) let sorted = sort logFiles relevant = filterLogFiles (Just youngestEntry) (Just entryCap) sorted firstEntryId = case relevant of [] -> 0 ( logFile : _logFiles) -> rangeStart logFile -- XXX: Strict bytestrings are used due to a performance bug in -- cereal-0.3.5.2 and binary-0.7.1.0. The code should revert back -- to lazy bytestrings once the bug has been fixed. archive <- liftM Lazy.fromChunks $ mapM (Strict.readFile . snd) relevant let entries = entriesToList $ readEntries archive return $ map decode' $ take (entryCap - youngestEntry) -- Take events under the eventCap. $ drop (youngestEntry - firstEntryId) entries -- Drop entries that are too young. where rangeStart (firstEntryId, _path) = firstEntryId -- Obliterate log entries younger than or equal to the EventId. Very unsafe, can't be undone rollbackTo :: SafeCopy object => LogKey object -> EntryId -> IO () rollbackTo identifier youngestEntry = do logFiles <- findLogFiles identifier let sorted = sort logFiles loop [] = return () loop ((rangeStart, path) : xs) | rangeStart >= youngestEntry = removeFile path >> loop xs | otherwise = do archive <- Strict.readFile path pathHandle <- openFile path WriteMode let entries = entriesToList $ readEntries (Lazy.fromChunks [archive]) entriesToKeep = take (youngestEntry - rangeStart + 1) entries lengthToKeep = Lazy.length (packEntries entriesToKeep) hSetFileSize pathHandle (fromIntegral lengthToKeep) hClose pathHandle loop (reverse sorted) -- Obliterate log entries as long as the filterFn returns True. rollbackWhile :: SafeCopy object => LogKey object -> (object -> Bool) -> IO () rollbackWhile identifier filterFn = do logFiles <- findLogFiles identifier let sorted = sort logFiles loop [] = return () loop ((_rangeStart, path) : xs) = do archive <- Strict.readFile path let entries = entriesToList $ readEntries (Lazy.fromChunks [archive]) entriesToSkip = takeWhile (filterFn . decode') $ reverse entries skip_size = Lazy.length (packEntries entriesToSkip) orig_size = fromIntegral $ Strict.length archive new_size = orig_size - skip_size if new_size == 0 then do removeFile path; loop xs else do pathHandle <- openFile path WriteMode hSetFileSize pathHandle (fromIntegral new_size) 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)] filterLogFiles minEntryIdMb maxEntryIdMb logFiles = worker logFiles where worker [] = [] worker [ logFile ] | ltMaxEntryId (rangeStart logFile) -- If the logfile starts before our maxEntryId then we're intersted. = [ logFile ] | otherwise = [] worker ( left : right : xs) | ltMinEntryId (rangeStart right) -- If 'right' starts before our minEntryId then we can discard 'left'. = worker (right : xs) | ltMaxEntryId (rangeStart left) -- If 'left' starts before our maxEntryId then we're interested. = left : worker (right : xs) | otherwise -- If 'left' starts after our maxEntryId then we're done. = [] ltMinEntryId = case minEntryIdMb of Nothing -> const False Just minEntryId -> (<= minEntryId) ltMaxEntryId = case maxEntryIdMb of Nothing -> const True 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. 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 createDirectoryIfMissing True archiveDir forM_ relevant $ \(_startEntry, logFilePath) -> renameFile logFilePath (archiveDir takeFileName logFilePath) where archiveDir = logDirectory (logIdentifier fLog) "Archive" getNextDurableEntryId :: FileLog object -> IO EntryId getNextDurableEntryId fLog = atomically $ do (entries, _) <- readTVar (logQueue fLog) next <- readTVar (logNextEntryId fLog) return (next - length entries) cutFileLog :: FileLog object -> IO EntryId cutFileLog fLog = do mvar <- newEmptyMVar let action = do currentEntryId <- getNextDurableEntryId fLog modifyMVar_ (logCurrent fLog) $ \old -> do close old open (logDirectory key formatLogFile (logPrefix key) currentEntryId) putMVar mvar currentEntryId pushAction fLog action takeMVar mvar 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. newestEntry :: SafeCopy object => LogKey object -> IO (Maybe object) newestEntry identifier = do logFiles <- findLogFiles identifier let sorted = reverse $ sort logFiles (_eventIds, files) = unzip sorted worker files where worker [] = return Nothing worker (logFile:logFiles) = do -- XXX: Strict bytestrings are used due to a performance bug in -- cereal-0.3.5.2 and binary-0.7.1.0. The code should revert back -- to lazy bytestrings once the bug has been fixed. archive <- fmap Lazy.fromStrict $ Strict.readFile logFile case Archive.readEntries archive of Done -> worker logFiles Next entry next -> return $ Just (decode' (lastEntry entry next)) Fail msg -> error msg lastEntry entry Done = entry lastEntry entry (Fail msg) = error 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. pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO () pushEntry fLog object finally = atomically $ do tid <- readTVar (logNextEntryId fLog) writeTVar (logNextEntryId fLog) (tid+1) (entries, actions) <- readTVar (logQueue fLog) writeTVar (logQueue fLog) ( encoded : entries, finally : actions ) where encoded = Lazy.fromChunks [ Strict.copy $ Put.runPut (safePut object) ] -- 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) writeTVar (logQueue fLog) (entries, finally : actions) askCurrentEntryId :: FileLog object -> IO EntryId askCurrentEntryId fLog = atomically $ readTVar (logNextEntryId fLog) -- FIXME: Check for unused input. decode' :: SafeCopy object => Lazy.ByteString -> object decode' inp = case Get.runGetLazy safeGet inp of Left msg -> error msg Right val -> val acid-state-0.14.2/src/Data/Acid/Memory.hs0000644000000000000000000001215412756631253016123 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- AcidState container without a transaction log. Mostly used for testing. -- module Data.Acid.Memory ( openMemoryState ) where import Data.Acid.Core import Data.Acid.Common import Data.Acid.Abstract 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 ) import Data.SafeCopy ( SafeCopy(..) ) {-| 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). -} data MemoryState st = MemoryState { localCore :: Core st , localCopy :: IORef st } deriving (Typeable) -- | Create an AcidState given an initial value. openMemoryState :: (IsAcidic st) => st -- ^ Initial state value. -> IO (AcidState st) openMemoryState initialState = do core <- mkCore (eventsToMethods acidEvents) initialState ref <- newIORef initialState 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. -- 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: -- -- @ --do scheduleUpdate acid EventA -- scheduleUpdate acid EventB -- @ scheduleMemoryUpdate :: UpdateEvent event => MemoryState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleMemoryUpdate acidState event = do mvar <- newEmptyMVar modifyCoreState_ (localCore acidState) $ \st -> do let !(result, !st') = runState hotMethod st writeIORef (localCopy acidState) st' putMVar mvar result return st' return mvar where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event scheduleMemoryColdUpdate :: MemoryState st -> Tagged ByteString -> IO (MVar ByteString) scheduleMemoryColdUpdate acidState event = do mvar <- newEmptyMVar modifyCoreState_ (localCore acidState) $ \st -> do let !(result, !st') = runState coldMethod st writeIORef (localCopy acidState) st' putMVar mvar result return st' return mvar where coldMethod = lookupColdMethod (localCore acidState) event -- | Issue a Query event and wait for its result. Events may be issued in parallel. memoryQuery :: QueryEvent event => MemoryState (EventState event) -> event -> IO (EventResult event) memoryQuery acidState event = do st <- readIORef (localCopy acidState) let (result, _st) = runState hotMethod st return result where hotMethod = lookupHotMethod (coreMethods (localCore acidState)) event memoryQueryCold :: MemoryState st -> Tagged ByteString -> IO ByteString memoryQueryCold acidState event = do st <- readIORef (localCopy acidState) let (result, _st) = runState coldMethod st return result where coldMethod = lookupColdMethod (localCore acidState) event -- | This is a nop with the memory backend. createMemoryCheckpoint :: SafeCopy st => MemoryState st -> IO () createMemoryCheckpoint acidState = return () -- | This is a nop with the memory backend. createMemoryArchive :: SafeCopy st => MemoryState st -> IO () createMemoryArchive acidState = return () -- | Close an AcidState and associated logs. -- Any subsequent usage of the AcidState will throw an exception. closeMemoryState :: MemoryState st -> IO () closeMemoryState acidState = closeCore (localCore acidState) toAcidState :: IsAcidic st => MemoryState st -> AcidState st toAcidState memory = AcidState { _scheduleUpdate = scheduleMemoryUpdate memory , scheduleColdUpdate = scheduleMemoryColdUpdate memory , _query = memoryQuery memory , queryCold = memoryQueryCold memory , createCheckpoint = createMemoryCheckpoint memory , createArchive = createMemoryArchive memory , closeAcidState = closeMemoryState memory , acidSubState = mkAnyState memory } acid-state-0.14.2/src/Data/Acid/Remote.hs0000644000000000000000000005711412756631253016113 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, RecordWildCards, ScopedTypeVariables #-} ----------------------------------------------------------------------------- {- | Module : Data.Acid.Remote Copyright : PublicDomain Maintainer : lemmih@gmail.com Portability : non-portable (uses GHC extensions) This module provides the ability perform 'update' and 'query' calls from a remote process. On the server-side you: 1. open your 'AcidState' normally 2. then use 'acidServer' to share the state On the client-side you: 1. use 'openRemoteState' to connect to the remote state 2. use the returned 'AcidState' like any other 'AcidState' handle '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 local communication between the client and server. Access can be controlled by setting the permissions of the parent directory containing the socket file. 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 authentication may not be required, so you can use 'skipAuthenticationCheck' and 'skipAuthenticationPerform'. Working with a remote 'AcidState' is nearly identical to working with a local 'AcidState' with a few important differences. The connection to the remote 'AcidState' can be lost. The client will automatically attempt to reconnect every second. Because 'query' events do not affect the state, an aborted 'query' will be retried automatically after the server is reconnected. If the connection was lost during an 'update' event, the event will not be retried. Instead 'RemoteConnectionError' will be raised. This is because it is impossible for the client to know if the aborted update completed on the server-side or not. When using a local 'AcidState', an update event in one thread does not block query events taking place in other threads. With a remote connection, all queries and requests are channeled over a single connection. As a result, updates and queries are performed in the order they are executed and do block each other. In the rare case where this is an issue, you could create one remote connection per thread. When working with local state, a query or update which returns the whole state is not usually a problem due to memory sharing. The update/query event basically just needs to return a pointer to the data already in memory. But, when working remotely, the entire result will be serialized and sent to the remote client. Hence, it is good practice to create queries and updates that will only return the required data. This module is designed to be extenible. You can easily add your own authentication methods by creating a suitable pair of functions and passing them to 'acidServer' and 'openRemoteState'. It is also possible to create alternative communication layers using 'CommChannel', 'process', and 'processRemoteState'. -} module Data.Acid.Remote ( -- * Server/Client acidServer , acidServer' , openRemoteState -- * Authentication , skipAuthenticationCheck , skipAuthenticationPerform , sharedSecretCheck , sharedSecretPerform -- * Exception type , AcidRemoteException(..) -- * Low-Level functions needed to implement additional communication channels , CommChannel(..) , process , processRemoteState ) where import Prelude hiding ( catch ) import Control.Concurrent.STM ( atomically ) import Control.Concurrent.STM.TMVar ( newEmptyTMVar, readTMVar, takeTMVar, tryTakeTMVar, putTMVar ) import Control.Concurrent.STM.TQueue import Control.Exception ( AsyncException(ThreadKilled) , Exception(fromException), IOException, Handler(..) , SomeException, catch, catches, throw ) import Control.Exception ( throwIO, finally ) import Control.Monad ( forever, liftM, join, when ) import Control.Concurrent ( ThreadId, forkIO, threadDelay, killThread, myThreadId ) import Control.Concurrent.MVar ( MVar, newEmptyMVar, putMVar, takeMVar ) import Control.Concurrent.Chan ( newChan, readChan, writeChan ) import Data.Acid.Abstract import Data.Acid.Core import Data.Acid.Common 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.SafeCopy ( SafeCopy, safeGet, safePut ) 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 System.Directory ( removeFile ) import System.IO ( Handle, hPrint, hFlush, hClose, stderr ) import System.IO.Error ( ioeGetErrorType, isFullError, isDoesNotExistError ) debugStrLn :: String -> IO () debugStrLn s = do -- putStrLn s -- uncomment to enable debugging return () -- | 'CommChannel' is a record containing the IO functions we need for communication between the server and client. -- -- We abstract this out of the core processing function so that we can easily add support for SSL/TLS and Unit testing. data CommChannel = CommChannel { ccPut :: Strict.ByteString -> IO () , ccGetSome :: Int -> IO (Strict.ByteString) , ccClose :: IO () } data AcidRemoteException = RemoteConnectionError | AcidStateClosed | SerializeError String | AuthenticationError String deriving (Eq, Show, Typeable) instance Exception AcidRemoteException -- | create a 'CommChannel' from a 'Handle'. The 'Handle' should be -- some two-way communication channel, such as a socket -- connection. Passing in a 'Handle' to a normal is file is unlikely -- to do anything useful. handleToCommChannel :: Handle -> CommChannel handleToCommChannel handle = CommChannel { ccPut = \bs -> Strict.hPut handle bs >> hFlush handle , ccGetSome = Strict.hGetSome handle , ccClose = hClose handle } {- | create a 'CommChannel' from a 'Socket'. The 'Socket' should be an accepted socket, not a listen socket. -} socketToCommChannel :: Socket -> CommChannel socketToCommChannel socket = CommChannel { ccPut = sendAll socket , ccGetSome = recv socket , ccClose = sClose socket } {- | skip server-side authentication checking entirely. -} skipAuthenticationCheck :: CommChannel -> IO Bool skipAuthenticationCheck _ = return True {- | skip client-side authentication entirely. -} skipAuthenticationPerform :: CommChannel -> IO () skipAuthenticationPerform _ = return () {- | check that the client knows a shared secret. The function takes a 'Set' of shared secrets. If a client knows any of them, it is considered to be trusted. The shared secret is any 'ByteString' of your choice. If you give each client a different shared secret then you can revoke access individually. see also: 'sharedSecretPerform' -} sharedSecretCheck :: Set Strict.ByteString -- ^ set of shared secrets -> (CommChannel -> IO Bool) sharedSecretCheck secrets cc = do bs <- ccGetSome cc 1024 if member bs secrets then do ccPut cc (pack "OK") return True else do ccPut cc (pack "FAIL") return False -- | attempt to authenticate with the server using a shared secret. sharedSecretPerform :: Strict.ByteString -- ^ shared secret -> (CommChannel -> IO ()) sharedSecretPerform pw cc = do ccPut cc pw r <- ccGetSome cc 1024 if r == (pack "OK") then return () else throwIO (AuthenticationError "shared secret authentication failed.") {- | Accept connections on @port@ 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'. -} acidServer :: SafeCopy st => (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' -> PortID -- ^ Port to listen on -> AcidState st -- ^ state to serve -> IO () acidServer checkAuth port acidState = withSocketsDo $ do listenSocket <- listenOn port (acidServer' checkAuth listenSocket acidState) `finally` (cleanup listenSocket) where cleanup socket = do sClose socket case port of #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) UnixSocket path -> removeFile path #endif _ -> return () {- | Works the same way as 'acidServer', but uses pre-binded socket @listenSocket@. Can be useful when fine-tuning of socket binding parameters is needed (for example, listening on a particular network interface, IPv4/IPv6 options). -} acidServer' :: SafeCopy st => (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform' -> Socket -- ^ binded socket to accept connections from -> AcidState st -- ^ state to serve -> IO () acidServer' checkAuth listenSocket acidState = do let loop = forever $ do (socket, _sockAddr) <- accept listenSocket let commChannel = socketToCommChannel socket forkIO $ do authorized <- checkAuth commChannel when authorized $ process commChannel acidState ccClose commChannel -- FIXME: `finally` ? infi = loop `catchSome` logError >> infi infi where logError :: (Show e) => e -> IO () logError e = hPrint stderr e isResourceVanishedError :: IOException -> Bool isResourceVanishedError = isResourceVanishedType . ioeGetErrorType isResourceVanishedType :: IOErrorType -> Bool isResourceVanishedType ResourceVanished = True isResourceVanishedType _ = False catchSome :: IO () -> (Show e => e -> IO ()) -> IO () catchSome op _h = op `catches` [ Handler $ \(e :: IOException) -> if isFullError e || isDoesNotExistError e || isResourceVanishedError e then return () -- h (toException e) -- we could log the exception, but there could be thousands of them else throw e ] data Command = RunQuery (Tagged Lazy.ByteString) | RunUpdate (Tagged Lazy.ByteString) | CreateCheckpoint | CreateArchive instance Serialize Command where put cmd = case cmd of RunQuery query -> do putWord8 0; put query RunUpdate update -> do putWord8 1; put update CreateCheckpoint -> putWord8 2 CreateArchive -> putWord8 3 get = do tag <- getWord8 case tag of 0 -> liftM RunQuery get 1 -> liftM RunUpdate get 2 -> return CreateCheckpoint 3 -> return CreateArchive _ -> error $ "Serialize.get for Command, invalid tag: " ++ show tag data Response = Result Lazy.ByteString | Acknowledgement | ConnectionError instance Serialize Response where put resp = case resp of Result result -> do putWord8 0; put result Acknowledgement -> putWord8 1 ConnectionError -> putWord8 2 get = do tag <- getWord8 case tag of 0 -> liftM Result get 1 -> return Acknowledgement 2 -> return ConnectionError _ -> error $ "Serialize.get for Response, invalid tag: " ++ show tag {- | Server inner-loop This function is generally only needed if you are adding a new communication channel. -} process :: SafeCopy st => CommChannel -- ^ a connected, authenticated communication channel -> AcidState st -- ^ state to share -> IO () process CommChannel{..} acidState = do chan <- newChan forkIO $ forever $ do response <- join (readChan chan) ccPut (encode response) worker chan (runGetPartial get Strict.empty) where worker chan inp = case inp of Fail msg _ -> throwIO (SerializeError msg) Partial cont -> do bs <- ccGetSome 1024 if Strict.null bs then return () else worker chan (cont bs) Done cmd rest -> do processCommand chan cmd; worker chan (runGetPartial get rest) processCommand chan cmd = case cmd of RunQuery query -> do result <- queryCold acidState query writeChan chan (return $ Result result) RunUpdate update -> do result <- scheduleColdUpdate acidState update writeChan chan (liftM Result $ takeMVar result) CreateCheckpoint -> do createCheckpoint acidState writeChan chan (return Acknowledgement) CreateArchive -> do createArchive acidState 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 -> IO (AcidState st) openRemoteState performAuthorization host port = withSocketsDo $ do processRemoteState reconnect where -- | reconnect reconnect :: IO CommChannel reconnect = (do debugStrLn "Reconnecting." handle <- connectTo host port let cc = handleToCommChannel handle performAuthorization cc debugStrLn "Reconnected." return cc ) `catch` ((\_ -> threadDelay 1000000 >> reconnect) :: IOError -> IO CommChannel) {- | Client inner-loop This function is generally only needed if you are adding a new communication channel. -} processRemoteState :: IsAcidic st => IO CommChannel -- ^ (re-)connect function -> IO (AcidState st) processRemoteState reconnect = do cmdQueue <- atomically newTQueue ccTMV <- atomically newEmptyTMVar isClosed <- newIORef False let actor :: Command -> IO (MVar Response) actor command = do debugStrLn "actor: begin." readIORef isClosed >>= flip when (throwIO AcidStateClosed) ref <- newEmptyMVar atomically $ writeTQueue cmdQueue (command, ref) debugStrLn "actor: end." return ref expireQueue listenQueue = do mCallback <- atomically $ tryReadTQueue listenQueue case mCallback of Nothing -> return () (Just callback) -> do callback ConnectionError expireQueue listenQueue handleReconnect :: SomeException -> IO () handleReconnect e = case fromException e of (Just ThreadKilled) -> do debugStrLn "handleReconnect: ThreadKilled. Not attempting to reconnect." return () _ -> do debugStrLn $ "handleReconnect begin." tmv <- atomically $ tryTakeTMVar ccTMV case tmv of Nothing -> do debugStrLn $ "handleReconnect: error handling already in progress." debugStrLn $ "handleReconnect end." return () (Just (oldCC, oldListenQueue, oldListenerTID)) -> do thisTID <- myThreadId when (thisTID /= oldListenerTID) (killThread oldListenerTID) ccClose oldCC expireQueue oldListenQueue cc <- reconnect listenQueue <- atomically $ newTQueue listenerTID <- forkIO $ listener cc listenQueue atomically $ putTMVar ccTMV (cc, listenQueue, listenerTID) debugStrLn $ "handleReconnect end." return () listener :: CommChannel -> TQueue (Response -> IO ()) -> IO () listener cc listenQueue = getResponse Strict.empty `catch` handleReconnect where getResponse leftover = do debugStrLn $ "listener: listening for Response." let go inp = case inp of Fail msg _ -> error msg Partial cont -> do debugStrLn $ "listener: ccGetSome" bs <- ccGetSome cc 1024 go (cont bs) Done resp rest -> do debugStrLn $ "listener: getting callback" callback <- atomically $ readTQueue listenQueue debugStrLn $ "listener: passing Response to callback" callback (resp :: Response) return rest rest <- go (runGetPartial get leftover) -- `catch` (\e -> do handleReconnect e -- throwIO e -- ) getResponse rest actorThread :: IO () actorThread = forever $ do debugStrLn "actorThread: waiting for something to do." (cc, cmd) <- atomically $ do (cmd, ref) <- readTQueue cmdQueue (cc, listenQueue, _) <- readTMVar ccTMV writeTQueue listenQueue (putMVar ref) return (cc, cmd) debugStrLn "actorThread: sending command." ccPut cc (encode cmd) `catch` handleReconnect debugStrLn "actorThread: sent." return () shutdown :: ThreadId -> IO () shutdown actorTID = do debugStrLn "shutdown: update isClosed IORef to True." writeIORef isClosed True debugStrLn "shutdown: killing actor thread." killThread actorTID debugStrLn "shutdown: taking ccTMV." (cc, listenQueue, listenerTID) <- atomically $ takeTMVar ccTMV -- FIXME: or should this by tryTakeTMVar debugStrLn "shutdown: killing listener thread." killThread listenerTID debugStrLn "shutdown: expiring listen queue." expireQueue listenQueue debugStrLn "shutdown: closing connection." ccClose cc return () cc <- reconnect listenQueue <- atomically $ newTQueue actorTID <- forkIO $ actorThread listenerTID <- forkIO $ listener cc listenQueue atomically $ putTMVar ccTMV (cc, listenQueue, listenerTID) return (toAcidState $ RemoteState actor (shutdown actorTID)) remoteQuery :: QueryEvent event => RemoteState (EventState event) -> event -> IO (EventResult event) remoteQuery acidState event = do let encoded = runPutLazy (safePut event) resp <- remoteQueryCold acidState (methodTag event, encoded) return (case runGetLazyFix safeGet resp of Left msg -> error msg Right result -> result) remoteQueryCold :: RemoteState st -> Tagged Lazy.ByteString -> IO Lazy.ByteString remoteQueryCold rs@(RemoteState fn _shutdown) event = do resp <- takeMVar =<< fn (RunQuery event) case resp of (Result result) -> return result ConnectionError -> do debugStrLn "retrying query event." remoteQueryCold rs event Acknowledgement -> error "remoteQueryCold got Acknowledgement. That should never happen." scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleRemoteUpdate (RemoteState fn _shutdown) event = do let encoded = runPutLazy (safePut event) parsed <- newEmptyMVar respRef <- fn (RunUpdate (methodTag event, encoded)) forkIO $ do Result resp <- takeMVar respRef putMVar parsed (case runGetLazyFix safeGet resp of Left msg -> error msg Right result -> result) return parsed scheduleRemoteColdUpdate :: RemoteState st -> Tagged Lazy.ByteString -> IO (MVar Lazy.ByteString) scheduleRemoteColdUpdate (RemoteState fn _shutdown) event = do parsed <- newEmptyMVar respRef <- fn (RunUpdate event) forkIO $ do Result resp <- takeMVar respRef putMVar parsed resp return parsed closeRemoteState :: RemoteState st -> IO () closeRemoteState (RemoteState _fn shutdown) = shutdown createRemoteCheckpoint :: RemoteState st -> IO () createRemoteCheckpoint (RemoteState fn _shutdown) = do Acknowledgement <- takeMVar =<< fn CreateCheckpoint return () createRemoteArchive :: RemoteState st -> IO () createRemoteArchive (RemoteState fn _shutdown) = do Acknowledgement <- takeMVar =<< fn CreateArchive return () toAcidState :: IsAcidic st => RemoteState st -> AcidState st toAcidState remote = AcidState { _scheduleUpdate = scheduleRemoteUpdate remote , scheduleColdUpdate = scheduleRemoteColdUpdate remote , _query = remoteQuery remote , queryCold = remoteQueryCold remote , createCheckpoint = createRemoteCheckpoint remote , createArchive = createRemoteArchive remote , closeAcidState = closeRemoteState remote , acidSubState = mkAnyState remote } acid-state-0.14.2/src/Data/Acid/TemplateHaskell.hs0000644000000000000000000003633412756631253017740 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} {- Holy crap this code is messy. -} module Data.Acid.TemplateHaskell ( makeAcidic ) where import Language.Haskell.TH import Language.Haskell.TH.Ppr import Data.Acid.Core import Data.Acid.Common import Data.List ((\\), nub) import Data.Maybe (mapMaybe) import Data.SafeCopy import Data.Typeable import Data.Char import Control.Applicative import Control.Monad {-| Create the control structures required for acid states using Template Haskell. This code: @ myUpdate :: Argument -> Update State Result myUpdate arg = ... myQuery :: Argument -> Query State Result myQuery arg = ... $(makeAcidic ''State ['myUpdate, 'myQuery]) @ will make @State@ an instance of 'IsAcidic' and provide the following events: @ data MyUpdate = MyUpdate Argument data MyQuery = MyQuery Argument @ -} makeAcidic :: Name -> [Name] -> Q [Dec] makeAcidic stateName eventNames = do stateInfo <- reify stateName case stateInfo of TyConI tycon ->case tycon of #if MIN_VERSION_template_haskell(2,11,0) DataD _cxt _name tyvars _kind constructors _derivs #else DataD _cxt _name tyvars constructors _derivs #endif -> makeAcidic' eventNames stateName tyvars constructors #if MIN_VERSION_template_haskell(2,11,0) NewtypeD _cxt _name tyvars _kind constructor _derivs #else NewtypeD _cxt _name tyvars constructor _derivs #endif -> makeAcidic' eventNames stateName tyvars [constructor] TySynD _name tyvars _ty -> makeAcidic' eventNames stateName tyvars [] _ -> error "Unsupported state type. Only 'data', 'newtype' and 'type' are supported." _ -> error "Given state is not a type." makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] makeAcidic' eventNames stateName tyvars constructors = do events <- sequence [ makeEvent eventName | eventName <- eventNames ] acidic <- makeIsAcidic eventNames stateName tyvars constructors return $ acidic : concat events makeEvent :: Name -> Q [Dec] makeEvent eventName = do eventType <- getEventType eventName d <- makeEventDataType eventName eventType b <- makeSafeCopyInstance eventName eventType i <- makeMethodInstance eventName eventType e <- makeEventInstance eventName eventType return [d,b,i,e] getEventType :: Name -> Q Type 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 -> return eventType _ -> error $ "Events must be functions: " ++ show eventName --instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where -- acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ] makeIsAcidic eventNames stateName tyvars constructors = do types <- mapM getEventType eventNames stateType' <- stateType let preds = [ ''SafeCopy, ''Typeable ] ty = appT (conT ''IsAcidic) stateType handlers = zipWith makeEventHandler eventNames types cxtFromEvents = nub $ concat $ zipWith (eventCxts stateType' tyvars) eventNames types cxts' <- mkCxtFromTyVars preds tyvars cxtFromEvents instanceD (return cxts') ty [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ] where stateType = foldl appT (conT stateName) (map varT (allTyVarBndrNames tyvars)) -- | This function analyses an event function and extracts any -- additional class contexts which need to be added to the IsAcidic -- instance. -- -- For example, if we have: -- -- > data State a = ... -- -- > setState :: (Ord a) => a -> UpdateEvent (State a) () -- -- Then we need to generate an IsAcidic instance like: -- -- > instance (SafeCopy a, Typeable a, Ord a) => IsAcidic (State a) -- -- Note that we can only add constraints for type variables which -- appear in the State type. If we tried to do this: -- -- > setState :: (Ord a, Ord b) => a -> b -> UpdateEvent (State a) () -- -- We will get an ambigious type variable when trying to create the -- 'IsAcidic' instance, because there is no way to figure out what -- type 'b' should be. -- -- The tricky part of this code is that we need to unify the type -- variables. -- -- Let's say the user writes their code using 'b' instead of 'a': -- -- > setState :: (Ord b) => b -> UpdateEvent (State b) () -- -- In the 'IsAcidic' instance, we are still going to use 'a'. So we -- need to rename the variables in the context to match. -- -- The contexts returned by this function will have the variables renamed. eventCxts :: Type -- ^ State type (used for error messages) -> [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 targetStateType targetTyVars eventName eventType = let (_tyvars, cxt, _args, stateType, _resultType, _isUpdate) = analyseType eventName eventType eventTyVars = findTyVars stateType -- find the type variable names that this event is using for the State type table = zip eventTyVars (map tyVarBndrName targetTyVars) -- create a lookup table in map (unify table) cxt -- rename the type variables 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 renameTyVar (PlainTV name) = PlainTV (renameName pred table name) renameTyVar (KindedTV name k) = KindedTV (renameName pred table name) k 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 rename _ _ typ = typ -- | rename a 'Name' renameName :: Pred -> [(Name, Name)] -> Name -> Name renameName pred table n = case lookup n table of Nothing -> error $ unlines [ show $ ppr_sig eventName eventType , "" , "can not be used as an UpdateEvent because the class context: " , "" , pprint pred , "" , "contains a type variable which is not found in the state type: " , "" , pprint targetStateType , "" , "You may be able to fix this by providing a type signature that fixes these type variable(s)" ] (Just n') -> n' -- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) makeEventHandler :: Name -> Type -> ExpQ makeEventHandler eventName eventType = do assertTyVarsOk vars <- replicateM (length args) (newName "arg") let lamClause = conP eventStructName [varP var | var <- vars ] conE constr `appE` lamE [lamClause] (foldl appE (varE eventName) (map varE vars)) where constr = if isUpdate then 'UpdateEvent else 'QueryEvent (tyvars, _cxt, args, stateType, _resultType, isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs stateTypeTyVars = findTyVars stateType tyVarNames = map tyVarBndrName tyvars assertTyVarsOk = case tyVarNames \\ stateTypeTyVars of [] -> return () ns -> error $ unlines [show $ ppr_sig eventName eventType , "" , "can not be used as an UpdateEvent because it contains the type variables: " , "" , pprint ns , "" , "which do not appear in the state type:" , "" , pprint stateType ] --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 -- deriving (Typeable) makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] #if MIN_VERSION_template_haskell(2,11,0) cxt = mapM conT [''Typeable] #else cxt = [''Typeable] #endif case args of #if MIN_VERSION_template_haskell(2,11,0) [_] -> newtypeD (return []) eventStructName tyvars Nothing con cxt _ -> dataD (return []) eventStructName tyvars Nothing [con] cxt #else [_] -> newtypeD (return []) eventStructName tyvars con cxt _ -> dataD (return []) eventStructName tyvars [con] cxt #endif where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs -- instance (SafeCopy key, SafeCopy val) => SafeCopy (MyUpdateEvent key val) where -- put (MyUpdateEvent a b) = do put a; put b -- get = MyUpdateEvent <$> get <*> get makeSafeCopyInstance eventName eventType = do let preds = [ ''SafeCopy ] ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) getBase = appE (varE 'return) (conE eventStructName) getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'safeGet))) getBase args contained val = varE 'contain `appE` val putVars <- replicateM (length args) (newName "arg") let putClause = conP eventStructName [varP var | var <- putVars ] putExp = doE $ [ noBindS $ appE (varE 'safePut) (varE var) | var <- putVars ] ++ [ noBindS $ appE (varE 'return) (tupE []) ] instanceD (mkCxtFromTyVars preds tyvars context) (return ty) [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []] , valD (varP 'getCopy) (normalB (contained getArgs)) [] ] where (tyvars, context, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs mkCxtFromTyVars preds tyvars extraContext = cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return extraContext {- instance (SafeCopy key, Typeable key ,SafeCopy val, Typeable val) => Method (MyUpdateEvent key val) where type MethodResult (MyUpdateEvent key val) = Return type MethodState (MyUpdateEvent key val) = State key val -} makeMethodInstance eventName eventType = do let preds = [ ''SafeCopy, ''Typeable ] ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) structType = foldl appT (conT eventStructName) (map varT (allTyVarBndrNames tyvars)) instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context) (return ty) #if __GLASGOW_HASKELL__ >= 707 [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType)) , tySynInstD ''MethodState (tySynEqn [structType] (return stateType)) #else [ tySynInstD ''MethodResult [structType] (return resultType) , tySynInstD ''MethodState [structType] (return stateType) #endif ] where (tyvars, context, _args, stateType, resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs --instance (SafeCopy key, Typeable key -- ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val) makeEventInstance eventName eventType = do let preds = [ ''SafeCopy, ''Typeable ] eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars))) instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context) (return ty) [] where (tyvars, context, _args, _stateType, _resultType, isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] structName (x:xs) = toUpper x : xs -- (tyvars, cxt, args, state type, result type, is update) analyseType :: Name -> Type -> ([TyVarBndr], Cxt, [Type], Type, Type, Bool) analyseType eventName t = let (tyvars, cxt, t') = case t of ForallT binds [] t' -> (binds, [], t') ForallT binds cxt t' -> (binds, cxt, t') _ -> ([], [], t) args = getArgs t' (stateType, resultType, isUpdate) = findMonad t' in (tyvars, cxt, args, stateType, resultType, isUpdate) where getArgs ForallT{} = error $ "Event has an invalid type signature: Nested forall: " ++ show eventName getArgs (AppT (AppT ArrowT a) b) = a : getArgs b getArgs _ = [] findMonad (AppT (AppT ArrowT a) b) = findMonad b findMonad (AppT (AppT (ConT con) state) result) | con == ''Update = (state, result, True) | con == ''Query = (state, result, False) findMonad _ = error $ "Event has an invalid type signature: Not an Update or a Query: " ++ show eventName -- | find the type variables -- | e.g. State a b ==> [a,b] findTyVars :: Type -> [Name] findTyVars (ForallT _ _ a) = findTyVars a findTyVars (VarT n) = [n] findTyVars (AppT a b) = findTyVars a ++ findTyVars b findTyVars (SigT a _) = findTyVars a findTyVars _ = [] -- | extract the 'Name' from a 'TyVarBndr' tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV n) = n tyVarBndrName (KindedTV n _) = n allTyVarBndrNames :: [TyVarBndr] -> [Name] allTyVarBndrNames tyvars = map tyVarBndrName tyvars acid-state-0.14.2/src/Data/Acid/Memory/0000755000000000000000000000000012756631253015564 5ustar0000000000000000acid-state-0.14.2/src/Data/Acid/Memory/Pure.hs0000644000000000000000000000641512756631253017041 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Memory.Pure -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- AcidState container without a transaction log. Mostly used for testing. -- module Data.Acid.Memory.Pure ( IsAcidic(..) , AcidState , Event(..) , EventResult , EventState , UpdateEvent , QueryEvent , Update , Query , openAcidState , update , update_ , query , liftQuery , runUpdate , runQuery ) where import Data.Acid.Core import Data.Acid.Common 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). -} data AcidState st = AcidState { localMethods :: MethodMap st , localState :: st } -- | Issue an Update event and wait for its result. Once this call returns, you are -- guaranteed that the changes to the state are durable. Events may be issued in -- parallel. -- -- It's a run-time error to issue events that aren't supported by the AcidState. update :: UpdateEvent event => AcidState (EventState event) -> event -> ( AcidState (EventState event) , EventResult event) update acidState event = case runState hotMethod (localState acidState) of !(result, !newState) -> ( acidState { localState = newState } , result ) where hotMethod = lookupHotMethod (localMethods acidState) event -- | Same as 'update' but ignoring the event result. update_ :: UpdateEvent event => AcidState (EventState event) -> event -> AcidState (EventState event) update_ acidState event = fst (update acidState event) -- | Issue a Query event and wait for its result. query :: QueryEvent event => AcidState (EventState event) -> event -> EventResult event query acidState event = case runState hotMethod (localState acidState) of !(result, !_st) -> result where hotMethod = lookupHotMethod (localMethods acidState) event -- | Create an AcidState given an initial value. openAcidState :: IsAcidic st => st -- ^ Initial state value. -> AcidState st openAcidState initialState = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) , localState = initialState } -- | Execute the 'Update' monad in a pure environment. runUpdate :: Update s r -> s -> (r, s) runUpdate update = runState $ unUpdate update -- | Execute the 'Query' monad in a pure environment. runQuery :: Query s r -> s -> r runQuery query = runReader $ unQuery query acid-state-0.14.2/src-unix/0000755000000000000000000000000012756631253013564 5ustar0000000000000000acid-state-0.14.2/src-unix/FileIO.hs0000644000000000000000000001404612756631253015234 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where import System.Posix(Fd(Fd), openFd, fdWriteBuf, fdToHandle, closeFd, OpenMode(WriteOnly,ReadWrite), exclusive, trunc, defaultFileFlags, stdFileMode ) import Data.Word(Word8,Word32) import Foreign(Ptr) import Foreign.C(CInt(..)) import System.IO import Data.Maybe (listToMaybe) import qualified System.IO.Error as SE import System.Posix.Process (getProcessID) import System.Posix.Signals (nullSignal, signalProcess) import System.Posix.Types (ProcessID) import Control.Exception.Extensible as E import System.Directory ( createDirectoryIfMissing, removeFile) import System.FilePath newtype PrefixLock = PrefixLock FilePath data FHandle = FHandle Fd -- should handle opening flags correctly open :: FilePath -> IO FHandle open filename = fmap FHandle $ openFd filename WriteOnly (Just stdFileMode) defaultFileFlags write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32 write (FHandle fd) data' length = fmap fromIntegral $ fdWriteBuf fd data' $ fromIntegral length -- Handle error values? flush :: FHandle -> IO () flush (FHandle (Fd c_fd)) = c_fsync c_fd >> return () foreign import ccall "fsync" c_fsync :: CInt -> IO CInt close :: FHandle -> IO () close (FHandle fd) = closeFd fd -- Unix needs to use a special open call to open files for exclusive writing --openExclusively :: FilePath -> IO Handle --openExclusively fp = -- fdToHandle =<< openFd fp ReadWrite (Just 0o600) flags -- where flags = defaultFileFlags {exclusive = True, trunc = True} obtainPrefixLock :: FilePath -> IO PrefixLock obtainPrefixLock prefix = do checkLock fp >> takeLock fp where fp = prefix ++ ".lock" -- |Read the lock and break it if the process is dead. checkLock :: FilePath -> IO () checkLock fp = readLock fp >>= maybeBreakLock fp -- |Read the lock and return the process id if possible. readLock :: FilePath -> IO (Maybe ProcessID) readLock fp = try (readFile fp) >>= return . either (checkReadFileError fp) (fmap (fromInteger . read) . listToMaybe . lines) -- |Is this a permission error? If so we don't have permission to -- remove the lock file, abort. checkReadFileError :: [Char] -> IOError -> Maybe ProcessID checkReadFileError fp e | SE.isPermissionError e = throw (userError ("Could not read lock file: " ++ show fp)) | SE.isDoesNotExistError e = Nothing | True = throw e maybeBreakLock :: FilePath -> Maybe ProcessID -> IO () maybeBreakLock fp Nothing = -- The lock file exists, but there's no PID in it. At this point, -- we will break the lock, because the other process either died -- or will give up when it failed to read its pid back from this -- file. breakLock fp maybeBreakLock fp (Just pid) = do -- The lock file exists and there is a PID in it. We can break the -- lock if that process has died. -- getProcessStatus only works on the children of the calling process. -- exists <- try (getProcessStatus False True pid) >>= either checkException (return . isJust) exists <- doesProcessExist pid case exists of True -> throw (lockedBy fp pid) False -> breakLock fp doesProcessExist :: ProcessID -> IO Bool doesProcessExist pid = -- Implementation 1 -- doesDirectoryExist ("/proc/" ++ show pid) -- Implementation 2 try (signalProcess nullSignal pid) >>= return . either checkException (const True) where checkException e | SE.isDoesNotExistError e = False | True = throw e -- |We have determined the locking process is gone, try to remove the -- lock. breakLock :: FilePath -> IO () breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ())) -- |An exception when we tried to break a lock, if it says the lock -- file has already disappeared we are still good to go. checkBreakError :: IOError -> IO () checkBreakError e | SE.isDoesNotExistError e = return () | True = throw e -- |Try to create lock by opening the file with the O_EXCL flag and -- writing our PID into it. Verify by reading the pid back out and -- matching, maybe some other process slipped in before we were done -- and broke our lock. takeLock :: FilePath -> IO PrefixLock takeLock fp = do createDirectoryIfMissing True (takeDirectory fp) h <- openFd fp ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>= fdToHandle pid <- getProcessID hPutStrLn h (show pid) >> hClose h -- Read back our own lock and make sure its still ours readLock fp >>= maybe (throw (cantLock fp pid)) (\ pid' -> if pid /= pid' then throw (stolenLock fp pid pid') else return (PrefixLock fp)) -- |An exception saying the data is locked by another process. lockedBy :: (Show a) => FilePath -> a -> SomeException lockedBy fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Locked by " ++ show pid) Nothing (Just fp)) -- |An exception saying we don't have permission to create lock. cantLock :: FilePath -> ProcessID -> SomeException cantLock fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ " could not create a lock") Nothing (Just fp)) -- |An exception saying another process broke our lock before we -- finished creating it. stolenLock :: FilePath -> ProcessID -> ProcessID -> SomeException stolenLock fp pid pid' = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ "'s lock was stolen by process " ++ show pid') Nothing (Just fp)) -- |Relinquish the lock by removing it and then verifying the removal. releasePrefixLock :: PrefixLock -> IO () releasePrefixLock (PrefixLock fp) = dropLock >>= either checkDrop return where dropLock = try (removeFile fp) checkDrop e | SE.isDoesNotExistError e = return () | True = throw e acid-state-0.14.2/src-win32/0000755000000000000000000000000012756631253013543 5ustar0000000000000000acid-state-0.14.2/src-win32/FileIO.hs0000644000000000000000000000423412756631253015211 0ustar0000000000000000module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where import System.Win32(HANDLE, createFile, gENERIC_WRITE, fILE_SHARE_NONE, cREATE_ALWAYS, fILE_ATTRIBUTE_NORMAL, win32_WriteFile, flushFileBuffers, closeHandle) import Data.Word(Word8,Word32) import Foreign(Ptr) import System.IO import System.Directory(createDirectoryIfMissing,removeFile) import Control.Exception.Extensible(try,throw) import Control.Exception(SomeException,IOException) import qualified Control.Exception as E type PrefixLock = (FilePath, Handle) data FHandle = FHandle HANDLE tryE :: IO a -> IO (Either SomeException a) tryE = try catchIO :: IO a -> (IOException -> IO a) -> IO a catchIO = E.catch open :: FilePath -> IO FHandle open filename = fmap FHandle $ createFile filename gENERIC_WRITE fILE_SHARE_NONE Nothing cREATE_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32 write (FHandle handle) data' length = win32_WriteFile handle data' length Nothing flush :: FHandle -> IO () flush (FHandle handle) = flushFileBuffers handle close :: FHandle -> IO () close (FHandle handle) = closeHandle handle -- Windows opens files for exclusive writing by default openExclusively :: FilePath -> IO Handle openExclusively fp = openFile fp ReadWriteMode obtainPrefixLock :: FilePath -> IO PrefixLock obtainPrefixLock prefix = do createDirectoryIfMissing True prefix -- catchIO obtainLock onError catchIO obtainLock onError where fp = prefix ++ ".lock" obtainLock = do h <- openExclusively fp return (fp, h) onError e = do putStrLn "There may already be an instance of this application running, which could result in a loss of data." putStrLn ("Please make sure there is no other application attempting to access '" ++ prefix ++ "'") throw e releasePrefixLock :: PrefixLock -> IO () releasePrefixLock (fp, h) = do tryE $ hClose h tryE $ removeFile fp return ()