mealstrom 0.0.0.1 → 0.0.1.0

raw patch · 14 files changed

+899/−64 lines, 14 filesdep +mealstromdep ~aesondep ~asyncdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: mealstrom

Dependency ranges changed: aeson, async, base, containers, postgresql-simple, stm, stm-containers, tasty, tasty-hunit, time

API changes (from Hackage documentation)

Files

• README.md +16/−4
• mealstrom.cabal +51/−52
• src/Mealstrom.hs +17/−0
• src/Mealstrom/FSM.hs +0/−5
• src/Mealstrom/FSMApi.hs +1/−1
• src/Mealstrom/PostgresJSONStore.hs +24/−1
• test/BasicFSM.hs +101/−0
• test/CounterFSM.hs +97/−0
• test/Exception.hs +81/−0
• test/FSM2FSM.hs +143/−0
• test/Main.hs +3/−1
• test/Recovery.hs +86/−0
• test/Timeout.hs +82/−0
• test/Upgrade.hs +197/−0

@@ -1,9 +1,9 @@-Mealstrom+Mealstrom [![Hackage version](https://img.shields.io/hackage/v/mealstrom.svg?colorB=4FB900)](https://hackage.haskell.org/package/mealstrom) =========  Mealstrom is a way of modeling, storing and running (business) processes using PostgreSQL. It is based on an idea that [Jakob Sievers](http://canned.primat.es/) had when we both worked at a payment service provider. -It is a remedy for a number of drawbacks of using relational database systems directly for the same task, while still building on some of their strengths.+It is a remedy for a number of drawbacks of using relational database systems for the same task directly, while still building on some of their strengths.  You often want to store not just the current state of a process instantiation, but keep a log of all steps taken so far. Obviously you cannot simply update the previous state in a relational database. @@ -15,7 +15,7 @@  In short: If you are not very careful, modeling state transitions in your processes becomes a tangled mess of SQL queries and code, with duplicated functionality and the potential of race conditions and low assurances of correctness. -##Enter Mealstrom+## Enter Mealstrom  With Mealstrom you model your process as a finite-state automaton, a Mealy machine to be precise. A Mealy machine, in contrast to a Moore machine, is an FSA that attaches effects to transitions instead of states. @@ -145,10 +145,22 @@ If, however, you choose to send a Msg to another _MealyInstance_ as an effect, i.e. call `patch` on it in the `effects` function, you can reuse the `msgId` from the first `Msg`. The receiving FSM instance can then even do the same thing, and so on. This way you can form a chain of idempotent updates that will, assuming failures are intermittent, eventually succeed.  ### Log-The `FSMAPI` attempt to provide an exception-safe way to work with FSM instances in production. If you want to examine an instances log or alter the past, you can use the functions from the respective stores directly, but have to take care of exceptions yourself.+The `FSMAPI` attempts to provide an exception-safe way to work with FSM instances in production. If you want to examine an instance's log or alter the past, you can use the functions from the respective stores directly, but have to take care of exceptions yourself. +### "Schema" updates+If at any time you decide to extend one of the types that constitute a `MealyMachine`, you must also update the JSON serialiser/deserialiser and make sure the deserialiser also works when the new fields are not present. Sometimes this is trivial, e.g. when adding another data constructor to a sum type. Sometimes the change is incompatible and you need to provide a default value or even a conversion (be careful not to shoot yourself in the foot by introducing ambiguity whether something is a "new" or an "old" instance).++Whenever you deserialise an "old" instance, it will be converted to a "new" instance and when you update it, it will be written back in the new format.++If you prefer, you can perform a batch update by using _batchConvert in PostgresJSONStore (this may take a long time if you have a lot of data).+ Lastly, Mealstrom is not a good fit if:  * You require every last bit of performance. * You do not care particularly whether updates are occasionally lost. * You require complex, cross-entity queries and/or already have a large amount of query language code, so that the drawbacks cited above do not seem too bad in comparison.+++## Tests++To run the tests you need to run `createdb fsmtest` first.

@@ -1,5 +1,7 @@+cabal-version:       2.2+ name:                mealstrom-version:             0.0.0.1+version:             0.0.1.0 synopsis:            Manipulate FSMs and store them in PostgreSQL. homepage:            https://github.com/linearray/mealstrom bug-reports:         https://github.com/linearray/mealstrom/issues@@ -17,61 +19,58 @@ category:            Database, Control build-type:          Simple extra-source-files:  README.md-cabal-version:       >=1.10 -library-  -- other-modules:       -  -- other-extensions:    -  build-depends:       base              >=4.8       && <4.10-                     , aeson             >= 0.11.2.0 && < 1.1-                     , async             >= 2.1.0    && < 2.2-                     , bytestring        >= 0.10.8.1 && < 0.11-                     , containers        >= 0.5.8.1  && < 0.6-                     , hashable          >= 1.2.4    && < 1.3-                     , list-t            >= 1        && < 2-                     , postgresql-simple >= 0.5.1.2  && < 0.6-                     , resource-pool     >= 0.2.3.2  && < 0.3-                     , stm               >= 2.4.4.1  && < 2.5-                     , stm-containers    >= 0.2.15   && < 0.3-                     , text              >= 1.2.2.1  && < 1.3-                     , time              >= 1.6      && < 1.7-                     , uuid              >= 1.3.12   && < 1.4+common deps+    build-depends:+      , base              >= 4.8      && < 5.0+      , aeson             >= 1.1      && < 1.5+      , async             >= 2.1.0    && < 2.3+      , bytestring        >= 0.10.8.1 && < 0.11+      , hashable          >= 1.2.4    && < 1.3+      , list-t            >= 1        && < 2+      , postgresql-simple >= 0.5.1.2  && < 0.7+      , resource-pool     >= 0.2.3.2  && < 0.3+      , stm               >= 2.4.4.1  && < 2.6+      , stm-containers    >= 0.2.15   && < 1+      , text              >= 1.2.2.1  && < 1.3+      , time              >= 1.6      && < 2.0+      , uuid              >= 1.3.12   && < 1.4 -  hs-source-dirs:      src-  default-language:    Haskell2010-  exposed-modules:     Mealstrom.FSM,-                       Mealstrom.FSMApi,-                       Mealstrom.FSMEngine,-                       Mealstrom.FSMStore,-                       Mealstrom.FSMTable,-                       Mealstrom.MemoryStore,-                       Mealstrom.PostgresJSONStore,-                       Mealstrom.WALStore-  ghc-options:+library+    import:             deps+    build-depends:+        containers      >= 0.5.8.1  && < 0.7+    hs-source-dirs:     src+    default-language:   Haskell2010+    exposed-modules:    Mealstrom,+                        Mealstrom.FSM,+                        Mealstrom.FSMApi,+                        Mealstrom.FSMEngine,+                        Mealstrom.FSMStore,+                        Mealstrom.FSMTable,+                        Mealstrom.MemoryStore,+                        Mealstrom.PostgresJSONStore,+                        Mealstrom.WALStore+    ghc-options:  test-suite test-  default-language:    Haskell2010-  type:                exitcode-stdio-1.0-  hs-source-dirs:      src-                       test-  main-is:             Main.hs-  ghc-options:         -threaded -with-rtsopts=-N-  build-depends:-                       base              >= 4.8      && < 4.10-                     , aeson             >= 0.11.2.0 && < 1.1-                     , async             >= 2.1.0    && < 2.2-                     , bytestring        >= 0.10.8.1 && < 0.11-                     , hashable          >= 1.2.4    && < 1.3-                     , list-t            >= 1        && < 2-                     , postgresql-simple >= 0.5.1.2  && < 0.6-                     , resource-pool     >= 0.2.3.2  && < 0.3-                     , stm               >= 2.4.4.1  && < 2.5-                     , stm-containers    >= 0.2.15   && < 0.3-                     , text              >= 1.2.2.1  && < 1.3-                     , time              >= 1.6      && < 1.7-                     , tasty             >= 0.11.0.2 && < 0.12-                     , tasty-hunit       >= 0.9.2    && < 1.0-                     , uuid              >= 1.3.12   && < 1.4+    import:             deps+    default-language:   Haskell2010+    type:               exitcode-stdio-1.0+    hs-source-dirs:     test+    main-is:            Main.hs+    build-depends:+      , mealstrom+      , tasty           >= 0.11.0.2 && < 1.2+      , tasty-hunit     >= 0.10.0.1 && < 1.0+    other-modules:+        BasicFSM+        CounterFSM+        Exception+        FSM2FSM+        Recovery+        Timeout+        Upgrade  source-repository head   type:     git

@@ -0,0 +1,17 @@++{-|+Module      : Mealstrom+Description : Main file.+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org+-}++module Mealstrom (+    module X+)+ where++import Mealstrom.FSM      as X+import Mealstrom.FSMApi   as X+import Mealstrom.FSMTable as X

@@ -112,11 +112,6 @@ -- ############## -- # JSON Codecs -- ##############-instance ToJSON UUID where-    toJSON u = toJSON (UUID.toText u)--instance FromJSON UUID where-    parseJSON = withText "UUID" $ \x -> return . fromJust $ UUID.fromText x  instance (ToJSON s, ToJSON e, ToJSON a) => ToJSON (Change s e a) where     toJSON (Count i) = object [ "count" .= toJSON i]

@@ -63,7 +63,7 @@  -- |Concurrent updates will be serialised by Postgres. -- Returns True when the state transition has been successfully computed--- and actions have been scheduled.+-- and actions have been scheduled, now or at any time in the past. -- Returns False on failure. patch :: forall st wal k s e a . (FSMStore st k s e a, MealyInstance k s e a, FSMKey k) => FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool patch h@FSMHandle{..} k es = do

@@ -24,7 +24,8 @@     mkStore,     _fsmRead,     _fsmCreate,-    _fsmUpdate+    _fsmUpdate,+    _batchConversion ) where  @@ -232,6 +233,28 @@ _queryValue :: (FromRow v) => Connection -> Text -> Text -> IO [v] _queryValue c tbl q =     PGS.query c "SELECT * FROM ? WHERE data @> ?" (Identifier tbl, q)++_getKeys :: forall k . (FSMKey k) => PostgresJSONStore -> Text -> IO [k]+_getKeys st tbl =+    withResource (storeConnPool st) (\conn -> do+       keys <- PGS.query conn "SELECT id FROM ?" (Only (Identifier tbl)) :: IO [Only Text]++       return  (fmap (\(Only t) -> fromText t) keys :: [k]))++-- | You can call this function when you changed the representation of your+-- MealyMachine. It will read all instances through FromJSON and write them+-- back using ToJSON.+_batchConversion :: forall k s e a .+                   (FromJSON s, FromJSON e, FromJSON a,+                    ToJSON   s, ToJSON   e, ToJSON   a,+                    Typeable s, Typeable e, Typeable a, MealyInstance k s e a)+                 => PostgresJSONStore+                 -> Text+                 -> Proxy k s e a+                 -> IO ()+_batchConversion st tbl _p = do+    keys <- _getKeys st tbl :: IO [k]+    mapM_ (\k -> _fsmUpdate st k (return :: MachineTransformer s e a)) keys   -- |Instance to convert one DB row to an instance of Instance ;)

@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : BasicFSM+Description : A simple example.+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org+-}++module BasicFSM (runBasicTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Concurrent+import Data.Aeson+import Data.Hashable+import Data.Text                   as Text+import Data.Typeable+import GHC.Generics++import Mealstrom+import Mealstrom.FSMStore+import Mealstrom.WALStore+import Mealstrom.PostgresJSONStore as PGJSON+import Mealstrom.MemoryStore       as MemStore+++-- ####################+-- # Connection Example+-- ####################++-- This is a contrived example of how to use a custom Key type, instead of the recommended Text and UUID.+newtype ConnectionKey = ConnectionKey (Int,Int) deriving (Show,Eq,Generic,Hashable)++instance FSMKey ConnectionKey where+    toText (ConnectionKey (a,b)) = Text.pack $ "(" ++ show a ++ "," ++ show b ++ ")"+    fromText t = case fmap (\s -> read (unpack s) :: Int) (splitOn "," $ Text.dropEnd 1 (Text.drop 1 t)) of+        a:[b] -> ConnectionKey (a,b)+        _     -> error ""++data ConnectionState  = New | Open | Closed+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++data ConnectionEvent  = Create | Close | Reset+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++data ConnectionAction = PrintStatusOpened | PrintStatusClosed+    deriving (Eq,Typeable,Generic,ToJSON,FromJSON)++instance MealyInstance ConnectionKey ConnectionState ConnectionEvent ConnectionAction++connEffects :: MVar () -> Msg ConnectionAction -> IO Bool+connEffects mvar (Msg _i c)+    | c == PrintStatusOpened = putStrLn "OUTPUT: Connection opened" >> putMVar mvar () >> return True+    | c == PrintStatusClosed = putStrLn "OUTPUT: Connection closed" >> putMVar mvar () >> return True++connTransition :: (ConnectionState, ConnectionEvent) -> (ConnectionState, [ConnectionAction])+connTransition (s,e) =+    case (s,e) of+        (New, Create) -> (Open,  [PrintStatusOpened])+        (Open, Close) -> (Closed,[PrintStatusClosed])+        (Open, Reset) -> (Open,  [PrintStatusClosed, PrintStatusOpened])++runBasicTests :: String -> TestTree+runBasicTests c = testGroup "BasicFSM" [+    testCase "BasicPG" (runTest (PGJSON.mkStore c)),+    testCase "BasicMem0" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore ConnectionKey ConnectionState ConnectionEvent ConnectionAction)))+    ]++runTest :: (FSMStore st ConnectionKey ConnectionState ConnectionEvent ConnectionAction,+            WALStore st ConnectionKey) => (Text -> IO st) -> IO ()+runTest c = do+    st       <- c "BasicFSMTest"+    sync     <- newEmptyMVar+    let t     = FSMTable connTransition (connEffects sync)+    let myFSM = FSMHandle st st t 90 3+    let firstId = ConnectionKey (1231231,21)   -- This represents a socket or something++    post myFSM firstId New+    Just fsmState1 <- get myFSM firstId+    fsmState1 @?= New++    msg1 <- mkMsgs [Create]+    _    <- patch myFSM firstId msg1++    takeMVar sync+    Just fsmState2 <- get myFSM firstId+    fsmState2 @?= Open++    msg2 <- mkMsgs [Close]+    _    <- patch myFSM firstId msg2++    takeMVar sync+    Just fsmState3 <- get myFSM firstId+    fsmState3 @?= Closed

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : CounterFSM+Description : Show how to "compress" multiple events into one.+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org++After this test has run the DB table should show a "Count" entry+instead of ten individual Desu events.+-}++module CounterFSM (runCounterTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Concurrent+import Control.Monad+import Data.Aeson+import Data.Text+import Data.Typeable+import GHC.Generics+import Data.UUID+import Data.UUID.V4++import Mealstrom+import Mealstrom.PostgresJSONStore as PGJSON+import Mealstrom.MemoryStore       as MemStore++type CounterKey   = UUID+data CounterState = Desu+    deriving (Eq,Show,Typeable)+instance ToJSON CounterState where+    toJSON _ = "Desu"+instance FromJSON CounterState where+    parseJSON "Desu" = return Desu++data CounterEvent = DesuEvent+    deriving (Eq,Show,Typeable)+instance ToJSON CounterEvent where+    toJSON _ = "DesuEvent"+instance FromJSON CounterEvent where+    parseJSON "DesuEvent" = return DesuEvent+++-- NOP+data CounterAction = DesuDummyAction+    deriving (Eq,Show,Typeable,Generic)+instance ToJSON CounterAction where+    toJSON _ = "DesuDummyAction"+instance FromJSON CounterAction where+    parseJSON "DesuDummyAction" = return DesuDummyAction+++instance MealyInstance CounterKey CounterState CounterEvent CounterAction++counterTransition :: (CounterState, CounterEvent) -> (CounterState,[CounterAction])+counterTransition =+    \case (Desu, DesuEvent) -> (Desu,[DesuDummyAction])++counterEffects :: MVar () -> Msg CounterAction -> IO Bool+counterEffects mvar _ =+    putMVar mvar () >> return True++runCounterTests :: String -> TestTree+runCounterTests c = testGroup "CounterFSM" [+    testCase "CounterPG" (runTest $ PGJSON.mkStore c),+    testCase "CounterMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore CounterKey CounterState CounterEvent CounterAction)))+    ]++runTest c = do+    sync   <- newEmptyMVar++    st     <- c "CounterTest"++    let t   = FSMTable counterTransition (counterEffects sync)+    let fsm = FSMHandle st st t 900 3++    i      <- nextRandom+    post fsm i Desu++    replicateM_ 10 (do+        m <- mkMsgs [DesuEvent]+        _ <- patch fsm i m+        takeMVar sync)++    s <- get fsm i++    s @?= Just Desu

@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-|+Module      : Exception+Description : Test that illegal actions throw an exception and that they are caught.+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org+-}++module Exception (runExceptionTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Concurrent+import Data.Aeson+import Data.Hashable+import Data.Maybe                  (isNothing)+import Data.Text                   as Text+import Data.Typeable+import Data.UUID+import Data.UUID.V4+import GHC.Generics++import Mealstrom+import Mealstrom.FSMStore+import Mealstrom.WALStore+import Mealstrom.PostgresJSONStore as PGJSON+import Mealstrom.MemoryStore       as MemStore+++type MyKey    = UUID+data MyState  = MyState1  | MyState2  deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)+data MyEvent  = MyEvent1  | MyEvent2  deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)+data MyAction = MyAction1 | MyAction2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)++instance MealyInstance MyKey MyState MyEvent MyAction+myTransition :: (MyState,MyEvent) -> (MyState,[MyAction])+myTransition (MyState1,MyEvent1) =+    (MyState2,[MyAction1])++myEffects :: Msg MyAction -> IO Bool+myEffects _a = do+    putStrLn "Action completed"+    return True+++runExceptionTests :: String -> TestTree+runExceptionTests c = testGroup "ExceptionFSM" [+    testCase "ExceptionPG" (runTest (PGJSON.mkStore c)),+    testCase "ExceptionMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore MyKey MyState MyEvent MyAction)))+    ]++runTest :: (FSMStore st MyKey MyState MyEvent MyAction,+            WALStore st MyKey) => (Text -> IO st) -> IO ()+runTest c = do+    st       <- c "ExceptionTest"+    let t     = FSMTable myTransition myEffects+    let myFSM = FSMHandle st st t 90 3+    firstId <- nextRandom++    res1 <- post myFSM firstId MyState1+    res2 <- post myFSM firstId MyState1++    assertBool "Insert Instance once"                 res1+    assertBool "Insert Instance again and fail" $ not res2++    -- Technically the following assertions are not concerned with exceptions, but fine, whatever+    secondId <- nextRandom++    res3 <- get myFSM secondId+    assertBool "Get non-existing instance" $ isNothing res3++    res4 <- mkMsgs [MyEvent1] >>= patch myFSM secondId+    assertBool "Patch non-existing instance" $ not res4

@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : FSM2FSM+Description : An example that shows how two FSMs can exchange messages with each other.+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org+-}++module FSM2FSM (runFSM2FSMTests) where++import Control.Concurrent.QSem+import Data.Aeson+import Data.Text+import Data.Typeable+import Data.UUID+import Data.UUID.V4+import GHC.Generics+import Test.Tasty+import Test.Tasty.HUnit++import Mealstrom+import Mealstrom.FSMStore+import Mealstrom.PostgresJSONStore as PGJSON+import Mealstrom.MemoryStore       as MemStore++-- #################+-- # Payment Example+-- #################++-- #######+-- # FSM 1+-- #######+type PaymentKey   = UUID+data PaymentState = PaymentPending Int | PaymentPaid | PaymentAborted+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++-- Yes, if you abort payment after it has been partially paid, you lose money :-)+data PaymentEvent = ReceivedPayment UUID Int | AbortPayment+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++-- Credit our own bank account with sweet funds+data PaymentAction = PaymentUpdateAccount UUID Int+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++paymentTransition :: (PaymentState, PaymentEvent) -> (PaymentState,[PaymentAction])+paymentTransition (s,e) = case (s,e) of+        (PaymentPending _o, AbortPayment)         -> (PaymentAborted,[])+        (PaymentPending o,  ReceivedPayment ba i) -> if i >= o+                                                     then (PaymentPaid, [PaymentUpdateAccount ba i])+                                                     else (PaymentPending (o-i),[])+        (PaymentAborted,   _)                     -> (PaymentAborted, [])++paymentEffects :: (FSMStore st BankAccountKey BankAccountState BankAccountEvent BankAccountAction)+               =>  QSem+               ->  FSMHandle st wal BankAccountKey BankAccountState BankAccountEvent BankAccountAction+               ->  Msg PaymentAction+               ->  IO Bool+paymentEffects qsem h (Msg d (PaymentUpdateAccount acc amount)) = do++    -- send message to bankaccount FSM using the same msgId!+    upsert h acc (BankAccountBalance 0) [Msg d (BankAccountDeposit amount)]+    signalQSem qsem+    return True++instance MealyInstance PaymentKey PaymentState PaymentEvent PaymentAction++-- #######+-- # FSM 2+-- #######+type BankAccountKey   = UUID+data BankAccountState = BankAccountBalance Int+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++data BankAccountEvent = BankAccountDeposit Int+    deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON)++-- NOP+data BankAccountAction = BankAccountDummyAction+    deriving (Eq,Show,Typeable,Generic)++instance ToJSON BankAccountAction where+    toJSON _ = "BankAccountDummyAction"++instance FromJSON BankAccountAction where+    parseJSON "BankAccountDummyAction" = return BankAccountDummyAction++bankAccountTransition :: (BankAccountState, BankAccountEvent) -> (BankAccountState,[BankAccountAction])+bankAccountTransition =+    \case (BankAccountBalance i, BankAccountDeposit j) -> (BankAccountBalance $ i + j, [BankAccountDummyAction])++bankAccountEffects :: QSem -> Msg BankAccountAction -> IO Bool+bankAccountEffects qsem _ = signalQSem qsem >> return True++instance MealyInstance BankAccountKey BankAccountState BankAccountEvent BankAccountAction++-- #######+-- # TEST+-- #######+runFSM2FSMTests :: String -> TestTree+runFSM2FSMTests c =+    testGroup "FSM2FSM" [+        testCase "FSM2FSMPG" (runTest (PGJSON.mkStore c)(PGJSON.mkStore c)),+        testCase "FSM2FSMMem" (runTest (MemStore.mkStore :: Text -> IO(MemoryStore BankAccountKey BankAccountState BankAccountEvent BankAccountAction))+                                       (MemStore.mkStore :: Text -> IO(MemoryStore PaymentKey     PaymentState     PaymentEvent     PaymentAction)))+    ]+  where+    runTest c1 c2 = do+        sync          <- newQSem 0++        st1           <- c1 "FSM2FSMTestBank"++        let t1         = FSMTable bankAccountTransition (bankAccountEffects sync)+        let bankFsm    = FSMHandle st1 st1 t1 900 3++        -- Using the first handle we can instantiate the second one.+        st2           <- c2 "FSM2FSMTestPayments"++        let t2         = FSMTable paymentTransition (paymentEffects sync bankFsm)+        let paymentFsm = FSMHandle st2 st2 t2 900 3++        paymentId     <- nextRandom+        bankAccount   <- nextRandom++        msg1          <- mkMsg $ ReceivedPayment bankAccount 1000+        post  paymentFsm paymentId (PaymentPending 1000)+        _ <- patch paymentFsm paymentId [msg1]++        waitQSem sync+        waitQSem sync+        pymtstatus <- get paymentFsm paymentId+        pymtstatus @?= Just PaymentPaid++        -- Now check that the second FSM has been updated as well+        bankstatus <- get bankFsm bankAccount+        bankstatus @?= Just (BankAccountBalance 1000)

@@ -4,6 +4,7 @@ import Recovery   (runRecoveryTests) import Timeout    (runTimeoutTests) import Exception  (runExceptionTests)+import Upgrade    (runUpgradeTests)  import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Types@@ -24,5 +25,6 @@             runCounterTests c,             runRecoveryTests c,             runTimeoutTests c,-            runExceptionTests c+            runExceptionTests c,+            runUpgradeTests c             ]

@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : Recovery+Description : Test that recovery works+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org+-}+module Recovery(runRecoveryTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Concurrent+import Data.Typeable+import Data.Aeson+import GHC.Generics+import Data.Text+import Data.IORef+import Data.UUID+import Data.UUID.V4++import Mealstrom+import Mealstrom.PostgresJSONStore as PGJSON+import Mealstrom.MemoryStore       as MemStore++type RecoveryKey    = UUID+data RecoveryState  = RecoveryState1  | RecoveryState2  deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)+data RecoveryEvent  = RecoveryEvent1  | RecoveryEvent2  deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)+data RecoveryAction = RecoveryAction1 | RecoveryAction2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)++instance MealyInstance RecoveryKey RecoveryState RecoveryEvent RecoveryAction++recoveryTransition :: (RecoveryState,RecoveryEvent) -> (RecoveryState,[RecoveryAction])+recoveryTransition (RecoveryState1,RecoveryEvent1) =+    (RecoveryState2,[RecoveryAction1])++recoveryEffects :: IORef Bool -> MVar () -> Msg RecoveryAction -> IO Bool+recoveryEffects b sync _a = do+    bb <- readIORef b++    -- indicate that we read the IORef and are running the action now+    putMVar sync ()++    return bb++runRecoveryTests :: String -> TestTree+runRecoveryTests c = testGroup "Recovery" [+    testCase "RecoveryPG" (runTest $ PGJSON.mkStore c),+    testCase "RecoveryMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore RecoveryKey RecoveryState RecoveryEvent RecoveryAction)))+    ]++runTest c = do+    st     <- c "RecoveryTest"++    b      <- newIORef False+    sync   <- newEmptyMVar++    let t   = FSMTable recoveryTransition (recoveryEffects b sync)+    let fsm = FSMHandle st st t 1 3    -- we have a timeout of 1 second for actions++    i <- nextRandom++    post fsm i RecoveryState1+    mkMsgs [RecoveryEvent1] >>= patch fsm i++    -- action is run for the first time+    takeMVar sync++    -- wait two seconds, so that the action is definitely recoverable+    threadDelay (2 * 10^6)+    writeIORef b True+    recoverAll fsm++    -- action is run again+    takeMVar sync++    -- If we reach this, then the recovery definitely ran, yet the entry in the DB+    -- might still be wrong. That's ok.+    assertBool "Failed action recovers successfully" True

@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : Timeout+Description : Make sure that recovery actually uses a timeout+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org+-}++module Timeout(runTimeoutTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Concurrent+import Data.Typeable+import Data.Aeson+import GHC.Generics+import Data.Text+import Data.IORef+import Data.UUID+import Data.UUID.V4++import Mealstrom+import Mealstrom.PostgresJSONStore as PGJSON+import Mealstrom.MemoryStore       as MemStore++type TimeoutKey    = UUID+data TimeoutState  = TimeoutState  deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)+data TimeoutEvent  = TimeoutEvent  deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)+data TimeoutAction = TimeoutAction deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON)++instance MealyInstance TimeoutKey TimeoutState TimeoutEvent TimeoutAction++timeoutTransition :: (TimeoutState,TimeoutEvent) -> (TimeoutState,[TimeoutAction])+timeoutTransition (TimeoutState,TimeoutEvent) = (TimeoutState,[TimeoutAction])++timeoutEffects :: IORef Bool -> MVar () -> Msg TimeoutAction -> IO Bool+timeoutEffects b sync _a = do+    bb <- readIORef b++    if   bb+    then putMVar sync ()               -- if this is the second run, we proceed normally+    else seq (sum [1..]) (return ())   -- else we timeout++    return True++runTimeoutTests :: String -> TestTree+runTimeoutTests c = testGroup "Timeout" [+    testCase "TimeoutPG" (runTest $ PGJSON.mkStore c),+    testCase "TimeoutMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore TimeoutKey TimeoutState TimeoutEvent TimeoutAction)))+    ]++runTest c = do+    st     <- c "TimeoutTest"++    b      <- newIORef False+    sync   <- newEmptyMVar++    let t   = FSMTable timeoutTransition (timeoutEffects b sync)+    let fsm = FSMHandle st st t 1 2    -- timeout of 1 second and we only try once++    i      <- nextRandom++    post fsm i TimeoutState+    mkMsgs [TimeoutEvent] >>= patch fsm i++    -- action is run for the first time and should timeout+    threadDelay (1*10^6)+    writeIORef b True++    -- action is run again+    takeMVar sync++    assertBool "Recovery after timeout successful" True

@@ -0,0 +1,197 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-|+Module      : Upgrade+Description : Test that upgrading the data model actually works+Copyright   : (c) Max Amanshauser, 2016+License     : MIT+Maintainer  : max@lambdalifting.org++All this looks a bit goofy because you cannot have duplicate+data constructors and I did not want to make separate modules.+In practice it's much less confusing.+-}++module Upgrade (runUpgradeTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Concurrent+import Control.Monad               (guard)+import Data.Aeson+import Data.Aeson.Types+import Data.Hashable+import Data.Maybe                  (isNothing)+import qualified Data.Text         as Text+import Data.Text                   (Text)+import Data.Typeable               (Typeable)+import Data.UUID+import Data.UUID.V4+import GHC.Generics++import Mealstrom+import Mealstrom.FSMStore+import Mealstrom.WALStore+import Mealstrom.PostgresJSONStore as PGJSON++-- |First FSM Instance+type FirstKey    = UUID+data FirstState  = OldState1 deriving (Eq,Show,Typeable)+instance ToJSON FirstState where+    toJSON s = "OldState1"+instance FromJSON FirstState where+    parseJSON = withText "expected OldState1" (\t -> case t of "OldState1" -> return OldState1)++data FirstEvent  = OldEvent1 deriving (Eq,Show,Typeable)+instance ToJSON FirstEvent where+    toJSON e = "OldEvent1"+instance FromJSON FirstEvent where+    parseJSON = withText "expected OldEvent1" (\t -> case t of "OldEvent1" -> return OldEvent1)++data FirstAction = OldAction1 {+    _a :: String,+    _b :: Int+} deriving (Eq,Show,Typeable)+instance ToJSON FirstAction where+    toJSON a = object [+           "a" .= _a a,+           "b" .= _b a+           ]+instance FromJSON FirstAction where+    parseJSON = withObject "expected OldAction1" $ \o -> do+        _a <- o .: "a"+        _b <- o .: "b"++        return $ OldAction1 _a _b+++instance MealyInstance FirstKey FirstState FirstEvent FirstAction+firstTransition :: (FirstState,FirstEvent) -> (FirstState,[FirstAction])+firstTransition (OldState1,OldEvent1) =+    (OldState1,[OldAction1 "lol" 42])++firstEffects :: Msg FirstAction -> IO Bool+firstEffects _a = do+    putStrLn "Action completed"+    return True++-- |Second FSM Instance+-- here we want to parse both values from the first Instance+-- as well as values from the second Instance+type SecondKey    = UUID++-- The first upgrade is adding another data constructor to the State+data SecondState  = NewState1 | NewState2 Int deriving (Eq,Show)+instance ToJSON SecondState where+    toJSON NewState1     = "NewState1"+    toJSON (NewState2 i) = object [+        "name"  .= String "NewState2",+        "value" .= i+        ]+instance FromJSON SecondState where+    parseJSON (Object o) = do+        name <- o .: "name"+        guard (name == String "NewState2")+        val  <- o .: "value"++        return $ NewState2 val++    -- |Conversion from old version+    parseJSON (String t) =+        case t of+            "NewState1" -> return NewState1+            "OldState1" -> return NewState1++-- The second upgrade is adding a parameter to the Event+data SecondEvent = NewEvent1 Int deriving (Eq,Show)+instance ToJSON SecondEvent where+    toJSON (NewEvent1 i) = object [+        "name"  .= String "NewEvent1",+        "value" .= i+        ]+instance FromJSON SecondEvent where+    parseJSON (Object o) = do+        name <- o .: "name"+        guard(name == String "NewEvent1")+        val  <- o .: "value"++        return $ NewEvent1 val++    -- Conversion from old version+    parseJSON (String t) = case t of+        "OldEvent1" -> return $ NewEvent1 0++-- |Here we just add another field to the existing data type+data SecondAction = NewAction1 {+    __a :: String,+    __b :: Int,+    __c :: Double+} deriving (Eq,Show,Typeable)+instance ToJSON SecondAction where+    toJSON a = object [+           "a" .= __a a,+           "b" .= __b a,+           "c" .= __c a+           ]+instance FromJSON SecondAction where+    parseJSON = withObject "expected FirstAction" $ \o -> do+        __a <- o .:  "a"+        __b <- o .:  "b"+        __c <- o .:? "c" .!= 0.0++        return $ NewAction1 __a __b __c+++instance MealyInstance SecondKey SecondState SecondEvent SecondAction+secondTransition :: (SecondState,SecondEvent) -> (SecondState,[SecondAction])+secondTransition (NewState1,NewEvent1 i) =+    (NewState2 i,[NewAction1 "double lol" 666 1.0])++secondEffects :: Msg SecondAction -> IO Bool+secondEffects _a = do+    putStrLn "Action completed"+    return True++runUpgradeTests :: String -> TestTree+runUpgradeTests c = testGroup "UpgradeFSM" [+    testCase "UpgradePG" (runTest (PGJSON.mkStore c))+    ]++runTest :: (Text -> IO PostgresJSONStore) -> IO ()+runTest c = do+    -- Start by creating the first FSMHandle and adding some data+    st       <- c "UpgradeTest" :: IO PostgresJSONStore+    let t1     = FSMTable firstTransition firstEffects+    let myFSM1 = FSMHandle st st t1 90 3++    firstId   <- nextRandom+    res1      <- post myFSM1 firstId OldState1+    mkMsgs [OldEvent1] >>= patch myFSM1 firstId++    sndId     <- nextRandom+    res2      <- post myFSM1 sndId OldState1+    mkMsgs [OldEvent1] >>= patch myFSM1 sndId++    -- Then, try to access the same FSM using another MealyInstance that uses upgraded data types+    let t2     = FSMTable secondTransition secondEffects+    let myFSM2 = FSMHandle st st t2 90 3++    -- Conversion when accessing+    res3  <- get myFSM2 firstId+    res3 @?= Just NewState1++    -- Conversion when saving+    mkMsgs [NewEvent1 15] >>= patch myFSM2 firstId+    res4  <- get myFSM2 firstId+    res4 @?= Just (NewState2 15)++    -- Batch conversion. Also examines already converted instances, but writes them back untouched.+    PGJSON._batchConversion st "UpgradeTest" (Proxy :: Proxy SecondKey SecondState SecondEvent SecondAction)+    res5  <- get myFSM2 sndId+    res5 @?= Just NewState1