├── .gitignore ├── LICENSE ├── README.md ├── Recording-Replaying.png ├── Setup.hs ├── app ├── circle_area.json ├── def_expr.json ├── package.yaml ├── src │ ├── Expression │ │ ├── Expr.hs │ │ ├── Flow.hs │ │ └── IO.hs │ ├── Main.hs │ ├── Playback.hs │ └── Scenarios.hs ├── students.json ├── students_invalid_result.json ├── students_invalid_step.json ├── students_invalid_step_result.json ├── students_missing_step.json └── test │ ├── Spec.hs │ └── guid.txt ├── dist └── cabal-config-flags ├── lib ├── flow.cabal ├── flow │ ├── DB │ │ └── Native.hs │ ├── Language.hs │ ├── Playback │ │ ├── Entries.hs │ │ ├── Machine.hs │ │ └── Types.hs │ ├── Runtime │ │ ├── Interpreter.hs │ │ ├── Options.hs │ │ ├── SystemCommands.hs │ │ └── Types.hs │ └── Types.hs ├── package.yaml └── test │ └── Spec.hs ├── recordings.txt └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | RR.cabal 3 | *~ 4 | app/app.cabal 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2019, Alexander Granin 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Automatic White-Box Testing with Free Monads 2 | 3 | ### Summary 4 | 5 | Automatic creation of regression tests by designing a system that records the input, output and side-effects of a business application in production. Functional programming and Free monads, that separate the pure computation from side-effects, enabled this innovation. 6 | 7 | --- 8 | 9 | Building applications with complex business logic is rarely done without testing. Essentially, the more complex business scenarios you have the easier it is to break something while editing the code. Pure calculations, DB interaction, communication with external services, state mutation - all these code parts may change with time, and sometimes by mistake. Moreover, external services your logic interacts with can also change even when they shouldn’t, and it will immediately make the code invalid. Thus, to be sure that the code works as it should, various testing is needed. But testing requires a lot of labour work, and it’s not really clear whether some kinds of tests are worth it. In this article, we’ll see that there is a very powerful approach to make testing as easy as possible. 10 | 11 | **Note.** We’ve developed this approach at [Juspay](https://juspay.in/) as a feature of the framework [Presto.Backend](https://github.com/juspay/purescript-presto-backend/tree/feature/record-replay) (Open Source, Free monad based). We’re already using it in production for our QA needs. 12 | 13 | **Note.** This article is not an introduction into Free Monads. You can get additional information in my book ["Functional Design and Architecture"](https://github.com/graninas/Functional-Design-and-Architecture) or try another resources. 14 | 15 | ![Recording-Replaying](https://github.com/graninas/automatic-whitebox-testing-showcase/blob/master/Recording-Replaying.png) 16 | 17 | - [Integration tests](#integration-tests) 18 | - [Automatic white-box testing](#Automatic-white-box-testing) 19 | - [Free monad eDSLs for business logic](#Free-monad-eDSLs-for-business-logic) 20 | - [The recording-replaying mechanism: entries and run modes](#The-recording-replaying-mechanism-entries-and-run-modes) 21 | - [The recording-replaying mechanism](#The-recording-replaying-mechanism) 22 | - [Abstracting over the native libraries and types](#Abstracting-over-the-native-libraries-and-types) 23 | - [Presto Backend possibilities and PureScript differences](#Presto-Backend-possibilities-and-PureScript-differences) 24 | - [Conclusion](#Conclusion) 25 | - [Acknowledges](#Acknowledges) 26 | 27 | ### Integration tests 28 | 29 | Integration tests can protect the logic to some degree. These tests consider the system to be a black-box working in the special environment, and interact with this box via public interface to check is the behaviour valid. Integration tests are very close to a production-like running of the code except they probably don’t usually make calls to real services and don’t use a real production data. Instead of this, integration tests may use some special environments like sandboxes and dummy services to simulate an actual interaction. 30 | 31 | There is a problem, though. Integration tests can be a bit fragile because the dependent services are not guaranteed to respond all the time. Sometimes integration tests fail by external reason, and this may be or may be not acceptable in different situations. If we want to make the tests completely stable, we need to mock all the external services. Taken to the extreme point, a test that has all the external calls and unpredictable side effects mocked cannot fail by the unexpected reason. Being run with mocks, the logic represents a pure computation which behaviour is definite and straightforward. We can pass a predefined input and get a predefined result from it. If the result somehow differs from the expected one, then the code has changed since the test was written. It’s either a bug or a valid change - we have to double check. 32 | 33 | One may argue that tests of this kind (with mocks) have too much in common with white-box unit testing from the mainstream practices. That’s true, the approaches are very similar. The next concern will be that these tests are a footprint of the logic and they are very sensitive to any code change. Creating and managing unit tests for long scenarios is a nightmare because the logic tends to evolve with time and the tests should be updated respectively. The more logic you have, the more management of unit tests you need. Annoying. Painful. Time-consuming. 34 | 35 | Now, knowing the title, you might have guessed already that we’re going to get rid of that hard work and make the white-box testing do a good job. Let’s see... 36 | 37 | ### Automatic white-box testing 38 | 39 | So what does this mean? How these tests look like? Well, there are three parts of the automatic testing system: 40 | 41 | * Recordings 42 | * Recorder 43 | * Player 44 | 45 | Recording is a text file recorded by, well, the recorder. This file contains a step-by-step footprint of a particular business logic scenario. There will be all the information related to the scenario: input parameters, result, all the effects, all the external calls, all the DB interactions and so on. Every significant step will be represented by a specific entry, and every entry is considered to be a mock for a particular scenario step (see the diagram above). 46 | For example, when a call to a DB happens, there will be recorded an entry for it: 47 | 48 | ```haskell 49 | getStudentsCount :: Flow Int 50 | getStudentsCount = do 51 | students <- runDBQuery "SELECT * FROM students" 52 | when (null students) $ logInfo "No records found." 53 | pure $ length students 54 | ``` 55 | 56 | ```json 57 | // recording.json: 58 | { 59 | "entries": [ 60 | [ 61 | 0, "RunDBQueryEntry", 62 | {"jsonResult":[], "query":"SELECT * FROM students"} 63 | ], 64 | [ 65 | 1, "LogInfoEntry", 66 | {"message":"No records found."} 67 | ] 68 | ] 69 | } 70 | ``` 71 | 72 | Having a whole scenario evaluation “serialized”, it is possible to “replay” the recording against the scenario again. If there are some changes in the logic, the player will immediately break on a step that differs. It will also show a sane error message describing the step recorded and the step happened, and thus it’s possible to localize the bug for a better debugging. 73 | 74 | Here is a sample output on a recording being replayed against the broken scenario: 75 | 76 | ```haskell 77 | getStudentsCount :: Flow Int 78 | getStudentsCount = do 79 | -- FIXME: for debug only 80 | -- students <- runDBQuery "SELECT * FROM students" 81 | -- when (null students) $ logInfo "No records found." 82 | -- pure $ length students 83 | pure 10 84 | ``` 85 | 86 | ``` 87 | $ player "recording.json" 88 | 89 | [FAIL] Playback failed: unexpected flow end. Expected: 90 | {0, "RunDBQueryEntry", {"jsonResult":[],"query":"SELECT * FROM students"}} 91 | ``` 92 | 93 | Notably, full mocking of the effects in the recordings is not the only thing we can do. More interesting use cases of automatic white-box testing emerge if we allow the playback to be configured in several ways. 94 | 95 | * **Partial mocking.** It might be useful to define what effects and external calls should be mocked, and what effects should be run. For example, you might want to mock the calls to all HTTP services but prefer to interact with a real DB to test some particular scenarios. With this, you’ll get a variant of integration tests which know a lot about logic. If this “knowledge” is not something desirable, you can configure the system to make it work as a black-box test as much as needed. 96 | * **Selective verification.** By default, every step is checked for match with the recorded one: input parameters, additional info, output result. But sometimes it’s needed to disable such verification for a set of entries while still doing the mocking. 97 | * **Disabled entries.** Sometimes the step should not affect the replaying process at all. For example, it’s possible to disable all the log entries so they won’t be played and checked somehow (the real effects will be evaluated). 98 | 99 | For even more advanced situations, a subtle tuning of the replaying process can be done with both global player configs and configs of a specific entry in the recording. 100 | 101 | Last but not the least thing to note that all of this can be achieved without affecting the business logic code. There will be no evidence in the logic that it’s recordable and replayable, and therefore no extra complexity will be brought into the project. The only pre requirement to implement such recording-replaying mechanism is to follow the approach with the business logic abstracted by Free monad domain specific language to enable a core manipulation with all the steps the logic has. We’ll be discussing this approach in the rest of the article. 102 | 103 | ### Free monad eDSLs for business logic 104 | 105 | It’s crucial to understand why we need to abstract our business logic with Free monads to enable such option as the automatic white-box testing. It seems other approaches (`Final Tagless`, `Service Handle Pattern`, `ReaderT Pattern`) do not allow to create this recording-replaying mechanism, or it will be less convenient to do so. It’s probably possible with FT to overcome this problem with different additional wrappers, but let’s agree that introspection of Free monads makes this task much easier. 106 | 107 | Suppose we have a Free monadic language with the following methods available: 108 | 109 | ```haskell 110 | data FlowF next where 111 | GenerateGUID :: (String -> next) -> FlowF next 112 | RunIO :: IO s -> (s -> next) -> FlowF next 113 | LogInfo :: String -> (() -> next) -> FlowF next 114 | 115 | type Flow a = Free FlowF a 116 | 117 | generateGUID :: Flow String 118 | generateGUID = liftF $ GenerateGUID id 119 | 120 | runIO :: IO s -> Flow s 121 | runIO ioAct = liftF $ RunIO ioAct id 122 | 123 | logInfo :: String -> Flow () 124 | logInfo msg = liftF $ LogInfo msg id 125 | ``` 126 | 127 | This is a simple eDSL that has only three methods: generating UUID, logging a message and evaluating a random `IO` effect. A toy example of a business logic scenario will be: 128 | 129 | ```haskell 130 | compareGUIDs :: String -> Flow () 131 | compareGUIDs fileName = do 132 | newGuid <- generateGUID 133 | oldGuid <- runIO $ readFile fileName 134 | 135 | let equal = newGuid == oldGuid 136 | when equal $ logInfo "GUIDs are equal." 137 | unless equal $ logInfo "GUIDs are not equal." 138 | ``` 139 | 140 | This program obtains a new GUID, reads a file for getting an old GUID and compares whether these two GUIDs are equal. (It can possibly crash if the readFile function throws an exception, let’s just ignore this for now.) Not very interesting program that is enough for us to talk about why we need this level of abstraction. 141 | 142 | Firstly, this Free monadic language is testable. Running the `compareGUIDs` script with different interpreters allows either to perform real effects or mock them for our testing purposes. 143 | 144 | ```haskell 145 | -- Real interpreter 146 | interpretFlowF :: FlowF a -> IO a 147 | interpretFlowF (GenerateGUID next) = next . toString <$> nextRandom 148 | interpretFlowF (RunIO ioAct next) = next <$> ioAct 149 | interpretFlowF (LogInfo msg next) = next <$> putStrLn msg 150 | 151 | -- Test mocking interpreter 152 | interpretFlowFTest :: FlowF a -> IO a 153 | interpretFlowFTest (GenerateGUID next) = pure $ next "111" 154 | interpretFlowFTest (RunIO ioAct next) = error "IO not supported in tests." 155 | interpretFlowFTest (LogInfo msg next) = pure $ next () 156 | ``` 157 | 158 | The `RunIO` method makes some troubles here. By the definition, we don’t know what result should be returned, we only know it’s a value of an arbitrary type `a`. It’s not mockable because mocking essentially means substituting a result by some predefined value of this type, and it’s possible only when the type is well-known. So it’s more likely that we won’t be able to test a flow containing such `runIO` method. To avoid the problem, we can at least require the type to be unit, so no return value is expected from the effect, and therefore we can handle it by “doing nothing”: 159 | 160 | ```haskell 161 | data FlowF next where 162 | RunIO :: IO () -> (() -> next) -> FlowF next 163 | 164 | runIO :: IO () -> Flow () 165 | runIO ioAct = liftF $ RunIO ioAct id 166 | 167 | interpretFlowFTest :: FlowF a -> IO a 168 | interpretFlowFTest (RunIO _ next) = pure $ next () 169 | ``` 170 | 171 | This is fine unless we do need the results from there. For example, a specific type that came from an external library: database connection, file handle, `IORef`, `MVar` and so on. Let’s consider the following flow with a `DB.Connection` type that came from the external library: 172 | 173 | ```haskell 174 | import qualified DB.Native as DB 175 | 176 | initDB :: String -> DB.Config -> Flow (Maybe DB.Connection) 177 | initDB dbName cfg = do 178 | mbConn <- runIO $ DB.initDatabase dbName cfg 179 | when (isJust mbConn) $ logInfo "Successfully initialized." 180 | pure mbConn 181 | ``` 182 | 183 | Our `RunIO` step cannot be recorded, so it will be absent in the recording. But when the player hits this `runIO` call, it will have to run a real effect, which is not what should happen. This effectively means the usage of bare types is not allowed because all the steps should be written into the recording. How we can solve this problem? To make scenarios recordable and replayable we have to abstract all the bare types by our own mockable and serializable types. We’ll see how to do it with DB connections in the next part of the article, and for now we’ll just proceed with a tiny change in the language. We’ll constrain the `RunIO` method by the `ToJSON / FromJSON` instances from the `aeson` package for the type `a`: 184 | 185 | ```haskell 186 | data FlowF next where 187 | RunIO :: (ToJSON s, FromJSON s) => IO s -> (s -> next) -> FlowF next 188 | 189 | runIO :: (ToJSON s, FromJSON s) => IO s -> Flow s 190 | runIO ioAct = liftF $ RunIO ioAct id 191 | 192 | -- Test mocking interpreter 193 | interpretFlowFTest :: FlowF a -> IO a 194 | interpretFlowFTest (RunIO ioAct next) = 195 | = pure $ next $ fromJust $ decode "{some_json_obj_here}" 196 | ``` 197 | 198 | Now, our language is ready for the recording-replaying mechanism. 199 | 200 | ### The recording-replaying mechanism: entries and run modes 201 | 202 | The idea behind this mechanism is to have three modes for the interpreter: 203 | 204 | * **Regular mode.** The scenario should be interpreted as usual. 205 | * **Recorder mode.** Every language step should be evaluated as usual, but also it should produce an entry describing what happened on this step (input parameters, output result, additional info). 206 | * **Player mode.** The interpreter will receive an array of recording entries, and it will be going through the scenario step-by-step, popping the next entry from the recording and doing a replay. In this mode, no real effect will be evaluated. Instead, entries will be providing mocks for steps, and the scenario will be used as a sequence of the steps that should be replayed. 207 | 208 | In the recording-replaying mechanism, all the `Flow` methods should be accompanied with a corresponding entry types, for instance: 209 | 210 | ```haskell 211 | data GenerateGUIDEntry = GenerateGUIDEntry { guid :: String } 212 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 213 | 214 | data RunIOEntry = RunIOEntry { jsonResult :: Value } 215 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 216 | 217 | data LogInfoEntry = LogInfoEntry { message :: String } 218 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 219 | 220 | -- Smart constructors 221 | mkGenerateGUIDEntry :: String -> GenerateGUIDEntry 222 | mkGenerateGUIDEntry guidStr = GenerateGUIDEntry guidStr 223 | 224 | mkRunIOEntry :: ToJSON ioResult => ioResult -> RunIOEntry 225 | mkRunIOEntry = RunIOEntry . encodeToValue 226 | 227 | mkLogInfoEntry :: String -> () -> LogInfoEntry 228 | mkLogInfoEntry msg _ = LogInfoEntry msg 229 | ``` 230 | 231 | These types will be serialized and written into the recording file. Sequence of such entries represents a particular scenario - its key steps with effects. Pure calculations won’t appear in the recordings because they are not encoded as Free monadic actions. If you need a pure calculation to be recorded, you can either introduce a method for it or turn this pure calculation into the impure one and pass it to `runIO`. In here, you’ll have to decide how many info about the calculation you want to record: the result only or the arguments and the operation too. You may end up with adding a separate Free language for expressions for a better granularity of your recordings, but that is another story... 232 | 233 | Technically, it’s seems clear how the recording mode should work: on every step, push a corresponding entry into the recordings array collecting them all during the evaluation. At the end we’ll have a recording that we may write into the file. Except... How would we put all these different entry types into a homogenous container? Well, we could just have a single type ADT for all the entries like so: 234 | 235 | ```haskell 236 | data RecordingEntry 237 | = GenerateGUIDEntry { guid :: String } 238 | | RunIOEntry { jsonResult :: Value } 239 | | LogInfoEntry { message :: String } 240 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 241 | ``` 242 | 243 | This is fine, but let’s make our lives harder. We’ll just encode an entry type and put it as string into the following `RecordingEntry` type: 244 | 245 | ```haskell 246 | type EntryIndex = Int 247 | type EntryName = String 248 | type EntryPayload = Value 249 | 250 | data RecordingEntry = RecordingEntry EntryIndex EntryName EntryPayload 251 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 252 | 253 | type RecordingEntries = IntMap RecordingEntry 254 | newtype Recording = Recording { entries :: RecordingEntries } 255 | ``` 256 | 257 | This is an operational data that exists only on the runtime layer, and it should not anyhow appear on the business logic layer. So we want to maintain a structure for runtime and interpreting process: 258 | 259 | ```haskell 260 | data RecorderRuntime = RecorderRuntime 261 | { recordingRef :: IORef RecordingEntries 262 | } 263 | ``` 264 | 265 | For the player mode, we’ll put the recordings and the current step into the PlayerRuntime. There will also be a variable for a playback error that could have possibly happened. Here: 266 | 267 | ```haskell 268 | data PlayerRuntime = PlayerRuntime 269 | { recording :: RecordingEntries 270 | , stepRef :: IORef Int 271 | , errorRef :: IORef (Maybe PlaybackError) 272 | } 273 | ``` 274 | 275 | The interpreter works in either of three modes. There can be another runtime operational data such as current DB connections, options, variables, that is needed by the interpreter. The `Runtime` type is a good place to keep this data (if you don’t want to use `ReaderT` or `StateT`): 276 | 277 | ```haskell 278 | data Runtime = Runtime 279 | { runMode :: RunMode 280 | -- More operational data for the interpreter 281 | } 282 | 283 | data RunMode 284 | = RegularMode 285 | | RecordingMode RecorderRuntime 286 | | ReplayingMode PlayerRuntime 287 | 288 | interpretFlowF :: Runtime -> FlowF a -> IO a 289 | interpretFlowF rt … = … 290 | 291 | runFlow :: Runtime -> Flow a -> IO a 292 | runFlow rt = foldFree (interpretFlowF rt) 293 | ``` 294 | 295 | So we prepared the environment for our Free monad language. Now, the most interesting part goes here: the details of the recording-replaying mechanism itself. 296 | 297 | ### The recording-replaying mechanism 298 | 299 | The recording mode is pretty simple and boring: the interpreter just walks by the script step-by-step and produces the entries. The replaying mode is a bit more difficult. In it, the interpreter also does a step-by-step interpreting, but the replaying mechanism should track entries from the recording and match them with the current step. It might be the script has changed and the entry won’t match the step: either its type, or the input parameters stored in it. When this happens, the replaying will be failed. 300 | 301 | There are more reasons for the playback failure while the player works. This is a happy path: 302 | 303 | * Take the flow step. 304 | * Take the next recording entry from the recording. 305 | * Decode the recording entry. 306 | * Check step and entry for match. 307 | * Check input parameters for match. 308 | * Decode a mock value. 309 | * Do not evaluate the real effect but rather return the mock value instead. 310 | 311 | Different errors can happen all the way down, and the player will finish with a playback error: 312 | 313 | ```haskell 314 | data PlaybackErrorType 315 | = UnexpectedRecordingEnd 316 | | UnknownRRItem 317 | | MockDecodingFailed 318 | | ItemMismatch 319 | 320 | data PlaybackError = PlaybackError 321 | { errorType :: PlaybackErrorType 322 | , errorMessage :: String 323 | } 324 | ``` 325 | 326 | The error message (and the diff between the previous and the current flows) is usually enough to understand what's happened. There will be a step index, an entry and the current `FlowF` method description. On a closer look however it’s not so obvious how the player obtains this info. Let’s elaborate that. 327 | 328 | When the interpreter hits a particular method, the latter contains all the information about the step. For example, the `LogInfo` method carries the message string, the `RunIO` method has a return type defined and so on. The replaying mechanism should be able to decode mocks, to prepare an entry for serialization, to check the input parameters of the method (if there are such parameters). We’re passing this information into the mechanism by associating it with the corresponding entry using the two type classes. First of them, `RRItem`, allows to serialize and deserialize the entry: 329 | 330 | ```haskell 331 | class (Eq rrItem, ToJSON rrItem, FromJSON rrItem) 332 | => RRItem rrItem where 333 | toRecordingEntry :: rrItem -> Int -> RecordingEntry 334 | fromRecordingEntry :: RecordingEntry -> Maybe rrItem 335 | getTag :: Proxy rrItem -> String 336 | 337 | instance RRItem GenerateGUIDEntry where 338 | toRecordingEntry rrItem idx = … 339 | fromRecordingEntry re = … 340 | getTag _ = "GenerateGUIDEntry" 341 | ``` 342 | 343 | The second type class, `MockedResult`, allows to extract a mock value from the entry: 344 | 345 | ```haskell 346 | class RRItem rrItem => MockedResult rrItem native where 347 | getMock :: rrItem -> Maybe native 348 | 349 | instance MockedResult GenerateGUIDEntry String where 350 | getMock (GenerateGUIDEntry g) = Just g 351 | ``` 352 | 353 | Notice that the native type is not necessarily serializable, it’s just something we should return from the `getMock` function. We are free to store some another type into the entry. This is a subtle design detail, though. 354 | 355 | Let’s move forward. There is a `withRunMode` function that is the entry point for the mechanism. It takes the run mode, the native effect (to be or not to be evaluated), and the entry creation function: 356 | 357 | ```haskell 358 | import Data.UUID (toString) 359 | import Data.UUID.V4 (nextRandom) 360 | 361 | interpretFlowF (Runtime mode) (GenerateGUID next) = do 362 | let (eff :: IO String) = toString <$> nextRandom 363 | guidStr <- withRunMode mode mkGenerateGUIDEntry eff 364 | pure $ next guidStr 365 | ``` 366 | 367 | Note that we don’t evaluate the effect immediately here, this is why we can’t finish construction of the entry: the result of the effect does not yet exist. So the final entry will be formed later using this construction function. 368 | 369 | Here is the interpreter for all methods we have. It’s written a bit more concise (and probably, less clear): 370 | 371 | ```haskell 372 | interpretFlowF :: Runtime -> FlowF a -> IO a 373 | 374 | interpretFlowF (Runtime mode) (GenerateGUID next) = 375 | next <$> withRunMode mode mkGenerateGUIDEntry (toString <$> nextRandom) 376 | 377 | interpretFlowF (Runtime mode) (RunIO ioAct next) = 378 | next <$> withRunMode mode mkRunIOEntry ioAct 379 | 380 | interpretFlowF (Runtime mode) (LogInfo msg next) = 381 | next <$> withRunMode mode (mkLogInfoEntry msg) (putStrLn msg) 382 | ``` 383 | 384 | So, what’s inside the `withRunMode` function? Well, it’s just a switch for the mode. All the underlying functions work with entries abstracted by the type classes. 385 | 386 | ```haskell 387 | withRunMode :: RRItem rrItem => MockedResult rrItem native 388 | => RunMode -> (native -> rrItem) -> IO native -> IO native 389 | 390 | withRunMode RegularMode _ act = act 391 | 392 | withRunMode (RecordingMode recorderRt) mkRRItem act 393 | = record recorderRt Proxy mkRRItem act 394 | 395 | withRunMode (ReplayingMode playerRt) mkRRItem act 396 | = replay playerRt mkRRItem act 397 | ``` 398 | 399 | Going deeper to the implementation seems not that necessary for this storytelling. The `record` and `replay` functions store and load entries, decode results, make checks and verifications. A more developed mechanism also supports configs for replaying and recording. You can see how it’s done in the [showcase project](https://github.com/graninas/automatic-whitebox-testing-showcase/blob/master/src/Playback/Machine.hs), and now we’d better cover an important question we mentioned earlier. Let’s return to the design space and talk about why we have to abstract native types and libraries for this mechanism particularly and in general. 400 | 401 | ### Abstracting over the native libraries and types 402 | 403 | The problem is that we cannot operate by the types that are not serializable because this immediately makes the scenario unrecordable and unreplayable. Why so? Back to the samples with database interaction, we might want to use a native connection type in the flows: 404 | 405 | ```haskell 406 | getStudentsCount :: String -> DB.Config -> Flow Int 407 | getStudentsCount dbName cfg = do 408 | (conn :: DB.Connection) <- runIO $ DB.connect dbName cfg 409 | students <- runIO $ DB.query conn "SELECT * FROM students" 410 | when (null students) $ logInfo "No records found." 411 | pure $ length students 412 | ``` 413 | 414 | The `runIO` method has changed since then and now the compilation will fail because `DB.Connection` does not have `ToJSON` and `FromJSON` instances. There is a simple refactoring that solves the problem in some kind: move all the DB operations into the impure block and do not expose connection out there: 415 | 416 | ```haskell 417 | getStudentsCount :: DBName -> DB.Config -> Flow Int 418 | getStudentsCount dbName cfg = do 419 | students <- runIO $ do 420 | (conn :: DB.Connection) <- DB.connect dbName cfg 421 | DB.query conn "SELECT * FROM students" 422 | when (null students) $ logInfo "No records found." 423 | pure $ length students 424 | ``` 425 | 426 | Now, the flow will be recorded as follows: 427 | 428 | ```json 429 | { 430 | "entries": [ 431 | [ 432 | 0, 433 | "RunIOEntry", 434 | { 435 | "jsonResult":[] 436 | } 437 | ], 438 | [ 439 | 1, 440 | "LogInfoEntry", 441 | { 442 | "message":"No records found." 443 | } 444 | ] 445 | ] 446 | } 447 | ``` 448 | 449 | We lost the information about DB interaction but at least the recording was successfully formed and can be replayed without errors. However, we usually want to keep the connection to the DB rather than create a new one every time we run a query. Consider the following (pretty stupid) scenario with the methods slightly reworked - this will be our primary scenario for the rest of this section: 450 | 451 | ```haskell 452 | getStudentsCount :: String -> DB.Config -> Flow Int 453 | getStudentsCount dbName cfg = do 454 | conn <- connect dbName cfg 455 | (students :: [Student]) <- query conn "SELECT * FROM students" 456 | (disabled :: [Student]) <- query conn "SELECT * FROM students WHERE disabled=1" 457 | let count = length students - length disabled 458 | when (count == 0) $ logInfo "No records found." 459 | pure count 460 | ``` 461 | 462 | Here, the conn value is used twice, and there is no any limitations to pass it across the scenarios. Its type is an abstraction over the native one: 463 | 464 | ```haskell 465 | data Connection 466 | = NativeConn DBName DB.Connection 467 | | MockedConn DBName 468 | ``` 469 | 470 | It’s also serializable in sense the corresponding entry will keep some useful info about it, namely, DB name: 471 | 472 | ```haskell 473 | data ConnectEntry = ConnectEntry 474 | { ceDBConfig :: DB.Config 475 | , ceDBName :: DBName 476 | } 477 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 478 | 479 | mkConnectEntry :: DBName -> DB.Config -> Connection -> ConnectEntry 480 | mkConnectEntry dbName dbCfg _ = ConnectEntry dbCfg dbName 481 | ``` 482 | 483 | So that in the recording and normal mode the `conn` variable will contain `NativeConn`, and `MockedConn` in the replay mode. The corresponding recordings might look like this: 484 | 485 | ```json 486 | { 487 | "entries": [ 488 | [ 489 | 0, 490 | "ConnectEntry", 491 | { 492 | "ceDBConfig":[], 493 | "ceDBName":"students" 494 | } 495 | ], 496 | [ 497 | 1, 498 | "RunDBEntry", 499 | { 500 | "dbeDescription":"SELECT * FROM students", 501 | "dbeJsonResult":[], 502 | "dbeDBName":"students" 503 | } 504 | ], 505 | [ 506 | 2, 507 | "RunDBEntry", 508 | { 509 | "dbeDescription":"SELECT * FROM students WHERE disabled=1", 510 | "dbeJsonResult":[], 511 | "dbeDBName":"students" 512 | } 513 | ], 514 | [ 515 | 3, 516 | "LogInfoEntry", 517 | { 518 | "message":"No records found." 519 | } 520 | ] 521 | ] 522 | } 523 | ``` 524 | 525 | As you can see the recordings do not contain the connection itself, just a help info about it. When replaying, there should be a code in the interpreter that is able to distinguish the two variants of connection. But before we get familiar with it, let’s figure out the design of the DB <-> Flow interaction that is used for the scenario above. This design utilizes a small but important idea of a clear separation between DB queries evaluation and DB connectivity management. 526 | 527 | ```haskell 528 | type Description = String 529 | 530 | data DatabaseF next where 531 | Query :: String -> ([a] -> next) -> DatabaseF next 532 | 533 | data FlowF next where 534 | Connect :: DBName -> DB.Config -> (Connection -> next) -> FlowF next 535 | 536 | RunDB :: (ToJSON s, FromJSON s) => Connection -> Description 537 | -> Database s -> (s -> next) -> FlowF next 538 | ``` 539 | 540 | The Database language is auxiliary. It will be only needed to abstract the native calls, but it won’t be visible to the client code. All the actual methods will be working within the `Flow` language. The following smart constructors provide a sane UX for this DB subsystem: 541 | 542 | ```haskell 543 | -- Helpers 544 | query' :: String -> Database [a] 545 | query' q = liftF $ Query q id 546 | 547 | runDB :: (ToJSON s, FromJSON s) 548 | => Connection -> Description -> Database s -> Flow s 549 | runDB conn descr db = liftF $ RunDB conn descr db id 550 | 551 | -- Exposed DB interface 552 | connect :: DBName -> DB.Config -> Flow Connection 553 | connect dbName dbCfg = liftF $ Connect dbName dbCfg id 554 | 555 | query :: (ToJSON s, FromJSON s) => Connection -> String -> Flow [s] 556 | query conn q = runDB conn q $ query' q 557 | ``` 558 | 559 | We also provide an additional info about queries for the `RunDB` method. For example, the query string. This makes recordings more useful. 560 | 561 | The interpreter for the `Connect` and `RunDB` methods looks similar to other methods except for `RunDB` there is a special case that checks the type of the connection, and if the latter is `NativeConn`, a real effect will be evaluated. 562 | 563 | ```haskell 564 | interpretFlowF rt (Connect dbName dbConfig next) = do 565 | conn <- withRunMode (runMode rt) 566 | (mkConnectEntry dbName dbConfig) 567 | (NativeConn dbName <$> DB.connect dbName dbConfig) 568 | pure $ next conn 569 | 570 | interpretFlowF rt (RunDB conn qInfo db next) = do 571 | res <- withRunMode (runMode rt) 572 | (mkRunDBEntry conn qInfo) 573 | (case conn of 574 | NativeConn _ nativeConn -> runDatabase nativeConn db 575 | MockedConn _ -> error "Should not be evaluated.") 576 | pure $ next res 577 | ``` 578 | 579 | The variant with `MockedConn` won’t be called in the replaying mode. Hopefully, no one will create a fake `MockedConn` for the normal mode. 580 | 581 | This is how we abstract over the native DB facilities, - this “pattern” can be (and should be) used for all other native effects and subsystems. Although they can require a slightly different design, the idea will remain the same: provide a custom, possibly serializable type, do not use native types in flows, hide native calls behind a eDSL. And the flows will become clean and nice. 582 | 583 | ### Presto Backend possibilities and PureScript differences 584 | 585 | In the [Presto.Backend](https://github.com/juspay/purescript-presto-backend/tree/feature/record-replay) framework (by [Juspay](http://juspay.in)), we’ve developed a powerful technology for automated regression testing. This particular showcase project is mostly a less-featured port from the PureScript code, so if you are interested to know more, you can check Presto.Backend. It supports such features as configs, async flows handling, KV DB and SQL DB interaction and many others. Here goes a short overview of its possibilities related to recording-replaying mechanism. 586 | 587 | Different configs can be used for a fine tuning of the recording-replaying process. 588 | 589 | - Recorder configs: 590 | * Disable entries from recording. These entries will not appear in the recording. 591 | 592 | - Player global configs. The entries of a specified type can be configured separately: 593 | * Disable verifying of entries. 594 | * Disable mocking and verifying of entries. 595 | * Skip entries completely. These particular entries will be filtered out from the recordings. 596 | 597 | Additionally, an entry can be individually configured by setting up its replaying mode. You can adjust it by editing the recording. Entry replaying modes: 598 | 599 | - Normal (default). Mocking and verifying enabled. 600 | - NoVerify. Verifying disabled, mocking enabled. 601 | - NoMock. Verifying and mocking disabled. Real effect will be used on this step. 602 | 603 | The framework also supports async evaluations, and the recording-replaying mechanism respects that. Forked flows will be recorded and replayed separately, thread-safely, without making a mess in the recording entries. This works for flows hierarchies or any size. The framework supports KV DBs and SQL DBs, and it has many other possibilities. You can find more samples of flows and recordings in tests to `Presto.Backend`, [here](https://github.com/juspay/purescript-presto-backend/blob/feature/record-replay/test/Presto/Backend/RunModesSpec.purs). 604 | 605 | PureScript has some significant differences from Haskell on the type level. In particular, there is no `GADTs`, `Type Families` and `Existential Types` there. This is sometimes an obstacle but many cases can be solved by other tools and features. For example, we workarounded the lack of existentials by a special type [Data.Exists](https://pursuit.purescript.org/packages/purescript-exists/4.0.0/docs/Data.Exists) that we’re using to wrap our types: 606 | 607 | ```haskell 608 | import Data.Exists (Exists) 609 | 610 | data BackendFlowCommands next s = 611 | ... 612 | 613 | newtype BackendFlowWrapper next = BackendFlowWrapper (Exists (BackendFlowCommands next)) 614 | 615 | type BackendFlow next = Free BackendFlowWrapper next 616 | ``` 617 | 618 | There is a burden in how we wrap the methods into the recordable-replayable form. Essentially, we convert a type class instance into an explicit dictionary because there is no possibility to pass type class instances via ADT methods with preserving access to the type class (no existentials and GADTs). Even more burden comes from the combo: lack of orphan instances and lack of serialization instances for some important types. Finally, effect system with row effects brings a lot of unnecessary code that is there for no practical reason. Some of these issues have been fixed in the new versions of PureScript, but we’re still on 0.11 - and have to deal with extra accidental complexity comparing to the ideal solution. Check it out for a simple method: 619 | 620 | ```haskell 621 | data BackendFlowCommands next s 622 | = GenerateGUID 623 | (Playback.RRItemDict Playback.GenerateGUIDEntry String) 624 | (String -> next) 625 | 626 | generateGUID :: String -> BackendFlow String 627 | generateGUID description = wrap $ GenerateGUID 628 | (Playback.mkEntryDict description $ Playback.mkGenerateGUIDEntry description) 629 | id 630 | ``` 631 | 632 | But... This is fine and not a problem. We wrote this code once during the framework improvement, and we won’t touch it anymore. The business logic has not been changed at all (except replacing the native types by their abstracted analogues), and it’s now completely recordable and replayable. Which is more important than any possible boilerplate on the implementation level. 633 | 634 | ### Conclusion 635 | 636 | The Free monad approach allowed us to add this very useful feature almost for free. We got interesting results and revealed even more use cases than we thought initially. For instance, it’s pretty much possible to automatically measure the performance of some important steps like HTTP calls, DB interaction, and so on, and have a way to get a structured, configurable report from the recordings. This is a very cheap approach to white-box testing that has the power to save a lot of hours that are otherwise could have been lost in unit testing. The last but not the least is that having an application being structured into layers with Free monads enables a lot more possibilities that were not possible with other approaches. 637 | 638 | ### Acknowledgments 639 | 640 | Thanks to all who made this article possible: 641 | 642 | * [Juspay Technology Private Limited](http://juspay.in/) 643 | * Vimal Kumar, Dilip Jain, Arun Raghavan 644 | * [Contributors to Presto.Backend](https://github.com/juspay/purescript-presto-backend/graphs/contributors) 645 | * Vasily Gorev, Sergey Stepanenko, Shubhanshu Mani 646 | * And other people who were working on this project. 647 | -------------------------------------------------------------------------------- /Recording-Replaying.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/graninas/automatic-whitebox-testing-showcase/ec34fe13e6c95566ae805c21e09ccbf28e0be300/Recording-Replaying.png -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/circle_area.json: -------------------------------------------------------------------------------- 1 | { 2 | "precision":"P4", 3 | "expression":{ 4 | "tag":"BinOpExpr", 5 | "arg1":{ 6 | "tag":"ConstExpr", 7 | "contents":"Pi" 8 | }, 9 | "bop":"Mul", 10 | "arg2":{ 11 | "tag":"UnOpExpr", 12 | "arg":{ 13 | "tag":"ValExpr", 14 | "contents":100 15 | }, 16 | "uop":"Sqr" 17 | } 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /app/def_expr.json: -------------------------------------------------------------------------------- 1 | { 2 | "precision":"P4", 3 | "expression":{ 4 | "bop":"Mul", 5 | "tag":"BinOpExpr", 6 | "arg1":{ 7 | "tag":"ValExpr", 8 | "contents":10 9 | }, 10 | "arg2":{ 11 | "tag":"ValExpr", 12 | "contents":2 13 | } 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /app/package.yaml: -------------------------------------------------------------------------------- 1 | name: app 2 | version: 0.1.0.0 3 | github: "graninas/automatic-whitebox-testing-showcase" 4 | license: BSD3 5 | author: "Alexander Granin" 6 | maintainer: "graninas@gmail.com" 7 | copyright: "2019 Alexander Granin" 8 | 9 | dependencies: 10 | - base >= 4.7 && < 5 11 | - free 12 | - uuid 13 | - aeson 14 | - text 15 | - bytestring 16 | - containers 17 | - vector 18 | - process 19 | - flow 20 | 21 | library: 22 | source-dirs: 23 | - src 24 | 25 | executables: 26 | app: 27 | main: Main.hs 28 | source-dirs: src/ 29 | ghc-options: 30 | - -threaded 31 | - -rtsopts 32 | - -with-rtsopts=-N 33 | - -Wall 34 | - -O2 35 | - -fspec-constr-recursive=10 36 | - -fno-ignore-asserts 37 | 38 | tests: 39 | app-test: 40 | main: Spec.hs 41 | source-dirs: test 42 | ghc-options: 43 | - -threaded 44 | - -rtsopts 45 | - -with-rtsopts=-N 46 | dependencies: 47 | - flow 48 | - app 49 | - hspec 50 | -------------------------------------------------------------------------------- /app/src/Expression/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Expression.Expr where 5 | 6 | import Data.Aeson (FromJSON, ToJSON) 7 | import qualified Data.ByteString.Char8 as BC 8 | import qualified Data.ByteString.Lazy.Char8 as BCL 9 | import qualified Data.ByteString.Lazy as BSL 10 | import GHC.Generics (Generic) 11 | 12 | data Precision 13 | = P1 14 | | P2 15 | | P4 16 | | P8 17 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 18 | 19 | data BinOp 20 | = Mul 21 | | Div 22 | | Add 23 | | Sub 24 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 25 | 26 | data UnOp 27 | = Neg 28 | | Sqr 29 | | Sqrt 30 | -- | Lg 31 | -- | Ln 32 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 33 | 34 | data Val = Val Precision Double 35 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 36 | 37 | data Const 38 | = Pi 39 | | E 40 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 41 | 42 | data Expr 43 | = BinOpExpr { bop :: BinOp, arg1 :: Expr, arg2 :: Expr } 44 | | UnOpExpr { uop :: UnOp, arg :: Expr} 45 | | ConstExpr Const 46 | | ValExpr Double 47 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 48 | 49 | data PrecExpr = PrecExpr 50 | { precision :: Precision 51 | , expression :: Expr 52 | } 53 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 54 | 55 | precVal :: Precision -> Double 56 | precVal P1 = 0.1 57 | precVal P2 = 0.01 58 | precVal P4 = 0.0001 59 | precVal P8 = 0.00000001 60 | 61 | isZero :: Precision -> Double -> Bool 62 | isZero p v = abs v <= precVal p 63 | 64 | valsEqual :: Val -> Val -> Bool 65 | valsEqual (Val p1 v1) (Val p2 v2) 66 | | precVal p1 > precVal p2 = abs (v1 - v2) <= precVal p1 67 | | otherwise = abs (v1 - v2) <= precVal p2 68 | 69 | evalBinOp :: Precision -> BinOp -> Double -> Double -> Either String Double 70 | evalBinOp prec Mul v1 v2 = Right $ v1 * v2 71 | evalBinOp prec Sub v1 v2 = Right $ v1 - v2 72 | evalBinOp prec Add v1 v2 = Right $ v1 + v2 73 | evalBinOp prec Div v1 v2 74 | | isZero prec v2 = Left "Zero division" 75 | | otherwise = Right $ v1 / v2 76 | 77 | evalUnOp :: Precision -> UnOp -> Double -> Either String Double 78 | evalUnOp prec Neg v = Right (0.0 - v) 79 | evalUnOp prec Sqr v = Right (v * v) 80 | evalUnOp prec Sqrt v 81 | | v < 0.0 = Left "SQRT from a negative number" 82 | | otherwise = Right $ sqrt v 83 | 84 | evalConst :: Precision -> Const -> Double 85 | evalConst _ Pi = pi 86 | evalConst _ E = exp 1 87 | 88 | eval :: PrecExpr -> Either String Val 89 | eval (PrecExpr prec expr) = do 90 | val <- eval' prec expr 91 | pure $ Val prec val 92 | 93 | eval' :: Precision -> Expr -> Either String Double 94 | eval' prec (BinOpExpr op arg1 arg2) = do 95 | r1 <- eval' prec arg1 96 | r2 <- eval' prec arg2 97 | evalBinOp prec op r1 r2 98 | eval' prec (UnOpExpr op arg) = do 99 | r <- eval' prec arg 100 | evalUnOp prec op r 101 | eval' prec (ConstExpr c) = Right $ evalConst prec c 102 | eval' prec (ValExpr v) = Right v 103 | 104 | demoExpr :: PrecExpr 105 | demoExpr = PrecExpr P4 106 | ( BinOpExpr Mul 107 | (ValExpr 10.0) 108 | (ValExpr 2.0) 109 | ) 110 | 111 | circleAreaExpr :: Double -> PrecExpr 112 | circleAreaExpr radius = PrecExpr P4 113 | ( BinOpExpr Mul 114 | (ConstExpr Pi) 115 | (UnOpExpr Sqr (ValExpr radius)) 116 | ) 117 | -------------------------------------------------------------------------------- /app/src/Expression/Flow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Expression.Flow where 5 | 6 | import Control.Monad (unless, void, when) 7 | import Data.Aeson (FromJSON, ToJSON, Result(), decode, encode, eitherDecode) 8 | import qualified Data.ByteString.Char8 as BC 9 | import qualified Data.ByteString.Lazy.Char8 as BCL 10 | import qualified Data.ByteString.Lazy as BSL 11 | import Data.UUID (toString) 12 | import Data.UUID.V4 (nextRandom) 13 | import Data.Either (either) 14 | import GHC.Generics (Generic) 15 | 16 | import qualified Language as L 17 | import Expression.Expr 18 | 19 | expressionScenario :: String -> L.Flow (Maybe Val) 20 | expressionScenario fileName = do 21 | jsonRequest <- L.runIO $ readFile fileName 22 | let eRes = do 23 | precExpr <- eitherDecode $ BCL.pack jsonRequest 24 | eval precExpr 25 | case eRes of 26 | Left err -> L.logInfo $ "Error got: " ++ err 27 | Right res -> L.logInfo $ "Result: " ++ show res 28 | pure $ either (const Nothing) Just eRes 29 | -------------------------------------------------------------------------------- /app/src/Expression/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Expression.IO where 5 | 6 | import Control.Monad (unless, void, when) 7 | import Data.Aeson (FromJSON, ToJSON, Result(), decode, encode, eitherDecode) 8 | import qualified Data.ByteString.Char8 as BC 9 | import qualified Data.ByteString.Lazy.Char8 as BCL 10 | import qualified Data.ByteString.Lazy as BSL 11 | import Data.UUID (toString) 12 | import Data.UUID.V4 (nextRandom) 13 | import Data.Either (either) 14 | import GHC.Generics (Generic) 15 | 16 | import Expression.Expr 17 | 18 | expressionScenario :: String -> IO (Maybe Val) 19 | expressionScenario fileName = do 20 | jsonRequest <- readFile fileName 21 | let eRes = do 22 | precExpr <- eitherDecode $ BCL.pack jsonRequest 23 | eval precExpr 24 | case eRes of 25 | Left err -> putStrLn $ "Error got: " ++ err 26 | Right res -> putStrLn $ "Result: " ++ show res 27 | pure $ either (const Nothing) Just eRes 28 | -------------------------------------------------------------------------------- /app/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Main where 5 | 6 | import qualified Data.Map.Strict as Map 7 | import Control.Concurrent.MVar 8 | import System.Environment (getArgs) 9 | import Data.Aeson (encode) 10 | import qualified Data.ByteString.Lazy as BSL 11 | 12 | import qualified Language as L 13 | import qualified Types as R 14 | import qualified Runtime.Types as R 15 | import qualified Runtime.Interpreter as R 16 | 17 | import qualified Expression.Flow as FlowExpr 18 | import qualified Expression.IO as IOExpr 19 | import Expression.Expr 20 | 21 | import Scenarios 22 | import Playback 23 | 24 | getStudentFlowAndMocks :: String -> IO (L.Flow Int, R.MockedData) 25 | getStudentFlowAndMocks "students" = do 26 | mocks <- R.MockedData 27 | <$> R.mkMocks @Int [] 28 | <*> R.mkMocks [ R.MockedConnection "test_db" ] 29 | <*> R.mkMocks [ [expelled1, expelled2, student1, student2, student3] 30 | , [expelled1, expelled2] ] 31 | pure (getStudentsCountFlow "test_db" dbConfig, mocks) 32 | getStudentFlowAndMocks "students_broken" = do 33 | mocks <- R.MockedData 34 | <$> R.mkMocks @Int [] 35 | <*> R.mkMocks [ R.MockedConnection "test_db" ] 36 | <*> R.mkMocks [ [expelled1, expelled2, student1, student2, student3] 37 | , [expelled1, expelled2] ] 38 | pure (getStudentsCountFlowBroken "test_db" dbConfig, mocks) 39 | getStudentFlowAndMocks scenario = error $ "Scenario is not supported: " ++ scenario 40 | 41 | main :: IO () 42 | main = do 43 | args <- getArgs 44 | 45 | (flow, mocks) <- case args of 46 | (_:_:scenario:[]) -> getStudentFlowAndMocks scenario 47 | _ -> getStudentFlowAndMocks "students" 48 | 49 | case args of 50 | [] -> putStrLn "Please specify arguments." 51 | ("recorder" : fName : _) -> recorder (Just mocks) fName flow 52 | ("player" : fName : _) -> player fName flow 53 | _ -> error "Args not recognized" 54 | 55 | 56 | -- main :: IO () 57 | -- main = do 58 | -- opts <- newMVar Map.empty 59 | -- let rt = R.Runtime R.RegularMode (Left $ R.OperationalData opts) 60 | -- 61 | -- args <- getArgs 62 | -- mbFlowRes <- case args of 63 | -- fileName : _ -> R.runFlow rt $ FlowExpr.expressionScenario fileName 64 | -- _ -> R.runFlow rt $ FlowExpr.expressionScenario "app/def_expr.json" 65 | -- 66 | -- mbIORes <- case args of 67 | -- fileName : _ -> IOExpr.expressionScenario fileName 68 | -- _ -> IOExpr.expressionScenario "app/def_expr.json" 69 | -- 70 | -- case (mbFlowRes, mbIORes) of 71 | -- (Nothing, Nothing) -> putStrLn "No results" 72 | -- (Nothing, _) -> putStrLn "Different results (nothing in Flow)" 73 | -- (_, Nothing) -> putStrLn "Different results (nothing in IO)" 74 | -- (Just v1, Just v2) 75 | -- | valsEqual v1 v2 -> putStrLn "Values are equal." 76 | -- | otherwise -> putStrLn "Values are not equal." 77 | -- 78 | -- mbCircleArea <- R.runFlow rt $ FlowExpr.expressionScenario "app/circle_area.json" 79 | -- case mbCircleArea of 80 | -- Nothing -> putStrLn "Failed to evaluate circle area." 81 | -- Just area -> putStrLn $ "Circle area: " ++ show area 82 | -------------------------------------------------------------------------------- /app/src/Playback.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Playback where 5 | 6 | import Control.Concurrent.MVar 7 | import qualified Data.Map.Strict as Map 8 | import Data.Aeson (ToJSON, FromJSON, Value, Result(..), encode, decode, eitherDecode, toJSON, fromJSON) 9 | import qualified Data.ByteString.Lazy as BSL 10 | import qualified Data.Vector as V 11 | import GHC.Generics (Generic) 12 | 13 | import qualified Language as L 14 | import qualified Types as L 15 | import qualified Runtime.Types as R 16 | import qualified Playback.Types as R 17 | import qualified Runtime.Interpreter as R 18 | 19 | data FlowRecording = FlowRecording 20 | { recording :: R.Recording 21 | , jsonResult :: Value 22 | } 23 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 24 | 25 | getRecording :: R.Runtime -> IO R.Recording 26 | getRecording rt = case R.runMode rt of 27 | R.RecordingMode rrt -> R.Recording <$> readMVar (R.recordingMVar rrt) 28 | _ -> error "wrong mode." 29 | 30 | getErrors :: R.Runtime -> IO (Maybe R.PlaybackError) 31 | getErrors rt = case R.runMode rt of 32 | R.ReplayingMode prtm -> readMVar $ R.errorMVar prtm 33 | _ -> error "wrong mode." 34 | 35 | initRecorderRT :: Maybe R.MockedData -> IO R.Runtime 36 | initRecorderRT mbMocks = do 37 | recMVar <- newMVar V.empty 38 | forkedRecMvar <- newMVar Map.empty 39 | opts <- newMVar Map.empty 40 | let recRt = R.RecorderRuntime "" recMVar forkedRecMvar [] 41 | pure $ R.Runtime 42 | { R.runMode = R.RecordingMode recRt 43 | , R.runtimeData = case mbMocks of 44 | Nothing -> Left $ R.OperationalData opts 45 | Just mocks -> Right mocks 46 | } 47 | 48 | initPlayerRT :: R.RecordingEntries -> IO R.Runtime 49 | initPlayerRT recEntries = do 50 | opts <- newMVar Map.empty 51 | step <- newMVar 0 52 | errMVar <- newMVar Nothing 53 | ffEV <- newMVar Map.empty 54 | let pRt = R.PlayerRuntime recEntries step errMVar [] [] [] False "" Map.empty ffEV 55 | pure $ R.Runtime 56 | { R.runMode = R.ReplayingMode pRt 57 | , R.runtimeData = Left $ R.OperationalData opts 58 | } 59 | 60 | recorder 61 | :: (ToJSON a, FromJSON a) 62 | => Maybe R.MockedData -> String -> L.Flow a -> IO () 63 | recorder mbMockedData fName flow = do 64 | 65 | rt <- initRecorderRT mbMockedData 66 | 67 | res <- R.runFlow rt flow 68 | recording <- getRecording rt 69 | 70 | BSL.writeFile fName $ encode $ FlowRecording recording (toJSON res) 71 | 72 | player 73 | :: (ToJSON a, FromJSON a, Show a, Eq a) 74 | => String -> L.Flow a -> IO () 75 | player fName flow = do 76 | mbFlowRecording <- eitherDecode <$> BSL.readFile fName 77 | case mbFlowRecording of 78 | Left err -> putStrLn $ "Failed to parse recordings: " ++ err 79 | Right (FlowRecording r jsonRes) -> do 80 | rt <- initPlayerRT $ R.entries r 81 | 82 | res <- R.runFlow rt flow 83 | mbErrors <- getErrors rt 84 | 85 | case (mbErrors, fromJSON jsonRes) of 86 | (_, Error err) -> putStrLn $ "Failed to decode result from recordings: " ++ err 87 | (Nothing, Success res') | res == res' -> putStrLn "Successfully replayed." 88 | (Nothing, Success res') | res /= res' -> do 89 | putStrLn "Results do not match." 90 | putStrLn $ "Expected from recordings: \n" ++ show res' 91 | putStrLn $ "Got from flow: \n" ++ show res 92 | (Just err, _) -> putStrLn $ "Playback failed: " ++ show err 93 | -------------------------------------------------------------------------------- /app/src/Scenarios.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE DeriveDataTypeable #-} 13 | 14 | module Scenarios where 15 | 16 | import Control.Monad (unless, void, when) 17 | import Control.Monad.Free 18 | import Data.Aeson (FromJSON, ToJSON, decode, encode) 19 | import qualified Data.ByteString.Char8 as BS 20 | import qualified Data.ByteString.Lazy as BSL 21 | import Data.Maybe (isJust) 22 | import Data.Proxy (Proxy (..)) 23 | import Data.Text (Text) 24 | import Data.UUID (toString, fromString) 25 | import Data.UUID.V4 (nextRandom) 26 | import GHC.Generics (Generic) 27 | import Data.Typeable 28 | 29 | import Language 30 | import Types 31 | import qualified Language as L 32 | import qualified DB.Native as DB 33 | 34 | 35 | data Student = Student 36 | { number :: Int 37 | , expelled :: Bool 38 | } 39 | deriving (Generic, ToJSON, FromJSON, Typeable) 40 | 41 | type Students = [Student] 42 | 43 | loadOrGenerateGuidIO :: String -> IO String 44 | loadOrGenerateGuidIO fileName = do 45 | mbGuid <- fromString <$> readFile fileName 46 | case mbGuid of 47 | Just (show -> guid) -> do 48 | putStrLn $ "Guid loaded: " ++ guid 49 | pure guid 50 | Nothing -> do 51 | newGuid <- toString <$> nextRandom 52 | writeFile fileName newGuid 53 | putStrLn $ "Guid generated: " ++ newGuid 54 | pure newGuid 55 | 56 | queryAll = "SELECT * FROM students" 57 | queryExpelled = "SELECT * FROM students WHERE expelled = 1" 58 | 59 | data Handle = Handle 60 | { hConnect :: DBName -> DBConfig -> IO DBConnection 61 | , hQuery :: DBConnection -> Query -> IO Students 62 | , hLogInfo :: String -> IO () 63 | } 64 | 65 | 66 | getStudentsCountIO :: DBName -> DBConfig -> IO Int 67 | getStudentsCountIO dbName cfg = do 68 | conn <- DB.connect dbName cfg 69 | students <- DB.query @Students conn queryAll 70 | expelled <- DB.query @Students conn queryExpelled 71 | 72 | let count = length students - length expelled 73 | when (count == 0) $ putStrLn "No records found." 74 | when (count /= 0) $ putStrLn $ "Number of students: " ++ show count 75 | pure count 76 | 77 | 78 | getStudentsCountSH :: Handle -> DBName -> DBConfig -> IO Int 79 | getStudentsCountSH handle dbName cfg = do 80 | conn <- hConnect handle dbName cfg 81 | 82 | students <- hQuery handle conn queryAll 83 | expelled <- hQuery handle conn queryExpelled 84 | 85 | let count = length students - length expelled 86 | 87 | when (count == 0) $ hLogInfo handle "No records found." 88 | when (count /= 0) $ hLogInfo handle $ "Number of students: " ++ show count 89 | pure count 90 | 91 | 92 | dbConfig :: DBConfig 93 | dbConfig = DBConfig 94 | 95 | getStudentsCountFlow :: String -> DBConfig -> Flow Int 96 | getStudentsCountFlow dbName cfg = do 97 | conn <- L.connect dbName cfg 98 | students <- L.query @Students conn queryAll 99 | expelled <- L.query @Students conn queryExpelled 100 | 101 | let count = length students - length expelled 102 | when (count == 0) $ L.logInfo "No records found." 103 | when (count /= 0) $ L.logInfo $ "Count: " ++ show count 104 | pure count 105 | 106 | getStudentsCountFlowBroken :: String -> DBConfig -> Flow Int 107 | getStudentsCountFlowBroken dbName cfg = do 108 | conn <- L.connect dbName cfg 109 | students <- L.query @Students conn queryAll 110 | expelled <- L.query @Students conn queryExpelled 111 | 112 | let count = length students + length expelled 113 | when (count == 0) $ L.logInfo "No records found." 114 | when (count /= 0) $ L.logInfo $ "Count: " ++ show count 115 | pure count 116 | 117 | 118 | 119 | compareGUIDs :: String -> Flow () 120 | compareGUIDs fileName = do 121 | newGuid <- generateGUID 122 | oldGuid <- runIO $ readFile fileName 123 | 124 | let equal = newGuid == oldGuid 125 | when equal $ logInfo "GUIDs are equal." 126 | unless equal $ logInfo "GUIDs are not equal." 127 | 128 | -- initDB :: String -> DB.DBConfig -> Maybe DB.Connection 129 | -- initDB dbName cfg = do 130 | -- mbConn <- runIO $ DB.initDatabase dbName cfg 131 | -- when (isJust mbConn) $ logInfo $ "Successfully initialized." 132 | -- pure mbConn 133 | 134 | -- scenario :: Flow Int 135 | -- scenario = do 136 | -- students <- runDBQuery "SELECT * FROM students" 137 | -- when (null students) $ logInfo "No records found." 138 | -- pure $ length students 139 | 140 | 141 | -- getStudentsCount :: String -> DBConfig -> Flow Int 142 | -- getStudentsCount dbName cfg = do 143 | -- (students :: [Student]) <- runDB $ do 144 | -- conn <- connect dbName cfg 145 | -- query conn "SELECT * FROM students" 146 | -- pure $ length students 147 | 148 | 149 | 150 | student1, student2, student3, expelled1, expelled2 :: Student 151 | student1 = Student 1 False 152 | student2 = Student 2 False 153 | student3 = Student 3 False 154 | expelled1 = Student 4 True 155 | expelled2 = Student 5 True 156 | -------------------------------------------------------------------------------- /app/students.json: -------------------------------------------------------------------------------- 1 | { 2 | "recording":{ 3 | "entries":[ 4 | [ 5 | 0, 6 | "Normal", 7 | "ConnectEntry", 8 | { 9 | "ceDBName":"test_db", 10 | "ceDBConfig":[ 11 | 12 | ] 13 | } 14 | ], 15 | [ 16 | 1, 17 | "Normal", 18 | "RunDBEntry", 19 | { 20 | "dbeDBName":"test_db", 21 | "dbeDescription":"SELECT * FROM students", 22 | "dbeJsonResult":[ 23 | { 24 | "number":4, 25 | "expelled":true 26 | }, 27 | { 28 | "number":5, 29 | "expelled":true 30 | }, 31 | { 32 | "number":1, 33 | "expelled":false 34 | }, 35 | { 36 | "number":2, 37 | "expelled":false 38 | }, 39 | { 40 | "number":3, 41 | "expelled":false 42 | } 43 | ] 44 | } 45 | ], 46 | [ 47 | 2, 48 | "Normal", 49 | "RunDBEntry", 50 | { 51 | "dbeDBName":"test_db", 52 | "dbeDescription":"SELECT * FROM students WHERE expelled = 1", 53 | "dbeJsonResult":[ 54 | { 55 | "number":4, 56 | "expelled":true 57 | }, 58 | { 59 | "number":5, 60 | "expelled":true 61 | } 62 | ] 63 | } 64 | ], 65 | [ 66 | 3, 67 | "Normal", 68 | "LogInfoEntry", 69 | { 70 | "message":"Count: 3" 71 | } 72 | ] 73 | ] 74 | }, 75 | "jsonResult":3 76 | } 77 | -------------------------------------------------------------------------------- /app/students_invalid_result.json: -------------------------------------------------------------------------------- 1 | { 2 | "recording":{ 3 | "entries":[ 4 | [ 5 | 0, 6 | "Normal", 7 | "ConnectEntry", 8 | { 9 | "ceDBName":"test_db", 10 | "ceDBConfig":[ 11 | 12 | ] 13 | } 14 | ], 15 | [ 16 | 1, 17 | "Normal", 18 | "RunDBEntry", 19 | { 20 | "dbeDBName":"test_db", 21 | "dbeDescription":"SELECT * FROM students", 22 | "dbeJsonResult":[ 23 | { 24 | "number":4, 25 | "expelled":true 26 | }, 27 | { 28 | "number":5, 29 | "expelled":true 30 | }, 31 | { 32 | "number":1, 33 | "expelled":false 34 | }, 35 | { 36 | "number":2, 37 | "expelled":false 38 | }, 39 | { 40 | "number":3, 41 | "expelled":false 42 | } 43 | ] 44 | } 45 | ], 46 | [ 47 | 2, 48 | "Normal", 49 | "RunDBEntry", 50 | { 51 | "dbeDBName":"test_db", 52 | "dbeDescription":"SELECT * FROM students WHERE expelled = 1", 53 | "dbeJsonResult":[ 54 | { 55 | "number":4, 56 | "expelled":true 57 | }, 58 | { 59 | "number":5, 60 | "expelled":true 61 | } 62 | ] 63 | } 64 | ], 65 | [ 66 | 3, 67 | "Normal", 68 | "LogInfoEntry", 69 | { 70 | "message":"Count: 3" 71 | } 72 | ] 73 | ] 74 | }, 75 | "jsonResult":0 76 | } 77 | -------------------------------------------------------------------------------- /app/students_invalid_step.json: -------------------------------------------------------------------------------- 1 | { 2 | "recording":{ 3 | "entries":[ 4 | [ 5 | 0, 6 | "Normal", 7 | "ConnectEntry", 8 | { 9 | "ceDBName":"test_db", 10 | "ceDBConfig":[ 11 | 12 | ] 13 | } 14 | ], 15 | 16 | [ 17 | 0, 18 | "Normal", 19 | "ConnectEntry", 20 | { 21 | "ceDBName":"test_db", 22 | "ceDBConfig":[ 23 | 24 | ] 25 | } 26 | ], 27 | 28 | [ 29 | 1, 30 | "Normal", 31 | "RunDBEntry", 32 | { 33 | "dbeDBName":"test_db", 34 | "dbeDescription":"SELECT * FROM students", 35 | "dbeJsonResult":[ 36 | { 37 | "number":4, 38 | "expelled":true 39 | }, 40 | { 41 | "number":5, 42 | "expelled":true 43 | }, 44 | { 45 | "number":1, 46 | "expelled":false 47 | }, 48 | { 49 | "number":2, 50 | "expelled":false 51 | }, 52 | { 53 | "number":3, 54 | "expelled":false 55 | } 56 | ] 57 | } 58 | ], 59 | [ 60 | 2, 61 | "Normal", 62 | "RunDBEntry", 63 | { 64 | "dbeDBName":"test_db", 65 | "dbeDescription":"SELECT * FROM students WHERE expelled = 1", 66 | "dbeJsonResult":[ 67 | { 68 | "number":4, 69 | "expelled":true 70 | }, 71 | { 72 | "number":5, 73 | "expelled":true 74 | } 75 | ] 76 | } 77 | ], 78 | [ 79 | 3, 80 | "Normal", 81 | "LogInfoEntry", 82 | { 83 | "message":"Count: 3" 84 | } 85 | ] 86 | ] 87 | }, 88 | "jsonResult":3 89 | } 90 | -------------------------------------------------------------------------------- /app/students_invalid_step_result.json: -------------------------------------------------------------------------------- 1 | { 2 | "recording":{ 3 | "entries":[ 4 | [ 5 | 0, 6 | "Normal", 7 | "ConnectEntry", 8 | { 9 | "ceDBName":"test_db", 10 | "ceDBConfig":[ 11 | 12 | ] 13 | } 14 | ], 15 | [ 16 | 1, 17 | "Normal", 18 | "RunDBEntry", 19 | { 20 | "dbeDBName":"test_db", 21 | "dbeDescription":"SELECT * FROM students", 22 | "dbeJsonResult":[ 23 | { 24 | "number":4, 25 | "expelled":true 26 | }, 27 | { 28 | "number":5, 29 | "expelled":true 30 | }, 31 | { 32 | "number":1, 33 | "expelled":false 34 | }, 35 | { 36 | "number":2, 37 | "expelled":false 38 | }, 39 | { 40 | "number":3, 41 | "expelled":false 42 | } 43 | ] 44 | } 45 | ], 46 | [ 47 | 2, 48 | "Normal", 49 | "RunDBEntry", 50 | { 51 | "dbeDBName":"test_db", 52 | "dbeDescription":"SELECT * FROM students WHERE expelled = 1", 53 | "dbeJsonResult":[ 54 | { 55 | "number":4, 56 | "expelled":true 57 | }, 58 | { 59 | "number":5, 60 | "expelled":true 61 | } 62 | ] 63 | } 64 | ], 65 | [ 66 | 3, 67 | "Normal", 68 | "LogInfoEntry", 69 | { 70 | "message":"Count: 5555" 71 | } 72 | ] 73 | ] 74 | }, 75 | "jsonResult":3 76 | } 77 | -------------------------------------------------------------------------------- /app/students_missing_step.json: -------------------------------------------------------------------------------- 1 | { 2 | "recording":{ 3 | "entries":[ 4 | [ 5 | 0, 6 | "Normal", 7 | "ConnectEntry", 8 | { 9 | "ceDBName":"test_db", 10 | "ceDBConfig":[ 11 | 12 | ] 13 | } 14 | ], 15 | [ 16 | 1, 17 | "Normal", 18 | "RunDBEntry", 19 | { 20 | "dbeDBName":"test_db", 21 | "dbeDescription":"SELECT * FROM students", 22 | "dbeJsonResult":[ 23 | { 24 | "number":4, 25 | "expelled":true 26 | }, 27 | { 28 | "number":5, 29 | "expelled":true 30 | }, 31 | { 32 | "number":1, 33 | "expelled":false 34 | }, 35 | { 36 | "number":2, 37 | "expelled":false 38 | }, 39 | { 40 | "number":3, 41 | "expelled":false 42 | } 43 | ] 44 | } 45 | ], 46 | [ 47 | 2, 48 | "Normal", 49 | "RunDBEntry", 50 | { 51 | "dbeDBName":"test_db", 52 | "dbeDescription":"SELECT * FROM students WHERE expelled = 1", 53 | "dbeJsonResult":[ 54 | { 55 | "number":4, 56 | "expelled":true 57 | }, 58 | { 59 | "number":5, 60 | "expelled":true 61 | } 62 | ] 63 | } 64 | ] 65 | ] 66 | }, 67 | "jsonResult":3 68 | } 69 | -------------------------------------------------------------------------------- /app/test/Spec.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | import Control.Concurrent.MVar 7 | import Control.Monad (when, unless) 8 | import qualified Data.Map.Strict as Map 9 | import qualified Data.Vector as V 10 | import qualified Data.Text as T 11 | import qualified Data.ByteString.Lazy as BL 12 | import Data.Aeson (decode, encode, toJSON) 13 | import Data.UUID (toString) 14 | import Data.UUID.V4 (nextRandom) 15 | import Test.Hspec 16 | 17 | import Playback.Types 18 | import Runtime.Types 19 | import Language 20 | import Types 21 | import qualified Language as L 22 | import Runtime.Interpreter 23 | import Scenarios 24 | import qualified Expression.Flow as FlowExpr 25 | 26 | initRegularRT = do 27 | opts <- newMVar Map.empty 28 | pure $ Runtime 29 | { runMode = RegularMode 30 | , runtimeData = Left $ OperationalData opts 31 | } 32 | 33 | initRecorderRT mbMocks = do 34 | recMVar <- newMVar V.empty 35 | forkedRecMvar <- newMVar Map.empty 36 | opts <- newMVar Map.empty 37 | let recRt = RecorderRuntime 38 | { flowGUID = "testFlow" 39 | , recordingMVar = recMVar 40 | , forkedRecordingsVar = forkedRecMvar 41 | , disableEntries = [] 42 | } 43 | pure $ Runtime 44 | { runMode = RecordingMode recRt 45 | , runtimeData = case mbMocks of 46 | Nothing -> Left $ OperationalData opts 47 | Just mocks -> Right mocks 48 | } 49 | 50 | initPlayerRT recEntries = do 51 | opts <- newMVar Map.empty 52 | step <- newMVar 0 53 | errMVar <- newMVar Nothing 54 | ffEV <- newMVar Map.empty 55 | let pRt = PlayerRuntime 56 | { recording = recEntries 57 | , stepMVar = step 58 | , errorMVar = errMVar 59 | , disableVerify = [] 60 | , disableMocking = [] 61 | , skipEntries = [] 62 | , entriesFiltered = False 63 | , flowGUID = "MainFlow" 64 | , forkedFlowRecordings = Map.empty 65 | , forkedFlowErrorsVar = ffEV 66 | } 67 | pure $ Runtime 68 | { runMode = ReplayingMode pRt 69 | , runtimeData = Left $ OperationalData opts 70 | } 71 | 72 | getRecording :: Runtime -> IO RecordingEntries 73 | getRecording rt = case runMode rt of 74 | RecordingMode rrt -> readMVar $ recordingMVar rrt 75 | _ -> error "wrong mode." 76 | 77 | getErrors :: Runtime -> IO (Maybe PlaybackError) 78 | getErrors rt = case runMode rt of 79 | ReplayingMode prtm -> readMVar $ errorMVar prtm 80 | _ -> error "wrong mode." 81 | 82 | main :: IO () 83 | main = hspec $ do 84 | 85 | describe "Students count scenarios tests" $ do 86 | it "Interpreter with mocks" $ do 87 | 88 | mockedData <- MockedData 89 | <$> mkMocks @Int [] 90 | <*> mkMocks [ MockedConnection "test_db" ] 91 | <*> mkMocks [ [expelled1, expelled2, student1, student2, student3] 92 | , [expelled1, expelled2] ] 93 | 94 | let testRt = Runtime RegularMode (Right mockedData) 95 | 96 | res <- runFlow testRt $ getStudentsCountFlow "test_db" dbConfig 97 | res `shouldBe` 3 98 | 99 | -- it "Service Handle without mocks" $ do 100 | -- let handle = Handle DB.connect DB.query putStrLn 101 | -- result <- getStudentsCountSH handle "test_db" dbConfig 102 | -- result `shouldBe` 3 103 | 104 | it "Service Handle with mocks" $ do 105 | let allStudents = [student1, student2, student3, expelled1, expelled2] 106 | let expelledStudents = [expelled1, expelled2] 107 | let mockedConnect _ _ = pure $ MockedConn $ MockedConnection "test_db" 108 | let mockedQuery _ q 109 | | q == queryAll = pure allStudents 110 | | q == queryExpelled = pure expelledStudents 111 | let handle = Handle mockedConnect mockedQuery putStrLn 112 | result <- getStudentsCountSH handle "test_db" dbConfig 113 | result `shouldBe` 3 114 | 115 | it "Flow recordings with mocks" $ do 116 | mockedData <- MockedData 117 | <$> mkMocks @Int [] 118 | <*> mkMocks [ MockedConnection "test_db" ] 119 | <*> mkMocks [ [expelled1, expelled2, student1, student2, student3] 120 | , [expelled1, expelled2] ] 121 | 122 | rt <- initRecorderRT $ Just mockedData 123 | runFlow rt $ getStudentsCountFlow "test_db" dbConfig 124 | entries <- getRecording rt 125 | pRt <- initPlayerRT entries 126 | runFlow pRt $ getStudentsCountFlow "test_db" dbConfig 127 | errors <- getErrors pRt 128 | errors `shouldBe` Nothing 129 | 130 | 131 | describe "Compare GUID scenarios tests" $ do 132 | it "Flow scenario" $ do 133 | rt <- initRecorderRT Nothing 134 | runFlow rt $ compareGUIDs "test/guid.txt" 135 | case runMode rt of 136 | RecordingMode rrt -> do 137 | entries <- readMVar $ recordingMVar rrt 138 | length entries `shouldBe` 3 139 | 140 | pRt <- initPlayerRT entries 141 | runFlow pRt $ compareGUIDs "test/guid.txt" 142 | case runMode pRt of 143 | ReplayingMode prtm -> do 144 | errors <- readMVar $ errorMVar prtm 145 | errors `shouldBe` Nothing 146 | -- let jsonRec = encode $ Recording entries 147 | -- jsonRec `shouldBe` "{\"entries\":[[0,\"Normal\",\"GenerateGUIDEntry\",{\"guid\":\"3a93686e-9b1a-4f02-84fd-1354221b0a63\"}],[1,\"Normal\",\"RunIOEntry\",{\"jsonResult\":\"58ee4992-31f6-11ea-978f-2e728ce88125\\n\"}],[2,\"Normal\",\"LogInfoEntry\",{\"message\":\"GUIDs are not equal.\"}]]}" 148 | _ -> fail "wrong mode" 149 | _ -> fail "wrong mode" 150 | -------------------------------------------------------------------------------- /app/test/guid.txt: -------------------------------------------------------------------------------- 1 | 58ee4992-31f6-11ea-978f-2e728ce88125 2 | -------------------------------------------------------------------------------- /dist/cabal-config-flags: -------------------------------------------------------------------------------- 1 | --verbose=1--ghc--prefix=/home/gas/.cabal--user--extra-prog-path=/home/gas/.cabal/bin--with-ghc=ghc--solver=modular -------------------------------------------------------------------------------- /lib/flow.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 38c6bb53c25a22bd5281ed7ac121e3f94c72433f1f374a205edf83073311b649 8 | 9 | name: flow 10 | version: 0.1.0.0 11 | homepage: https://github.com/graninas/automatic-whitebox-testing-showcase#readme 12 | bug-reports: https://github.com/graninas/automatic-whitebox-testing-showcase/issues 13 | author: Alexander Granin 14 | maintainer: graninas@gmail.com 15 | copyright: 2019 Alexander Granin 16 | license: BSD3 17 | build-type: Simple 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/graninas/automatic-whitebox-testing-showcase 22 | 23 | library 24 | exposed-modules: 25 | DB.Native 26 | Language 27 | Playback.Entries 28 | Playback.Machine 29 | Playback.Types 30 | Runtime.Interpreter 31 | Runtime.Options 32 | Runtime.SystemCommands 33 | Runtime.Types 34 | Types 35 | other-modules: 36 | Paths_flow 37 | hs-source-dirs: 38 | flow 39 | build-depends: 40 | aeson 41 | , base >=4.7 && <5 42 | , bytestring 43 | , containers 44 | , free 45 | , process 46 | , text 47 | , uuid 48 | , vector 49 | default-language: Haskell2010 50 | 51 | test-suite flow-test 52 | type: exitcode-stdio-1.0 53 | main-is: Spec.hs 54 | other-modules: 55 | Paths_flow 56 | hs-source-dirs: 57 | test 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | build-depends: 60 | aeson 61 | , base >=4.7 && <5 62 | , bytestring 63 | , containers 64 | , flow 65 | , free 66 | , hspec 67 | , process 68 | , text 69 | , uuid 70 | , vector 71 | default-language: Haskell2010 72 | -------------------------------------------------------------------------------- /lib/flow/DB/Native.hs: -------------------------------------------------------------------------------- 1 | -- Fake "native DB library" module 2 | 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | 12 | module DB.Native 13 | ( NativeConnection (..) 14 | , DBConfig (..) 15 | , Query 16 | , connect 17 | , query 18 | ) where 19 | 20 | import Data.Aeson (FromJSON, ToJSON) 21 | import GHC.Generics (Generic) 22 | 23 | newtype NativeConnection = NativeConnection String 24 | 25 | data DBConfig = DBConfig 26 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 27 | 28 | type Query = String 29 | 30 | connect :: String -> DBConfig -> IO NativeConnection 31 | connect dbName _ = pure $ NativeConnection dbName 32 | 33 | query :: NativeConnection -> String -> IO a 34 | query _ _ = error "Just a demo, not implemented" 35 | -------------------------------------------------------------------------------- /lib/flow/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | 11 | module Language where 12 | 13 | import Control.Monad (unless, void, when) 14 | import Control.Monad.Free 15 | import Data.Aeson (FromJSON, ToJSON, decode, encode) 16 | import qualified Data.ByteString.Char8 as BS 17 | import qualified Data.ByteString.Lazy as BSL 18 | import qualified Data.IntMap as MArr 19 | import Data.Maybe (isJust) 20 | import Data.Monoid ((<>)) 21 | import Data.Proxy (Proxy (..)) 22 | import Data.Text (Text) 23 | import Data.UUID (toString) 24 | import Data.UUID.V4 (nextRandom) 25 | import Data.Typeable 26 | import GHC.Generics (Generic) 27 | 28 | import Types 29 | import Runtime.Options 30 | 31 | data DatabaseF next where 32 | Query :: String -> (a -> next) -> DatabaseF next 33 | 34 | instance Functor DatabaseF where 35 | fmap f (Query q next) = Query q (f . next) 36 | 37 | type Database a = Free DatabaseF a 38 | 39 | query' :: String -> Database a 40 | query' q = liftF $ Query q id 41 | 42 | 43 | data FlowF next where 44 | GenerateGUID :: (String -> next) -> FlowF next 45 | RunIO :: (ToJSON s, FromJSON s) => IO s -> (s -> next) -> FlowF next 46 | LogInfo :: String -> (() -> next) -> FlowF next 47 | Fork :: String -> String -> Flow s -> (() -> next) -> FlowF next 48 | RunSysCmd :: String -> (String -> next) -> FlowF next 49 | GetOption :: OptionEntity k v => k -> (Maybe v -> next) -> FlowF next 50 | SetOption :: OptionEntity k v => k -> v -> (() -> next) -> FlowF next 51 | 52 | Connect :: DBName -> DBConfig -> (DBConnection -> next) -> FlowF next 53 | RunDB :: (ToJSON s, FromJSON s, Typeable s) 54 | => DBConnection -> String -> Database s 55 | -> (s -> next) -> FlowF next 56 | 57 | 58 | instance Functor FlowF where 59 | fmap f (GenerateGUID next) = GenerateGUID (f . next) 60 | fmap f (RunIO ioAct next) = RunIO ioAct (f . next) 61 | fmap f (LogInfo msg next) = LogInfo msg (f . next) 62 | fmap f (Fork desc guid ioAct next) = Fork desc guid ioAct (f.next) 63 | fmap f (RunSysCmd cmd next) = RunSysCmd cmd (f.next) 64 | fmap f (GetOption k next) = GetOption k (f.next) 65 | fmap f (SetOption k v next) = SetOption k v (f.next) 66 | 67 | fmap f (Connect dbName dbConfig next) = Connect dbName dbConfig (f . next) 68 | fmap f (RunDB conn qInfo db next) = RunDB conn qInfo db (f . next) 69 | 70 | type Flow a = Free FlowF a 71 | 72 | generateGUID :: Flow String 73 | generateGUID = liftF $ GenerateGUID id 74 | 75 | runIO :: (ToJSON s, FromJSON s) => IO s -> Flow s 76 | runIO ioAct = liftF $ RunIO ioAct id 77 | 78 | logInfo :: String -> Flow () 79 | logInfo msg = liftF $ LogInfo msg id 80 | 81 | forkFlow :: (ToJSON s, FromJSON s) => String -> Flow s -> Flow () 82 | forkFlow description flow = do 83 | flowGUID <- generateGUID 84 | unless (null description) $ logInfo $ "Flow forked. Description: " <> description <> " GUID: " <> flowGUID 85 | when (null description) $ logInfo $ "Flow forked. GUID: " <> flowGUID 86 | void $ liftF $ Fork description flowGUID flow id 87 | 88 | runSysCmd :: String -> Flow String 89 | runSysCmd cmd = liftF $ RunSysCmd cmd id 90 | 91 | getOption :: OptionEntity k v => k -> Flow (Maybe v) 92 | getOption k = liftF $ GetOption k id 93 | 94 | setOption :: OptionEntity k v => k -> v -> Flow () 95 | setOption k v = liftF $ SetOption k v id 96 | 97 | connect :: DBName -> DBConfig -> Flow DBConnection 98 | connect dbName dbCfg = liftF $ Connect dbName dbCfg id 99 | 100 | runDB 101 | :: (ToJSON s, FromJSON s, Typeable s) 102 | => DBConnection 103 | -> String 104 | -> Database s 105 | -> Flow s 106 | runDB conn qInfo db = liftF $ RunDB conn qInfo db id 107 | 108 | query :: (ToJSON s, FromJSON s, Typeable s) => DBConnection -> String -> Flow s 109 | query conn q = runDB conn q $ query' q 110 | -------------------------------------------------------------------------------- /lib/flow/Playback/Entries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | {-# LANGUAGE DuplicateRecordFields #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | 11 | module Playback.Entries where 12 | 13 | import Control.Monad (unless, void, when) 14 | import Control.Monad.Free 15 | import Data.Aeson (FromJSON, ToJSON, Value, decode, encode, toJSON, parseJSON) 16 | import qualified Data.ByteString.Char8 as BS 17 | import qualified Data.ByteString.Lazy as BSL 18 | import qualified Data.IntMap as MArr 19 | import Data.Maybe (isJust) 20 | import Data.Proxy (Proxy (..)) 21 | import Data.Text (Text) 22 | import Data.UUID (toString) 23 | import Data.UUID.V4 (nextRandom) 24 | import GHC.Generics (Generic) 25 | 26 | import Playback.Types 27 | import Types 28 | import Runtime.Options 29 | 30 | data SetOptionEntry = SetOptionEntry 31 | { key :: Value 32 | , value :: Value 33 | } 34 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 35 | 36 | mkSetOptionEntry :: OptionEntity k v => k -> v -> () -> SetOptionEntry 37 | mkSetOptionEntry k v _ = SetOptionEntry (encodeToValue k) (encodeToValue v) 38 | 39 | data GetOptionEntry = GetOptionEntry 40 | { key :: Value 41 | , value :: Value 42 | } 43 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 44 | 45 | mkGetOptionEntry :: OptionEntity k v => k -> Maybe v -> GetOptionEntry 46 | mkGetOptionEntry k mv = GetOptionEntry (encodeToValue k) (encodeToValue mv) 47 | 48 | data RunSysCmdEntry = RunSysCmdEntry 49 | { cmd :: String 50 | , result :: String 51 | } 52 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 53 | 54 | mkRunSysCmdEntry :: String -> String -> RunSysCmdEntry 55 | mkRunSysCmdEntry cmd result = RunSysCmdEntry cmd result 56 | 57 | data ForkFlowEntry = ForkFlowEntry 58 | { description :: String 59 | , guid :: String 60 | } 61 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 62 | 63 | mkForkFlowEntry :: String -> String -> () -> ForkFlowEntry 64 | mkForkFlowEntry desc guid _ = ForkFlowEntry desc guid 65 | 66 | data GenerateGUIDEntry = GenerateGUIDEntry 67 | { guid :: String 68 | } 69 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 70 | 71 | mkGenerateGUIDEntry :: String -> GenerateGUIDEntry 72 | mkGenerateGUIDEntry = GenerateGUIDEntry 73 | 74 | data RunIOEntry = RunIOEntry 75 | { jsonResult :: Value 76 | } 77 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 78 | 79 | mkRunIOEntry :: ToJSON a => a -> RunIOEntry 80 | mkRunIOEntry = RunIOEntry . encodeToValue 81 | 82 | data LogInfoEntry = LogInfoEntry 83 | { message :: String 84 | } 85 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 86 | 87 | mkLogInfoEntry :: String -> () -> LogInfoEntry 88 | mkLogInfoEntry msg _ = LogInfoEntry msg 89 | 90 | data ConnectEntry = ConnectEntry 91 | { ceDBConfig :: DBConfig 92 | , ceDBName :: String 93 | } 94 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 95 | 96 | mkConnectEntry :: String -> DBConfig -> DBConnection -> ConnectEntry 97 | mkConnectEntry dbName dbCfg _ = ConnectEntry dbCfg dbName 98 | 99 | data RunDBEntry = RunDBEntry 100 | { dbeDBName :: String 101 | , dbeDescription :: String 102 | , dbeJsonResult :: Value 103 | } 104 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 105 | 106 | mkRunDBEntry 107 | :: ToJSON a 108 | => DBConnection 109 | -> String 110 | -> a 111 | -> RunDBEntry 112 | mkRunDBEntry (NativeConn dbName _) qInfo dbRes 113 | = RunDBEntry dbName qInfo $ encodeToValue dbRes 114 | mkRunDBEntry (MockedConn (MockedConnection dbName)) qInfo dbRes 115 | = RunDBEntry dbName qInfo $ encodeToValue dbRes 116 | 117 | instance RRItem GetOptionEntry where 118 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "GetOptionEntry" $ encodeToValue rrItem 119 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 120 | getTag _ = "GetOptionEntry" 121 | 122 | instance FromJSON v => MockedResult GetOptionEntry v where 123 | getMock GetOptionEntry{..} = decodeFromValue value 124 | 125 | instance RRItem SetOptionEntry where 126 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "SetOptionEntry" $ encodeToValue rrItem 127 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 128 | getTag _ = "SetOptionEntry" 129 | 130 | instance MockedResult SetOptionEntry () where 131 | getMock _ = Just () 132 | 133 | instance RRItem RunSysCmdEntry where 134 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "RunSysCmdEntry" $ encodeToValue rrItem 135 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 136 | getTag _ = "RunSysCmdEntry" 137 | 138 | instance MockedResult RunSysCmdEntry String where 139 | getMock RunSysCmdEntry {..} = Just result 140 | 141 | instance RRItem ForkFlowEntry where 142 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "ForkFlowEntry" $ encodeToValue rrItem 143 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 144 | getTag _ = "ForkFlowEntry" 145 | 146 | instance MockedResult ForkFlowEntry () where 147 | getMock _ = Just () 148 | 149 | instance RRItem GenerateGUIDEntry where 150 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "GenerateGUIDEntry" $ encodeToValue rrItem 151 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 152 | getTag _ = "GenerateGUIDEntry" 153 | 154 | instance MockedResult GenerateGUIDEntry String where 155 | getMock (GenerateGUIDEntry g) = Just g 156 | 157 | instance RRItem RunIOEntry where 158 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "RunIOEntry" $ encodeToValue rrItem 159 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 160 | getTag _ = "RunIOEntry" 161 | 162 | instance FromJSON a => MockedResult RunIOEntry a where 163 | getMock (RunIOEntry r) = decodeFromValue r 164 | 165 | instance RRItem LogInfoEntry where 166 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "LogInfoEntry" $ encodeToValue rrItem 167 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 168 | getTag _ = "LogInfoEntry" 169 | 170 | instance MockedResult LogInfoEntry () where 171 | getMock _ = Just () 172 | 173 | instance RRItem ConnectEntry where 174 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "ConnectEntry" $ encodeToValue rrItem 175 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 176 | getTag _ = "ConnectEntry" 177 | 178 | instance MockedResult ConnectEntry DBConnection where 179 | getMock (ConnectEntry _ dbName) = Just $ MockedConn $ MockedConnection dbName 180 | 181 | instance RRItem RunDBEntry where 182 | toRecordingEntry rrItem idx mode = RecordingEntry idx mode "RunDBEntry" $ encodeToValue rrItem 183 | fromRecordingEntry (RecordingEntry _ _ _ payload) = decodeFromValue payload 184 | getTag _ = "RunDBEntry" 185 | 186 | instance FromJSON a => MockedResult RunDBEntry a where 187 | getMock (RunDBEntry _ _ r) = decodeFromValue r 188 | -------------------------------------------------------------------------------- /lib/flow/Playback/Machine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | 12 | module Playback.Machine where 13 | 14 | import Control.Concurrent.MVar (MVar, takeMVar, putMVar 15 | , isEmptyMVar, swapMVar, readMVar) 16 | import Control.Exception (throwIO) 17 | import Control.Monad (unless, when, void) 18 | import Control.Monad.Free 19 | import qualified Data.ByteString.Char8 as BS 20 | import qualified Data.ByteString.Lazy as BSL 21 | import Data.UUID (toString) 22 | import Data.Maybe (isJust, fromMaybe) 23 | import qualified Data.Vector as V 24 | import Data.Vector ((!?)) 25 | import Data.UUID.V4 (nextRandom) 26 | import Data.Aeson (ToJSON, FromJSON, encode, decode) 27 | import Data.Proxy (Proxy(..)) 28 | import Data.Text (Text) 29 | import GHC.Generics (Generic) 30 | 31 | import Playback.Types 32 | 33 | 34 | showInfo :: String -> String -> String 35 | showInfo flowStep recordingEntry = 36 | "\n Flow step: " ++ flowStep 37 | ++ "\n Recording entry: " ++ recordingEntry 38 | 39 | unexpectedRecordingEnd :: String -> PlaybackError 40 | unexpectedRecordingEnd flowStep 41 | = PlaybackError UnexpectedRecordingEnd 42 | $ "\n Flow step: " ++ flowStep 43 | 44 | unknownRRItem :: String -> String -> PlaybackError 45 | unknownRRItem flowStep recordingEntry 46 | = PlaybackError UnknownRRItem 47 | $ showInfo flowStep recordingEntry 48 | 49 | mockDecodingFailed :: String -> String -> PlaybackError 50 | mockDecodingFailed flowStep recordingEntry 51 | = PlaybackError MockDecodingFailed 52 | $ showInfo flowStep recordingEntry 53 | 54 | itemMismatch :: String -> String -> PlaybackError 55 | itemMismatch flowStep recordingEntry 56 | = PlaybackError ItemMismatch 57 | $ showInfo flowStep recordingEntry 58 | 59 | setReplayingError :: PlayerRuntime -> PlaybackError -> IO a 60 | setReplayingError playerRt err = do 61 | void $ takeMVar $ errorMVar playerRt 62 | putMVar (errorMVar playerRt) (Just err) 63 | throwIO $ ReplayingException err 64 | 65 | pushRecordingEntry 66 | :: RecorderRuntime 67 | -> RecordingEntry 68 | -> IO () 69 | pushRecordingEntry recorderRt (RecordingEntry _ mode n p) = do 70 | entries <- takeMVar $ recordingMVar recorderRt 71 | let idx = (V.length entries) 72 | let re = RecordingEntry idx mode n p 73 | putMVar (recordingMVar recorderRt) $ V.snoc entries re 74 | 75 | popNextRecordingEntry :: PlayerRuntime -> IO (Maybe RecordingEntry) 76 | popNextRecordingEntry PlayerRuntime{..} = do 77 | cur <- takeMVar stepMVar 78 | let mbItem = (!?) recording cur 79 | when (isJust mbItem) $ putMVar stepMVar (cur + 1) 80 | pure mbItem 81 | 82 | popNextRRItem 83 | :: forall rrItem native 84 | . RRItem rrItem 85 | => PlayerRuntime 86 | -> IO (Either PlaybackError (RecordingEntry, rrItem)) 87 | popNextRRItem playerRt = do 88 | mbRecordingEntry <- popNextRecordingEntry playerRt 89 | let flowStep = getTag $ Proxy @rrItem 90 | pure $ do 91 | recordingEntry <- note (unexpectedRecordingEnd flowStep) mbRecordingEntry 92 | let unknownErr = unknownRRItem flowStep $ show recordingEntry 93 | rrItem <- note unknownErr $ fromRecordingEntry recordingEntry 94 | pure (recordingEntry, rrItem) 95 | 96 | popNextRRItemAndResult 97 | :: forall rrItem native 98 | . RRItem rrItem 99 | => MockedResult rrItem native 100 | => PlayerRuntime 101 | -> IO (Either PlaybackError (RecordingEntry, rrItem, native)) 102 | popNextRRItemAndResult playerRt = do 103 | let flowStep = getTag $ Proxy @rrItem 104 | eNextRRItem <- popNextRRItem playerRt 105 | pure $ do 106 | (recordingEntry, rrItem) <- eNextRRItem 107 | let mbNative = getMock rrItem 108 | nextResult <- note (mockDecodingFailed flowStep (show recordingEntry)) mbNative 109 | pure (recordingEntry, rrItem, nextResult) 110 | 111 | compareRRItems 112 | :: RRItem rrItem 113 | => MockedResult rrItem native 114 | => PlayerRuntime 115 | -> (RecordingEntry, rrItem, native) 116 | -> rrItem 117 | -> IO () 118 | compareRRItems playerRt (recordingEntry, rrItem, mockedResult) flowRRItem = do 119 | when (rrItem /= flowRRItem) $ do 120 | let flowStep = encodeToStr flowRRItem 121 | setReplayingError playerRt $ itemMismatch flowStep (show recordingEntry) 122 | 123 | getCurrentEntryReplayMode :: PlayerRuntime -> IO EntryReplayingMode 124 | getCurrentEntryReplayMode PlayerRuntime{..} = do 125 | cur <- readMVar stepMVar 126 | pure $ fromMaybe Normal $ do 127 | (RecordingEntry _ mode _ _) <- (!?) recording cur 128 | pure mode 129 | 130 | replayWithGlobalConfig 131 | :: forall rrItem native 132 | . RRItem rrItem 133 | => MockedResult rrItem native 134 | => PlayerRuntime 135 | -> IO native 136 | -> (native -> rrItem) 137 | -> Either PlaybackError (RecordingEntry, rrItem, native) 138 | -> IO native 139 | replayWithGlobalConfig playerRt ioAct mkRRItem eNextRRItemRes = do 140 | let tag = getTag $ Proxy @rrItem 141 | let config = checkForReplayConfig playerRt tag 142 | case config of 143 | GlobalNoVerify -> case eNextRRItemRes of 144 | Left err -> setReplayingError playerRt err 145 | Right stepInfo@(_, _, r) -> pure r 146 | GlobalNormal -> case eNextRRItemRes of 147 | Left err -> setReplayingError playerRt err 148 | Right stepInfo@(_, _, r) -> do 149 | compareRRItems playerRt stepInfo $ mkRRItem r 150 | pure r 151 | GlobalNoMocking -> ioAct 152 | GlobalSkip -> ioAct 153 | 154 | checkForReplayConfig :: PlayerRuntime -> String -> GlobalReplayingMode 155 | checkForReplayConfig PlayerRuntime{..} tag | tag `elem` disableMocking = GlobalNoMocking 156 | | tag `elem` disableVerify = GlobalNoVerify 157 | | otherwise = GlobalNormal 158 | 159 | replay 160 | :: forall rrItem native 161 | . RRItem rrItem 162 | => MockedResult rrItem native 163 | => PlayerRuntime 164 | -> (native -> rrItem) 165 | -> IO native 166 | -> IO native 167 | replay playerRt@PlayerRuntime{..} mkRRItem ioAct 168 | | getTag (Proxy @rrItem) `elem` skipEntries = ioAct 169 | | otherwise = do 170 | entryReplayMode <- getCurrentEntryReplayMode playerRt 171 | eNextRRItemRes <- popNextRRItemAndResult playerRt 172 | case entryReplayMode of 173 | Normal -> replayWithGlobalConfig playerRt ioAct mkRRItem eNextRRItemRes 174 | NoVerify -> case eNextRRItemRes of 175 | Left err -> setReplayingError playerRt err 176 | Right stepInfo@(_, _, r) -> pure r 177 | NoMock -> ioAct 178 | 179 | 180 | 181 | record 182 | ::forall rrItem native 183 | . RRItem rrItem 184 | => RecorderRuntime 185 | -> (native -> rrItem) 186 | -> IO native 187 | -> IO native 188 | record recorderRt@RecorderRuntime{..} mkRRItem ioAct = do 189 | native <- ioAct 190 | let tag = getTag $ Proxy @rrItem 191 | when (tag `notElem` disableEntries) 192 | $ pushRecordingEntry recorderRt $ toRecordingEntry (mkRRItem native) 0 Normal 193 | pure native 194 | -------------------------------------------------------------------------------- /lib/flow/Playback/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | 11 | module Playback.Types where 12 | 13 | import Control.Concurrent.MVar (MVar) 14 | import Control.Exception (Exception) 15 | import Control.Monad (unless, when, void) 16 | import Control.Monad.Free 17 | import Data.Vector 18 | import qualified Data.ByteString.Char8 as BS 19 | import qualified Data.ByteString.Lazy as BSL 20 | import Data.UUID (toString) 21 | import Data.Maybe (isJust) 22 | import Data.Map.Strict (Map) 23 | import qualified Data.Map.Strict as Map 24 | import qualified Data.IntMap as MArr 25 | import Data.UUID.V4 (nextRandom) 26 | import Data.Aeson (ToJSON, FromJSON, Value, Result(..), encode, decode, toJSON, fromJSON, parseJSON) 27 | import Data.Proxy (Proxy(..)) 28 | import Data.Text (Text) 29 | import GHC.Generics (Generic) 30 | 31 | type EntryIndex = Int 32 | type EntryName = String 33 | type EntryPayload = Value 34 | data RecordingEntry = RecordingEntry EntryIndex EntryReplayingMode EntryName EntryPayload 35 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 36 | 37 | type RecordingEntries = Vector RecordingEntry 38 | newtype Recording = Recording 39 | { entries :: RecordingEntries 40 | } 41 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 42 | 43 | data GlobalReplayingMode = GlobalNormal | GlobalNoVerify | GlobalNoMocking | GlobalSkip 44 | 45 | data EntryReplayingMode = Normal | NoVerify | NoMock 46 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 47 | 48 | class (Eq rrItem, ToJSON rrItem, FromJSON rrItem) 49 | => RRItem rrItem where 50 | toRecordingEntry :: rrItem -> Int -> EntryReplayingMode -> RecordingEntry 51 | fromRecordingEntry :: RecordingEntry -> Maybe rrItem 52 | getTag :: Proxy rrItem -> String 53 | 54 | class RRItem rrItem => MockedResult rrItem native where 55 | getMock :: rrItem -> Maybe native 56 | 57 | 58 | data PlaybackErrorType 59 | = UnexpectedRecordingEnd 60 | | UnknownRRItem 61 | | MockDecodingFailed 62 | | ItemMismatch 63 | | UnknownPlaybackError 64 | | ForkedFlowRecordingsMissed 65 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 66 | 67 | data PlaybackError = PlaybackError 68 | { errorType :: PlaybackErrorType 69 | , errorMessage :: String 70 | } 71 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 72 | 73 | data ReplayingException = ReplayingException PlaybackError 74 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 75 | instance Exception ReplayingException 76 | 77 | data RecorderRuntime = RecorderRuntime 78 | { flowGUID :: String 79 | , recordingMVar :: MVar RecordingEntries 80 | , forkedRecordingsVar :: MVar ( Map String (MVar RecordingEntries)) 81 | , disableEntries :: [String] 82 | } 83 | 84 | data PlayerRuntime = PlayerRuntime 85 | { recording :: RecordingEntries 86 | , stepMVar :: MVar Int 87 | , errorMVar :: MVar (Maybe PlaybackError) 88 | , disableVerify :: [String] 89 | , disableMocking :: [String] 90 | , skipEntries :: [String] 91 | , entriesFiltered :: Bool 92 | , flowGUID :: String 93 | , forkedFlowRecordings :: Map String RecordingEntries 94 | , forkedFlowErrorsVar :: MVar (Map String (Maybe PlaybackError)) 95 | } 96 | 97 | 98 | encodeToStr :: ToJSON a => a -> String 99 | encodeToStr = BS.unpack . BSL.toStrict . encode 100 | 101 | decodeFromStr :: FromJSON a => String -> Maybe a 102 | decodeFromStr = decode . BSL.fromStrict . BS.pack 103 | 104 | encodeToValue :: ToJSON a => a -> Value 105 | encodeToValue = toJSON 106 | 107 | decodeFromValue :: FromJSON a => Value -> Maybe a 108 | decodeFromValue val = case fromJSON val of 109 | Error _ -> Nothing -- TODO 110 | Success a -> Just a 111 | 112 | 113 | 114 | note :: forall a b. a -> Maybe b -> Either a b 115 | note a Nothing = Left a 116 | note _ (Just b) = Right b 117 | -------------------------------------------------------------------------------- /lib/flow/Runtime/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE NamedFieldPuns #-} 11 | {-# LANGUAGE DuplicateRecordFields #-} 12 | 13 | module Runtime.Interpreter where 14 | 15 | import Control.Concurrent (forkIO) 16 | import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, takeMVar 17 | , putMVar, readMVar) 18 | import Control.Monad (unless, void, when) 19 | import Control.Monad.Free 20 | import Data.Aeson (FromJSON, ToJSON, Value, Result(..), decode, encode, fromJSON) 21 | import qualified Data.ByteString.Char8 as BS 22 | import qualified Data.ByteString.Lazy as BSL 23 | import qualified Data.IntMap as MArr 24 | import Data.Monoid ((<>)) 25 | import qualified Data.Map.Strict as Map 26 | import Data.UUID (toString) 27 | import Data.UUID.V4 (nextRandom) 28 | import qualified Data.Vector as V 29 | import GHC.Generics (Generic) 30 | import Data.Typeable 31 | 32 | import qualified DB.Native as DB 33 | import Language 34 | import Playback.Entries 35 | import Playback.Machine 36 | import Playback.Types 37 | import Runtime.SystemCommands 38 | import Runtime.Types 39 | import Types 40 | 41 | forkF :: Runtime -> Flow a -> IO () 42 | forkF rt flow = void $ forkIO $ void $ runFlow rt flow 43 | 44 | forkPlayerRt :: String -> PlayerRuntime -> IO (Maybe PlayerRuntime) 45 | forkPlayerRt newFlowGUID PlayerRuntime {..} = 46 | case Map.lookup newFlowGUID forkedFlowRecordings of 47 | Nothing -> do 48 | let missedRecsErr = Just $ PlaybackError 49 | { errorType = ForkedFlowRecordingsMissed 50 | , errorMessage = "No recordings found for forked flow: " <> newFlowGUID 51 | } 52 | forkedFlowErrors <- takeMVar forkedFlowErrorsVar 53 | let forkedFlowErrors' = Map.insert newFlowGUID missedRecsErr forkedFlowErrors 54 | putMVar forkedFlowErrorsVar forkedFlowErrors' 55 | pure Nothing 56 | Just recording' -> do 57 | stepVar' <- newMVar 0 58 | errorVar' <- newEmptyMVar 59 | pure $ Just PlayerRuntime 60 | { flowGUID = newFlowGUID 61 | , stepMVar = stepVar' 62 | , errorMVar = errorVar' 63 | , recording = recording' 64 | , .. 65 | } 66 | 67 | forkRecorderRt :: String -> RecorderRuntime -> IO RecorderRuntime 68 | forkRecorderRt newFlowGUID RecorderRuntime {..} = do 69 | recordingVar <- newMVar V.empty 70 | forkedRecs <- takeMVar forkedRecordingsVar 71 | let forkedRecs' = Map.insert newFlowGUID recordingVar forkedRecs 72 | putMVar forkedRecordingsVar forkedRecs' 73 | pure RecorderRuntime 74 | { flowGUID = newFlowGUID 75 | , recordingMVar = recordingVar 76 | , .. 77 | } 78 | 79 | forkBackendRuntime flowGUID Runtime {..} = do 80 | mbForkedMode <- case runMode of 81 | RegularMode -> pure $ Just RegularMode 82 | RecordingMode recorderRt -> Just . RecordingMode <$> forkRecorderRt flowGUID recorderRt 83 | ReplayingMode playerRt -> do 84 | mbRt <- forkPlayerRt flowGUID playerRt 85 | pure $ ReplayingMode <$> mbRt 86 | 87 | case mbForkedMode of 88 | Nothing -> pure Nothing 89 | Just forkedMode -> pure $ Just $ Runtime 90 | { runMode = forkedMode 91 | , .. 92 | } 93 | 94 | -- Entry point into the recording replaying mechanism 95 | withRunMode 96 | :: RRItem rrItem 97 | => MockedResult rrItem native 98 | => RunMode 99 | -> (native -> rrItem) 100 | -> IO native 101 | -> IO native 102 | 103 | withRunMode RegularMode _ act = act 104 | 105 | withRunMode (RecordingMode recorderRt) mkRRItem act 106 | = record recorderRt mkRRItem act 107 | 108 | withRunMode (ReplayingMode playerRt) mkRRItem act 109 | = replay playerRt mkRRItem act 110 | 111 | -------------------------------------------------------------------------------- 112 | -- DB interpreter 113 | interpretDatabaseF :: DB.NativeConnection -> DatabaseF a -> IO a 114 | 115 | interpretDatabaseF nativeConn (Query q next) = 116 | next <$> DB.query nativeConn q 117 | 118 | runDatabase :: DB.NativeConnection -> Database a -> IO a 119 | runDatabase nativeConn = foldFree (interpretDatabaseF nativeConn) 120 | 121 | -------------------------------------------------------------------------------- 122 | -- Flow interpreter 123 | mkMocks :: (ToJSON a, FromJSON a) => [a] -> IO (MVar [BSL.ByteString]) 124 | mkMocks as = newMVar $ fmap encode as 125 | 126 | getNextMock 127 | :: forall a. (ToJSON a, FromJSON a, Typeable a) 128 | => Proxy a -> MVar [BSL.ByteString] -> String -> IO a 129 | getNextMock p mvar method = do 130 | mocks <- takeMVar mvar 131 | case mocks of 132 | [] -> do 133 | putMVar mvar [] 134 | error $ "Mocks are exausted for " ++ method 135 | (m:ms) -> do 136 | putMVar mvar ms 137 | case decode m of 138 | Just r -> pure r 139 | Nothing -> error $ "Failed to decode mock for " ++ method 140 | 141 | getNextRunIOMock :: forall a. (ToJSON a, FromJSON a, Typeable a) => MockedData -> IO a 142 | getNextRunIOMock rt = getNextMock (Proxy :: Proxy a) (runIOMocks rt) "RunIO" 143 | 144 | getNextConnectMock :: MockedData -> IO DBConnection 145 | getNextConnectMock rt = MockedConn <$> getNextMock (Proxy :: Proxy MockedConnection) (connectMocks rt) "Connect" 146 | 147 | getNextRunDBMock :: forall a. (ToJSON a, FromJSON a, Typeable a) => MockedData -> IO a 148 | getNextRunDBMock rt = getNextMock (Proxy :: Proxy a) (runDBMocks rt) "RunDB" 149 | 150 | 151 | 152 | withRuntimeData (Left l) (lAct, rAct) = lAct l 153 | withRuntimeData (Right r) (lAct, rAct) = rAct r 154 | 155 | interpretFlowF :: Runtime -> FlowF a -> IO a 156 | 157 | interpretFlowF Runtime {..} (GetOption k next) = 158 | next <$> 159 | ( withRunMode runMode (mkGetOptionEntry k) 160 | $ withRuntimeData runtimeData (maybeValue, \_ -> error "GetOpt mock not implemented") ) 161 | where 162 | maybeValue (OperationalData {..}) = do 163 | m <- readMVar options 164 | pure $ decodeFromStr =<< Map.lookup (encodeToStr k) m 165 | 166 | interpretFlowF Runtime {..} (SetOption k v next) = 167 | next <$> 168 | ( withRunMode runMode (mkSetOptionEntry k v) 169 | $ withRuntimeData runtimeData (set, \_ -> pure ())) 170 | where 171 | set (OperationalData {..}) = do 172 | m <- takeMVar options 173 | let newMap = Map.insert (encodeToStr k) (encodeToStr v) m 174 | putMVar options newMap 175 | 176 | interpretFlowF Runtime {..} (RunSysCmd cmd next) = 177 | next <$> 178 | ( withRunMode runMode (mkRunSysCmdEntry cmd) 179 | $ withRuntimeData runtimeData (\_ -> runCmd cmd, \_ -> error "RunSysCmd mock not implemented")) 180 | 181 | -- TODO: mock 182 | interpretFlowF rt (Fork desc flowGUID flow next) = do 183 | mbForkedRt <- forkBackendRuntime flowGUID rt 184 | void $ withRunMode (runMode rt) (mkForkFlowEntry desc flowGUID) 185 | (case mbForkedRt of 186 | Nothing -> putStrLn (flowGUID <> " Failed to fork flow.") *> pure () 187 | Just forkedBrt -> forkF forkedBrt flow *> pure ()) 188 | pure $ next () 189 | 190 | interpretFlowF Runtime {..} (GenerateGUID next) = 191 | next <$> 192 | ( withRunMode runMode mkGenerateGUIDEntry 193 | $ withRuntimeData runtimeData (\_ -> toString <$> nextRandom, \_ -> error "GenerateGUID mock not implemented")) 194 | 195 | interpretFlowF Runtime {..} (RunIO ioAct next) = 196 | next <$> 197 | ( withRunMode runMode mkRunIOEntry 198 | $ withRuntimeData runtimeData (\_ -> ioAct, \_ -> error "RunIO mock not implemented")) 199 | 200 | interpretFlowF Runtime {..} (LogInfo msg next) = 201 | next <$> 202 | ( withRunMode runMode (mkLogInfoEntry msg) 203 | $ withRuntimeData runtimeData (\_ -> putStrLn msg, \_ -> pure ())) 204 | 205 | interpretFlowF Runtime {..} (Connect dbName dbConfig next) = do 206 | let act = NativeConn dbName <$> DB.connect dbName dbConfig 207 | next <$> 208 | ( withRunMode runMode (mkConnectEntry dbName dbConfig) 209 | $ withRuntimeData runtimeData (\_ -> act, getNextConnectMock)) 210 | 211 | interpretFlowF Runtime {..} (RunDB conn qInfo db next) = do 212 | let act = case conn of 213 | NativeConn _ nativeConn -> runDatabase nativeConn db 214 | MockedConn (MockedConnection dbName) -> error $ "MockedConn should not be evaluated: " ++ dbName 215 | next <$> 216 | ( withRunMode runMode (mkRunDBEntry conn qInfo) 217 | $ withRuntimeData runtimeData (\_ -> act, getNextRunDBMock)) 218 | 219 | runFlow :: Runtime -> Flow a -> IO a 220 | runFlow rt = foldFree (interpretFlowF rt) 221 | -------------------------------------------------------------------------------- /lib/flow/Runtime/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | 3 | 4 | module Runtime.Options where 5 | 6 | import Data.Aeson (ToJSON, FromJSON) 7 | 8 | class (FromJSON k, FromJSON v, ToJSON k, ToJSON v) => OptionEntity k v | k -> v -------------------------------------------------------------------------------- /lib/flow/Runtime/SystemCommands.hs: -------------------------------------------------------------------------------- 1 | module Runtime.SystemCommands 2 | (runCmd) 3 | where 4 | 5 | import System.Process (shell, readCreateProcess) 6 | 7 | runCmd cmd = readCreateProcess (shell cmd) "" -------------------------------------------------------------------------------- /lib/flow/Runtime/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE BangPatterns #-} 10 | 11 | module Runtime.Types where 12 | 13 | import Control.Concurrent.MVar (MVar) 14 | import Data.ByteString.Lazy (ByteString) 15 | import Data.Map.Strict (Map) 16 | import Data.Aeson (ToJSON, FromJSON, Value) 17 | import GHC.Generics (Generic) 18 | 19 | import Playback.Types 20 | 21 | data OperationalData = OperationalData 22 | { options :: MVar (Map String String) 23 | } 24 | 25 | data MockedData = MockedData 26 | { runIOMocks :: MVar [ByteString] 27 | , connectMocks :: MVar [ByteString] 28 | , runDBMocks :: MVar [ByteString] 29 | } 30 | 31 | data Runtime = Runtime 32 | { runMode :: RunMode 33 | , runtimeData :: Either OperationalData MockedData 34 | } 35 | 36 | data RunMode 37 | = RegularMode 38 | | RecordingMode RecorderRuntime 39 | | ReplayingMode PlayerRuntime 40 | -------------------------------------------------------------------------------- /lib/flow/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE DeriveDataTypeable #-} 10 | 11 | module Types 12 | ( module Types 13 | , module X 14 | ) where 15 | 16 | import Data.Aeson (FromJSON, ToJSON) 17 | import Data.Typeable (Typeable) 18 | import GHC.Generics (Generic) 19 | import DB.Native (NativeConnection) 20 | 21 | import DB.Native as X (DBConfig(..), Query) 22 | 23 | type DBName = String 24 | 25 | data MockedConnection = MockedConnection DBName 26 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, Typeable) 27 | 28 | data DBConnection 29 | = NativeConn DBName NativeConnection 30 | | MockedConn MockedConnection 31 | -------------------------------------------------------------------------------- /lib/package.yaml: -------------------------------------------------------------------------------- 1 | name: flow 2 | version: 0.1.0.0 3 | github: "graninas/automatic-whitebox-testing-showcase" 4 | license: BSD3 5 | author: "Alexander Granin" 6 | maintainer: "graninas@gmail.com" 7 | copyright: "2019 Alexander Granin" 8 | 9 | dependencies: 10 | - base >= 4.7 && < 5 11 | - free 12 | - uuid 13 | - aeson 14 | - text 15 | - bytestring 16 | - containers 17 | - vector 18 | - process 19 | 20 | library: 21 | source-dirs: flow 22 | 23 | tests: 24 | flow-test: 25 | main: Spec.hs 26 | source-dirs: test 27 | ghc-options: 28 | - -threaded 29 | - -rtsopts 30 | - -with-rtsopts=-N 31 | dependencies: 32 | - flow 33 | - hspec 34 | -------------------------------------------------------------------------------- /lib/test/Spec.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import Control.Concurrent.MVar 6 | import Control.Monad (when, unless) 7 | import qualified Data.Map.Strict as Map 8 | import qualified Data.Vector as V 9 | import Data.Aeson (decode, encode) 10 | import Test.Hspec 11 | import Data.UUID (toString) 12 | import Data.UUID.V4 (nextRandom) 13 | 14 | import Playback.Types 15 | import Runtime.Types 16 | import Language 17 | import qualified Language as L 18 | import Runtime.Interpreter 19 | 20 | initRegularRT = do 21 | opts <- newMVar Map.empty 22 | pure $ Runtime 23 | { runMode = RegularMode 24 | , runtimeData = Left $ OperationalData opts 25 | } 26 | 27 | initRecorderRT = do 28 | recMVar <- newMVar V.empty 29 | forkedRecMvar <- newMVar Map.empty 30 | opts <- newMVar Map.empty 31 | let recRt = RecorderRuntime 32 | { flowGUID = "testFlow" 33 | , recordingMVar = recMVar 34 | , forkedRecordingsVar = forkedRecMvar 35 | , disableEntries = [] 36 | } 37 | pure $ Runtime 38 | { runMode = RecordingMode recRt 39 | , runtimeData = Left $ OperationalData opts 40 | } 41 | 42 | initPlayerRT recEntries = do 43 | opts <- newMVar Map.empty 44 | step <- newMVar 0 45 | errMVar <- newMVar Nothing 46 | ffEV <- newMVar Map.empty 47 | let pRt = PlayerRuntime 48 | { recording = recEntries 49 | , stepMVar = step 50 | , errorMVar = errMVar 51 | , disableVerify = [] 52 | , disableMocking = [] 53 | , skipEntries = [] 54 | , entriesFiltered = False 55 | , flowGUID = "MainFlow" 56 | , forkedFlowRecordings = Map.empty 57 | , forkedFlowErrorsVar = ffEV 58 | } 59 | pure $ Runtime 60 | { runMode = ReplayingMode pRt 61 | , runtimeData = Left $ OperationalData opts 62 | } 63 | 64 | cmdScript = do 65 | guid <- generateGUID 66 | logInfo $ "Generated guid is: " ++ guid 67 | forkFlow "forked test flow" cmdScript2 68 | runSysCmd "echo hello" 69 | 70 | cmdScript2 = do 71 | guid <- generateGUID 72 | logInfo $ "Generated guid from 2-nd script is: " ++ guid 73 | runSysCmd "echo hello from 2-nd script" 74 | 75 | main :: IO () 76 | main = hspec $ do 77 | 78 | describe "Tests" $ do 79 | it "Regular mode" $ do 80 | rt <- initRegularRT 81 | res <- runFlow rt cmdScript 82 | res `shouldBe` "hello\n" 83 | 84 | it "Recorder mode" $ do 85 | rt <- initRecorderRT 86 | res <- runFlow rt cmdScript 87 | case runMode rt of 88 | RecordingMode rrt -> do 89 | recs <- readMVar $ recordingMVar rrt 90 | V.length recs `shouldBe` 6 91 | res `shouldBe` "hello\n" 92 | _ -> fail "wrong mode" 93 | 94 | it "Player mode" $ do 95 | rt <- initRecorderRT 96 | res <- runFlow rt cmdScript 97 | case runMode rt of 98 | RecordingMode rrt -> do 99 | entries <- readMVar $ recordingMVar rrt 100 | pRt <- initPlayerRT entries 101 | res2 <- runFlow pRt cmdScript 102 | res `shouldBe` res2 103 | case runMode pRt of 104 | ReplayingMode prtm -> do 105 | errors <- readMVar $ errorMVar prtm 106 | errors `shouldBe` Nothing 107 | _ -> fail "wrong mode" 108 | _ -> fail "wrong mode" 109 | -------------------------------------------------------------------------------- /recordings.txt: -------------------------------------------------------------------------------- 1 | { 2 | "entries": [ 3 | [ 4 | 0, "GenerateGUIDEntry", 5 | {\"contents\":{\"guid\":\"662ed4a1-950b-48cd-a91d-1091342070d9\"},\"tag\":\"GenerateGUIDEntry\"} 6 | ], 7 | [ 8 | 1, "RunIOEntry", 9 | {\"contents\":{\"jsonResult\":\"662ed4a1-950b-48cd-a91d-1091342070d9\"},\"tag\":\"RunIOEntry\"} 10 | ], 11 | [ 12 | 2, "LogInfoEntry", 13 | {\"contents\":{\"message\":\"GUIDs are equal.\"},\"tag\":\"LogInfoEntry\"} 14 | ] 15 | ] 16 | } 17 | 18 | { 19 | "entries": [ 20 | [ 21 | 0, "RunDBQueryEntry", 22 | {\"contents\":{\"jsonResult\":\"[]\", \"query\":\"SELECT * FROM students\"}} 23 | ], 24 | [ 25 | 1, "LogInfoEntry", 26 | {\"contents\":{\"message\":\"No records found.\"}} 27 | ] 28 | ] 29 | } 30 | 31 | { 32 | "entries": [ 33 | [ 34 | 0, "RunIOEntry", 35 | {\"contents\":{\"jsonResult\":\"[]\"}} 36 | ] 37 | ] 38 | } 39 | 40 | 41 | { 42 | "entries": [ 43 | [ 44 | 0, "ConnectEntry", 45 | "{\"contents\":{\"ceDBConfig\":\"[]\", \"ceDBName\":\"students\"}}" 46 | ], 47 | [ 48 | 1, "RunDBEntry", 49 | "{\"contents\":{\"dbeDescription\":\"SELECT * FROM students\", 50 | \"dbeJsonResult\":\"[]\", 51 | \"dbeDBName\":"students"}}" 52 | ], 53 | [ 54 | 2, "RunDBEntry", 55 | "{\"contents\":{\"dbeDescription\":\"SELECT * FROM students WHERE disabled=1\", 56 | \"dbeJsonResult\":\"[]\", 57 | \"dbeDBName\":"students"}}" 58 | ], 59 | [ 60 | 3, "LogInfoEntry", 61 | "{\"contents\":{\"message\":\"No records found.\"}}" 62 | ] 63 | ] 64 | } 65 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.22 2 | 3 | packages: 4 | - lib 5 | - app 6 | --------------------------------------------------------------------------------