├── .github └── workflows │ └── haskell.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── mealstrom.cabal ├── src ├── Mealstrom.hs └── Mealstrom │ ├── FSM.hs │ ├── FSMApi.hs │ ├── FSMEngine.hs │ ├── FSMStore.hs │ ├── FSMTable.hs │ ├── MemoryStore.hs │ ├── PostgresJSONStore.hs │ └── WALStore.hs └── test ├── BasicFSM.hs ├── CommonDefs.hs ├── CounterFSM.hs ├── Exception.hs ├── FSM2FSM.hs ├── Main.hs ├── Recovery.hs ├── Timeout.hs └── Upgrade.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | if: "!contains(github.event.head_commit.message, 'skip ci') && !contains(github.event.head_commit.message, 'ci skip')" 8 | runs-on: ubuntu-latest 9 | 10 | services: 11 | postgres: 12 | image: postgres 13 | # Provide the password for postgres 14 | env: 15 | POSTGRES_PASSWORD: postgres 16 | # Set health checks to wait until postgres has started 17 | options: >- 18 | --health-cmd pg_isready 19 | --health-interval 10s 20 | --health-timeout 5s 21 | --health-retries 5 22 | ports: 23 | # Maps tcp port 5432 on service container to the host 24 | - 5432:5432 25 | 26 | strategy: 27 | matrix: 28 | ghc-version: ['8.0.2','8.2.2','8.4.4','8.6.5','8.8.4','8.10.3'] 29 | fail-fast: false 30 | steps: 31 | - uses: actions/checkout@v2 32 | - uses: actions/setup-haskell@v1 33 | with: 34 | ghc-version: ${{ matrix.ghc-version }} 35 | cabal-version: '3.2' 36 | 37 | - name: Cache 38 | uses: actions/cache@v2 39 | env: 40 | cache-name: cache-cabal-ghc-${{ matrix.ghc-version }} 41 | with: 42 | path: ~/.cabal 43 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 44 | restore-keys: | 45 | ${{ runner.os }}-build-${{ env.cache-name }}- 46 | 47 | - name: Prepare PostgreSQL database 48 | run: createdb fsmtest 49 | env: 50 | PGHOST: localhost 51 | PGPORT: 5432 52 | PGUSER: postgres 53 | PGPASSWORD: postgres 54 | - name: Install dependencies 55 | run: | 56 | cabal update 57 | cabal build --only-dependencies --enable-tests --enable-benchmarks 58 | - name: Build 59 | run: cabal build --enable-tests --enable-benchmarks all 60 | - name: Run tests 61 | run: cabal test all 62 | env: 63 | PGHOST: localhost 64 | PGPORT: 5432 65 | PGUSER: postgres 66 | PGPASSWORD: postgres 67 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) 5 | 6 | ## [Unreleased] 7 | 8 | ## [0.0.1.1] - 2021-01-15 9 | ### Changed 10 | - bump dependencies and make code compile again 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Max Amanshauser 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Mealstrom [![Hackage version](https://img.shields.io/hackage/v/mealstrom.svg?colorB=4FB900)](https://hackage.haskell.org/package/mealstrom) 2 | ========= 3 | 4 | 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. 5 | 6 | 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. 7 | 8 | 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. 9 | 10 | * Therefore in a RDBMS you must store *events* in their own right, and have a way to compute the object's current state. You need to implement checks for what constitutes *valid state transitions* manually, again and again for each entity. 11 | 12 | * While RDBMS are very powerful, it often feels like you are doing all the work twice, e.g. you write constraints, foreign key checks, triggers etc. and then do all the input validity checking in the client as well, because you do not want to incur the overhead of constantly sending all input to the DB and because relying on parsing the thrown exceptions is often not even possible. 13 | 14 | * If you want to make sure that updates are actually applied, keep in mind that database transactions guarantee all-or-nothing handling of your updates, but you do not necessarily know which one of the two happened! Your database connection can drop between when a transaction completes and when control returns to your session. Hence, you need to make all your updates idempotent, and where they are not naturally, you need to add client-generated IDs to your queries (and perhaps use some of the RDBMS' power like triggers). That assumes you actually read the part on transaction isolation in your database manual, because the details are surprisingly tricky and the tiniest mistake can lead to data loss. 15 | 16 | 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. 17 | 18 | ## Enter Mealstrom 19 | 20 | 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. 21 | 22 | Modeling a process as an FSA is the natural way to do it. FSAs have defined states, defined transitions and rules which transitions are permissable in a given state. 23 | 24 | You can then create instances of the machine definition and manipulate them using API functions. 25 | 26 | A Mealy machine in Mealstrom has the types **State**, **Event** and **Action**, an instance furthermore has a type **Key**. Mealstrom comes with support for `Text` and `UUID` as the Key type. You can have your own Key type, if you make it an instance of `(FSMKey k)` and implement `toText :: k -> Text` and `fromText :: Text -> k`. If you have no preference, it is recommended to use `UUID`. 27 | 28 | To persist the machines to PostgreSQL, you need to have Aeson `ToJSON`, `FromJSON` and `Typeable` instances for your four types. Typically, they can be derived generically. 29 | 30 | Once you have your four types, you make an instance of `MealyInstance`. 31 | 32 | Let's go through an example - A simple system a surgery ward might use to track patients. 33 | 34 | ``` 35 | -- First the language extension and import dance: 36 | 37 | {-# LANGUAGE TypeSynonymInstances #-} 38 | {-# LANGUAGE MultiParamTypeClasses #-} 39 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} 40 | {-# LANGUAGE OverloadedStrings #-} 41 | {-# LANGUAGE MultiWayIf #-} 42 | 43 | import Data.Aeson 44 | import Data.Text (Text) 45 | import Data.Typeable 46 | import GHC.Generics 47 | 48 | import Mealstrom 49 | import Mealstrom.PostgresJSONStore as PGJSON 50 | 51 | type SSN = Text 52 | data Limb = Arm | Hand | Leg deriving (Show,Eq,Generic,ToJSON,FromJSON,Typeable) 53 | data PatientStatus = PatientAdmitted Integer [LimbSurgery] 54 | | PatientReleased 55 | | PatientDeceased 56 | deriving (Show,Eq,Generic,ToJSON,FromJSON,Typeable) 57 | data LimbSurgery = Removed Limb | Attached Limb deriving (Show,Eq,Generic,ToJSON,FromJSON,Typeable) 58 | data Event = Operation LimbSurgery | Release | Deceased deriving (Show,Eq,Generic,ToJSON,FromJSON,Typeable) 59 | data Action = SendBill Integer | SendCondolences deriving (Show,Eq,Generic,ToJSON,FromJSON,Typeable) 60 | 61 | instance MealyInstance SSN PatientStatus Event Action 62 | 63 | ``` 64 | 65 | There is also a transition function `transition :: (State,Event) -> (State,[Action])`, 66 | 67 | as well as an effects function `effects :: Msg Action -> IO Bool`. 68 | 69 | You implement `transition` to indicate which transitions are valid and which effects you want to run when a transition occurs. 70 | 71 | An `Action` (wrapped in a Msg) is then used to pattern match in `effects` and execute the appropriate code. 72 | 73 | NB *Action* is the type you use to represent the *effects* you want to run. 74 | 75 | Because the states, events, actions as well as the transition/effects functions are just Haskell data types and code, you can go crazy, but for now let's expand on the simple example above: 76 | 77 | ``` 78 | -- |Calculates current number of specified limb on patient 79 | -- Boldly assumes every patient comes in with full set of limbs 80 | limbsOnPatient :: [LimbSurgery] -> Limb -> Int 81 | limbsOnPatient ops limb = 82 | foldr (\op acc -> if 83 | | op == Removed limb -> acc-1 84 | | op == Attached limb -> acc+1 85 | | otherwise -> acc) 2 ops 86 | 87 | cost :: LimbSurgery -> Integer 88 | cost (Removed Arm) = 5000 89 | cost (Attached Arm) = 15000 90 | cost (Removed Hand) = 2000 91 | cost (Attached Hand) = 8000 92 | cost (Removed Leg) = 12000 93 | cost (Attached Leg) = 20000 94 | 95 | tr (PatientAdmitted bill ls, Operation (Removed l)) 96 | | limbsOnPatient ls l < 1 = error "Cannot remove limb that's not there anymore!" 97 | | otherwise = let newbill = bill + cost (Removed l) in 98 | (PatientAdmitted newbill $ Removed l : ls, [SendCondolences]) 99 | 100 | tr (PatientAdmitted bill ls, Operation (Attached l)) 101 | | limbsOnPatient ls l > 1 = error "Cannot attach limb, there is no space!" 102 | | otherwise = let newbill = bill + cost (Attached l) in 103 | (PatientAdmitted newbill $ Attached l : ls, []) 104 | 105 | tr (PatientAdmitted bill _ls, Release) = (PatientReleased, [SendBill bill]) 106 | tr (PatientAdmitted bill _ls, Deceased) = (PatientDeceased, [SendCondolences, SendBill bill]) 107 | 108 | tr (PatientReleased, _) = error "Patient escaped, operation invalid." 109 | tr (PatientDeceased, _) = error "Operations on dead patients are not billable" 110 | 111 | eff :: Msg Action -> IO Bool 112 | eff (Msg msgId SendCondolences) = putStrLn "not implemented" >> return True 113 | eff (Msg msgId (SendBill bill)) = charge bill :: IO Bool 114 | ``` 115 | 116 | 117 | From wherever you wish to manipulate a Patient instance, you can then use a simple REST-like interface: 118 | 119 | ``` 120 | main = do 121 | st <- PGJSON.mkStore "host='localhost' port=5432 dbname='butchershop'" "Patient" 122 | 123 | -- You specify transition and effects when creating the Handle for a machine 124 | -- This is so that you can pass variables to the functions, if you want to. 125 | let t = FSMTable tr eff 126 | let patientFSM = FSMHandle st st t 90 3 :: FSMHandle PostgresJSONStore PostgresJSONStore SSN PatientStatus Event Action 127 | 128 | -- `post` gives you the flexibility of having different start states. 129 | post patientFSM "123-12-1235" (PatientAdmitted 0 []) 130 | res <- mkMsgs [Operation (Removed Arm)] >>= patch patientFSM "123-12-1235" 131 | 132 | get patientFSM "123-12-1235" -- Just (PatientAdmitted 5000 [Removed Arm]) 133 | ``` 134 | 135 | 136 | ### Reliability 137 | You may have noticed up there, that "patches" are wrapped in Msgs. They are used to give certain reliability guarantees in Mealstrom. 138 | 139 | The `FSMAPI` through which you should interact with instances guarantees idempotance. `get` is trivially idempotent, `post` will let you know if the instance already exists and it is safe to retry. Finally, for `patch` you generate a `Msg` using `mkMsg` or `mkMsgs` that wraps an `Event` you want to send to an instance. 140 | 141 | Once `patch` returns `True`, you can be assured that the state transition has occurred and the associated Actions are now running asynchronously. You can safely retry `patch`, because when a `msgId` is already known, the message is discarded. 142 | 143 | You can run arbitrary effects, they will be retried until a retry limit you set is hit or until they succeed. This means they may happen [more than once] (https://en.wikipedia.org/wiki/Two_Generals'_Problem) or not at all. Failed effects can be retried at any time by calling `recoverAll`. 144 | 145 | 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. 146 | 147 | ### Log 148 | 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. 149 | 150 | ### "Schema" updates 151 | 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). 152 | 153 | 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. 154 | 155 | 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). 156 | 157 | Lastly, Mealstrom is not a good fit if: 158 | 159 | * You require every last bit of performance. 160 | * You do not care particularly whether updates are occasionally lost. 161 | * 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. 162 | 163 | 164 | ## Tests 165 | 166 | To run the tests you need to run `createdb fsmtest` first. 167 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /mealstrom.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: mealstrom 4 | version: 0.0.1.1 5 | synopsis: Manipulate FSMs and store them in PostgreSQL. 6 | homepage: https://github.com/linearray/mealstrom 7 | bug-reports: https://github.com/linearray/mealstrom/issues 8 | description: 9 | 10 | Mealstrom is a library that allows you to work with Mealy machines, 11 | a kind of finite-state machine, in Haskell using PostgreSQL for 12 | persistence. 13 | 14 | extra-source-files: 15 | README.md 16 | CHANGELOG.md 17 | license: MIT 18 | license-file: LICENSE 19 | author: Max Amanshauser 20 | maintainer: max@lambdalifting.org 21 | copyright: Copyright (c) Max Amanshauser 2016 22 | category: Database, Control 23 | build-type: Simple 24 | extra-source-files: README.md 25 | 26 | common deps 27 | build-depends: 28 | , base >= 4.8 && < 5.0 29 | , aeson >= 1.1 && < 1.6 30 | , async >= 2.1.0 && < 2.3 31 | , bytestring >= 0.10.8.1 && < 0.11 32 | , hashable >= 1.2.4 && < 1.4 33 | , deferred-folds >= 0.9.10.1 && < 1 34 | , postgresql-simple >= 0.5.1.2 && < 0.7 35 | , resource-pool >= 0.2.3.2 && < 0.3 36 | , stm >= 2.4.4.1 && < 2.6 37 | , stm-containers >= 1.0 && < 1.3 38 | , text >= 1.2.2.1 && < 1.3 39 | , time >= 1.6 && < 1.12 40 | , uuid >= 1.3.12 && < 1.4 41 | 42 | library 43 | import: deps 44 | build-depends: 45 | containers >= 0.5.8.1 && < 0.7 46 | hs-source-dirs: src 47 | default-language: Haskell2010 48 | exposed-modules: Mealstrom, 49 | Mealstrom.FSM, 50 | Mealstrom.FSMApi, 51 | Mealstrom.FSMEngine, 52 | Mealstrom.FSMStore, 53 | Mealstrom.FSMTable, 54 | Mealstrom.MemoryStore, 55 | Mealstrom.PostgresJSONStore, 56 | Mealstrom.WALStore 57 | ghc-options: 58 | 59 | test-suite test 60 | import: deps 61 | default-language: Haskell2010 62 | type: exitcode-stdio-1.0 63 | hs-source-dirs: test 64 | main-is: Main.hs 65 | build-depends: 66 | , mealstrom 67 | , tasty >= 0.11.0.2 && < 1.2 68 | , tasty-hunit >= 0.10.0.1 && < 1.0 69 | other-modules: 70 | BasicFSM 71 | CounterFSM 72 | Exception 73 | FSM2FSM 74 | Recovery 75 | Timeout 76 | Upgrade 77 | 78 | source-repository head 79 | type: git 80 | location: git://github.com/linearray/mealstrom.git 81 | 82 | -------------------------------------------------------------------------------- /src/Mealstrom.hs: -------------------------------------------------------------------------------- 1 | 2 | {-| 3 | Module : Mealstrom 4 | Description : Main file. 5 | Copyright : (c) Max Amanshauser, 2016 6 | License : MIT 7 | Maintainer : max@lambdalifting.org 8 | -} 9 | 10 | module Mealstrom ( 11 | module X 12 | ) 13 | where 14 | 15 | import Mealstrom.FSM as X 16 | import Mealstrom.FSMApi as X 17 | import Mealstrom.FSMTable as X 18 | -------------------------------------------------------------------------------- /src/Mealstrom/FSM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | {-| 7 | Module : Mealstrom.FSM 8 | Description : Finite State Machine Definitions 9 | Copyright : (c) Max Amanshauser, 2016 10 | License : MIT 11 | Maintainer : max@lambdalifting.org 12 | 13 | These defintions are concerned with the basic functions of 14 | finite state machines, keeping a memory and state transitions. 15 | -} 16 | 17 | module Mealstrom.FSM where 18 | 19 | import Data.Aeson 20 | import Data.Foldable (asum) 21 | import Data.Hashable (Hashable) 22 | import Data.Maybe (fromJust, fromMaybe) 23 | import Data.Text (Text) 24 | import Data.Time.Clock 25 | import Data.Typeable (Typeable) 26 | import qualified Data.UUID as UUID 27 | import Data.UUID (UUID) 28 | import Data.UUID.V4 29 | import GHC.Generics 30 | 31 | type MachineTransformer s e a = Machine s e a -> IO (Machine s e a) 32 | 33 | -- |A data type that often comes in handy when describing whether 34 | -- updates have succeeded in the backend. 35 | data MealyStatus = MealyError | Pending | Done deriving (Eq, Show) 36 | 37 | 38 | -- |FSMs are uniquely identified by a type k, which must be convertible from/to Text. 39 | class (Hashable k, Eq k) => FSMKey k where 40 | toText :: k -> Text 41 | fromText :: Text -> k 42 | 43 | -- |This typeclass is needed to provide a constraint for the FSMStore abstraction. 44 | class (FSMKey k) => MealyInstance k s e a 45 | 46 | -- |A change in a FSM is either a (Step Timestamp oldState event newState Actions) 47 | -- or an increase in a counter. 48 | data Change s e a = Step UTCTime s e s [a] | Count Int deriving (Show) 49 | 50 | -- |Steps are equal to each other when they originated in the same state 51 | -- received the same event and ended up in the same state 52 | instance (Eq s, Eq e) => Eq (Change s e a) where 53 | (==) (Count a) (Count b) = a == b 54 | (==) (Step _ os1 e1 ns1 _) (Step _ os2 e2 ns2 _) = (os1 == os2) && (e1 == e2) && (ns1 == ns2) 55 | (==) (Count _) Step{} = False 56 | (==) Step{} (Count _) = False 57 | 58 | data Instance k s e a = Instance { 59 | key :: k, 60 | machine :: Machine s e a 61 | } deriving (Eq,Show,Generic,Typeable) 62 | 63 | data Machine s e a = Machine { 64 | inbox :: [Msg e], 65 | outbox :: [Msg a], 66 | committed :: [UUID], 67 | initState :: s, 68 | currState :: s, 69 | hist :: [Change s e a] 70 | } deriving (Eq,Show,Generic,Typeable) 71 | 72 | mkEmptyMachine :: s -> Machine s e a 73 | mkEmptyMachine s = Machine [] [] [] s s [] 74 | 75 | mkEmptyInstance :: k -> s -> Instance k s e a 76 | mkEmptyInstance k s = Instance k (mkEmptyMachine s) 77 | 78 | mkInstance :: k -> s -> [Msg e] -> Instance k s e a 79 | mkInstance k s es = Instance k ((mkEmptyMachine s) {inbox = es}) 80 | 81 | 82 | -- |Type of messages that are sent between FSMs 83 | -- Messages are always identified by UUID. 84 | -- The purpose of Msg is to attach a unique ID to an event, so that 85 | -- certain guarantees can be provided. 86 | data Msg e = Msg { 87 | msgID :: Maybe UUID, 88 | msgContents :: e 89 | } deriving (Show,Eq,Generic) 90 | 91 | mkMsg :: t -> IO (Msg t) 92 | mkMsg t = nextRandom >>= \i -> return $ Msg (Just i) t 93 | 94 | mkMsgs :: [t] -> IO [Msg t] 95 | mkMsgs = mapM mkMsg 96 | 97 | mkBogusMsg :: (Eq t) => t -> Msg t 98 | mkBogusMsg = Msg Nothing 99 | 100 | -- |Append a Change to a history. 101 | -- Identical steps are just counted, otherwise they are consed to the history. 102 | histAppend :: (Eq s, Eq e) => Change s e a -> [Change s e a] -> [Change s e a] 103 | histAppend s1 all@(Count i:s2:rest) 104 | | s1 == s2 = Count (i+1):s2:rest 105 | | otherwise = s1 : all 106 | histAppend s1 all@(s2:_rest) 107 | | s1 == s2 = Count 1 : all 108 | | otherwise = s1 : all 109 | histAppend s ss = s:ss 110 | 111 | 112 | -- ############## 113 | -- # JSON Codecs 114 | -- ############## 115 | 116 | instance (ToJSON s, ToJSON e, ToJSON a) => ToJSON (Change s e a) where 117 | toJSON (Count i) = object [ "count" .= toJSON i] 118 | toJSON (Step ts os ev ns as) = 119 | object [ 120 | "timestamp" .= toJSON ts, 121 | "old_state" .= toJSON os, 122 | "event" .= toJSON ev, 123 | "new_state" .= toJSON ns, 124 | "actions" .= toJSON as 125 | ] 126 | 127 | instance (FromJSON s, FromJSON e, FromJSON a) => FromJSON (Change s e a) where 128 | parseJSON = 129 | withObject "Change" $ \o -> 130 | asum [ 131 | Count <$> o .: "count", 132 | Step <$> o .: "timestamp" <*> o .: "old_state" <*> o .: "event" <*> o .: "new_state" <*> o .: "actions" 133 | ] 134 | 135 | 136 | -- Other Instances 137 | instance FSMKey Text where 138 | toText = id 139 | fromText = id 140 | 141 | instance FSMKey UUID where 142 | toText = UUID.toText 143 | fromText a = fromMaybe (error "Conversion from UUID failed") (UUID.fromText a) 144 | -------------------------------------------------------------------------------- /src/Mealstrom/FSMApi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | 10 | {-| 11 | Module : Mealstrom.FSMApi 12 | Description : API for FSMs 13 | Copyright : (c) Max Amanshauser, 2016 14 | License : MIT 15 | Maintainer : max@lambdalifting.org 16 | 17 | This is the interface through which you primarily interact with a FSM 18 | from the rest of your program. 19 | -} 20 | 21 | module Mealstrom.FSMApi where 22 | 23 | import Control.Concurrent 24 | import Control.Exception 25 | import Control.Monad (void) 26 | import qualified Data.Text as Text 27 | import System.IO 28 | import System.Timeout 29 | 30 | import Mealstrom.FSM 31 | import Mealstrom.FSMEngine 32 | import Mealstrom.FSMStore 33 | import Mealstrom.FSMTable 34 | import Mealstrom.WALStore 35 | 36 | 37 | data FSMHandle st wal k s e a where 38 | FSMHandle :: (Eq s, Eq e, Eq a, FSMStore st k s e a, WALStore wal k, FSMKey k) => { 39 | fsmStore :: st, -- ^ Which backend to use for storing FSMs. 40 | walStore :: wal, -- ^ Which backend to use for the WAL. 41 | fsmTable :: FSMTable s e a, -- ^ A table of transitions and effects. 42 | -- This is not in a typeclass, because you may want to use MVars or similar in effects. 43 | -- See the tests for examples. 44 | effTimeout :: Int, -- ^ How much time to allow for Actions until they are considered failed. 45 | retryCount :: Int -- ^ How often to automatically retry actions. 46 | } -> FSMHandle st wal k s e a 47 | 48 | 49 | get :: forall st wal k s e a . FSMStore st k s e a => FSMHandle st wal k s e a -> k -> IO(Maybe s) 50 | get FSMHandle{..} k = fsmRead fsmStore k (Proxy :: Proxy k s e a) 51 | 52 | 53 | -- |Idempotent because of usage of caller-generated keys. 54 | post :: forall st wal k s e a . FSMStore st k s e a => 55 | FSMHandle st wal k s e a -> 56 | k -> 57 | s -> IO Bool 58 | post FSMHandle{..} k s0 = 59 | fsmCreate fsmStore (mkInstance k s0 [] :: Instance k s e a) >>= \case 60 | Nothing -> return True 61 | Just s -> hPutStrLn stderr s >> return False 62 | 63 | 64 | -- |Concurrent updates will be serialised by Postgres. 65 | -- Returns True when the state transition has been successfully computed 66 | -- and actions have been scheduled, now or at any time in the past. 67 | -- Returns False on failure. 68 | 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 69 | patch h@FSMHandle{..} k es = do 70 | openTxn walStore k 71 | 72 | status <- handle (\(e::SomeException) -> hPutStrLn stderr (show e) >> return MealyError) 73 | (fsmUpdate fsmStore k ((patchPhase1 fsmTable es) :: MachineTransformer s e a)) 74 | 75 | if status /= MealyError 76 | then recover h k >> return True 77 | else return False 78 | 79 | 80 | -- |Recovering is the process of asynchronously applying Actions. It is performed 81 | -- immediately after the synchronous part of an update and, on failure, retried until it 82 | -- succeeds or the retry limit is hit. 83 | recover :: 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 -> IO () 84 | recover h@FSMHandle{..} k 85 | | retryCount == 0 = hPutStrLn stderr $ "Alarma! Recovery retries for " ++ Text.unpack (toText k) ++ " exhausted. Giving up!" 86 | | otherwise = 87 | void $ forkFinally (timeout (effTimeout*10^6) (fsmUpdate fsmStore k (patchPhase2 fsmTable :: MachineTransformer s e a))) -- (patchPhase2 fsmTable)) 88 | (\case Left exn -> do -- the damn thing crashed, print log and try again 89 | hPutStrLn stderr $ "Exception occurred while trying to recover " ++ Text.unpack (toText k) 90 | hPrint stderr exn 91 | recover h{retryCount = retryCount - 1} k 92 | Right Nothing -> do -- We hit the timeout. Try again until we hit the retry limit. 93 | hPutStrLn stderr $ "Timeout while trying to recover " ++ Text.unpack (toText k) 94 | recover h{retryCount = retryCount - 1} k 95 | Right (Just Done) -> closeTxn walStore k -- All good. 96 | Right (Just Pending) -> -- Some actions did not complete successfully. 97 | recover h{retryCount = retryCount - 1} k) 98 | 99 | 100 | -- |During certain long-lasting failures, like network outage, the retry limit of Actions will be exhausted. 101 | -- You should regularly, e.g. ever 10 minutes, call this function to clean up those hard cases. 102 | recoverAll :: forall st wal k s e a . (MealyInstance k s e a) => FSMHandle st wal k s e a -> IO () 103 | recoverAll h@FSMHandle{..} = do 104 | wals <- walScan walStore effTimeout 105 | mapM_ (recover h . walId) wals 106 | 107 | 108 | -- |A helper that is sometimes useful 109 | upsert :: forall st wal k s e a . MealyInstance k s e a => FSMStore st k s e a => 110 | FSMHandle st wal k s e a -> k -> s -> [Msg e] -> IO () 111 | upsert h k s es = do 112 | ms <- get h k 113 | maybe (post h k s >> void (patch h k es)) 114 | (\_s -> void $ patch h k es) 115 | ms 116 | -------------------------------------------------------------------------------- /src/Mealstrom/FSMEngine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | {-| 4 | Module : Mealstrom.FSMEngine 5 | Description : Apply changes to the machine and run effects 6 | Copyright : (c) Max Amanshauser, 2016 7 | License : MIT 8 | Maintainer : max@lambdalifting.org 9 | -} 10 | 11 | module Mealstrom.FSMEngine(patchPhase1,patchPhase2) where 12 | 13 | import Mealstrom.FSM 14 | import Mealstrom.FSMTable 15 | 16 | import Control.Monad (filterM, liftM) 17 | import Data.List 18 | import Data.Time.Clock 19 | 20 | -- |patchPhase1 is the part of a "change" to an FSM that happens synchronously. 21 | patchPhase1 :: (Eq s, Eq e) => FSMTable s e a -> [Msg e] -> Machine s e a -> IO (Machine s e a) 22 | patchPhase1 tab es m = getCurrentTime >>= \ts -> eval tab ts (sendMultiple m es) 23 | 24 | -- |patchPhase2 is the part of a "change" to an FSM that happens *asynchronously*. 25 | patchPhase2 :: (Eq a) => FSMTable s e a -> Machine s e a -> IO (Machine s e a) 26 | patchPhase2 = apply 27 | 28 | -- |Wrapper to send multiple messages at once. 29 | sendMultiple :: Machine s e a -> [Msg e] -> Machine s e a 30 | sendMultiple = foldr (flip send) 31 | 32 | -- |See if the message has already been recorded once 33 | -- If not, add it to the inbox. 34 | -- This is where duplicates, resulting from e.g. a crashed client, are filtered out. 35 | send :: Machine s e a -> Msg e -> Machine s e a 36 | send m e = 37 | let 38 | msgId (Msg (Just i) _) = i 39 | ibox = inbox m 40 | in 41 | if elem (msgId e) $ map msgId ibox ++ committed m 42 | then m 43 | else m {inbox = ibox ++ [e]} 44 | 45 | -- |Calculate the state changes in response to a message 46 | eval :: (Eq s, Eq e) => FSMTable s e a -> UTCTime -> Machine s e a -> IO (Machine s e a) 47 | eval FSMTable{..} ts m = 48 | let 49 | ibox = inbox m 50 | obox = outbox m 51 | comm = committed m 52 | (ids,events) = foldr (\(Msg (Just i) e) (is,es) -> (i:is,e:es)) ([],[]) ibox 53 | (newm,as) = closure transitions ts m events 54 | asmsgs = map mkMsg as 55 | in do 56 | s <- sequence asmsgs 57 | return $ newm {inbox = [], outbox = obox ++ s, committed = comm ++ ids} 58 | 59 | -- |Take messages from outbox and apply the effects. 60 | -- Failed applications of effects shall remain in the outbox. 61 | apply :: (Eq a) => FSMTable s e a -> Machine s e a -> IO (Machine s e a) 62 | apply FSMTable{..} m = do 63 | newas <- filterM (liftM not . effects) (outbox m) 64 | 65 | return $ m {outbox = newas} 66 | 67 | -- |Apply a list of events to a Memory according to a transition function 68 | closure :: (Eq s, Eq e) => Transitions s e a -> UTCTime -> Machine s e a -> [e] -> (Machine s e a, [a]) 69 | closure trans ts m@Machine{..} = 70 | foldl' (\(mm,oldas) e -> 71 | let (newm, newas) = step trans ts mm e in 72 | (newm, oldas ++ newas) 73 | ) (m,[]) 74 | 75 | -- |Calculates a new Memory, according to the transition function, for one event. 76 | step :: (Eq s, Eq e) => Transitions s e a -> UTCTime -> Machine s e a -> e -> (Machine s e a, [a]) 77 | step trans ts Machine{..} e = 78 | let 79 | (newState,as) = trans (currState,e) 80 | newHist = histAppend (Step ts currState e newState as) hist 81 | in 82 | (Machine inbox outbox committed initState newState newHist, as) 83 | -------------------------------------------------------------------------------- /src/Mealstrom/FSMStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | {-| 4 | Module : Mealstrom.FSMStore 5 | Description : Typeclass for FSMStores 6 | Copyright : (c) Max Amanshauser, 2016 7 | License : MIT 8 | Maintainer : max@lambdalifting.org 9 | -} 10 | 11 | module Mealstrom.FSMStore where 12 | 13 | import Mealstrom.FSM 14 | 15 | data Proxy k s e a = Proxy 16 | 17 | -- |Even the Read method needs type parameters 'e' and 'a' because it needs to deserialise the entry from storage. 18 | -- Implementations are expected to not throw exceptions in fsmRead/fsmCreate. 19 | -- Throwing in fsmUpdate is OK. 20 | class FSMStore st k s e a where 21 | fsmRead :: st -> k -> Proxy k s e a -> IO (Maybe s) 22 | fsmCreate :: st -> Instance k s e a -> IO (Maybe String) 23 | fsmUpdate :: st -> k -> MachineTransformer s e a -> IO MealyStatus 24 | -------------------------------------------------------------------------------- /src/Mealstrom/FSMTable.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : FSMTable 3 | Description : Types for Transitions and Effects 4 | Copyright : (c) Max Amanshauser, 2016 5 | License : MIT 6 | Maintainer : max@lambdalifting.org 7 | -} 8 | 9 | module Mealstrom.FSMTable where 10 | 11 | import Mealstrom.FSM 12 | 13 | type Transitions s e a = (s,e) -> (s,[a]) 14 | 15 | -- |Effects are wrapped in Msgs so that the effects function 16 | -- can access the msgId. This is useful when the effects function 17 | -- sends messages of its own, because it can reuse the msgId, thereby 18 | -- creating a message chain with the same Id. Doing so extends guarantees 19 | -- to the receiving FSM. 20 | type Effects a = Msg a -> IO Bool 21 | 22 | data FSMTable s e a = FSMTable { 23 | transitions :: Transitions s e a, 24 | effects :: Effects a 25 | } 26 | -------------------------------------------------------------------------------- /src/Mealstrom/MemoryStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | {-| 8 | Module : Mealstrom.MemoryStore 9 | Description : A memory-only storage backend, using STM. 10 | Copyright : (c) Max Amanshauser, 2016 11 | License : MIT 12 | Maintainer : max@lambdalifting.org 13 | -} 14 | module Mealstrom.MemoryStore ( 15 | MemoryStore, 16 | mkStore, 17 | _fsmRead, 18 | _fsmCreate, 19 | _fsmUpdate, 20 | printWal 21 | ) where 22 | 23 | import Control.Concurrent.STM 24 | import Control.Exception 25 | import Data.Text 26 | import Data.Time 27 | import qualified DeferredFolds.UnfoldlM as UnfoldlM 28 | import StmContainers.Map as Map 29 | 30 | import Mealstrom.FSM 31 | import Mealstrom.FSMStore 32 | import Mealstrom.WALStore 33 | 34 | instance (MealyInstance k s e a) => FSMStore (MemoryStore k s e a) k s e a where 35 | fsmRead st k _p = do 36 | may <- atomically (_fsmRead st k) 37 | return $ fmap (currState . machine) may 38 | fsmCreate st a = atomically $ _fsmCreate st a 39 | fsmUpdate st k t = _fsmUpdate st k t 40 | 41 | instance WALStore (MemoryStore k s e a) k where 42 | walUpsertIncrement = Mealstrom.MemoryStore.walUpsertIncrement 43 | walDecrement st k = atomically $ Mealstrom.MemoryStore.walDecrement st k 44 | walScan = Mealstrom.MemoryStore.walScan 45 | 46 | data MemoryStore k s e a where 47 | MemoryStore :: (MealyInstance k s e a) => { 48 | memstoreName :: Text, 49 | memstoreBacking :: Map k (Instance k s e a), 50 | memstoreLocks :: Map k (TMVar ()), 51 | memstoreWals :: Map k (UTCTime,Int) 52 | } -> MemoryStore k s e a 53 | 54 | _fsmRead :: MemoryStore k s e a -> k -> STM (Maybe (Instance k s e a)) 55 | _fsmRead MemoryStore{..} k = Map.lookup k memstoreBacking >>= \case 56 | Just a -> return $ Just a 57 | _ -> return Nothing 58 | 59 | -- |For compatibility with the other stores we check existence here 60 | _fsmCreate :: MemoryStore k s e a -> Instance k s e a -> STM (Maybe String) 61 | _fsmCreate MemoryStore{..} ins = do 62 | exists <- Map.lookup (key ins) memstoreBacking 63 | maybe (do 64 | t <- newTMVar () 65 | Map.insert t (key ins) memstoreLocks 66 | Map.insert ins (key ins) memstoreBacking 67 | return Nothing 68 | ) 69 | (\_ -> return $ Just "MemoryStore: Duplicate key") 70 | exists 71 | 72 | -- |We need to use a lock here, because we are in the unfortunate position of 73 | -- having to use IO while performing STM operations, which is not possible. 74 | -- Using the lock we can rest assured no concurrent update operation can progress. 75 | _fsmUpdate :: MemoryStore k s e a -> k -> MachineTransformer s e a -> IO MealyStatus 76 | _fsmUpdate MemoryStore{..} k t = 77 | let 78 | m = memstoreBacking 79 | ls = memstoreLocks 80 | in 81 | atomically (Map.lookup k ls) >>= \lock -> 82 | maybe (return MealyError) 83 | (\l -> 84 | bracket_ (atomically $ takeTMVar l) 85 | (atomically $ putTMVar l ()) 86 | (atomically (Map.lookup k m) >>= \res -> 87 | maybe (return MealyError) 88 | (\inst -> 89 | (do 90 | newMach <- t (machine inst) 91 | let r = if Prelude.null (outbox newMach) then Done else Pending 92 | atomically $ Map.insert inst{machine=newMach} k m 93 | return r 94 | ) 95 | ) res) 96 | ) 97 | lock 98 | 99 | walUpsertIncrement :: MemoryStore k s e a -> k -> IO () 100 | walUpsertIncrement MemoryStore{..} k = 101 | getCurrentTime >>= \t -> atomically $ 102 | Map.lookup k memstoreWals >>= \res -> 103 | maybe (Map.insert (t,1) k memstoreWals) 104 | (\(_oldt,w) -> Map.insert (t,w+1) k memstoreWals) 105 | res 106 | 107 | walDecrement :: MemoryStore k s e a -> k -> STM () 108 | walDecrement MemoryStore{..} k = 109 | Map.lookup k memstoreWals >>= \res -> 110 | maybe (error "trying to recover non-existing entry") 111 | (\(t,w) -> Map.insert (t,w-1) k memstoreWals) 112 | res 113 | 114 | walScan :: MemoryStore k s e a -> Int -> IO [WALEntry k] 115 | walScan MemoryStore{..} cutoff = 116 | getCurrentTime >>= \t -> atomically $ 117 | let xx = addUTCTime (negate (fromInteger (toInteger cutoff) :: NominalDiffTime)) t in 118 | 119 | UnfoldlM.foldlM' (\acc (k,(t,w)) -> if t < xx 120 | then return (WALEntry k t w : acc) 121 | else return acc) [] (Map.unfoldlM memstoreWals) 122 | 123 | 124 | printWal :: MemoryStore k s e a -> k -> IO () 125 | printWal MemoryStore{..} k = 126 | atomically (Map.lookup k memstoreWals) >>= \res -> 127 | maybe (putStrLn "NO WAL") 128 | print 129 | res 130 | 131 | 132 | mkStore :: (MealyInstance k s e a) => Text -> IO (MemoryStore k s e a) 133 | mkStore name = atomically $ do 134 | back <- new :: STM (Map k (Instance k s e a)) 135 | locks <- new :: STM (Map k (TMVar ())) 136 | wals <- new :: STM (Map k (UTCTime,Int)) 137 | return $ MemoryStore name back locks wals 138 | -------------------------------------------------------------------------------- /src/Mealstrom/PostgresJSONStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE DeriveAnyClass #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | {-| 11 | Module : Mealstrom.PostgresJSONStore 12 | Description : Main backend for FSMs and WALs. 13 | Copyright : (c) Max Amanshauser, 2016 14 | License : MIT 15 | Maintainer : max@lambdalifting.org 16 | 17 | This module is the main backend for FSMs. Instances are stored in a table 18 | with the name passed as storeName when creating the PostgresJSONStore. WALs use 19 | the same name with "Wal" appended. 20 | -} 21 | 22 | module Mealstrom.PostgresJSONStore( 23 | PostgresJSONStore, 24 | mkStore, 25 | _fsmRead, 26 | _fsmCreate, 27 | _fsmUpdate, 28 | _batchConversion 29 | ) where 30 | 31 | 32 | import Control.Exception (handle,SomeException) 33 | import Control.Monad (void) 34 | import Database.PostgreSQL.Simple as PGS 35 | import Database.PostgreSQL.Simple.FromRow 36 | import Database.PostgreSQL.Simple.ToField 37 | import Database.PostgreSQL.Simple.Transaction 38 | import Database.PostgreSQL.Simple.Types 39 | import Data.Aeson 40 | import qualified Data.ByteString.Char8 as DBSC8 41 | import Data.Int (Int64) 42 | import Data.Maybe (listToMaybe) 43 | import Data.Pool 44 | import Data.Text 45 | import Data.Time 46 | import Data.Typeable hiding (Proxy) 47 | import GHC.Generics 48 | import Database.PostgreSQL.Simple.FromField (FromField (fromField), 49 | fromJSONField, 50 | Conversion) 51 | 52 | import Mealstrom.FSM 53 | import Mealstrom.FSMStore 54 | import Mealstrom.WALStore 55 | 56 | data PostgresJSONStore = PostgresJSONStore { 57 | storeConnPool :: Pool Connection, 58 | storeName :: Text 59 | } 60 | 61 | instance (FromJSON s, FromJSON e, FromJSON a, 62 | ToJSON s, ToJSON e, ToJSON a, 63 | Typeable s, Typeable e, Typeable a, 64 | MealyInstance k s e a) => FSMStore PostgresJSONStore k s e a where 65 | fsmRead st k p = Mealstrom.PostgresJSONStore._fsmRead st k p >>= \mi -> return $ fmap (currState . machine) mi 66 | fsmCreate = Mealstrom.PostgresJSONStore._fsmCreate 67 | fsmUpdate = Mealstrom.PostgresJSONStore._fsmUpdate 68 | 69 | instance (FSMKey k) => WALStore PostgresJSONStore k where 70 | walUpsertIncrement = Mealstrom.PostgresJSONStore.walUpsertIncrement 71 | walDecrement = Mealstrom.PostgresJSONStore.walDecrement 72 | walScan = Mealstrom.PostgresJSONStore.walScan 73 | 74 | -- |We create a database pool (no subpools) of 20 connections that will be closed 75 | -- after 10 seconds of inactivity. 76 | givePool :: IO Connection -> IO (Pool Connection) 77 | givePool creator = createPool creator close 1 10 20 78 | 79 | 80 | -- ######### 81 | -- # FSM API 82 | -- ######### 83 | _fsmRead :: (FromJSON s, FromJSON e, FromJSON a, 84 | Typeable s, Typeable e, Typeable a, 85 | MealyInstance k s e a) => 86 | PostgresJSONStore -> 87 | k -> 88 | Proxy k s e a -> IO (Maybe (Instance k s e a)) 89 | _fsmRead st k _p = 90 | withResource (storeConnPool st) (\conn -> 91 | withTransactionSerializable conn $ do 92 | el <- _getValue conn (storeName st) (toText k) 93 | return $ listToMaybe el) 94 | 95 | 96 | _fsmCreate :: forall k s e a . 97 | (ToJSON s, ToJSON e, ToJSON a, 98 | Typeable s, Typeable e, Typeable a, 99 | MealyInstance k s e a) => 100 | PostgresJSONStore -> 101 | Instance k s e a -> IO (Maybe String) 102 | _fsmCreate st i = 103 | handle (\(e::SomeException) -> return $ Just (show e)) 104 | (withResource (storeConnPool st) (\conn -> 105 | withTransactionSerializable conn $ do 106 | void $ _postValue conn (storeName st) (toText $ key i) (machine i) 107 | return Nothing)) 108 | 109 | 110 | -- |Postgresql-simple exceptions will be caught by `patch` in FSMApi.hs 111 | -- In principle all transaction isolation levels offered by Postgres are safe 112 | -- here, because we do explicit locking in _getValueForUpdate. 113 | -- However things become more interesting when considering that you can do 114 | -- arbitrary queries in effects, either using the functions in this 115 | -- module or otherwise. 116 | 117 | -- We use Serializable here, because it involves no extra cost in our case, and 118 | -- it provides safety when used in arbitrary ways in effects. 119 | -- Hence, 120 | -- * Serializable is recommended and safe. 121 | -- * Repeatable Read, or in PostgreSQL's case Snapshot Isolation, does *not* protect 122 | -- against write skew, which means that if two Actions perform reads and based 123 | -- on the result update data, one of the two updates may be lost. 124 | -- * Read Committed means the usual caveats apply (Nonrepeatable reads, Phantom reads, Write skew…). 125 | -- 126 | -- If you are not careful you may end up with wrong data or attempts to insert data 127 | -- with a duplicate ID… 128 | -- Hence, when in doubt, do not lower the isolation level. 129 | _fsmUpdate :: forall k s e a . 130 | (FromJSON s, FromJSON e, FromJSON a, 131 | ToJSON s, ToJSON e, ToJSON a, 132 | Typeable s, Typeable e, Typeable a, 133 | MealyInstance k s e a) => 134 | PostgresJSONStore -> 135 | k -> 136 | MachineTransformer s e a -> IO MealyStatus 137 | _fsmUpdate st k t = 138 | withResource (storeConnPool st) (\conn -> 139 | withTransactionSerializable conn $ do 140 | el <- _getValueForUpdate conn (storeName st) (toText k) :: IO [Instance k s e a] 141 | let entry = listToMaybe el 142 | 143 | maybe 144 | (return MealyError) 145 | (\e -> do 146 | newMachine <- t (machine e) 147 | void (_postOrUpdateValue conn (storeName st) (toText k) newMachine) 148 | return $ if Prelude.null (outbox newMachine) then Done else Pending) 149 | entry) 150 | 151 | 152 | -- ##### 153 | -- # WAL 154 | -- ##### 155 | _createWalTable :: Connection -> Text -> IO Int64 156 | _createWalTable conn name = 157 | PGS.execute conn "CREATE TABLE IF NOT EXISTS ? ( id TEXT PRIMARY KEY, date timestamptz NOT NULL, count int NOT NULL )" (Only (Identifier name)) 158 | 159 | -- |Updates a WALEntry if it exists, inserts a new WALEntry if is is missing. 160 | walUpsertIncrement :: (FSMKey k) => PostgresJSONStore -> k -> IO () 161 | walUpsertIncrement st i = 162 | _walExecute st i _walIncrement 163 | 164 | walDecrement :: (FSMKey k) => PostgresJSONStore -> k -> IO () 165 | walDecrement st i = 166 | _walExecute st i _walDecrement 167 | 168 | _walExecute :: (FSMKey k) => PostgresJSONStore -> k -> Query -> IO () 169 | _walExecute st k q = let tbl = append (storeName st) "Wal" in 170 | withResource (storeConnPool st) (\conn -> 171 | withTransactionSerializable conn $ do 172 | now <- getCurrentTime 173 | void $ PGS.execute conn q (Identifier tbl, toText k, now, Identifier tbl)) 174 | 175 | _walIncrement :: Query 176 | _walIncrement = "INSERT INTO ? VALUES (?,?,1) ON CONFLICT (id) DO UPDATE SET count = ?.count + 1, date = EXCLUDED.date" 177 | 178 | _walDecrement :: Query 179 | _walDecrement = "INSERT INTO ? VALUES (?,?,0) ON CONFLICT (id) DO UPDATE SET count = ?.count - 1" 180 | 181 | 182 | -- |Returns a list of all transactions that were not successfully terminated 183 | -- and are older than `cutoff`. 184 | walScan :: (FSMKey k) => PostgresJSONStore -> Int -> IO [WALEntry k] 185 | walScan st cutoff = do 186 | t <- getCurrentTime 187 | let xx = addUTCTime (negate (fromInteger (toInteger cutoff) :: NominalDiffTime)) t 188 | 189 | withResource (storeConnPool st) (\c -> 190 | withTransactionSerializable c $ 191 | PGS.query c "SELECT * FROM ? WHERE date < ? AND count > 0" (Identifier $ append (storeName st) "Wal", xx)) 192 | 193 | -- |Creates a postgresql store 194 | mkStore :: String -> Text -> IO PostgresJSONStore 195 | mkStore connStr name = 196 | let 197 | connBS = DBSC8.pack connStr 198 | in do 199 | pool <- givePool (PGS.connectPostgreSQL connBS) 200 | _ <- withResource pool $ flip _createFsmTable name 201 | _ <- withResource pool $ flip _createWalTable (append name "Wal") 202 | return $ PostgresJSONStore pool name 203 | 204 | _createFsmTable :: Connection -> Text -> IO Int64 205 | _createFsmTable conn name = 206 | PGS.execute conn "CREATE TABLE IF NOT EXISTS ? ( id text PRIMARY KEY, data jsonb NOT NULL)" (Only (Identifier name)) 207 | 208 | -- SELECT .. FOR UPDATE locks the rows matching the query. Concurrent 209 | -- (repeatable read and serializable) transactions will block and 210 | -- abort once the new value has been inserted. Since we run effects 211 | -- between SELECT and INSERT, this is what we want. 212 | -- Concurrent SELECTS (without FOR UPDATE) will be unaffected. 213 | _getValue :: (FromRow v) => Connection -> Text -> Text -> IO [v] 214 | _getValue c tbl k = 215 | PGS.query c "SELECT * FROM ? WHERE id = ?" (Identifier tbl, k) 216 | 217 | _getValueForUpdate :: (FromRow v) => Connection -> Text -> Text -> IO [v] 218 | _getValueForUpdate c tbl k = 219 | PGS.query c "SELECT * FROM ? WHERE id = ? FOR UPDATE" (Identifier tbl, k) 220 | 221 | _postOrUpdateValue :: (ToField v) => Connection -> Text -> Text -> v -> IO Int64 222 | _postOrUpdateValue c tbl k v = 223 | PGS.execute c "INSERT INTO ? VALUES (?,?) ON CONFLICT (id) DO UPDATE SET data = EXCLUDED.data" (Identifier tbl, k, v) 224 | 225 | _postValue :: (ToField v) => Connection -> Text -> Text -> v -> IO Int64 226 | _postValue c tbl k v = 227 | PGS.execute c "INSERT INTO ? VALUES (?,?)" (Identifier tbl, k, v) 228 | 229 | _deleteValue :: (ToField k) => Connection -> Text -> k -> IO Int64 230 | _deleteValue c tbl k = 231 | PGS.execute c "DELETE FROM ? WHERE id = ?" (Identifier tbl, k) 232 | 233 | _queryValue :: (FromRow v) => Connection -> Text -> Text -> IO [v] 234 | _queryValue c tbl q = 235 | PGS.query c "SELECT * FROM ? WHERE data @> ?" (Identifier tbl, q) 236 | 237 | _getKeys :: forall k . (FSMKey k) => PostgresJSONStore -> Text -> IO [k] 238 | _getKeys st tbl = 239 | withResource (storeConnPool st) (\conn -> do 240 | keys <- PGS.query conn "SELECT id FROM ?" (Only (Identifier tbl)) :: IO [Only Text] 241 | 242 | return (fmap (\(Only t) -> fromText t) keys :: [k])) 243 | 244 | -- | You can call this function when you changed the representation of your 245 | -- MealyMachine. It will read all instances through FromJSON and write them 246 | -- back using ToJSON. 247 | _batchConversion :: forall k s e a . 248 | (FromJSON s, FromJSON e, FromJSON a, 249 | ToJSON s, ToJSON e, ToJSON a, 250 | Typeable s, Typeable e, Typeable a, MealyInstance k s e a) 251 | => PostgresJSONStore 252 | -> Text 253 | -> Proxy k s e a 254 | -> IO () 255 | _batchConversion st tbl _p = do 256 | keys <- _getKeys st tbl :: IO [k] 257 | mapM_ (\k -> _fsmUpdate st k (return :: MachineTransformer s e a)) keys 258 | 259 | 260 | -- |Instance to convert one DB row to an instance of Instance ;) 261 | -- users of this module must provide instances for ToJSON, FromJSON for `s`, `e` and `a`. 262 | instance (ToJSON s, ToJSON e, ToJSON a) => ToJSON (Machine s e a) 263 | instance (FromJSON s, FromJSON e, FromJSON a) => FromJSON (Machine s e a) 264 | 265 | instance (ToJSON e) => ToJSON (Msg e) 266 | instance (FromJSON e) => FromJSON (Msg e) 267 | 268 | instance (Typeable s, Typeable e, Typeable a, 269 | FromJSON s, FromJSON e, FromJSON a, FSMKey k) => FromRow (Instance k s e a) where 270 | fromRow = Instance <$> field <*> field 271 | 272 | instance (Typeable s, Typeable e, Typeable a, 273 | FromJSON s, FromJSON e, FromJSON a) => FromField (Machine s e a) where 274 | fromField = fromJSONField 275 | 276 | instance (Typeable s, Typeable e, Typeable a, 277 | ToJSON s, ToJSON e, ToJSON a) => ToField (Machine s e a) where 278 | toField = toJSONField 279 | 280 | instance {-# OVERLAPS #-} (FSMKey k) => ToField k where 281 | toField k = toField (toText k) 282 | 283 | instance {-# OVERLAPS #-} (FSMKey k) => FromField k where 284 | fromField f mdata = fmap fromText (fromField f mdata :: Conversion Text) 285 | 286 | instance (FSMKey k) => FromRow (WALEntry k) where 287 | fromRow = WALEntry <$> field <*> field <*> field 288 | 289 | deriving instance (FSMKey k) => Generic (WALEntry k) 290 | deriving instance (FSMKey k) => Typeable (WALEntry k) 291 | -------------------------------------------------------------------------------- /src/Mealstrom/WALStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | {-| 4 | Module : Mealstrom.WALStore 5 | Description : Store WALEntries 6 | Copyright : (c) Max Amanshauser, 2016 7 | License : MIT 8 | Maintainer : max@lambdalifting.org 9 | 10 | A WALStore is anything being able to store WALEntries. 11 | WALEntries indicate how often a recovery process has been started for 12 | an instance. 13 | -} 14 | module Mealstrom.WALStore where 15 | 16 | import Data.Time.Clock 17 | 18 | class WALStore st k where 19 | walUpsertIncrement :: st -> k -> IO () 20 | walDecrement :: st -> k -> IO () 21 | walScan :: st -> Int -> IO [WALEntry k] 22 | 23 | data WALEntry k = WALEntry { 24 | walId :: k, 25 | walTime :: UTCTime, 26 | walCount :: Int 27 | } deriving (Show,Eq) 28 | 29 | openTxn :: WALStore st k => st -> k -> IO () 30 | openTxn = walUpsertIncrement 31 | 32 | closeTxn :: WALStore st k => st -> k -> IO () 33 | closeTxn = walDecrement 34 | -------------------------------------------------------------------------------- /test/BasicFSM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | {-| 8 | Module : BasicFSM 9 | Description : A simple example. 10 | Copyright : (c) Max Amanshauser, 2016 11 | License : MIT 12 | Maintainer : max@lambdalifting.org 13 | -} 14 | 15 | module BasicFSM (runBasicTests) where 16 | 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | 20 | import Control.Concurrent 21 | import Data.Aeson 22 | import Data.Hashable 23 | import Data.Text as Text 24 | import Data.Typeable 25 | import GHC.Generics 26 | 27 | import Mealstrom 28 | import Mealstrom.FSMStore 29 | import Mealstrom.WALStore 30 | import Mealstrom.PostgresJSONStore as PGJSON 31 | import Mealstrom.MemoryStore as MemStore 32 | 33 | 34 | -- #################### 35 | -- # Connection Example 36 | -- #################### 37 | 38 | -- This is a contrived example of how to use a custom Key type, instead of the recommended Text and UUID. 39 | newtype ConnectionKey = ConnectionKey (Int,Int) deriving (Show,Eq,Generic,Hashable) 40 | 41 | instance FSMKey ConnectionKey where 42 | toText (ConnectionKey (a,b)) = Text.pack $ "(" ++ show a ++ "," ++ show b ++ ")" 43 | fromText t = case fmap (\s -> read (unpack s) :: Int) (splitOn "," $ Text.dropEnd 1 (Text.drop 1 t)) of 44 | a:[b] -> ConnectionKey (a,b) 45 | _ -> error "" 46 | 47 | data ConnectionState = New | Open | Closed 48 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 49 | 50 | data ConnectionEvent = Create | Close | Reset 51 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 52 | 53 | data ConnectionAction = PrintStatusOpened | PrintStatusClosed 54 | deriving (Eq,Typeable,Generic,ToJSON,FromJSON) 55 | 56 | instance MealyInstance ConnectionKey ConnectionState ConnectionEvent ConnectionAction 57 | 58 | connEffects :: MVar () -> Msg ConnectionAction -> IO Bool 59 | connEffects mvar (Msg _i c) 60 | | c == PrintStatusOpened = putStrLn "OUTPUT: Connection opened" >> putMVar mvar () >> return True 61 | | c == PrintStatusClosed = putStrLn "OUTPUT: Connection closed" >> putMVar mvar () >> return True 62 | 63 | connTransition :: (ConnectionState, ConnectionEvent) -> (ConnectionState, [ConnectionAction]) 64 | connTransition (s,e) = 65 | case (s,e) of 66 | (New, Create) -> (Open, [PrintStatusOpened]) 67 | (Open, Close) -> (Closed,[PrintStatusClosed]) 68 | (Open, Reset) -> (Open, [PrintStatusClosed, PrintStatusOpened]) 69 | 70 | runBasicTests :: String -> TestTree 71 | runBasicTests c = testGroup "BasicFSM" [ 72 | testCase "BasicPG" (runTest (PGJSON.mkStore c)), 73 | testCase "BasicMem0" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore ConnectionKey ConnectionState ConnectionEvent ConnectionAction))) 74 | ] 75 | 76 | runTest :: (FSMStore st ConnectionKey ConnectionState ConnectionEvent ConnectionAction, 77 | WALStore st ConnectionKey) => (Text -> IO st) -> IO () 78 | runTest c = do 79 | st <- c "BasicFSMTest" 80 | sync <- newEmptyMVar 81 | let t = FSMTable connTransition (connEffects sync) 82 | let myFSM = FSMHandle st st t 90 3 83 | let firstId = ConnectionKey (1231231,21) -- This represents a socket or something 84 | 85 | post myFSM firstId New 86 | Just fsmState1 <- get myFSM firstId 87 | fsmState1 @?= New 88 | 89 | msg1 <- mkMsgs [Create] 90 | _ <- patch myFSM firstId msg1 91 | 92 | takeMVar sync 93 | Just fsmState2 <- get myFSM firstId 94 | fsmState2 @?= Open 95 | 96 | msg2 <- mkMsgs [Close] 97 | _ <- patch myFSM firstId msg2 98 | 99 | takeMVar sync 100 | Just fsmState3 <- get myFSM firstId 101 | fsmState3 @?= Closed 102 | -------------------------------------------------------------------------------- /test/CommonDefs.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : CommonDefs 3 | Description : Some things that sometimes come in handy. 4 | Copyright : (c) Max Amanshauser, 2016 5 | License : MIT 6 | Maintainer : max@lambdalifting.org 7 | -} 8 | module CommonDefs where 9 | 10 | import Data.Aeson 11 | import Data.Time 12 | import Data.Typeable 13 | 14 | import Mealstrom 15 | import Mealstrom.FSMStore 16 | 17 | cutOff :: NominalDiffTime 18 | cutOff = 2 19 | 20 | -- |Don't ever use this in production :^) 21 | busyWaitForState :: (FromJSON s, FromJSON e, FromJSON a, 22 | Typeable s, Typeable e, Typeable a, 23 | Eq s, Eq e, Eq a, MealyInstance k s e a, FSMStore st k s e a) 24 | => FSMHandle st wal k s e a 25 | -> k 26 | -> s 27 | -> UTCTime 28 | -> IO Bool 29 | busyWaitForState fsm i s t = do 30 | ct <- getCurrentTime 31 | 32 | if addUTCTime cutOff t < ct 33 | then return False 34 | else do 35 | mcs <- get fsm i 36 | 37 | if mcs == Just s 38 | then return True 39 | else busyWaitForState fsm i s t 40 | -------------------------------------------------------------------------------- /test/CounterFSM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | 9 | {-| 10 | Module : CounterFSM 11 | Description : Show how to "compress" multiple events into one. 12 | Copyright : (c) Max Amanshauser, 2016 13 | License : MIT 14 | Maintainer : max@lambdalifting.org 15 | 16 | After this test has run the DB table should show a "Count" entry 17 | instead of ten individual Desu events. 18 | -} 19 | 20 | module CounterFSM (runCounterTests) where 21 | 22 | import Test.Tasty 23 | import Test.Tasty.HUnit 24 | 25 | import Control.Concurrent 26 | import Control.Monad 27 | import Data.Aeson 28 | import Data.Text 29 | import Data.Typeable 30 | import GHC.Generics 31 | import Data.UUID 32 | import Data.UUID.V4 33 | 34 | import Mealstrom 35 | import Mealstrom.PostgresJSONStore as PGJSON 36 | import Mealstrom.MemoryStore as MemStore 37 | 38 | type CounterKey = UUID 39 | data CounterState = Desu 40 | deriving (Eq,Show,Typeable) 41 | instance ToJSON CounterState where 42 | toJSON _ = "Desu" 43 | instance FromJSON CounterState where 44 | parseJSON "Desu" = return Desu 45 | 46 | data CounterEvent = DesuEvent 47 | deriving (Eq,Show,Typeable) 48 | instance ToJSON CounterEvent where 49 | toJSON _ = "DesuEvent" 50 | instance FromJSON CounterEvent where 51 | parseJSON "DesuEvent" = return DesuEvent 52 | 53 | 54 | -- NOP 55 | data CounterAction = DesuDummyAction 56 | deriving (Eq,Show,Typeable,Generic) 57 | instance ToJSON CounterAction where 58 | toJSON _ = "DesuDummyAction" 59 | instance FromJSON CounterAction where 60 | parseJSON "DesuDummyAction" = return DesuDummyAction 61 | 62 | 63 | instance MealyInstance CounterKey CounterState CounterEvent CounterAction 64 | 65 | counterTransition :: (CounterState, CounterEvent) -> (CounterState,[CounterAction]) 66 | counterTransition = 67 | \case (Desu, DesuEvent) -> (Desu,[DesuDummyAction]) 68 | 69 | counterEffects :: MVar () -> Msg CounterAction -> IO Bool 70 | counterEffects mvar _ = 71 | putMVar mvar () >> return True 72 | 73 | runCounterTests :: String -> TestTree 74 | runCounterTests c = testGroup "CounterFSM" [ 75 | testCase "CounterPG" (runTest $ PGJSON.mkStore c), 76 | testCase "CounterMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore CounterKey CounterState CounterEvent CounterAction))) 77 | ] 78 | 79 | runTest c = do 80 | sync <- newEmptyMVar 81 | 82 | st <- c "CounterTest" 83 | 84 | let t = FSMTable counterTransition (counterEffects sync) 85 | let fsm = FSMHandle st st t 900 3 86 | 87 | i <- nextRandom 88 | post fsm i Desu 89 | 90 | replicateM_ 10 (do 91 | m <- mkMsgs [DesuEvent] 92 | _ <- patch fsm i m 93 | takeMVar sync) 94 | 95 | s <- get fsm i 96 | 97 | s @?= Just Desu 98 | -------------------------------------------------------------------------------- /test/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | 8 | {-| 9 | Module : Exception 10 | Description : Test that illegal actions throw an exception and that they are caught. 11 | Copyright : (c) Max Amanshauser, 2016 12 | License : MIT 13 | Maintainer : max@lambdalifting.org 14 | -} 15 | 16 | module Exception (runExceptionTests) where 17 | 18 | import Test.Tasty 19 | import Test.Tasty.HUnit 20 | 21 | import Control.Concurrent 22 | import Data.Aeson 23 | import Data.Hashable 24 | import Data.Maybe (isNothing) 25 | import Data.Text as Text 26 | import Data.Typeable 27 | import Data.UUID 28 | import Data.UUID.V4 29 | import GHC.Generics 30 | 31 | import Mealstrom 32 | import Mealstrom.FSMStore 33 | import Mealstrom.WALStore 34 | import Mealstrom.PostgresJSONStore as PGJSON 35 | import Mealstrom.MemoryStore as MemStore 36 | 37 | 38 | type MyKey = UUID 39 | data MyState = MyState1 | MyState2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 40 | data MyEvent = MyEvent1 | MyEvent2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 41 | data MyAction = MyAction1 | MyAction2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 42 | 43 | instance MealyInstance MyKey MyState MyEvent MyAction 44 | myTransition :: (MyState,MyEvent) -> (MyState,[MyAction]) 45 | myTransition (MyState1,MyEvent1) = 46 | (MyState2,[MyAction1]) 47 | 48 | myEffects :: Msg MyAction -> IO Bool 49 | myEffects _a = do 50 | putStrLn "Action completed" 51 | return True 52 | 53 | 54 | runExceptionTests :: String -> TestTree 55 | runExceptionTests c = testGroup "ExceptionFSM" [ 56 | testCase "ExceptionPG" (runTest (PGJSON.mkStore c)), 57 | testCase "ExceptionMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore MyKey MyState MyEvent MyAction))) 58 | ] 59 | 60 | runTest :: (FSMStore st MyKey MyState MyEvent MyAction, 61 | WALStore st MyKey) => (Text -> IO st) -> IO () 62 | runTest c = do 63 | st <- c "ExceptionTest" 64 | let t = FSMTable myTransition myEffects 65 | let myFSM = FSMHandle st st t 90 3 66 | firstId <- nextRandom 67 | 68 | res1 <- post myFSM firstId MyState1 69 | res2 <- post myFSM firstId MyState1 70 | 71 | assertBool "Insert Instance once" res1 72 | assertBool "Insert Instance again and fail" $ not res2 73 | 74 | -- Technically the following assertions are not concerned with exceptions, but fine, whatever 75 | secondId <- nextRandom 76 | 77 | res3 <- get myFSM secondId 78 | assertBool "Get non-existing instance" $ isNothing res3 79 | 80 | res4 <- mkMsgs [MyEvent1] >>= patch myFSM secondId 81 | assertBool "Patch non-existing instance" $ not res4 82 | -------------------------------------------------------------------------------- /test/FSM2FSM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | 9 | {-| 10 | Module : FSM2FSM 11 | Description : An example that shows how two FSMs can exchange messages with each other. 12 | Copyright : (c) Max Amanshauser, 2016 13 | License : MIT 14 | Maintainer : max@lambdalifting.org 15 | -} 16 | 17 | module FSM2FSM (runFSM2FSMTests) where 18 | 19 | import Control.Concurrent.QSem 20 | import Data.Aeson 21 | import Data.Text 22 | import Data.Typeable 23 | import Data.UUID 24 | import Data.UUID.V4 25 | import GHC.Generics 26 | import Test.Tasty 27 | import Test.Tasty.HUnit 28 | 29 | import Mealstrom 30 | import Mealstrom.FSMStore 31 | import Mealstrom.PostgresJSONStore as PGJSON 32 | import Mealstrom.MemoryStore as MemStore 33 | 34 | -- ################# 35 | -- # Payment Example 36 | -- ################# 37 | 38 | -- ####### 39 | -- # FSM 1 40 | -- ####### 41 | type PaymentKey = UUID 42 | data PaymentState = PaymentPending Int | PaymentPaid | PaymentAborted 43 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 44 | 45 | -- Yes, if you abort payment after it has been partially paid, you lose money :-) 46 | data PaymentEvent = ReceivedPayment UUID Int | AbortPayment 47 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 48 | 49 | -- Credit our own bank account with sweet funds 50 | data PaymentAction = PaymentUpdateAccount UUID Int 51 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 52 | 53 | paymentTransition :: (PaymentState, PaymentEvent) -> (PaymentState,[PaymentAction]) 54 | paymentTransition (s,e) = case (s,e) of 55 | (PaymentPending _o, AbortPayment) -> (PaymentAborted,[]) 56 | (PaymentPending o, ReceivedPayment ba i) -> if i >= o 57 | then (PaymentPaid, [PaymentUpdateAccount ba i]) 58 | else (PaymentPending (o-i),[]) 59 | (PaymentAborted, _) -> (PaymentAborted, []) 60 | 61 | paymentEffects :: (FSMStore st BankAccountKey BankAccountState BankAccountEvent BankAccountAction) 62 | => QSem 63 | -> FSMHandle st wal BankAccountKey BankAccountState BankAccountEvent BankAccountAction 64 | -> Msg PaymentAction 65 | -> IO Bool 66 | paymentEffects qsem h (Msg d (PaymentUpdateAccount acc amount)) = do 67 | 68 | -- send message to bankaccount FSM using the same msgId! 69 | upsert h acc (BankAccountBalance 0) [Msg d (BankAccountDeposit amount)] 70 | signalQSem qsem 71 | return True 72 | 73 | instance MealyInstance PaymentKey PaymentState PaymentEvent PaymentAction 74 | 75 | -- ####### 76 | -- # FSM 2 77 | -- ####### 78 | type BankAccountKey = UUID 79 | data BankAccountState = BankAccountBalance Int 80 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 81 | 82 | data BankAccountEvent = BankAccountDeposit Int 83 | deriving (Eq,Show,Typeable,Generic,ToJSON,FromJSON) 84 | 85 | -- NOP 86 | data BankAccountAction = BankAccountDummyAction 87 | deriving (Eq,Show,Typeable,Generic) 88 | 89 | instance ToJSON BankAccountAction where 90 | toJSON _ = "BankAccountDummyAction" 91 | 92 | instance FromJSON BankAccountAction where 93 | parseJSON "BankAccountDummyAction" = return BankAccountDummyAction 94 | 95 | bankAccountTransition :: (BankAccountState, BankAccountEvent) -> (BankAccountState,[BankAccountAction]) 96 | bankAccountTransition = 97 | \case (BankAccountBalance i, BankAccountDeposit j) -> (BankAccountBalance $ i + j, [BankAccountDummyAction]) 98 | 99 | bankAccountEffects :: QSem -> Msg BankAccountAction -> IO Bool 100 | bankAccountEffects qsem _ = signalQSem qsem >> return True 101 | 102 | instance MealyInstance BankAccountKey BankAccountState BankAccountEvent BankAccountAction 103 | 104 | -- ####### 105 | -- # TEST 106 | -- ####### 107 | runFSM2FSMTests :: String -> TestTree 108 | runFSM2FSMTests c = 109 | testGroup "FSM2FSM" [ 110 | testCase "FSM2FSMPG" (runTest (PGJSON.mkStore c)(PGJSON.mkStore c)), 111 | testCase "FSM2FSMMem" (runTest (MemStore.mkStore :: Text -> IO(MemoryStore BankAccountKey BankAccountState BankAccountEvent BankAccountAction)) 112 | (MemStore.mkStore :: Text -> IO(MemoryStore PaymentKey PaymentState PaymentEvent PaymentAction))) 113 | ] 114 | where 115 | runTest c1 c2 = do 116 | sync <- newQSem 0 117 | 118 | st1 <- c1 "FSM2FSMTestBank" 119 | 120 | let t1 = FSMTable bankAccountTransition (bankAccountEffects sync) 121 | let bankFsm = FSMHandle st1 st1 t1 900 3 122 | 123 | -- Using the first handle we can instantiate the second one. 124 | st2 <- c2 "FSM2FSMTestPayments" 125 | 126 | let t2 = FSMTable paymentTransition (paymentEffects sync bankFsm) 127 | let paymentFsm = FSMHandle st2 st2 t2 900 3 128 | 129 | paymentId <- nextRandom 130 | bankAccount <- nextRandom 131 | 132 | msg1 <- mkMsg $ ReceivedPayment bankAccount 1000 133 | post paymentFsm paymentId (PaymentPending 1000) 134 | _ <- patch paymentFsm paymentId [msg1] 135 | 136 | waitQSem sync 137 | waitQSem sync 138 | pymtstatus <- get paymentFsm paymentId 139 | pymtstatus @?= Just PaymentPaid 140 | 141 | -- Now check that the second FSM has been updated as well 142 | bankstatus <- get bankFsm bankAccount 143 | bankstatus @?= Just (BankAccountBalance 1000) 144 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | import BasicFSM (runBasicTests) 2 | import FSM2FSM (runFSM2FSMTests) 3 | import CounterFSM (runCounterTests) 4 | import Recovery (runRecoveryTests) 5 | import Timeout (runTimeoutTests) 6 | import Exception (runExceptionTests) 7 | import Upgrade (runUpgradeTests) 8 | 9 | import Database.PostgreSQL.Simple 10 | import Database.PostgreSQL.Simple.Types 11 | 12 | import Data.ByteString.Char8 as DBSC8 13 | import Data.Maybe (fromMaybe) 14 | import Data.Semigroup ((<>)) 15 | 16 | import System.Environment 17 | 18 | import Test.Tasty 19 | 20 | main :: IO () 21 | main = do 22 | h <- fromMaybe "localhost" <$> lookupEnv "PGHOST" 23 | p <- fromMaybe "5432" <$> lookupEnv "PGPORT" 24 | u <- fromMaybe "postgres" <$> lookupEnv "PGUSER" 25 | pw <- fromMaybe "" <$> lookupEnv "PGPASSWORD" 26 | 27 | let c = "host='" <> h <> "' port=" <> p <> " dbname='fsmtest' user='" <> u <> "' password='" <> pw <> "'" 28 | conn <- connectPostgreSQL (DBSC8.pack c) 29 | _ <- execute_ conn $ Query (DBSC8.pack "DROP SCHEMA public CASCADE; CREATE SCHEMA public;") 30 | 31 | defaultMain $ testGroup "All tests" [ 32 | runBasicTests c, 33 | runFSM2FSMTests c, 34 | runCounterTests c, 35 | runRecoveryTests c, 36 | runTimeoutTests c, 37 | runExceptionTests c, 38 | runUpgradeTests c 39 | ] 40 | -------------------------------------------------------------------------------- /test/Recovery.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | {-| 9 | Module : Recovery 10 | Description : Test that recovery works 11 | Copyright : (c) Max Amanshauser, 2016 12 | License : MIT 13 | Maintainer : max@lambdalifting.org 14 | -} 15 | module Recovery(runRecoveryTests) where 16 | 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | 20 | import Control.Concurrent 21 | import Data.Typeable 22 | import Data.Aeson 23 | import GHC.Generics 24 | import Data.Text 25 | import Data.IORef 26 | import Data.UUID 27 | import Data.UUID.V4 28 | 29 | import Mealstrom 30 | import Mealstrom.PostgresJSONStore as PGJSON 31 | import Mealstrom.MemoryStore as MemStore 32 | 33 | type RecoveryKey = UUID 34 | data RecoveryState = RecoveryState1 | RecoveryState2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 35 | data RecoveryEvent = RecoveryEvent1 | RecoveryEvent2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 36 | data RecoveryAction = RecoveryAction1 | RecoveryAction2 deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 37 | 38 | instance MealyInstance RecoveryKey RecoveryState RecoveryEvent RecoveryAction 39 | 40 | recoveryTransition :: (RecoveryState,RecoveryEvent) -> (RecoveryState,[RecoveryAction]) 41 | recoveryTransition (RecoveryState1,RecoveryEvent1) = 42 | (RecoveryState2,[RecoveryAction1]) 43 | 44 | recoveryEffects :: IORef Bool -> MVar () -> Msg RecoveryAction -> IO Bool 45 | recoveryEffects b sync _a = do 46 | bb <- readIORef b 47 | 48 | -- indicate that we read the IORef and are running the action now 49 | putMVar sync () 50 | 51 | return bb 52 | 53 | runRecoveryTests :: String -> TestTree 54 | runRecoveryTests c = testGroup "Recovery" [ 55 | testCase "RecoveryPG" (runTest $ PGJSON.mkStore c), 56 | testCase "RecoveryMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore RecoveryKey RecoveryState RecoveryEvent RecoveryAction))) 57 | ] 58 | 59 | runTest c = do 60 | st <- c "RecoveryTest" 61 | 62 | b <- newIORef False 63 | sync <- newEmptyMVar 64 | 65 | let t = FSMTable recoveryTransition (recoveryEffects b sync) 66 | let fsm = FSMHandle st st t 1 3 -- we have a timeout of 1 second for actions 67 | 68 | i <- nextRandom 69 | 70 | post fsm i RecoveryState1 71 | mkMsgs [RecoveryEvent1] >>= patch fsm i 72 | 73 | -- action is run for the first time 74 | takeMVar sync 75 | 76 | -- wait two seconds, so that the action is definitely recoverable 77 | threadDelay (2 * 10^6) 78 | writeIORef b True 79 | recoverAll fsm 80 | 81 | -- action is run again 82 | takeMVar sync 83 | 84 | -- If we reach this, then the recovery definitely ran, yet the entry in the DB 85 | -- might still be wrong. That's ok. 86 | assertBool "Failed action recovers successfully" True 87 | -------------------------------------------------------------------------------- /test/Timeout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | 9 | {-| 10 | Module : Timeout 11 | Description : Make sure that recovery actually uses a timeout 12 | Copyright : (c) Max Amanshauser, 2016 13 | License : MIT 14 | Maintainer : max@lambdalifting.org 15 | -} 16 | 17 | module Timeout(runTimeoutTests) where 18 | 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | 22 | import Control.Concurrent 23 | import Data.Typeable 24 | import Data.Aeson 25 | import GHC.Generics 26 | import Data.Text 27 | import Data.IORef 28 | import Data.UUID 29 | import Data.UUID.V4 30 | 31 | import Mealstrom 32 | import Mealstrom.PostgresJSONStore as PGJSON 33 | import Mealstrom.MemoryStore as MemStore 34 | 35 | type TimeoutKey = UUID 36 | data TimeoutState = TimeoutState deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 37 | data TimeoutEvent = TimeoutEvent deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 38 | data TimeoutAction = TimeoutAction deriving (Eq,Show,Generic,Typeable,ToJSON,FromJSON) 39 | 40 | instance MealyInstance TimeoutKey TimeoutState TimeoutEvent TimeoutAction 41 | 42 | timeoutTransition :: (TimeoutState,TimeoutEvent) -> (TimeoutState,[TimeoutAction]) 43 | timeoutTransition (TimeoutState,TimeoutEvent) = (TimeoutState,[TimeoutAction]) 44 | 45 | timeoutEffects :: IORef Bool -> MVar () -> Msg TimeoutAction -> IO Bool 46 | timeoutEffects b sync _a = do 47 | bb <- readIORef b 48 | 49 | if bb 50 | then putMVar sync () -- if this is the second run, we proceed normally 51 | else seq (sum [1..]) (return ()) -- else we timeout 52 | 53 | return True 54 | 55 | runTimeoutTests :: String -> TestTree 56 | runTimeoutTests c = testGroup "Timeout" [ 57 | testCase "TimeoutPG" (runTest $ PGJSON.mkStore c), 58 | testCase "TimeoutMem" (runTest (MemStore.mkStore :: Text -> IO (MemoryStore TimeoutKey TimeoutState TimeoutEvent TimeoutAction))) 59 | ] 60 | 61 | runTest c = do 62 | st <- c "TimeoutTest" 63 | 64 | b <- newIORef False 65 | sync <- newEmptyMVar 66 | 67 | let t = FSMTable timeoutTransition (timeoutEffects b sync) 68 | let fsm = FSMHandle st st t 1 2 -- timeout of 1 second and we only try once 69 | 70 | i <- nextRandom 71 | 72 | post fsm i TimeoutState 73 | mkMsgs [TimeoutEvent] >>= patch fsm i 74 | 75 | -- action is run for the first time and should timeout 76 | threadDelay (1*10^6) 77 | writeIORef b True 78 | 79 | -- action is run again 80 | takeMVar sync 81 | 82 | assertBool "Recovery after timeout successful" True 83 | -------------------------------------------------------------------------------- /test/Upgrade.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | 8 | {-| 9 | Module : Upgrade 10 | Description : Test that upgrading the data model actually works 11 | Copyright : (c) Max Amanshauser, 2016 12 | License : MIT 13 | Maintainer : max@lambdalifting.org 14 | 15 | All this looks a bit goofy because you cannot have duplicate 16 | data constructors and I did not want to make separate modules. 17 | In practice it's much less confusing. 18 | -} 19 | 20 | module Upgrade (runUpgradeTests) where 21 | 22 | import Test.Tasty 23 | import Test.Tasty.HUnit 24 | 25 | import Control.Concurrent 26 | import Control.Monad (guard) 27 | import Data.Aeson 28 | import Data.Aeson.Types 29 | import Data.Hashable 30 | import Data.Maybe (isNothing) 31 | import qualified Data.Text as Text 32 | import Data.Text (Text) 33 | import Data.Typeable (Typeable) 34 | import Data.UUID 35 | import Data.UUID.V4 36 | import GHC.Generics 37 | 38 | import Mealstrom 39 | import Mealstrom.FSMStore 40 | import Mealstrom.WALStore 41 | import Mealstrom.PostgresJSONStore as PGJSON 42 | 43 | -- |First FSM Instance 44 | type FirstKey = UUID 45 | data FirstState = OldState1 deriving (Eq,Show,Typeable) 46 | instance ToJSON FirstState where 47 | toJSON s = "OldState1" 48 | instance FromJSON FirstState where 49 | parseJSON = withText "expected OldState1" (\t -> case t of "OldState1" -> return OldState1) 50 | 51 | data FirstEvent = OldEvent1 deriving (Eq,Show,Typeable) 52 | instance ToJSON FirstEvent where 53 | toJSON e = "OldEvent1" 54 | instance FromJSON FirstEvent where 55 | parseJSON = withText "expected OldEvent1" (\t -> case t of "OldEvent1" -> return OldEvent1) 56 | 57 | data FirstAction = OldAction1 { 58 | _a :: String, 59 | _b :: Int 60 | } deriving (Eq,Show,Typeable) 61 | instance ToJSON FirstAction where 62 | toJSON a = object [ 63 | "a" .= _a a, 64 | "b" .= _b a 65 | ] 66 | instance FromJSON FirstAction where 67 | parseJSON = withObject "expected OldAction1" $ \o -> do 68 | _a <- o .: "a" 69 | _b <- o .: "b" 70 | 71 | return $ OldAction1 _a _b 72 | 73 | 74 | instance MealyInstance FirstKey FirstState FirstEvent FirstAction 75 | firstTransition :: (FirstState,FirstEvent) -> (FirstState,[FirstAction]) 76 | firstTransition (OldState1,OldEvent1) = 77 | (OldState1,[OldAction1 "lol" 42]) 78 | 79 | firstEffects :: Msg FirstAction -> IO Bool 80 | firstEffects _a = do 81 | putStrLn "Action completed" 82 | return True 83 | 84 | -- |Second FSM Instance 85 | -- here we want to parse both values from the first Instance 86 | -- as well as values from the second Instance 87 | type SecondKey = UUID 88 | 89 | -- The first upgrade is adding another data constructor to the State 90 | data SecondState = NewState1 | NewState2 Int deriving (Eq,Show) 91 | instance ToJSON SecondState where 92 | toJSON NewState1 = "NewState1" 93 | toJSON (NewState2 i) = object [ 94 | "name" .= String "NewState2", 95 | "value" .= i 96 | ] 97 | instance FromJSON SecondState where 98 | parseJSON (Object o) = do 99 | name <- o .: "name" 100 | guard (name == String "NewState2") 101 | val <- o .: "value" 102 | 103 | return $ NewState2 val 104 | 105 | -- |Conversion from old version 106 | parseJSON (String t) = 107 | case t of 108 | "NewState1" -> return NewState1 109 | "OldState1" -> return NewState1 110 | 111 | -- The second upgrade is adding a parameter to the Event 112 | data SecondEvent = NewEvent1 Int deriving (Eq,Show) 113 | instance ToJSON SecondEvent where 114 | toJSON (NewEvent1 i) = object [ 115 | "name" .= String "NewEvent1", 116 | "value" .= i 117 | ] 118 | instance FromJSON SecondEvent where 119 | parseJSON (Object o) = do 120 | name <- o .: "name" 121 | guard(name == String "NewEvent1") 122 | val <- o .: "value" 123 | 124 | return $ NewEvent1 val 125 | 126 | -- Conversion from old version 127 | parseJSON (String t) = case t of 128 | "OldEvent1" -> return $ NewEvent1 0 129 | 130 | -- |Here we just add another field to the existing data type 131 | data SecondAction = NewAction1 { 132 | __a :: String, 133 | __b :: Int, 134 | __c :: Double 135 | } deriving (Eq,Show,Typeable) 136 | instance ToJSON SecondAction where 137 | toJSON a = object [ 138 | "a" .= __a a, 139 | "b" .= __b a, 140 | "c" .= __c a 141 | ] 142 | instance FromJSON SecondAction where 143 | parseJSON = withObject "expected FirstAction" $ \o -> do 144 | __a <- o .: "a" 145 | __b <- o .: "b" 146 | __c <- o .:? "c" .!= 0.0 147 | 148 | return $ NewAction1 __a __b __c 149 | 150 | 151 | instance MealyInstance SecondKey SecondState SecondEvent SecondAction 152 | secondTransition :: (SecondState,SecondEvent) -> (SecondState,[SecondAction]) 153 | secondTransition (NewState1,NewEvent1 i) = 154 | (NewState2 i,[NewAction1 "double lol" 666 1.0]) 155 | 156 | secondEffects :: Msg SecondAction -> IO Bool 157 | secondEffects _a = do 158 | putStrLn "Action completed" 159 | return True 160 | 161 | runUpgradeTests :: String -> TestTree 162 | runUpgradeTests c = testGroup "UpgradeFSM" [ 163 | testCase "UpgradePG" (runTest (PGJSON.mkStore c)) 164 | ] 165 | 166 | runTest :: (Text -> IO PostgresJSONStore) -> IO () 167 | runTest c = do 168 | -- Start by creating the first FSMHandle and adding some data 169 | st <- c "UpgradeTest" :: IO PostgresJSONStore 170 | let t1 = FSMTable firstTransition firstEffects 171 | let myFSM1 = FSMHandle st st t1 90 3 172 | 173 | firstId <- nextRandom 174 | res1 <- post myFSM1 firstId OldState1 175 | mkMsgs [OldEvent1] >>= patch myFSM1 firstId 176 | 177 | sndId <- nextRandom 178 | res2 <- post myFSM1 sndId OldState1 179 | mkMsgs [OldEvent1] >>= patch myFSM1 sndId 180 | 181 | -- Then, try to access the same FSM using another MealyInstance that uses upgraded data types 182 | let t2 = FSMTable secondTransition secondEffects 183 | let myFSM2 = FSMHandle st st t2 90 3 184 | 185 | -- Conversion when accessing 186 | res3 <- get myFSM2 firstId 187 | res3 @?= Just NewState1 188 | 189 | -- Conversion when saving 190 | mkMsgs [NewEvent1 15] >>= patch myFSM2 firstId 191 | res4 <- get myFSM2 firstId 192 | res4 @?= Just (NewState2 15) 193 | 194 | -- Batch conversion. Also examines already converted instances, but writes them back untouched. 195 | PGJSON._batchConversion st "UpgradeTest" (Proxy :: Proxy SecondKey SecondState SecondEvent SecondAction) 196 | res5 <- get myFSM2 sndId 197 | res5 @?= Just NewState1 198 | --------------------------------------------------------------------------------