├── .drone.yml ├── .ghci ├── .gitattributes ├── .gitignore ├── .gitlab-ci.yml ├── .stylish-haskell.yaml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Enecuum │ └── Main.hs ├── brittany.yaml ├── configs ├── default │ ├── tst_graph_node_receiver.json │ └── tst_graph_node_transmitter.json ├── tst_client.json ├── tst_client_test_config.json ├── tst_gen_poa.json ├── tst_gen_pow.json ├── tst_graph_node_receiver.json ├── tst_graph_node_transmitter.json ├── tst_ping_server.json ├── tst_pong_client1.json └── tst_pong_client2.json ├── package.yaml ├── src ├── Control │ └── Monad │ │ └── Extra.hs ├── Data │ ├── Aeson │ │ └── Extra.hs │ ├── ByteString │ │ ├── Base64 │ │ │ └── Extra.hs │ │ └── Extra.hs │ ├── HGraph │ │ ├── StringHashable.hs │ │ └── THGraph.hs │ └── TypeLevel.hs ├── Enecuum │ ├── Config.hs │ ├── Core │ │ ├── ControlFlow │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── CoreEffect │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── Crypto │ │ │ ├── Crypto.hs │ │ │ ├── Interpreter.hs │ │ │ ├── Keys.hs │ │ │ ├── Language.hs │ │ │ ├── Signature.hs │ │ │ └── Verification.hs │ │ ├── Database │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── FileSystem │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── HGraph │ │ │ ├── Internal │ │ │ │ ├── Impl.hs │ │ │ │ └── Types.hs │ │ │ ├── Interpreters │ │ │ │ ├── IO.hs │ │ │ │ └── STM.hs │ │ │ ├── Language.hs │ │ │ └── Types.hs │ │ ├── Interpreters.hs │ │ ├── Language.hs │ │ ├── Lens.hs │ │ ├── Logger │ │ │ ├── Impl │ │ │ │ └── HsLogger.hs │ │ │ └── Language.hs │ │ ├── RLens.hs │ │ ├── Random │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── Runtime.hs │ │ ├── State │ │ │ ├── DelayedLogger.hs │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── Time │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── Types.hs │ │ └── Types │ │ │ ├── Database.hs │ │ │ ├── Logger.hs │ │ │ └── State.hs │ ├── Domain.hs │ ├── Framework │ │ ├── Domain.hs │ │ ├── Domain │ │ │ ├── Error.hs │ │ │ ├── Networking.hs │ │ │ ├── Node.hs │ │ │ ├── Process.hs │ │ │ ├── RPC.hs │ │ │ ├── Range.hs │ │ │ └── Tags.hs │ │ ├── Handler │ │ │ ├── Cmd │ │ │ │ ├── Interpreter.hs │ │ │ │ └── Language.hs │ │ │ ├── Network │ │ │ │ ├── Interpreter.hs │ │ │ │ └── Language.hs │ │ │ └── Rpc │ │ │ │ ├── Interpreter.hs │ │ │ │ └── Language.hs │ │ ├── Interpreters.hs │ │ ├── Language.hs │ │ ├── Language │ │ │ └── Extra.hs │ │ ├── Lens.hs │ │ ├── Networking │ │ │ ├── Internal │ │ │ │ ├── Client.hs │ │ │ │ ├── Connection.hs │ │ │ │ ├── Datagram.hs │ │ │ │ ├── Tcp │ │ │ │ │ └── Connection.hs │ │ │ │ └── Udp │ │ │ │ │ └── Connection.hs │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── Node │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── NodeDefinition │ │ │ ├── Interpreter.hs │ │ │ └── Language.hs │ │ ├── RLens.hs │ │ └── Runtime.hs │ ├── Interpreters.hs │ ├── Language.hs │ ├── Prelude.hs │ ├── Runtime.hs │ └── Samples │ │ ├── Assets │ │ ├── Blockchain │ │ │ ├── Generation.hs │ │ │ ├── Keys.hs │ │ │ └── Wallet.hs │ │ ├── ConfigParsing.hs │ │ ├── GenConfigs.hs │ │ ├── Initialization.hs │ │ ├── Nodes │ │ │ ├── Address.hs │ │ │ ├── CLens.hs │ │ │ ├── Client.hs │ │ │ ├── GraphService │ │ │ │ ├── Config.hs │ │ │ │ ├── DB │ │ │ │ │ ├── Dump.hs │ │ │ │ │ ├── Helpers.hs │ │ │ │ │ └── Restore.hs │ │ │ │ ├── GraphServiceData.hs │ │ │ │ ├── Initialization.hs │ │ │ │ └── Logic.hs │ │ │ ├── Messages.hs │ │ │ ├── Methods.hs │ │ │ └── TstNodes │ │ │ │ ├── GenPoA │ │ │ │ ├── Config.hs │ │ │ │ └── Node.hs │ │ │ │ ├── GenPoW │ │ │ │ ├── Config.hs │ │ │ │ └── Node.hs │ │ │ │ ├── GraphNode │ │ │ │ ├── Config.hs │ │ │ │ └── Node.hs │ │ │ │ └── PingPong │ │ │ │ ├── Messages.hs │ │ │ │ ├── PingServer.hs │ │ │ │ └── PongClient.hs │ │ ├── System │ │ │ └── Directory.hs │ │ └── TstScenarios.hs │ │ └── Blockchain │ │ ├── DB.hs │ │ ├── DB │ │ ├── Entities.hs │ │ ├── Entities │ │ │ ├── KBlock.hs │ │ │ ├── KBlockMeta.hs │ │ │ ├── MBlock.hs │ │ │ ├── MBlockMeta.hs │ │ │ ├── Transaction.hs │ │ │ ├── TransactionMeta.hs │ │ │ └── Types.hs │ │ ├── Lens.hs │ │ └── Model.hs │ │ ├── Domain.hs │ │ ├── Domain │ │ ├── BlockchainData.hs │ │ ├── Graph.hs │ │ ├── Internal.hs │ │ ├── KBlock.hs │ │ ├── Microblock.hs │ │ ├── Transaction.hs │ │ ├── Types.hs │ │ └── UUID.hs │ │ ├── Language.hs │ │ ├── Language │ │ ├── Graph.hs │ │ ├── Ledger.hs │ │ ├── Pending.hs │ │ ├── Transaction.hs │ │ └── Verification.hs │ │ └── Lens.hs └── Language │ └── Haskell │ └── TH │ └── MakeFunctor.hs ├── stack.yaml ├── test ├── spec │ ├── Enecuum │ │ └── Tests │ │ │ ├── Functional │ │ │ ├── CryptoSpec.hs │ │ │ ├── Data │ │ │ │ └── ByteStringSpec.hs │ │ │ ├── DifficultySpec.hs │ │ │ ├── HGraphSpec.hs │ │ │ ├── NodeSpec.hs │ │ │ ├── RandomSpec.hs │ │ │ ├── RetryAndTcpLikeSpec.hs │ │ │ └── StateSpec.hs │ │ │ ├── Helpers.hs │ │ │ ├── Integration │ │ │ ├── ConfigsSpec.hs │ │ │ ├── DatabaseSpec.hs │ │ │ ├── LoggerSpec.hs │ │ │ ├── NetworkSpec.hs │ │ │ └── RpcServerSpec.hs │ │ │ └── Scenarios │ │ │ ├── GraphNodeDBSpec.hs │ │ │ ├── MaliciousCryptoSpec.hs │ │ │ ├── PoASpec.hs │ │ │ ├── PoWSpec.hs │ │ │ └── SyncNodesSpec.hs │ └── Spec.hs └── test-framework │ └── Enecuum │ ├── TestData │ ├── Nodes.hs │ ├── Nodes │ │ ├── Address.hs │ │ ├── Scenario1.hs │ │ ├── Scenario3.hs │ │ ├── Scenario4.hs │ │ ├── Scenario5.hs │ │ └── Scenarios.hs │ ├── RPC.hs │ ├── TestGraph.hs │ └── Validation.hs │ ├── Testing.hs │ └── Testing │ ├── Core │ ├── Interpreters.hs │ ├── Interpreters │ │ ├── ControlFlow.hs │ │ ├── CoreEffect.hs │ │ └── Logger.hs │ └── LoggerRuntime.hs │ ├── Framework │ ├── Internal │ │ ├── RpcServer.hs │ │ ├── TcpLikeServer.hs │ │ ├── TcpLikeServerBinding.hs │ │ └── TcpLikeServerWorker.hs │ ├── Interpreters.hs │ ├── Interpreters │ │ ├── Networking.hs │ │ ├── Node.hs │ │ ├── NodeDefinition.hs │ │ └── State.hs │ └── NodeRuntime.hs │ ├── Integrational.hs │ ├── RLens.hs │ ├── TestRuntime.hs │ ├── Types.hs │ └── Wrappers.hs └── transfer /.drone.yml: -------------------------------------------------------------------------------- 1 | pipeline: 2 | build: 3 | image: plugins/docker 4 | secrets: [docker_username, docker_password] 5 | registry: dev.enecuum.com:2087 6 | repo: dev.enecuum.com:2087/testnet/node 7 | tags: latest 8 | when: 9 | branch: 10 | - master 11 | event: 12 | - push 13 | - tag 14 | notify-build: 15 | image: dev.enecuum.com:2087/library/drone-telegram:v1.0.0 16 | secrets: [telegram_token, telegram_id] 17 | when: 18 | branch: 19 | - master 20 | status: 21 | - success 22 | - failure 23 | event: 24 | - push 25 | - tag 26 | deploy: 27 | image: dev.enecuum.com:2087/testnet/testnet-master:latest 28 | when: 29 | branch: 30 | - master 31 | status: 32 | - success 33 | event: 34 | - push 35 | - tag 36 | notify-deploy: 37 | image: dev.enecuum.com:2087/library/drone-telegram:v1.0.0 38 | secrets: [telegram_token, telegram_id] 39 | message: \u2705 ${DRONE_REPO}:`${DRONE_COMMIT_BRANCH}` ${DRONE_BUILD_NUMBER} deployment successful 40 | when: 41 | branch: 42 | - master 43 | status: 44 | - success 45 | event: 46 | - push 47 | - tag 48 | notify-pr: 49 | image: dev.enecuum.com:2087/library/drone-telegram:v1.0.0 50 | secrets: [telegram_token, telegram_id] 51 | message: \u2757 PR ${DRONE_REPO_LINK}/pull/${DRONE_PULL_REQUEST} 52 | when: 53 | branch: 54 | - master 55 | event: pull_request 56 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set prompt "λ> " 2 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | Dockerfile merge=ours 2 | .drone.yml merge=ours 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/* 2 | data/* 3 | *.swp 4 | cabal-helper*build/ 5 | log.txt 6 | *.csv 7 | .hspec-failures 8 | *.cabal 9 | .vscode -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | image: fpco/stack-build:lts-11.22 2 | 3 | variables: 4 | STACK_ROOT: "${CI_PROJECT_DIR}/.stack-root" 5 | 6 | cache: 7 | paths: 8 | - .stack-work/ 9 | - .stack-root/ 10 | 11 | stages: 12 | - build 13 | stack-build: 14 | stage: build 15 | script: 16 | - stack build --test --test-arguments "-m Stable" 17 | - stack install --local-bin-path binaries 18 | artifacts: 19 | paths: 20 | - binaries/ 21 | 22 | before_script: 23 | - apt update -qq && apt install -y -qq librocksdb-dev libtinfo-dev libgd-dev 24 | - mkdir binaries 25 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Node project changelog 2 | 3 | ## Changes in v0.7.0 4 | - Repository now contains framework, sample nodes and tests. 5 | It is cleared from company-specific business logic. 6 | It is now suitable to build your own applications. 7 | - Executable is now `enq-test-node-haskell`. 8 | 9 | ## Changes in v0.6.0 10 | - Framework updates: 11 | * Framework structure improvements (renamings, movings) 12 | * New languages (TimeL) 13 | * Some languages updated (FileSystemL, DatabaseL, CryptoL) 14 | * Configs parsing improved, errors made more friendly 15 | * TCP and UDP implementation reworked, several bugs fixed 16 | - Blockchain algorithms: 17 | * Database model update (entities for microblocks & transactions added) 18 | * Wallet & keys logic updated 19 | - Sample nodes updates: 20 | * Logic of sample nodes updated 21 | * Full restore and dump of graph to DB 22 | * Windowed graph processing added 23 | * New sample nodes: tst_ping_server.json, tst_pong_client1.json, , tst_pong_client2.json 24 | * More options for sample nodes added 25 | - Misc: 26 | * Documentation updates 27 | * More integrational tests 28 | 29 | ## Changes in v0.5.0 30 | - New architecture, design and approaches to build network nodes and blockchain protocols. 31 | The architecture is now based on Free monads, STM and eDSLs. 32 | Nodes are the interpretable monadic scripts. 33 | - Enecuum.Framework (library). Features: 34 | - TCP, UDP, JSON-RPC for client and server side 35 | - Parallel network requests processing 36 | - Arbitrary concurrent state handling 37 | - Parallel computations and in-app processes 38 | - Concurrent in-memory data graph of arbitrary structure 39 | - KV-database support, rocksdb as implementation 40 | - Embeddable console client 41 | - Arbitrary configs for nodes 42 | - Basic cryptography 43 | - Basic random generation 44 | - Basic configurable logging (file, console) 45 | - Sample nodes (executables): 46 | - GraphNode Transmitter. Works with blockchain graph and ledger. 47 | Accepts K-blocks and microblocks, has a wide API. 48 | - GraphNode Receiver. Implements a basic synchronisation scenario. 49 | - PoW. Fake Proof-of-Work node that generates fake K-blocks (without hash complexity). 50 | - PoA. Fake Proof-of-Action node that generates random transactions and microblocks. 51 | - Client. Provides a control over other nodes via RPC API. Handles user commands from stdin. 52 | - Configs for sample nodes (see ./configs). 53 | - Integration and acceptance tests 54 | - Limited functional testing environment 55 | - Unit and functional tests 56 | 57 | # Legacy, old versioning 58 | 59 | ## Changes in node-haskell-legacy (06b82eb) 60 | - The latest commit with legacy code. 61 | 62 | ## Changes in Bambino.v0.1.3 (06b82eb) 63 | - Special version of Enecuum wallet that works with TestNet Alfa. 64 | 65 | ## Changes in v2.1 (6f91459) 66 | - The first attempt to build Enecuum blockchain protocol. 67 | The code contains several network nodes and some part of Enecuum blockchain 68 | protocol, but satisfying the requirements was not complete. 69 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Enecuum (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Enecuum nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Enecuum/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Enecuum.Config (withConfig) 4 | import Enecuum.Prelude 5 | import Enecuum.Samples.Assets.GenConfigs (genConfigs) 6 | import Enecuum.Samples.Assets.Initialization (initialize) 7 | 8 | help :: IO () 9 | help = putStrLn @Text $ "Please, specify node config:" 10 | <> "\n\n$ enq-test-node-haskell singlenode configs/tst_graph_node_transmitter.json" 11 | <> "\n\nOr generate default configs (they will be placed to ./configs/default):" 12 | <> "\n\n$ enq-test-node-haskell generate-configs" 13 | 14 | main :: IO () 15 | main = do 16 | args <- getArgs 17 | case args of 18 | ["singlenode", configFile] -> withConfig configFile initialize 19 | ["generate-configs"] -> genConfigs 20 | _ -> help 21 | -------------------------------------------------------------------------------- /brittany.yaml: -------------------------------------------------------------------------------- 1 | conf_errorHandling: 2 | econf_Werror: false 3 | econf_produceOutputOnErrors: false 4 | econf_CPPMode: CPPModeNowarn 5 | conf_layout: 6 | lconfig_indentPolicy: IndentPolicyFree 7 | lconfig_cols: 120 8 | lconfig_indentAmount: 4 9 | lconfig_importColumn: 60 10 | lconfig_altChooser: 11 | tag: AltChooserBoundedSearch 12 | contents: 3 13 | lconfig_indentWhereSpecial: true 14 | lconfig_indentListSpecial: true 15 | conf_forward: 16 | options_ghc: 17 | - -XBangPatterns 18 | - -XConstraintKinds 19 | - -XDataKinds 20 | - -XDefaultSignatures 21 | - -XDeriveFunctor 22 | - -XDeriveGeneric 23 | - -XExplicitForAll 24 | - -XExplicitNamespaces 25 | - -XFlexibleContexts 26 | - -XFlexibleInstances 27 | - -XFunctionalDependencies 28 | - -XGADTs 29 | - -XImplicitParams 30 | - -XLambdaCase 31 | - -XMultiParamTypeClasses 32 | - -XMultiWayIf 33 | - -XNamedFieldPuns 34 | - -XNoImplicitPrelude 35 | - -XOverloadedStrings 36 | - -XPatternGuards 37 | - -XPatternSynonyms 38 | - -XPolyKinds 39 | - -XQuasiQuotes 40 | - -XRankNTypes 41 | - -XRecursiveDo 42 | - -XScopedTypeVariables 43 | - -XTemplateHaskell 44 | - -XTupleSections 45 | - -XTypeApplications 46 | - -XTypeFamilies 47 | - -XTypeOperators 48 | - -XViewPatterns 49 | 50 | conf_debug: 51 | dconf_dump_annotations: false 52 | dconf_dump_bridoc_simpl_par: false 53 | dconf_dump_bridoc_simpl_indent: false 54 | dconf_dump_bridoc_simpl_floating: false 55 | dconf_dump_ast_full: false 56 | dconf_dump_bridoc_simpl_columns: false 57 | dconf_dump_ast_unknown: false 58 | dconf_dump_bridoc_simpl_alt: false 59 | dconf_dump_bridoc_final: false 60 | dconf_dump_bridoc_raw: false 61 | dconf_dump_config: false 62 | -------------------------------------------------------------------------------- /configs/default/tst_graph_node_receiver.json: -------------------------------------------------------------------------------- 1 | { 2 | "nodeConfig": { 3 | "tag": "TstGraphNodeConfig", 4 | "graphServiceConfig": { 5 | "dbConfig": { 6 | "stopOnDatabaseError": true, 7 | "tag": "DBConfig", 8 | "dbOptions": { 9 | "errorIfExists": true, 10 | "createIfMissing": true 11 | }, 12 | "dbModelName": "", 13 | "useDatabase": false, 14 | "useEnqHomeDir": false 15 | }, 16 | "graphWindowConfig": { 17 | "tag": "GraphWindowConfig", 18 | "shrinkingEnabled": false, 19 | "windowSize": 10, 20 | "shrinkingDelay": 1000000 21 | }, 22 | "tag": "GraphServiceConfig", 23 | "rpcSynco": { 24 | "host": "127.0.0.1", 25 | "port": 6050 26 | } 27 | }, 28 | "nodePorts": { 29 | "tag": "NodePorts", 30 | "nodeRpcPort": 6051, 31 | "nodeUdpPort": 4051, 32 | "nodeTcpPort": 5051 33 | } 34 | }, 35 | "node": "TstGraphNode", 36 | "loggerConfig": { 37 | "logFilePath": "", 38 | "format": "$prio $loggername: $msg", 39 | "logToFile": false, 40 | "logToConsole": true, 41 | "level": "Debug" 42 | }, 43 | "nodeScenario": "GN" 44 | } -------------------------------------------------------------------------------- /configs/default/tst_graph_node_transmitter.json: -------------------------------------------------------------------------------- 1 | { 2 | "nodeConfig": { 3 | "tag": "TstGraphNodeConfig", 4 | "graphServiceConfig": { 5 | "dbConfig": { 6 | "stopOnDatabaseError": true, 7 | "tag": "DBConfig", 8 | "dbOptions": { 9 | "errorIfExists": true, 10 | "createIfMissing": true 11 | }, 12 | "dbModelName": "", 13 | "useDatabase": false, 14 | "useEnqHomeDir": false 15 | }, 16 | "graphWindowConfig": { 17 | "tag": "GraphWindowConfig", 18 | "shrinkingEnabled": false, 19 | "windowSize": 10, 20 | "shrinkingDelay": 1000000 21 | }, 22 | "tag": "GraphServiceConfig", 23 | "rpcSynco": null 24 | }, 25 | "nodePorts": { 26 | "tag": "NodePorts", 27 | "nodeRpcPort": 6050, 28 | "nodeUdpPort": 4050, 29 | "nodeTcpPort": 5050 30 | } 31 | }, 32 | "node": "TstGraphNode", 33 | "loggerConfig": { 34 | "logFilePath": "", 35 | "format": "$prio $loggername: $msg", 36 | "logToFile": false, 37 | "logToConsole": true, 38 | "level": "Debug" 39 | }, 40 | "nodeScenario": "GN" 41 | } -------------------------------------------------------------------------------- /configs/tst_client.json: -------------------------------------------------------------------------------- 1 | { 2 | "node":"ClientNode", 3 | "nodeScenario":"CLI", 4 | "nodeConfig": 5 | { 6 | "tag":"ClientNodeConfig", 7 | "dummyOption":0 8 | }, 9 | "loggerConfig": 10 | { 11 | "logFilePath":"/tmp/log/app.log", 12 | "format":"$prio $loggername: $msg", 13 | "logToConsole":true, 14 | "logToFile": true, 15 | "level":"Debug" 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /configs/tst_client_test_config.json: -------------------------------------------------------------------------------- 1 | { 2 | "node":"ClientNode", 3 | "nodeScenario":"CLI", 4 | "nodeConfig": 5 | { 6 | "tag":"ClientNodeConfig", 7 | "dummyOption":0 8 | }, 9 | "loggerConfig": 10 | { 11 | "logFilePath":"/tmp/log/test.log", 12 | "format":"$prio $loggername: $msg", 13 | "logToConsole":true, 14 | "logToFile": true, 15 | "level":"Debug" 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /configs/tst_gen_poa.json: -------------------------------------------------------------------------------- 1 | { 2 | "node":"TstGenPoANode", 3 | "nodeScenario":"Good", 4 | "nodeConfig": 5 | { 6 | "tag": "TstGenPoANodeConfig", 7 | "controlRpcPort": 6200, 8 | "genPoaGraphNodeUDPAddress": {"host":"127.0.0.1","port":4050}, 9 | "genPoaGraphNodeRPCAddress": {"host":"127.0.0.1","port":6050} 10 | }, 11 | "loggerConfig": 12 | { 13 | "logFilePath": "/tmp/log/tst_gen_poa.log", 14 | "format":"$prio $loggername: $msg", 15 | "logToConsole":true, 16 | "logToFile": true, 17 | "level":"Debug" 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /configs/tst_gen_pow.json: -------------------------------------------------------------------------------- 1 | { 2 | "node":"TstGenPoWNode", 3 | "nodeScenario":"PoW", 4 | "nodeConfig": 5 | { 6 | "defaultBlocksDelay":1000000, 7 | "tag": "TstGenPoWNodeConfig", 8 | "kblocksOrder": "InOrder", 9 | "genPowGraphNodeUDPAddress": {"host":"127.0.0.1","port":4050}, 10 | "controlRpcPort": 6300 11 | }, 12 | "loggerConfig": 13 | { 14 | "logFilePath": "/tmp/log/tst_gen_pow.log", 15 | "format":"$prio $loggername: $msg", 16 | "logToConsole":true, 17 | "logToFile": true, 18 | "level":"Debug" 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /configs/tst_graph_node_receiver.json: -------------------------------------------------------------------------------- 1 | { 2 | "nodeConfig": { 3 | "tag": "TstGraphNodeConfig", 4 | "graphServiceConfig": { 5 | "dbConfig": { 6 | "stopOnDatabaseError": true, 7 | "tag": "DBConfig", 8 | "dbOptions": { 9 | "errorIfExists": true, 10 | "createIfMissing": true 11 | }, 12 | "dbModelName": "", 13 | "useDatabase": false, 14 | "useEnqHomeDir": false 15 | }, 16 | "graphWindowConfig": { 17 | "tag": "GraphWindowConfig", 18 | "shrinkingEnabled": false, 19 | "windowSize": 100, 20 | "shrinkingDelay": 1000000 21 | }, 22 | "tag": "GraphServiceConfig", 23 | "rpcSynco": { 24 | "host": "127.0.0.1", 25 | "port": 6050 26 | } 27 | }, 28 | "nodePorts": { 29 | "tag": "NodePorts", 30 | "nodeRpcPort": 6040, 31 | "nodeUdpPort": 4040, 32 | "nodeTcpPort": 5040 33 | } 34 | }, 35 | "node": "TstGraphNode", 36 | "loggerConfig": { 37 | "logFilePath": "/tmp/log/tst_graph_node_receiver.log", 38 | "format": "$prio $loggername: $msg", 39 | "logToFile": true, 40 | "logToConsole": true, 41 | "level": "Debug" 42 | }, 43 | "nodeScenario": "GN" 44 | } 45 | -------------------------------------------------------------------------------- /configs/tst_graph_node_transmitter.json: -------------------------------------------------------------------------------- 1 | { 2 | "nodeConfig": { 3 | "tag": "TstGraphNodeConfig", 4 | "graphServiceConfig": { 5 | "dbConfig": { 6 | "stopOnDatabaseError": true, 7 | "tag": "DBConfig", 8 | "dbOptions": { 9 | "errorIfExists": false, 10 | "createIfMissing": true 11 | }, 12 | "dbModelName": "graph_node_transmitter.dbm", 13 | "useDatabase": true, 14 | "useEnqHomeDir": true 15 | }, 16 | "graphWindowConfig": { 17 | "tag": "GraphWindowConfig", 18 | "shrinkingEnabled": false, 19 | "windowSize": 100, 20 | "shrinkingDelay": 1000000 21 | }, 22 | "tag": "GraphServiceConfig", 23 | "rpcSynco": null 24 | }, 25 | "nodePorts": { 26 | "tag": "NodePorts", 27 | "nodeRpcPort": 6050, 28 | "nodeUdpPort": 4050, 29 | "nodeTcpPort": 5050 30 | } 31 | }, 32 | "node": "TstGraphNode", 33 | "loggerConfig": { 34 | "logFilePath": "/tmp/log/tst_graph_node_transmitter.log", 35 | "format": "$prio $loggername: $msg", 36 | "logToFile": true, 37 | "logToConsole": true, 38 | "level": "Debug" 39 | }, 40 | "nodeScenario": "GN" 41 | } 42 | -------------------------------------------------------------------------------- /configs/tst_ping_server.json: -------------------------------------------------------------------------------- 1 | { 2 | "node": "PingServerNode", 3 | "nodeScenario": "PingServer", 4 | "nodeConfig": { 5 | "tag": "PingServerNodeConfig", 6 | "stopOnPing": 200, 7 | "servingPort": 3000 8 | }, 9 | "loggerConfig": { 10 | "logFilePath": "", 11 | "format": "$prio $loggername: $msg", 12 | "logToFile": false, 13 | "logToConsole": true, 14 | "level": "Debug" 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /configs/tst_pong_client1.json: -------------------------------------------------------------------------------- 1 | { 2 | "node": "PongClientNode", 3 | "nodeScenario": "PongClient", 4 | "nodeConfig": { 5 | "tag": "PongClientNodeConfig", 6 | "clientName": "Pong client #1", 7 | "pingDelay": 1000000, 8 | "pingServerAddress": {"host":"127.0.0.1","port":3000} 9 | }, 10 | "loggerConfig": { 11 | "logFilePath": "", 12 | "format": "$prio $loggername: $msg", 13 | "logToFile": false, 14 | "logToConsole": true, 15 | "level": "Debug" 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /configs/tst_pong_client2.json: -------------------------------------------------------------------------------- 1 | { 2 | "node": "PongClientNode", 3 | "nodeScenario": "PongClient", 4 | "nodeConfig": { 5 | "tag": "PongClientNodeConfig", 6 | "clientName": "Pong client #2", 7 | "pingDelay": 100000, 8 | "pingServerAddress": {"host":"127.0.0.1","port":3000} 9 | }, 10 | "loggerConfig": { 11 | "logFilePath": "", 12 | "format": "$prio $loggername: $msg", 13 | "logToFile": false, 14 | "logToConsole": true, 15 | "level": "Debug" 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: Node 2 | version: 0.7.0.0 3 | github: "Enecuum/Node" 4 | license: BSD3 5 | author: "Enecuum" 6 | maintainer: "mail@enecuum.com" 7 | copyright: "2018 Enecuum" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | description: 14 | Node is the project that allows to build network actors and blockchain protocols. 15 | It contains Enecuum.Framework and sample nodes performing some blockchain-like activity. 16 | Please see the README.md at . 17 | 18 | default-extensions: 19 | - NoImplicitPrelude 20 | - GADTs 21 | - RankNTypes 22 | - DeriveFunctor 23 | - DeriveGeneric 24 | - OverloadedStrings 25 | - LambdaCase 26 | - MultiParamTypeClasses 27 | - ExplicitNamespaces 28 | - TypeApplications 29 | - ScopedTypeVariables 30 | - TypeOperators 31 | - TypeFamilies 32 | - DataKinds 33 | - FlexibleContexts 34 | - FlexibleInstances 35 | - PatternSynonyms 36 | - PolyKinds 37 | - DefaultSignatures 38 | - ConstraintKinds 39 | - NamedFieldPuns 40 | - TupleSections 41 | - ViewPatterns 42 | - MultiWayIf 43 | 44 | dependencies: 45 | - base >= 4.7 && < 5 46 | - bytestring 47 | - time-units 48 | - network 49 | - aeson 50 | - aeson-pretty 51 | - cereal 52 | - mtl 53 | - cryptonite 54 | - base16-bytestring 55 | - base58-bytestring 56 | - base64-bytestring 57 | - arithmoi 58 | - directory 59 | - filepath 60 | - process 61 | - extra 62 | - time 63 | - clock 64 | - vector 65 | - scientific 66 | - containers 67 | - random 68 | - free 69 | - iproute 70 | - memory 71 | - transformers 72 | - template-haskell 73 | - async 74 | - text 75 | - rocksdb-haskell 76 | - haskeline 77 | - cryptohash-sha256 78 | - bytestring-conversion 79 | - newtype-generics 80 | - lens 81 | - universum 82 | - fmt 83 | - stm 84 | - hslogger 85 | - lens-aeson 86 | - th-abstraction 87 | - MonadRandom 88 | - entropy 89 | - validation 90 | - silently 91 | - uuid 92 | - resourcet 93 | - triplesec 94 | - yaml 95 | - hspec 96 | - HUnit 97 | - QuickCheck 98 | - hspec-contrib 99 | - newtype-generics 100 | - regex-posix 101 | - safe-exceptions 102 | 103 | library: 104 | source-dirs: 105 | - src 106 | - test/test-framework 107 | ghc-options: 108 | - -Wall 109 | 110 | 111 | executables: 112 | enq-test-node-haskell: 113 | main: Main.hs 114 | source-dirs: app/Enecuum 115 | ghc-options: 116 | - -threaded 117 | - -rtsopts 118 | - -with-rtsopts=-N 119 | - -Wall 120 | - -O2 121 | dependencies: 122 | - Node 123 | 124 | 125 | tests: 126 | functional-tests: 127 | main: Spec.hs 128 | 129 | dependencies: 130 | - Node 131 | source-dirs: 132 | - test/spec 133 | ghc-options: 134 | - -threaded 135 | - -rtsopts 136 | - -with-rtsopts=-N 137 | -------------------------------------------------------------------------------- /src/Control/Monad/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module Control.Monad.Extra (module X, tryMR, tryML, tryM, timeout) where 3 | 4 | import Control.Monad 5 | import qualified "extra" Control.Monad.Extra as X 6 | import Control.Concurrent.Async (race) 7 | import Enecuum.Prelude 8 | 9 | tryMR :: MonadCatch m => m t -> (t -> m ()) -> m () 10 | tryMR operation = tryM operation (pure ()) 11 | 12 | tryML :: MonadCatch m => m t -> m () -> m () 13 | tryML operation f = tryM operation f (\_ -> pure ()) 14 | 15 | tryM :: MonadCatch m => m t -> m a -> (t -> m a) -> m a 16 | tryM operation f g = catchAny (g =<< operation) $ const f 17 | 18 | timeout :: Int -> a -> IO b -> IO (Either a b) 19 | timeout i res = race (threadDelay i >> pure res) -------------------------------------------------------------------------------- /src/Data/Aeson/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Extra where 2 | 3 | import Prelude (drop, Bool (..)) 4 | import Data.Aeson 5 | ( Options 6 | , defaultOptions 7 | , fieldLabelModifier 8 | , unwrapUnaryRecords 9 | , tagSingleConstructors 10 | ) 11 | 12 | noLensPrefix :: Options 13 | noLensPrefix = defaultOptions { fieldLabelModifier = drop 1 } 14 | 15 | noLensPrefixJsonConfig :: Options 16 | noLensPrefixJsonConfig = noLensPrefix 17 | { unwrapUnaryRecords = False 18 | , tagSingleConstructors = True 19 | } -------------------------------------------------------------------------------- /src/Data/ByteString/Base64/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.ByteString.Base64.Extra where 2 | 3 | import qualified Data.ByteString.Base64 as B 4 | import Enecuum.Prelude 5 | 6 | base64ToText :: ByteString -> Text 7 | base64ToText = decodeUtf8 . B.encode 8 | 9 | textToBase64 :: Text -> ByteString 10 | textToBase64 aStr = case B.decode . encodeUtf8 $ aStr of 11 | Right a -> a 12 | Left s -> error $ "Can not convert text to Base64" +|| s ||+ "" 13 | -------------------------------------------------------------------------------- /src/Data/ByteString/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Data.ByteString.Extra where 3 | 4 | import Data.Aeson 5 | import Data.Aeson.Types (typeMismatch) 6 | import qualified Data.ByteString.Char8 as BS 7 | import qualified Data.Text as E (pack, unpack) 8 | import Enecuum.Prelude 9 | 10 | instance ToJSON ByteString where 11 | toJSON h = String $ E.pack $ BS.unpack h 12 | 13 | instance FromJSON ByteString where 14 | parseJSON (String s) = pure $ BS.pack $ E.unpack s 15 | parseJSON s = typeMismatch "ByteString: Wrong object format" s -------------------------------------------------------------------------------- /src/Data/HGraph/StringHashable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | --{-# LANGUAGE DerivingVia #-} 4 | 5 | module Data.HGraph.StringHashable where 6 | 7 | import Enecuum.Prelude 8 | import Data.Serialize 9 | import qualified Data.Aeson as A 10 | import qualified Data.Aeson.Types as A 11 | import qualified Data.ByteString as BS 12 | import Data.Bits 13 | import qualified Data.ByteString.Base64 as Base64 14 | import qualified Data.ByteString.Lazy.Char8 as BLC 15 | import qualified Crypto.Hash.SHA256 as SHA 16 | import qualified Data.Text.Encoding as T 17 | 18 | newtype StringHash = StringHash ByteString 19 | deriving (Eq, Ord, Show, Read, Generic, Serialize) 20 | 21 | class StringHashable a where 22 | toHash :: a -> StringHash 23 | 24 | toHashGeneric :: Serialize a => a -> StringHash 25 | toHashGeneric = StringHash . Base64.encode . SHA.hash . encode 26 | 27 | -- TODO: make it right. 28 | -- Currently, there is no "hashing" in here. 29 | -- https://task.enecuum.com/issues/2718 30 | 31 | instance StringHashable Integer where toHash = toHashGeneric 32 | instance StringHashable Int where toHash = toHashGeneric 33 | instance StringHashable Int64 where toHash = toHashGeneric 34 | instance StringHashable Int32 where toHash = toHashGeneric 35 | instance StringHashable Int16 where toHash = toHashGeneric 36 | instance StringHashable Int8 where toHash = toHashGeneric 37 | instance StringHashable Word where toHash = toHashGeneric 38 | instance StringHashable Word64 where toHash = toHashGeneric 39 | instance StringHashable Word32 where toHash = toHashGeneric 40 | instance StringHashable Word16 where toHash = toHashGeneric 41 | instance StringHashable Word8 where toHash = toHashGeneric 42 | 43 | 44 | instance StringHashable StringHash where 45 | toHash = id 46 | 47 | fromStringHash :: StringHash -> ByteString 48 | fromStringHash (StringHash sh) = sh 49 | 50 | 51 | instance ToJSON StringHash where 52 | toJSON (StringHash bytes) = toJSON $ T.decodeUtf8 bytes 53 | 54 | instance FromJSON StringHash where 55 | parseJSON (A.String v) = pure $ StringHash (T.encodeUtf8 v) 56 | parseJSON _ = mzero 57 | 58 | 59 | -- | integerToHash . hashToInteger === id 60 | -- hashToInteger . integerToHash === abs 61 | hashToInteger :: StringHash -> Integer 62 | hashToInteger x = rollInteger . BS.unpack $ fromRight "" (Base64.decode $ fromStringHash x) 63 | 64 | integerToHash :: Integer -> StringHash 65 | integerToHash = StringHash . Base64.encode . BS.pack . unrollInteger 66 | 67 | hashToWord64 :: StringHash -> Word64 68 | hashToWord64 x = fromIntegral $ hashToInteger x `div` 2^64 69 | 70 | unrollInteger :: Integer -> [Word8] 71 | unrollInteger = unfoldr step 72 | where 73 | step 0 = Nothing 74 | step i = Just (fromIntegral i, i `shiftR` 8) 75 | 76 | rollInteger :: [Word8] -> Integer 77 | rollInteger = foldr unstep 0 78 | where 79 | unstep b a = a `shiftL` 8 .|. fromIntegral b 80 | -------------------------------------------------------------------------------- /src/Data/TypeLevel.hs: -------------------------------------------------------------------------------- 1 | module Data.TypeLevel where 2 | 3 | 4 | -- | Type-level lists concatenation. 5 | type family (as :: [k]) ++ (bs :: [k]) :: [k] where 6 | '[] ++ bs = bs 7 | (a ': as) ++ bs = a ': (as ++ bs) 8 | -------------------------------------------------------------------------------- /src/Enecuum/Core/ControlFlow/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.ControlFlow.Interpreter where 2 | 3 | import Enecuum.Prelude 4 | import qualified Enecuum.Core.ControlFlow.Language as L 5 | import qualified Enecuum.Runtime as Rt 6 | 7 | interpretControlFlowF :: Rt.CoreRuntime -> L.ControlFlowF a -> IO a 8 | interpretControlFlowF _ (L.Delay i next) = do 9 | threadDelay i 10 | pure $ next () 11 | 12 | runControlFlow :: Rt.CoreRuntime -> Free L.ControlFlowF a -> IO a 13 | runControlFlow coreRt = foldFree (interpretControlFlowF coreRt) 14 | 15 | -------------------------------------------------------------------------------- /src/Enecuum/Core/ControlFlow/Language.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.ControlFlow.Language where 2 | 3 | import Enecuum.Prelude 4 | 5 | data ControlFlowF next where 6 | Delay :: Int -> (() -> next) -> ControlFlowF next 7 | 8 | instance Functor ControlFlowF where 9 | fmap g (Delay i next) = Delay i (g . next) 10 | 11 | type ControlFlowL next = Free ControlFlowF next 12 | 13 | class ControlFlow m where 14 | delay :: Int -> m () 15 | 16 | instance ControlFlow (Free ControlFlowF) where 17 | delay i = liftF $ Delay i id 18 | -------------------------------------------------------------------------------- /src/Enecuum/Core/CoreEffect/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.CoreEffect.Interpreter where 2 | 3 | import Enecuum.Prelude 4 | 5 | import Enecuum.Core.ControlFlow.Interpreter (runControlFlow) 6 | import Enecuum.Core.FileSystem.Interpreter (runFileSystemL) 7 | import qualified Enecuum.Core.Language as L 8 | import Enecuum.Core.Logger.Impl.HsLogger (runLoggerL) 9 | import Enecuum.Core.Random.Interpreter 10 | import qualified Enecuum.Core.RLens as RLens 11 | import Enecuum.Core.Time.Interpreter (runTimeL) 12 | import qualified Enecuum.Runtime as Rt 13 | 14 | -- | Interprets core effect. 15 | interpretCoreEffectF :: Rt.CoreRuntime -> L.CoreEffectF a -> IO a 16 | interpretCoreEffectF coreRt (L.EvalLogger msg next) = 17 | next <$> runLoggerL (coreRt ^. RLens.loggerRuntime . RLens.hsLoggerHandle) msg 18 | interpretCoreEffectF _ (L.EvalFileSystem s next) = next <$> runFileSystemL s 19 | interpretCoreEffectF _ (L.EvalRandom s next) = next <$> runERandomL s 20 | interpretCoreEffectF coreRt (L.EvalControlFlow f next) = next <$> runControlFlow coreRt f 21 | interpretCoreEffectF coreRt (L.EvalTime f next) = next <$> runTimeL f 22 | interpretCoreEffectF _ (L.EvalIO f next) = next <$> f 23 | 24 | -- | Runs core effect language. 25 | runCoreEffectL :: Rt.CoreRuntime -> L.CoreEffectL a -> IO a 26 | runCoreEffectL coreRt = foldFree (interpretCoreEffectF coreRt) 27 | -------------------------------------------------------------------------------- /src/Enecuum/Core/CoreEffect/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Enecuum.Core.CoreEffect.Language 3 | ( CoreEffectF (..) 4 | , CoreEffectL 5 | , evalLogger 6 | , evalRandom 7 | , IOL(..) 8 | ) where 9 | 10 | import Enecuum.Core.ControlFlow.Language (ControlFlow (..), ControlFlowL) 11 | import Enecuum.Core.FileSystem.Language 12 | import Enecuum.Core.Logger.Language (Logger, LoggerL, logMessage) 13 | import Enecuum.Core.Random.Language 14 | import Enecuum.Core.Time.Language (Time (..), TimeL) 15 | import Enecuum.Prelude hiding (readFile, writeFile) 16 | import Language.Haskell.TH.MakeFunctor (makeFunctorInstance) 17 | 18 | -- | Core effects container language. 19 | data CoreEffectF next where 20 | -- | Logger effect 21 | EvalLogger :: LoggerL () -> (() -> next) -> CoreEffectF next 22 | -- | Random effect 23 | EvalRandom :: ERandomL a -> (a -> next) -> CoreEffectF next 24 | -- | FileSystem effect 25 | EvalFileSystem :: FileSystemL a -> (a -> next) -> CoreEffectF next 26 | -- | ControlFlow effect 27 | EvalControlFlow :: ControlFlowL a -> (a -> next) -> CoreEffectF next 28 | -- | Time effect 29 | EvalTime :: TimeL a -> (a -> next) -> CoreEffectF next 30 | -- | Impure effect. Avoid using it in production code (it's not testable). 31 | EvalIO :: IO a -> (a -> next) -> CoreEffectF next 32 | 33 | makeFunctorInstance ''CoreEffectF 34 | 35 | type CoreEffectL = Free CoreEffectF 36 | 37 | class IOL m where 38 | evalIO :: IO a -> m a 39 | 40 | instance IOL CoreEffectL where 41 | evalIO io = liftF $ EvalIO io id 42 | 43 | evalLogger :: LoggerL () -> CoreEffectL () 44 | evalLogger logger = liftF $ EvalLogger logger id 45 | 46 | instance Logger CoreEffectL where 47 | logMessage level msg = evalLogger $ logMessage level msg 48 | 49 | evalFileSystem :: FileSystemL a -> CoreEffectL a 50 | evalFileSystem filepath = liftF $ EvalFileSystem filepath id 51 | 52 | instance FileSystem CoreEffectL where 53 | readFile filepath = evalFileSystem $ readFile filepath 54 | writeFile filename text = evalFileSystem $ writeFile filename text 55 | appendFile filename text = evalFileSystem $ writeFile filename text 56 | getHomeDirectory = evalFileSystem getHomeDirectory 57 | createFilePath filepath = evalFileSystem $ createFilePath filepath 58 | doesFileExist = evalFileSystem . doesFileExist 59 | 60 | evalRandom :: ERandomL a -> CoreEffectL a 61 | evalRandom g = liftF $ EvalRandom g id 62 | 63 | instance ERandom CoreEffectL where 64 | getRandomInt = evalRandom . getRandomInt 65 | getRandomByteString = evalRandom . getRandomByteString 66 | evalCoreCrypto = evalRandom . evalCoreCrypto 67 | nextUUID = evalRandom nextUUID 68 | 69 | evalControlFlow :: ControlFlowL a -> CoreEffectL a 70 | evalControlFlow a = liftF $ EvalControlFlow a id 71 | 72 | instance ControlFlow CoreEffectL where 73 | delay i = evalControlFlow $ delay i 74 | 75 | evalTime :: TimeL a -> CoreEffectL a 76 | evalTime action = liftF $ EvalTime action id 77 | 78 | instance Time CoreEffectL where 79 | getUTCTime = evalTime getUTCTime 80 | getPosixTime = evalTime getPosixTime 81 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Crypto/Crypto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module Enecuum.Core.Crypto.Crypto 3 | ( module X, 4 | ECDSA.Signature 5 | ) where 6 | 7 | import Enecuum.Core.Crypto.Keys as X 8 | import Enecuum.Core.Crypto.Signature as X 9 | import Enecuum.Core.Crypto.Verification as X 10 | import qualified "cryptonite" Crypto.PubKey.ECC.ECDSA as ECDSA -------------------------------------------------------------------------------- /src/Enecuum/Core/Crypto/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module Enecuum.Core.Crypto.Interpreter where 3 | 4 | import "cryptonite" Crypto.Random (MonadRandom) 5 | import Crypto.TripleSec --(decryptIO, encryptIO) 6 | import Data.ByteString.Char8 (pack) 7 | import Enecuum.Core.Crypto.Crypto (generateNewRandomAnonymousKeyPair, sign) 8 | import Enecuum.Core.Crypto.Crypto 9 | import qualified Enecuum.Core.Language as L 10 | import Enecuum.Prelude 11 | 12 | interpretCryptoL :: L.CryptoF a -> IO a 13 | interpretCryptoL (L.GenerateKeyPair next) = 14 | next <$> generateNewRandomAnonymousKeyPair 15 | interpretCryptoL (L.Sign key msg next) = do 16 | signature <- sign key msg 17 | pure $ next signature 18 | interpretCryptoL (L.Encrypt key msg next) = do 19 | encryptedMsg <- encryptIO key msg 20 | pure $ next encryptedMsg 21 | interpretCryptoL (L.Decrypt key encryptedMsg next) = do 22 | eDecryptedMsg :: Either SomeException L.Key <- try $ decryptIO key encryptedMsg 23 | let decryptedMsg = case eDecryptedMsg of 24 | Left e -> Nothing 25 | Right decryptedMsg -> Just decryptedMsg 26 | pure $ next decryptedMsg 27 | 28 | runCryptoL :: L.CryptoL a -> IO a 29 | runCryptoL = foldFree interpretCryptoL 30 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Crypto/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PackageImports #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Enecuum.Core.Crypto.Language where 7 | 8 | import Control.Monad.Random hiding (Random, next) 9 | import Data.ByteString.Char8 (pack) 10 | import Enecuum.Core.Crypto.Crypto 11 | import Enecuum.Prelude hiding (Key) 12 | import Language.Haskell.TH.MakeFunctor 13 | 14 | type Key = ByteString 15 | type Msg = ByteString 16 | type CipheredMsg = ByteString 17 | 18 | -- | Language for Cryptography. 19 | data CryptoF next where 20 | GenerateKeyPair :: (KeyPair -> next) -> CryptoF next 21 | Sign :: (Serialize msg) => PrivateKey -> msg -> (Signature -> next) -> CryptoF next 22 | Encrypt :: Key -> Msg -> (CipheredMsg -> next) -> CryptoF next 23 | Decrypt :: Key -> CipheredMsg -> (Maybe Msg -> next) -> CryptoF next 24 | makeFunctorInstance ''CryptoF 25 | 26 | type CryptoL next = Free CryptoF next 27 | 28 | class Crypto m where 29 | generateKeyPair :: m KeyPair 30 | sign :: (Serialize msg) => PrivateKey -> msg -> m Signature 31 | encrypt :: Key -> Msg -> m CipheredMsg 32 | decrypt :: Key -> CipheredMsg -> m (Maybe Msg) 33 | 34 | instance Crypto (Free CryptoF) where 35 | generateKeyPair = liftF $ GenerateKeyPair id 36 | sign key msg = liftF $ Sign key msg id 37 | encrypt key msg = liftF $ Encrypt key msg id 38 | decrypt key secretMsg = liftF $ Decrypt key secretMsg id 39 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Crypto/Verification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Enecuum.Core.Crypto.Verification (verifyEncodable) where 5 | 6 | import "cryptonite" Crypto.Hash (SHA3_256(..)) 7 | import Crypto.PubKey.ECC.ECDSA (Signature, verify) 8 | import Data.Serialize (encode) 9 | import Enecuum.Prelude 10 | import qualified Enecuum.Core.Crypto.Keys as Enq 11 | 12 | verifyEncodable :: Serialize msg => Enq.PublicKey -> Signature -> msg -> Bool 13 | verifyEncodable publicKey signature msg = verify SHA3_256 (Enq.decompressPublicKey publicKey) signature (encode msg) 14 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Database/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | module Enecuum.Core.Database.Interpreter where 4 | 5 | import Enecuum.Prelude 6 | import qualified Enecuum.Core.Language as L 7 | import qualified Enecuum.Core.Types as D 8 | import qualified "rocksdb-haskell" Database.RocksDB as Rocks 9 | 10 | 11 | -- TODO: think about read / write options. 12 | -- https://task.enecuum.com/issues/2859 13 | 14 | writeOpts :: Rocks.WriteOptions 15 | writeOpts = Rocks.defaultWriteOptions { Rocks.sync = True } 16 | 17 | -- | Interpret DatabaseL language. 18 | interpretDatabaseL :: Rocks.DB -> L.DatabaseF db a -> IO a 19 | 20 | -- TODO: Perhaps, this method can be implemented more effectively with using Bloom filter. 21 | -- For now, it's just the same as GetValueRaw. 22 | interpretDatabaseL db (L.HasKeyRaw key next) = do 23 | mbVal <- Rocks.get db Rocks.defaultReadOptions key 24 | pure $ next $ isJust mbVal 25 | 26 | interpretDatabaseL db (L.GetValueRaw key next) = do 27 | mbVal <- Rocks.get db Rocks.defaultReadOptions key 28 | pure $ next $ case mbVal of 29 | Nothing -> Left $ D.DBError D.KeyNotFound (show key) 30 | Just val -> Right val 31 | 32 | interpretDatabaseL db (L.PutValueRaw key val next) = do 33 | -- TODO: catch exceptions, if any 34 | r <- Rocks.put db writeOpts key val 35 | pure $ next $ Right r 36 | 37 | runDatabaseL :: Rocks.DB -> L.DatabaseL db a -> IO a 38 | runDatabaseL db = foldFree (interpretDatabaseL db) 39 | -------------------------------------------------------------------------------- /src/Enecuum/Core/FileSystem/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.FileSystem.Interpreter where 2 | 3 | import qualified Data.ByteString.Lazy as B 4 | import qualified Enecuum.Core.Language as L 5 | import Enecuum.Prelude 6 | import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory) 7 | import System.FilePath.Posix (splitFileName) 8 | -- import System.FilePath (()) 9 | 10 | -- | Interpret CryptoL language. 11 | interpretFileSystemL :: L.FileSystemF a -> IO a 12 | interpretFileSystemL (L.ReadFile filename next) = do 13 | text <- B.readFile filename 14 | pure $ next $ text 15 | interpretFileSystemL (L.WriteFile filename text next) = do 16 | B.writeFile filename text 17 | pure $ next () 18 | interpretFileSystemL (L.AppendFile filename text next) = do 19 | B.appendFile filename text 20 | pure $ next () 21 | interpretFileSystemL (L.GetHomeDirectory next) = do 22 | filename <- getHomeDirectory 23 | pure $ next filename 24 | interpretFileSystemL (L.CreateFilePath filepath next) = do 25 | let (dir, filename) = splitFileName filepath 26 | createDirectoryIfMissing True dir 27 | pure $ next filepath 28 | interpretFileSystemL (L.DoesFileExist filepath next) = do 29 | isFileExist <- doesFileExist filepath 30 | pure $ next isFileExist 31 | 32 | runFileSystemL :: L.FileSystemL a -> IO a 33 | runFileSystemL = foldFree interpretFileSystemL 34 | -------------------------------------------------------------------------------- /src/Enecuum/Core/FileSystem/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Enecuum.Core.FileSystem.Language where 3 | 4 | import Enecuum.Prelude 5 | import Language.Haskell.TH.MakeFunctor 6 | import qualified Data.ByteString.Lazy as B 7 | import qualified Data.ByteString.Lazy.Internal as BSI 8 | -- import qualified Data.ByteString.Internal as BSI 9 | 10 | -- | Language for FileSystem. 11 | data FileSystemF next where 12 | ReadFile :: FilePath -> (BSI.ByteString -> next) -> FileSystemF next 13 | WriteFile :: FilePath -> BSI.ByteString -> (() -> next) -> FileSystemF next 14 | AppendFile :: FilePath -> BSI.ByteString -> (() -> next) -> FileSystemF next 15 | GetHomeDirectory :: (FilePath -> next) -> FileSystemF next 16 | CreateFilePath :: FilePath -> (FilePath -> next) -> FileSystemF next 17 | DoesFileExist :: FilePath -> (Bool -> next) -> FileSystemF next 18 | makeFunctorInstance ''FileSystemF 19 | 20 | type FileSystemL next = Free FileSystemF next 21 | 22 | class FileSystem m where 23 | readFile :: FilePath -> m B.ByteString 24 | writeFile :: FilePath -> B.ByteString -> m () 25 | appendFile :: FilePath -> B.ByteString -> m () 26 | getHomeDirectory :: m FilePath 27 | createFilePath :: FilePath -> m FilePath 28 | doesFileExist :: FilePath -> m Bool 29 | 30 | instance FileSystem (Free FileSystemF) where 31 | readFile filename = liftF $ ReadFile filename id 32 | writeFile filename text = liftF $ WriteFile filename text id 33 | appendFile filename text = liftF $ WriteFile filename text id 34 | getHomeDirectory = liftF $ GetHomeDirectory id 35 | createFilePath filepath = liftF $ CreateFilePath filepath id 36 | doesFileExist filepath = liftF $ DoesFileExist filepath id 37 | -------------------------------------------------------------------------------- /src/Enecuum/Core/HGraph/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | module Enecuum.Core.HGraph.Internal.Types where 14 | 15 | import Universum 16 | import Data.Serialize 17 | import Data.HGraph.THGraph (THNode) 18 | import Data.HGraph.StringHashable (StringHash, StringHashable, toHash) 19 | import Enecuum.Core.HGraph.Types (HNodeRef, HNode (..), HNodeContent, 20 | ToNodeRef, ToContent, 21 | fromContent, toContent, toNodeRef) 22 | 23 | 24 | 25 | -- This type doesn't look correct. It reveals implementation details 26 | -- on the language level. 27 | 28 | 29 | type TNodeL content = HNode (TVar (THNode content)) content 30 | 31 | -------------------------------------------------------------------------------- 32 | -- INTERNAL 33 | -------------------------------------------------------------------------------- 34 | 35 | instance ToNodeRef (TNodeL content) (TVar (THNode content)) where 36 | toNodeRef = TNodeRef 37 | 38 | instance ToNodeRef (TNodeL content) (HNodeRef (TNodeL content)) where 39 | toNodeRef = id 40 | 41 | instance ToNodeRef (TNodeL content) StringHash where 42 | toNodeRef = TNodeHash 43 | 44 | instance StringHashable content => ToNodeRef (TNodeL content) content where 45 | toNodeRef = TNodeHash . toHash 46 | 47 | instance Serialize c => Serialize (HNodeContent (TNodeL c)) 48 | 49 | instance (Serialize c, StringHashable c) => StringHashable (HNodeContent (TNodeL c)) where 50 | toHash (TNodeContent c) = toHash c 51 | 52 | instance (Serialize c, StringHashable c) => ToContent (TNodeL c) c where 53 | toContent = TNodeContent 54 | fromContent (TNodeContent a) = a 55 | 56 | data instance HNodeContent (HNode (TVar (THNode content)) content) 57 | = TNodeContent content 58 | deriving (Generic) 59 | 60 | data instance HNodeRef (HNode (TVar (THNode content)) content) 61 | = TNodeRef (TVar (THNode content)) 62 | | TNodeHash StringHash 63 | deriving (Generic) 64 | -------------------------------------------------------------------------------- /src/Enecuum/Core/HGraph/Interpreters/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | module Enecuum.Core.HGraph.Interpreters.IO 14 | ( interpretHGraphLIO 15 | , runHGraphLIO 16 | , runHGraphIO 17 | ) where 18 | 19 | import Universum 20 | import Data.Serialize 21 | import Control.Monad.Free 22 | 23 | import qualified Enecuum.Core.HGraph.Internal.Impl as Impl 24 | 25 | import Data.HGraph.StringHashable (StringHashable) 26 | import Enecuum.Core.HGraph.Language (HGraphF (..), HGraphL) 27 | import Enecuum.Core.HGraph.Internal.Types (TNodeL) 28 | import Enecuum.Core.HGraph.Types 29 | -- | The interpreter of the language describing the action on graphs. 30 | interpretHGraphLIO :: (Serialize c, StringHashable c) => TGraph c -> HGraphF (TNodeL c) a -> IO a 31 | 32 | -- create a new node 33 | interpretHGraphLIO graph (NewNode x next) = next <$> atomically (Impl.newNode graph x) 34 | 35 | -- get node by hash, content or ref 36 | interpretHGraphLIO graph (GetNode x next) = do 37 | node <- atomically $ Impl.getNode graph x 38 | pure $ next node 39 | 40 | -- delete node by hash, content or ref 41 | interpretHGraphLIO graph (DeleteNode x next) = do 42 | ok <- atomically $ Impl.deleteNode graph x 43 | pure $ next ok 44 | 45 | -- create new link by contents, hashes or refs of the node 46 | interpretHGraphLIO graph (NewLink x y next) = do 47 | ok <- atomically $ Impl.newLink graph x y 48 | pure $ next ok 49 | 50 | -- delete link inter a nodes by contents, hashes or refs of the node 51 | interpretHGraphLIO graph (DeleteLink x y next) = do 52 | ok <- atomically $ Impl.deleteLink graph x y 53 | pure $ next ok 54 | 55 | interpretHGraphLIO graph (ClearGraph next) = do 56 | atomically $ Impl.clearGraph graph 57 | pure $ next () 58 | 59 | 60 | -- | Run H graph interpret. 61 | runHGraphLIO, runHGraphIO :: (Serialize c, StringHashable c) => TGraph c -> HGraphL c w -> IO w 62 | runHGraphLIO graph = foldFree (interpretHGraphLIO graph) 63 | 64 | -- | Run H graph interpret in IO monad. 65 | runHGraphIO = runHGraphLIO 66 | -------------------------------------------------------------------------------- /src/Enecuum/Core/HGraph/Interpreters/STM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | module Enecuum.Core.HGraph.Interpreters.STM 14 | ( interpretHGraphLSTM 15 | , runHGraphLSTM 16 | , runHGraphSTM 17 | ) where 18 | 19 | import Universum 20 | import Data.Serialize 21 | import Control.Monad.Free 22 | 23 | import qualified Enecuum.Core.HGraph.Internal.Impl as Impl 24 | 25 | import Data.HGraph.StringHashable (StringHashable) 26 | import Enecuum.Core.HGraph.Language (HGraphF (..), HGraphL) 27 | import Enecuum.Core.HGraph.Internal.Types (TNodeL) 28 | import Enecuum.Core.HGraph.Types 29 | -- | The interpreter of the language describing the action on graphs. 30 | interpretHGraphLSTM :: (Serialize c, StringHashable c) => TGraph c -> HGraphF (TNodeL c) a -> STM a 31 | 32 | -- create a new node 33 | interpretHGraphLSTM graph (NewNode x next) = next <$> Impl.newNode graph x 34 | 35 | -- get nodeby hash, content or ref 36 | interpretHGraphLSTM graph (GetNode x next) = do 37 | node <- Impl.getNode graph x 38 | pure $ next node 39 | 40 | -- delete node by hash, content or ref 41 | interpretHGraphLSTM graph (DeleteNode x next) = do 42 | ok <- Impl.deleteNode graph x 43 | pure $ next ok 44 | 45 | -- create new link by contents, hashes or refs of the node 46 | interpretHGraphLSTM graph (NewLink x y next) = do 47 | ok <- Impl.newLink graph x y 48 | pure $ next ok 49 | 50 | -- delete link inter a nodes by contents, hashes or refs of the node 51 | interpretHGraphLSTM graph (DeleteLink x y next) = do 52 | ok <- Impl.deleteLink graph x y 53 | pure $ next ok 54 | 55 | interpretHGraphLSTM graph (ClearGraph next) = do 56 | Impl.clearGraph graph 57 | pure $ next () 58 | 59 | 60 | -- | Run H graph interpret. 61 | runHGraphLSTM, runHGraphSTM :: (Serialize c, StringHashable c) => TGraph c -> HGraphL c w -> STM w 62 | runHGraphLSTM graph = foldFree (interpretHGraphLSTM graph) 63 | 64 | -- | Run H graph interpret in STM monad. 65 | runHGraphSTM = runHGraphLSTM 66 | -------------------------------------------------------------------------------- /src/Enecuum/Core/HGraph/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeFamilyDependencies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | module Enecuum.Core.HGraph.Language ( 13 | -- * Language 14 | HGraphL 15 | -- * Algebra 16 | , HGraphF (..) 17 | -- * Type Class 18 | , HGraph(..) 19 | -- * Functions 20 | , newNode 21 | , newLink 22 | , deleteLink 23 | , deleteNode 24 | , deleteLink' 25 | , deleteNode' 26 | ) where 27 | 28 | import Control.Monad.Free 29 | import Enecuum.Core.HGraph.Internal.Types (TNodeL) 30 | import Enecuum.Core.HGraph.Types (HNodeContent, HNodeRef, ToContent, ToNodeRef, toContent, toNodeRef) 31 | import Universum 32 | 33 | data HGraphF node a where 34 | NewNode :: HNodeContent node -> (Bool -> a) -> HGraphF node a 35 | DeleteNode :: HNodeRef node -> (Bool -> a) -> HGraphF node a 36 | NewLink :: HNodeRef node -> HNodeRef node -> (Bool -> a) -> HGraphF node a 37 | DeleteLink :: HNodeRef node -> HNodeRef node -> (Bool -> a) -> HGraphF node a 38 | GetNode :: HNodeRef node -> (Maybe node -> a) -> HGraphF node a 39 | ClearGraph :: (() -> a) -> HGraphF node a 40 | deriving (Functor) 41 | 42 | class Functor m => HGraph node m | m -> node where 43 | newLink', deleteLink' 44 | :: (ToNodeRef node b, ToNodeRef node c) => c -> b -> m Bool 45 | 46 | newNode' :: ToContent node c => c -> m Bool 47 | deleteNode' :: ToNodeRef node h => h -> m Bool 48 | getNode :: ToNodeRef node h => h -> m (Maybe node) 49 | clearGraph :: m () 50 | 51 | instance HGraph node (Free (HGraphF node)) where 52 | newLink' a b = liftF (NewLink (toNodeRef a) (toNodeRef b) id) 53 | deleteLink' a b = liftF (DeleteLink (toNodeRef a) (toNodeRef b) id) 54 | newNode' a = liftF (NewNode (toContent a) id) 55 | deleteNode' a = liftF (DeleteNode (toNodeRef a) id) 56 | getNode a = liftF (GetNode (toNodeRef a) id) 57 | clearGraph = liftF (ClearGraph id) 58 | 59 | -- | Graph language. 60 | type HGraphL g next = Free (HGraphF (TNodeL g)) next 61 | 62 | newLink, deleteLink :: (HGraph node m, ToNodeRef node b, ToNodeRef node c) => c -> b -> m () 63 | newLink a b = void $ newLink' a b 64 | deleteLink a b = void $ deleteLink' a b 65 | 66 | deleteNode :: (HGraph node m, ToNodeRef node h) => h -> m () 67 | deleteNode = void . deleteNode' 68 | 69 | newNode :: (HGraph node m, ToContent node c) => c -> m () 70 | newNode = void . newNode' 71 | -------------------------------------------------------------------------------- /src/Enecuum/Core/HGraph/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | 3 | module Enecuum.Core.HGraph.Types 4 | ( HNodeContent 5 | , HNodeRef 6 | , HNode (..) 7 | -- * Type Classes 8 | , ToContent (..) 9 | , ToNodeRef (..) 10 | , TGraph (..) 11 | , hashLinks 12 | ) where 13 | 14 | import Data.HGraph.StringHashable (StringHash, StringHashable) 15 | import Data.HGraph.THGraph as G 16 | import qualified Data.Map as Map 17 | import Enecuum.Prelude 18 | 19 | data family HNodeContent a 20 | 21 | data family HNodeRef a 22 | 23 | data HNode ref content = HNode 24 | { _hash :: StringHash 25 | , _ref :: HNodeRef (HNode ref content) 26 | , _content :: HNodeContent (HNode ref content) 27 | , _links :: Map StringHash (HNodeRef (HNode ref content)) 28 | , _rLinks :: Map StringHash (HNodeRef (HNode ref content)) 29 | } 30 | 31 | newtype TGraph content = TGraph (TVar (G.THGraph content)) 32 | 33 | class StringHashable (HNodeContent config) => ToContent config b | config -> b where 34 | toContent :: b -> HNodeContent config 35 | fromContent :: HNodeContent config -> b 36 | 37 | class ToNodeRef config b where 38 | toNodeRef :: b -> HNodeRef config 39 | 40 | hashLinks :: Map StringHash (HNodeRef (HNode ref content)) -> [StringHash] 41 | hashLinks = Map.keys 42 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Interpreters.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Interpreters 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Core.CoreEffect.Interpreter as X 6 | import Enecuum.Core.Crypto.Interpreter as X 7 | import Enecuum.Core.Database.Interpreter as X 8 | import Enecuum.Core.FileSystem.Interpreter as X 9 | import Enecuum.Core.HGraph.Interpreters.IO as X 10 | import Enecuum.Core.HGraph.Interpreters.STM as X 11 | import Enecuum.Core.Logger.Impl.HsLogger as X 12 | import Enecuum.Core.Random.Interpreter as X 13 | import Enecuum.Core.State.Interpreter as X 14 | import Enecuum.Core.Time.Interpreter as X 15 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Language.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Language 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Core.ControlFlow.Language as X 6 | import Enecuum.Core.CoreEffect.Language as X 7 | import Enecuum.Core.Crypto.Language as X 8 | import Enecuum.Core.Database.Language as X 9 | import Enecuum.Core.FileSystem.Language as X 10 | import Enecuum.Core.HGraph.Language as X 11 | import Enecuum.Core.Logger.Language as X 12 | import Enecuum.Core.Random.Language as X 13 | import Enecuum.Core.State.Language as X 14 | import Enecuum.Core.Time.Language as X 15 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | 5 | -- | Lenses for Core types. 6 | module Enecuum.Core.Lens where 7 | 8 | import Control.Lens ( makeFieldsNoPrefix, makeLenses ) 9 | 10 | import Enecuum.Core.HGraph.Types (HNode) 11 | import Enecuum.Core.Types.Logger (LoggerConfig) 12 | import Enecuum.Core.Types.Database (DBOptions, DBConfig, Storage) 13 | 14 | makeLenses ''HNode 15 | makeFieldsNoPrefix ''LoggerConfig 16 | makeFieldsNoPrefix ''DBOptions 17 | makeFieldsNoPrefix ''DBConfig 18 | makeFieldsNoPrefix ''Storage 19 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Logger/Impl/HsLogger.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Logger.Impl.HsLogger where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Text as TXT (unpack) 6 | import System.IO (Handle, stdout) 7 | import System.Log.Formatter 8 | import System.Log.Handler (close, setFormatter) 9 | import System.Log.Handler.Simple (GenericHandler, fileHandler, streamHandler) 10 | import System.Log.Logger 11 | 12 | import qualified Enecuum.Core.Language as L 13 | import qualified Enecuum.Core.Types as T (LogLevel (..), LoggerConfig(..)) 14 | 15 | -- | Opaque type covering all information needed to teardown the logger. 16 | data HsLoggerHandle = HsLoggerHandle 17 | { handlers :: [GenericHandler Handle] 18 | } 19 | 20 | component :: String 21 | component = "" 22 | 23 | -- | Bracket an IO action which denotes the whole scope where the loggers of 24 | -- the application are needed to installed. Sets them up before running the action 25 | -- and tears them down afterwards. Even in case of an exception. 26 | withLogger :: T.LoggerConfig -> (HsLoggerHandle -> IO c) -> IO c 27 | withLogger config = bracket (setupLogger config) teardownLogger 28 | 29 | -- | Dispatch log level from the LoggerL language 30 | -- to the relevant log level of hslogger package 31 | dispatchLogLevel :: T.LogLevel -> Priority 32 | dispatchLogLevel T.Debug = DEBUG 33 | dispatchLogLevel T.Info = INFO 34 | dispatchLogLevel T.Warning = WARNING 35 | dispatchLogLevel T.Error = ERROR 36 | 37 | -- | Interpret LoggerL language. 38 | interpretLoggerL :: HsLoggerHandle -> L.LoggerF a -> IO a 39 | interpretLoggerL _ (L.LogMessage level msg next) = do 40 | logM component (dispatchLogLevel level) $ TXT.unpack msg 41 | pure $ next () 42 | 43 | runLoggerL :: Maybe HsLoggerHandle -> L.LoggerL () -> IO () 44 | runLoggerL (Just h) l = foldFree (interpretLoggerL h) l 45 | runLoggerL Nothing _ = pure () 46 | 47 | -- | Setup logger required by the application. 48 | setupLogger :: T.LoggerConfig -> IO HsLoggerHandle 49 | setupLogger (T.LoggerConfig format level logFileName isConsoleLog isFileLog) = do 50 | let logLevel = dispatchLogLevel level 51 | let setFormat lh = pure $ setFormatter lh (simpleLogFormatter format) 52 | 53 | let fileH = [fileHandler logFileName logLevel >>= setFormat | isFileLog ] 54 | let consoleH = [streamHandler stdout logLevel >>= setFormat | isConsoleLog] 55 | 56 | handlers <- sequence $ fileH ++ consoleH 57 | 58 | when (length handlers > 0) $ updateGlobalLogger rootLoggerName (setLevel DEBUG . setHandlers handlers) 59 | pure $ HsLoggerHandle handlers 60 | 61 | -- TODO: FIXME: these clearings don't work for console logger. 62 | -- | Tear down the application logger; i.e. close all associated log handlers. 63 | teardownLogger :: HsLoggerHandle -> IO () 64 | teardownLogger (HsLoggerHandle handlers) = do 65 | let x = setHandlers @(GenericHandler Handle) [] 66 | updateGlobalLogger rootLoggerName (setLevel EMERGENCY . x) 67 | mapM_ close handlers 68 | 69 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Logger/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Enecuum.Core.Logger.Language where 5 | 6 | import qualified Enecuum.Core.Types as T (LogLevel (..), Message) 7 | import Enecuum.Prelude 8 | import Language.Haskell.TH.MakeFunctor 9 | 10 | -- | Language for logging. 11 | data LoggerF next where 12 | -- | Log message with a predefined level. 13 | LogMessage :: T.LogLevel -> T.Message -> (() -> next) -> LoggerF next 14 | 15 | makeFunctorInstance ''LoggerF 16 | 17 | type LoggerL next = Free LoggerF next 18 | 19 | class Logger m where 20 | logMessage :: T.LogLevel -> T.Message -> m () 21 | 22 | instance Logger (Free LoggerF) where 23 | logMessage level msg = liftF $ LogMessage level msg id 24 | 25 | -- | Log message with Info level. 26 | logInfo :: Logger m => T.Message -> m () 27 | logInfo = logMessage T.Info 28 | 29 | -- | Log message with Error level. 30 | logError :: Logger m => T.Message -> m () 31 | logError = logMessage T.Error 32 | 33 | -- | Log message with Debug level. 34 | logDebug :: Logger m => T.Message -> m () 35 | logDebug = logMessage T.Debug 36 | 37 | -- | Log message with Warning level. 38 | logWarning :: Logger m => T.Message -> m () 39 | logWarning = logMessage T.Warning 40 | -------------------------------------------------------------------------------- /src/Enecuum/Core/RLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | 5 | -- | Lenses for Core Runtime types. 6 | module Enecuum.Core.RLens where 7 | 8 | import Enecuum.Core.Runtime (CoreRuntime, LoggerRuntime, StateRuntime) 9 | import Control.Lens (makeFieldsNoPrefix) 10 | 11 | makeFieldsNoPrefix ''LoggerRuntime 12 | makeFieldsNoPrefix ''CoreRuntime 13 | makeFieldsNoPrefix ''StateRuntime 14 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Random/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Random.Interpreter where 2 | 3 | import qualified Enecuum.Core.Language as L 4 | import Enecuum.Prelude 5 | import System.Entropy 6 | import System.Random hiding (next) 7 | import qualified Enecuum.Core.Crypto.Interpreter as I 8 | import Data.UUID.V1 (nextUUID) 9 | 10 | -- | Interpret RandomL language. 11 | interpretERandomL :: L.ERandomF a -> IO a 12 | interpretERandomL (L.EvalCoreCrypto a next) = do 13 | r <- I.runCryptoL a 14 | pure $ next r 15 | interpretERandomL (L.GetRandomInt k next) = do 16 | r <- randomRIO k 17 | pure $ next r 18 | interpretERandomL (L.GetRandomByteString k next) = do 19 | r<- getEntropy k 20 | pure $ next r 21 | interpretERandomL (L.NextUUID next) = do 22 | r <- fromJust <$> nextUUID 23 | pure $ next r 24 | 25 | runERandomL :: L.ERandomL a -> IO a 26 | runERandomL = foldFree interpretERandomL 27 | 28 | 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Random/Language.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PackageImports #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Enecuum.Core.Random.Language where 7 | 8 | import Control.Monad.Random hiding (Random, next) 9 | import qualified Data.ByteString.Internal as BSI 10 | import Enecuum.Core.Crypto.Language as L 11 | import Enecuum.Prelude 12 | import Language.Haskell.TH.MakeFunctor 13 | import Data.UUID (UUID) 14 | 15 | -- | Language for Random. 16 | data ERandomF next where 17 | -- | Eval core crypto effect. 18 | EvalCoreCrypto :: CryptoL a -> (a -> next) -> ERandomF next 19 | -- | Get Int from range 20 | GetRandomInt :: (Int, Int) -> (Int -> next) -> ERandomF next 21 | -- | Get Random ByteString 22 | GetRandomByteString :: Int -> ( BSI.ByteString -> next) -> ERandomF next 23 | -- | create UUID 24 | NextUUID :: ( UUID -> next ) -> ERandomF next 25 | makeFunctorInstance ''ERandomF 26 | 27 | type ERandomL next = Free ERandomF next 28 | 29 | class ERandom m where 30 | evalCoreCrypto :: CryptoL a -> m a 31 | getRandomInt :: (Int,Int) -> m Int 32 | getRandomByteString :: Int -> m BSI.ByteString 33 | nextUUID :: m UUID 34 | 35 | instance ERandom (Free ERandomF) where 36 | evalCoreCrypto s = liftF $ EvalCoreCrypto s id 37 | getRandomInt range = liftF $ GetRandomInt range id 38 | getRandomByteString k = liftF $ GetRandomByteString k id 39 | nextUUID = liftF $ NextUUID id 40 | -------------------------------------------------------------------------------- /src/Enecuum/Core/State/DelayedLogger.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.State.DelayedLogger where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Enecuum.Core.Language as L 6 | import qualified Enecuum.Core.Runtime as Rt 7 | 8 | 9 | -- | Interpret LoggerL language for a delayed log. 10 | interpretDelayedLoggerF :: TVar Rt.DelayedLog -> L.LoggerF a -> STM a 11 | interpretDelayedLoggerF delayedLog (L.LogMessage level msg next) = 12 | next <$> modifyTVar delayedLog (Rt.DelayedLogEntry level msg :) 13 | 14 | -- | Interpret LoggerL language for a delayed log. 15 | runDelayedLoggerL :: TVar Rt.DelayedLog -> L.LoggerL () -> STM () 16 | runDelayedLoggerL delayedLog = foldFree (interpretDelayedLoggerF delayedLog) -------------------------------------------------------------------------------- /src/Enecuum/Core/State/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Enecuum.Core.State.Language where 5 | 6 | import Enecuum.Prelude 7 | 8 | import qualified Enecuum.Core.Types as D 9 | import qualified Enecuum.Core.HGraph.Language as L 10 | import qualified Enecuum.Core.Logger.Language as L 11 | import Language.Haskell.TH.MakeFunctor 12 | 13 | -- | State language. It reflects STM and its behavior. 14 | data StateF next where 15 | -- | Create variable. 16 | NewVar :: a -> (D.StateVar a -> next) -> StateF next 17 | -- | Read variable. 18 | ReadVar :: D.StateVar a -> (a -> next) -> StateF next 19 | -- | Write variable. 20 | WriteVar :: D.StateVar a -> a -> (() -> next) -> StateF next 21 | -- | Retry until some variable is changed in this atomic block. 22 | Retry :: (a -> next) -> StateF next 23 | -- | Eval graph atomically. 24 | EvalGraph :: (Serialize c, D.StringHashable c) => D.TGraph c -> Free (L.HGraphF (D.TNodeL c)) x -> (x -> next) -> StateF next 25 | -- | Eval "delayed" logger: it will be written after successfull state operation. 26 | EvalDelayedLogger :: L.LoggerL () -> (() -> next) -> StateF next 27 | 28 | makeFunctorInstance ''StateF 29 | 30 | type StateL = Free StateF 31 | 32 | class StateIO m where 33 | atomically :: StateL a -> m a 34 | newVarIO :: a -> m (D.StateVar a) 35 | readVarIO :: D.StateVar a -> m a 36 | writeVarIO :: D.StateVar a -> a -> m () 37 | 38 | -- | Create variable. 39 | newVar :: a -> StateL (D.StateVar a) 40 | newVar val = liftF $ NewVar val id 41 | 42 | -- | Read variable. 43 | readVar :: D.StateVar a -> StateL a 44 | readVar var = liftF $ ReadVar var id 45 | 46 | -- | Write variable. 47 | writeVar :: D.StateVar a -> a -> StateL () 48 | writeVar var val = liftF $ WriteVar var val id 49 | 50 | -- | Modify variable with function. 51 | modifyVar :: D.StateVar a -> (a -> a) -> StateL () 52 | modifyVar var f = readVar var >>= writeVar var . f 53 | 54 | -- | Retry until some variable is changed in this atomic block. 55 | retry :: StateL a 56 | retry = liftF $ Retry id 57 | 58 | -- | Eval graph atomically. 59 | evalGraph :: (D.StringHashable c, Serialize c) => D.TGraph c -> Free (L.HGraphF (D.TNodeL c)) a -> StateL a 60 | evalGraph g act = liftF $ EvalGraph g act id 61 | 62 | -- | Eval "delayed" logger: it will be written after successfull state operation. 63 | evalDelayedLogger :: L.LoggerL () -> StateL () 64 | evalDelayedLogger action = liftF $ EvalDelayedLogger action id 65 | 66 | instance L.Logger StateL where 67 | logMessage level = evalDelayedLogger . L.logMessage level 68 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Time/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Time.Interpreter where 2 | 3 | import Data.Time (getCurrentTime) 4 | import Data.Time.Clock.POSIX (getPOSIXTime) 5 | import qualified Enecuum.Core.Time.Language as L 6 | import Enecuum.Prelude 7 | 8 | interpretTimeF :: L.TimeF a -> IO a 9 | interpretTimeF (L.GetUTCTime next) = next <$> getCurrentTime 10 | interpretTimeF (L.GetPosixTime next) = next <$> getPOSIXTime 11 | 12 | runTimeL :: Free L.TimeF a -> IO a 13 | runTimeL = foldFree interpretTimeF 14 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Time/Language.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Time.Language where 2 | 3 | import Data.Time (UTCTime) 4 | import Data.Time.Clock.POSIX (POSIXTime) 5 | import Enecuum.Prelude 6 | 7 | data TimeF next where 8 | GetUTCTime :: (UTCTime -> next) -> TimeF next 9 | GetPosixTime :: (POSIXTime -> next) -> TimeF next 10 | 11 | instance Functor TimeF where 12 | fmap g (GetUTCTime next) = GetUTCTime (g . next) 13 | fmap g (GetPosixTime next) = GetPosixTime (g . next) 14 | 15 | type TimeL = Free TimeF 16 | 17 | class Time m where 18 | getUTCTime :: m UTCTime 19 | getPosixTime :: m POSIXTime 20 | 21 | instance Time TimeL where 22 | getUTCTime = liftF $ GetUTCTime id 23 | getPosixTime = liftF $ GetPosixTime id 24 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Types.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Types 2 | ( module X 3 | ) where 4 | 5 | import Crypto.PubKey.ECC.ECDSA as X (Signature) 6 | import Data.HGraph.StringHashable as X 7 | import Data.Time as X (UTCTime) 8 | import Data.Time.Clock.POSIX as X (POSIXTime) 9 | import Data.UUID as X 10 | import Enecuum.Core.Crypto.Crypto as X (KeyPair (..), PrivateKey (..), PublicKey (..)) 11 | import Enecuum.Core.HGraph.Internal.Types as X 12 | import Enecuum.Core.HGraph.Types as X 13 | import Enecuum.Core.Types.Database as X 14 | import Enecuum.Core.Types.Logger as X 15 | import Enecuum.Core.Types.State as X 16 | -------------------------------------------------------------------------------- /src/Enecuum/Core/Types/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Core.Types.Database where 5 | 6 | import Enecuum.Prelude 7 | import Data.Aeson.Extra (noLensPrefix) 8 | import qualified Data.Aeson as A 9 | import qualified Data.ByteString.Lazy as LBS 10 | 11 | type DBKeyRaw = ByteString 12 | type DBValueRaw = ByteString 13 | 14 | class DB db where 15 | getDbName :: FilePath 16 | 17 | class DBEntity entity where 18 | data DBKey entity :: * 19 | data DBValue entity :: * 20 | 21 | class DBEntity entity => ToDBKey entity src where 22 | toDBKey :: src -> DBKey entity 23 | 24 | class DBEntity entity => ToDBValue entity src where 25 | toDBValue :: src -> DBValue entity 26 | 27 | class (DB db, DBEntity entity) => DBModelEntity db entity 28 | 29 | class DBModelEntity db entity => RawDBEntity db entity where 30 | toRawDBKey :: DBKey entity -> DBKeyRaw 31 | toRawDBValue :: DBValue entity -> DBValueRaw 32 | fromRawDBValue :: DBValueRaw -> Maybe (DBValue entity) 33 | 34 | -- TODO: this doesn't work by some strange reason. 35 | default toRawDBValue :: ToJSON (DBValue entity) => DBValue entity -> DBValueRaw 36 | toRawDBValue = LBS.toStrict . A.encode 37 | default fromRawDBValue :: FromJSON (DBValue entity) => DBValueRaw -> Maybe (DBValue entity) 38 | fromRawDBValue = A.decode . LBS.fromStrict 39 | 40 | type DBE entity = (DBKey entity, DBValue entity) 41 | 42 | data DBErrorType 43 | = SystemError 44 | | KeyNotFound 45 | | InvalidType 46 | deriving (Generic, Ord, Eq, Enum, Bounded, Show, Read) 47 | 48 | data DBError = DBError DBErrorType Text 49 | deriving (Generic, Ord, Eq, Show, Read) 50 | 51 | type DBResult a = Either DBError a 52 | 53 | data Storage db = Storage 54 | { _path :: FilePath 55 | } 56 | deriving (Show, Generic) 57 | 58 | instance ToJSON (Storage db) where toJSON = genericToJSON noLensPrefix 59 | instance FromJSON (Storage db) where parseJSON = genericParseJSON noLensPrefix 60 | 61 | data DBOptions = DBOptions 62 | { _createIfMissing :: Bool 63 | , _errorIfExists :: Bool 64 | } 65 | deriving (Show, Generic) 66 | 67 | instance ToJSON DBOptions where toJSON = genericToJSON noLensPrefix 68 | instance FromJSON DBOptions where parseJSON = genericParseJSON noLensPrefix 69 | 70 | data DBConfig db = DBConfig 71 | { _path :: FilePath 72 | , _options :: DBOptions 73 | } 74 | deriving (Show, Generic) 75 | 76 | instance ToJSON (DBConfig db) where toJSON = genericToJSON noLensPrefix 77 | instance FromJSON (DBConfig db) where parseJSON = genericParseJSON noLensPrefix 78 | 79 | defaultDbOptions :: DBOptions 80 | defaultDbOptions = DBOptions 81 | { _createIfMissing = False 82 | , _errorIfExists = False 83 | } 84 | 85 | toDBEntity 86 | :: (ToDBKey entity src, ToDBValue entity src) 87 | => src 88 | -> DBE entity 89 | toDBEntity src = (toDBKey src, toDBValue src) -------------------------------------------------------------------------------- /src/Enecuum/Core/Types/Logger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | module Enecuum.Core.Types.Logger where 4 | 5 | import Data.Aeson.Extra (noLensPrefix) 6 | import Enecuum.Prelude 7 | 8 | -- | Logging level. 9 | data LogLevel = Debug | Info | Warning | Error 10 | deriving (Generic, Eq, Ord, Show, Read, Enum, ToJSON, FromJSON) 11 | 12 | -- | Logging format. 13 | type Format = String 14 | 15 | data LoggerConfig = LoggerConfig 16 | { _format :: Format 17 | , _level :: LogLevel 18 | , _logFilePath :: FilePath 19 | , _logToConsole :: Bool 20 | , _logToFile :: Bool 21 | } deriving (Generic, Show, Read) 22 | 23 | instance ToJSON LoggerConfig where toJSON = genericToJSON noLensPrefix 24 | instance FromJSON LoggerConfig where parseJSON = genericParseJSON noLensPrefix 25 | 26 | type Message = Text 27 | 28 | standardFormat :: String 29 | standardFormat = "$prio $loggername: $msg" 30 | 31 | nullFormat :: String 32 | nullFormat = "$msg" 33 | 34 | defaultLoggerConfig :: LoggerConfig 35 | defaultLoggerConfig = LoggerConfig 36 | { _format = standardFormat 37 | , _level = Debug 38 | , _logFilePath = "" 39 | , _logToConsole = True 40 | , _logToFile = False 41 | } 42 | 43 | nullLoger :: LoggerConfig 44 | nullLoger = defaultLoggerConfig 45 | { _logFilePath = "null" 46 | , _logToConsole = False 47 | } -------------------------------------------------------------------------------- /src/Enecuum/Core/Types/State.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Core.Types.State where 2 | 3 | import Enecuum.Prelude 4 | import Data.HGraph.StringHashable (StringHash) 5 | 6 | type VarId = StringHash 7 | 8 | -- | Concurrent variable (STM TVar). 9 | newtype StateVar a = StateVar 10 | { _varId :: VarId } 11 | 12 | -- | Denotes a signaling concurrent variable. 13 | type SignalVar = StateVar Bool 14 | -------------------------------------------------------------------------------- /src/Enecuum/Domain.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Domain 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Config as X 6 | import Enecuum.Core.Types as X 7 | import Enecuum.Framework.Domain as X 8 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Domain 2 | ( module X 3 | ) 4 | where 5 | 6 | import Enecuum.Framework.Domain.Range as X 7 | import Enecuum.Framework.Domain.Error as X 8 | import Enecuum.Framework.Domain.Networking as X 9 | import Enecuum.Framework.Domain.Node as X 10 | import Enecuum.Framework.Domain.Process as X 11 | import Enecuum.Framework.Domain.RPC as X 12 | import Enecuum.Framework.Domain.Tags as X 13 | import Network.Socket as X (PortNumber) 14 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/Error.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Domain.Error where 2 | 3 | import Enecuum.Prelude 4 | 5 | -- Temporary function for handling errors. 6 | -- Should not be used in prod (uses unsafe `error`). 7 | 8 | withSuccess :: (Show err, Monad m) => m (Either err a) -> m a 9 | withSuccess act = act >>= \case 10 | Left err -> error $ show err 11 | Right a -> pure a 12 | 13 | eitherToText :: Show a => Either Text a -> Text 14 | eitherToText (Left a) = "Server error: " <> a 15 | eitherToText (Right a) = show a 16 | 17 | eitherToText2 :: Either Text Text -> Text 18 | eitherToText2 (Left a) = "Server error: " <> a 19 | eitherToText2 (Right a) = a 20 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/Networking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Enecuum.Framework.Domain.Networking where 7 | 8 | import qualified Data.Text as T 9 | import Enecuum.Prelude 10 | 11 | import qualified Data.Aeson as A 12 | import Data.IP 13 | import Data.Scientific 14 | import qualified Network.Socket as S hiding (recv) 15 | 16 | type Host = String 17 | 18 | -- | Node address (like IP) 19 | data Address = Address 20 | { _host :: Host 21 | , _port :: S.PortNumber 22 | } deriving (Show, Eq, Ord, Generic, Serialize, Read) 23 | 24 | type MyAddress = Address 25 | type SennderAddress = Address 26 | type ReceiverAddress = Address 27 | 28 | data Udp = Udp 29 | data Tcp = Tcp 30 | data Rpc = Rpc 31 | 32 | data NetworkError = ConnectionClosed Text | TooBigMessage Text | AddressNotExist Text 33 | deriving (Eq, Show) 34 | 35 | newtype BoundAddress = BoundAddress Address 36 | deriving (Show, Eq, Ord, Generic) 37 | 38 | type ConnectId = Int 39 | 40 | data Connection a = Connection 41 | { _address :: BoundAddress 42 | , _connectId :: ConnectId 43 | } 44 | deriving (Show, Eq, Ord, Generic) 45 | 46 | getHostAddress :: Connection a -> Host 47 | getHostAddress (Connection (BoundAddress (Address host _)) _) = host 48 | 49 | type RawData = LByteString 50 | 51 | data NetworkMsg = NetworkMsg Text A.Value deriving (Generic, ToJSON, FromJSON) 52 | 53 | sockAddrToHost :: S.SockAddr -> Host 54 | sockAddrToHost sockAddr = case sockAddr of 55 | S.SockAddrInet _ hostAddress -> show $ fromHostAddress hostAddress 56 | S.SockAddrInet6 _ _ hostAddress _ -> show $ fromHostAddress6 hostAddress 57 | S.SockAddrUnix string -> string 58 | _ -> error "Error" 59 | 60 | deriving instance Generic S.PortNumber 61 | instance Serialize S.PortNumber 62 | 63 | instance ToJSON Address where 64 | toJSON (Address h p) = A.object ["host" A..= h, "port" A..= p] 65 | 66 | instance FromJSON Address where 67 | parseJSON = A.withObject "Address" $ \v -> Address 68 | <$> v A..: "host" 69 | <*> v A..: "port" 70 | 71 | instance ToJSON S.PortNumber where 72 | toJSON = toJSON.fromEnum 73 | 74 | instance FromJSON S.PortNumber where 75 | parseJSON (A.Number a) = pure.toEnum.fromJust.toBoundedInteger $ a 76 | parseJSON _ = mzero 77 | 78 | formatAddress :: Address -> Text 79 | formatAddress (Address addr port) = T.pack addr <> ":" <> show port 80 | 81 | packetSize :: Int 82 | packetSize = 1024*400 83 | 84 | 85 | -- | Tries to parse address of the form "0.0.0.0:0000." 86 | -- It may throw exception or may parse the address incorectly. 87 | unsafeParseAddress :: String -> Address 88 | unsafeParseAddress strAddr | length strAddr < 3 || ':' `notElem` strAddr = error "Address parse error: malformed string." 89 | unsafeParseAddress strAddr = let 90 | hostStr = takeWhile (/= ':') strAddr 91 | portStr = drop 1 $ dropWhile (/= ':') strAddr 92 | mbPort = readMaybe portStr 93 | port = fromMaybe (error "Address parse error: port is not a number") mbPort 94 | in Address hostStr port 95 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/Node.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | module Enecuum.Framework.Domain.Node where 4 | 5 | import qualified Data.Aeson as J 6 | import Data.Aeson.Extra (noLensPrefixJsonConfig) 7 | import Enecuum.Core.Types (StringHash) 8 | import Enecuum.Framework.Domain.Networking 9 | import Enecuum.Prelude 10 | import Network.Socket (PortNumber) 11 | 12 | type NodeTag = Text 13 | type NodeId = StringHash 14 | 15 | data NodePorts = NodePorts 16 | { _nodeUdpPort :: PortNumber 17 | , _nodeTcpPort :: PortNumber 18 | , _nodeRpcPort :: PortNumber 19 | } deriving (Show, Eq, Ord, Generic, Serialize) 20 | 21 | data NodeAddress = NodeAddress 22 | { _nodeHost :: Host 23 | , _nodePorts :: NodePorts 24 | , _nodeId :: NodeId 25 | } deriving (Show, Eq, Ord, Generic) 26 | 27 | data NodeStatus = NodeActing | NodeFinished 28 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 29 | 30 | data StopNode = StopNode deriving Read 31 | 32 | instance ToJSON NodePorts where toJSON = J.genericToJSON noLensPrefixJsonConfig 33 | instance FromJSON NodePorts where parseJSON = J.genericParseJSON noLensPrefixJsonConfig 34 | instance ToJSON NodeAddress where toJSON = J.genericToJSON noLensPrefixJsonConfig 35 | instance FromJSON NodeAddress where parseJSON = J.genericParseJSON noLensPrefixJsonConfig 36 | 37 | -- This is used in tests only. 38 | -- TODO: get rid of it. 39 | newtype NodeID = NodeID Text 40 | deriving (Show, Eq) 41 | 42 | -- | Common 43 | data SuccessMsg = SuccessMsg 44 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 45 | 46 | newtype IsDead = IsDead StringHash 47 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 48 | 49 | -- | Network messages 50 | data Ping = Ping 51 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 52 | 53 | data Pong = Pong 54 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 55 | 56 | data Stop = Stop 57 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 58 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/Process.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Domain.Process 2 | ( ProcessId 3 | , ProcessPtr 4 | , ProcessVar 5 | , createProcessPtr 6 | , getProcessId 7 | , getProcessVar 8 | ) where 9 | 10 | import Enecuum.Prelude 11 | 12 | type ProcessVar a = TMVar a 13 | type ProcessId = Int 14 | data ProcessPtr a = ProcessPtr ProcessId (ProcessVar a) 15 | 16 | createProcessPtr :: ProcessId -> IO (ProcessPtr a, ProcessVar a) 17 | createProcessPtr pId = do 18 | pVar <- newEmptyTMVarIO 19 | pure (ProcessPtr pId pVar, pVar) 20 | 21 | getProcessId :: ProcessPtr a -> IO ProcessId 22 | getProcessId (ProcessPtr pId _) = pure pId 23 | 24 | getProcessVar :: ProcessPtr a -> IO (ProcessVar a) 25 | getProcessVar (ProcessPtr _ pVar) = pure pVar -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/RPC.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Domain.RPC where 2 | 3 | import Enecuum.Prelude 4 | import Data.Aeson as A 5 | import Data.Text as T 6 | import Data.Typeable 7 | 8 | data RpcRequest = RpcRequest Text A.Value Int 9 | deriving (Show) 10 | 11 | data RpcResponse 12 | = RpcResponseResult A.Value Int 13 | | RpcResponseError A.Value Int 14 | deriving (Show) 15 | 16 | toRpcRequest :: (Typeable a, ToJSON a) => a -> RpcRequest 17 | toRpcRequest a = RpcRequest (T.pack . show . typeOf $ a) (toJSON a) 0 18 | 19 | class Content a where 20 | content :: a -> A.Value 21 | 22 | instance Content RpcRequest where 23 | content (RpcRequest _ a _) = a 24 | 25 | instance Content RpcResponse where 26 | content (RpcResponseResult a _) = a 27 | content (RpcResponseError a _) = a 28 | 29 | instance FromJSON RpcRequest where 30 | parseJSON (Object o) = RpcRequest 31 | <$> o .: "method" 32 | <*> o .: "params" 33 | <*> o .: "id" 34 | parseJSON _ = error "" 35 | 36 | instance ToJSON RpcRequest where 37 | toJSON (RpcRequest method val requesId) = object [ 38 | "method" A..= method, 39 | "params" A..= val, 40 | "id" A..= requesId 41 | ] 42 | 43 | instance ToJSON RpcResponse where 44 | toJSON (RpcResponseResult val requesId) = object [ 45 | "result" A..= val, 46 | "id" A..= requesId 47 | ] 48 | toJSON (RpcResponseError val requesId) = object [ 49 | "error" A..= val, 50 | "id" A..= requesId 51 | ] 52 | 53 | instance FromJSON RpcResponse where 54 | parseJSON (Object a) 55 | = (RpcResponseResult <$> a .: "result" <*> a .: "id") 56 | <|> (RpcResponseError <$> a .: "error" <*> a .: "id") 57 | parseJSON _ = error "" 58 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/Range.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Enecuum.Framework.Domain.Range where 5 | 6 | import Enecuum.Prelude hiding (foldMap) 7 | import Data.Foldable (Foldable (..)) 8 | import qualified Data.Aeson as J 9 | 10 | data Range a where 11 | Range :: (Eq a, Enum a, Ord a) => a -> a -> Range a 12 | EmptyRange :: Range a 13 | 14 | deriving instance Show a => Show (Range a) 15 | 16 | newRange :: (Eq a, Enum a, Ord a) => a -> a -> Range a 17 | newRange a b 18 | | a <= b = Range a b 19 | | otherwise = EmptyRange 20 | 21 | bottomBound :: Range a -> Maybe a 22 | bottomBound (Range a _) = Just a 23 | bottomBound _ = Nothing 24 | 25 | topBound :: Range a -> Maybe a 26 | topBound (Range _ a) = Just a 27 | topBound _ = Nothing 28 | 29 | instance Foldable Range where 30 | foldMap f (Range a b) 31 | | a < b = f a `mappend` foldMap f (Range (succ a) b) 32 | | otherwise = f a 33 | 34 | newEmptyRange :: Range a 35 | newEmptyRange = EmptyRange 36 | 37 | rangeToList :: Enum a => Range a -> [a] 38 | rangeToList (Range a b) = [a..b] 39 | rangeToList EmptyRange = [] 40 | 41 | instance (FromJSON a, Eq a, Enum a, Ord a) => FromJSON (Range a) where 42 | parseJSON (J.Object v) = do 43 | tag <- v J..: "tag" 44 | case tag of 45 | ("Range" :: Text) -> do 46 | minVal <- v J..: "minValue" 47 | maxVal <- v J..: "maxValue" 48 | pure $ newRange minVal maxVal 49 | ("EmptyRange" :: Text) -> pure EmptyRange 50 | _ -> mzero 51 | parseJSON _ = mzero 52 | 53 | instance (ToJSON a, Eq a, Enum a, Ord a) => ToJSON (Range a) where 54 | toJSON (Range a b) = J.object 55 | [ "tag" J..= ("Range" :: Text) 56 | , "minValue" J..= a 57 | , "maxValue" J..= b 58 | ] 59 | toJSON EmptyRange = J.object 60 | [ "tag" J..= ("EmptyRange" :: Text) 61 | ] -------------------------------------------------------------------------------- /src/Enecuum/Framework/Domain/Tags.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Domain.Tags where 2 | 3 | import Universum 4 | import qualified Data.Text as T 5 | import Data.Typeable 6 | 7 | toTag :: Typeable a => a -> Text 8 | toTag = T.pack . takeWhile (/= ' ') . show . typeOf -------------------------------------------------------------------------------- /src/Enecuum/Framework/Handler/Cmd/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Handler.Cmd.Interpreter where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Map as M 6 | import Enecuum.Framework.Handler.Cmd.Language 7 | 8 | interpretCmdHandlerL :: TVar (M.Map Text CmdHandler) -> CmdHandlerF a -> IO a 9 | interpretCmdHandlerL m (CmdHandler name method' next) = do 10 | atomically $ modifyTVar m (M.insert name method') 11 | pure (next ()) 12 | 13 | runCmdHandlerL :: TVar (Map Text CmdHandler) -> CmdHandlerL a -> IO a 14 | runCmdHandlerL m = foldFree (interpretCmdHandlerL m) 15 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Handler/Cmd/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module Enecuum.Framework.Handler.Cmd.Language 5 | ( CmdHandlerF (..) 6 | , stdHandler 7 | , CmdHandler 8 | , CmdHandlerL 9 | , CLICommand 10 | ) where 11 | 12 | import Enecuum.Framework.Domain.Tags as D 13 | import qualified Enecuum.Framework.Node.Language as L 14 | import Enecuum.Prelude 15 | 16 | data CmdHandlerF a where 17 | CmdHandler :: Text -> CmdHandler -> (() -> a) -> CmdHandlerF a 18 | 19 | instance Functor CmdHandlerF where 20 | fmap g (CmdHandler text f next) = CmdHandler text f (g . next) 21 | 22 | type CmdHandler = String -> L.NodeL Text 23 | type CmdHandlerL a = Free CmdHandlerF a 24 | 25 | stdHandler :: (Typeable a, Read a) => (a -> L.NodeL Text) -> CmdHandlerL () 26 | stdHandler f = liftF $ CmdHandler (D.toTag f) (makeStdHandler f) id 27 | 28 | makeStdHandler :: Read a => (a -> L.NodeL Text) -> String -> L.NodeL Text 29 | makeStdHandler f raw = case readMaybe raw of 30 | Just req -> f req 31 | Nothing -> pure "Error of request parsing" 32 | 33 | type CLICommand = String 34 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Handler/Network/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Handler.Network.Interpreter where 2 | 3 | import Enecuum.Prelude 4 | import Control.Monad.Free() 5 | 6 | import qualified Data.Map as M 7 | import Enecuum.Framework.Handler.Network.Language 8 | 9 | interpretNetworkHandlerL :: TVar (M.Map Text (NetworkHandler p m)) -> NetworkHandlerF p m a -> IO a 10 | interpretNetworkHandlerL m (NetworkHandler name method' next) = do 11 | atomically $ modifyTVar m (M.insert name method') 12 | pure (next ()) 13 | 14 | runNetworkHandlerL :: TVar (Map Text (NetworkHandler p m)) -> NetworkHandlerL p m a -> IO a 15 | runNetworkHandlerL m = foldFree (interpretNetworkHandlerL m) 16 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Handler/Network/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeInType #-} 4 | 5 | module Enecuum.Framework.Handler.Network.Language where 6 | 7 | import Data.Aeson as A 8 | import qualified Enecuum.Framework.Domain as D 9 | import Enecuum.Prelude 10 | 11 | -- | Rpc server description language. 12 | data NetworkHandlerF p m a where 13 | -- | Set rpc method to list. 14 | NetworkHandler :: Text -> NetworkHandler p m -> (() -> a) -> NetworkHandlerF p m a 15 | 16 | instance Functor (NetworkHandlerF p m) where 17 | fmap g (NetworkHandler text f next) = NetworkHandler text f (g . next) 18 | 19 | type NetworkHandler p m = A.Value -> D.Connection p -> m () 20 | type NetworkHandlerL p m a = Free (NetworkHandlerF p m) a 21 | 22 | msgHandler :: Text -> NetworkHandler p m -> NetworkHandlerL p m () 23 | msgHandler text f = liftF (NetworkHandler text f id) 24 | 25 | makeHandler :: (FromJSON a, Monad m) => (a -> D.Connection p -> m ()) -> NetworkHandler p m 26 | makeHandler f raw = case A.fromJSON raw of 27 | A.Success req -> f req 28 | A.Error _ -> \_ -> pure () 29 | 30 | handler 31 | :: forall k a m (p :: k). 32 | (Typeable a, Typeable k, FromJSON a, Typeable m, Monad m, Typeable p) 33 | => (a -> D.Connection p -> m ()) -> NetworkHandlerL p m () 34 | handler f = msgHandler (D.toTag f) (makeHandler f) -------------------------------------------------------------------------------- /src/Enecuum/Framework/Handler/Rpc/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Handler.Rpc.Interpreter where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Map as M 6 | import Enecuum.Framework.Handler.Rpc.Language 7 | 8 | interpretRpcHandlerL :: TVar (M.Map Text (RpcHandler m)) -> RpcHandlerF m a -> IO a 9 | interpretRpcHandlerL m (RpcHandler name method' next) = do 10 | atomically $ modifyTVar m (M.insert name method') 11 | pure (next ()) 12 | 13 | runRpcHandlerL :: TVar (Map Text (RpcHandler m)) -> RpcHandlerL m a -> IO a 14 | runRpcHandlerL m = foldFree (interpretRpcHandlerL m) 15 | 16 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Handler/Rpc/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | 4 | module Enecuum.Framework.Handler.Rpc.Language where 5 | 6 | import Enecuum.Prelude 7 | import Data.Aeson as A 8 | import Control.Monad.Free 9 | import Enecuum.Framework.Domain.Tags as D 10 | import Enecuum.Framework.Domain.RPC 11 | 12 | -- | Rpc server description language. 13 | data RpcHandlerF m a where 14 | -- | Set rpc method to list. 15 | RpcHandler :: Text -> RpcHandler m -> (() -> a) -> RpcHandlerF m a 16 | 17 | instance Functor (RpcHandlerF m) where 18 | fmap g (RpcHandler text f next) = RpcHandler text f (g . next) 19 | 20 | type RpcHandler m = A.Value -> Int -> m RpcResponse 21 | type RpcHandlerL m a = Free (RpcHandlerF m) a 22 | 23 | whenSucces 24 | :: (Applicative f, FromJSON t) 25 | => Value -> Int -> (t -> f RpcResponse) -> f RpcResponse 26 | whenSucces a i f = case A.fromJSON a of 27 | A.Success req -> f req 28 | A.Error _ -> 29 | pure $ RpcResponseError (A.toJSON $ A.String "Error in parsing of args") i 30 | 31 | makeRpc :: MonadFree (RpcHandlerF m1) m2 => Text -> RpcHandler m1 -> m2 () 32 | makeRpc t f = liftF $ RpcHandler t f id 33 | 34 | makeMethod :: (FromJSON a, ToJSON b, Monad m) => (a -> m b) -> RpcHandler m 35 | makeMethod f a i = whenSucces a i $ \req -> do 36 | res <- f req 37 | pure $ RpcResponseResult (A.toJSON res) i 38 | 39 | makeMethod' :: (FromJSON a, ToJSON b, Monad m) => (a -> m (Either Text b)) -> RpcHandler m 40 | makeMethod' f a i = whenSucces a i $ \req -> do 41 | res <- f req 42 | pure $ case res of 43 | Right b -> RpcResponseResult (A.toJSON b) i 44 | Left t -> RpcResponseError (A.toJSON $ A.String t) i 45 | 46 | method :: (Typeable a, Typeable b, ToJSON b, FromJSON a, Typeable m, Monad m) => (a -> m b) -> RpcHandlerL m () 47 | method f = makeRpc (D.toTag f) (makeMethod f) 48 | 49 | methodE 50 | :: (Typeable a, Typeable b, ToJSON b, FromJSON a, Typeable m, Monad m) 51 | => (a -> m (Either Text b)) 52 | -> RpcHandlerL m () 53 | methodE f = makeRpc (D.toTag f) (makeMethod' f) 54 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Interpreters.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Interpreters 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Framework.NodeDefinition.Interpreter as X 6 | -- import Enecuum.Framework.Network.Interpreter as X 7 | import Enecuum.Framework.Networking.Interpreter as X 8 | import Enecuum.Framework.Node.Interpreter as X 9 | import Enecuum.Framework.Handler.Rpc.Interpreter as X 10 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Language.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Language 2 | ( module X 3 | ) 4 | where 5 | 6 | import Enecuum.Framework.NodeDefinition.Language as X 7 | import Enecuum.Framework.Networking.Language as X 8 | import Enecuum.Framework.Node.Language as X 9 | import Enecuum.Framework.Handler.Rpc.Language as X 10 | import Enecuum.Framework.Language.Extra as X 11 | import Enecuum.Framework.Handler.Network.Language as X 12 | import Enecuum.Framework.Handler.Cmd.Language as X 13 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | -- | Lenses for Framework domain types. 6 | module Enecuum.Framework.Lens where 7 | 8 | import Control.Lens (makeFieldsNoPrefix) 9 | 10 | import Enecuum.Framework.Domain 11 | 12 | makeFieldsNoPrefix ''Address 13 | makeFieldsNoPrefix ''Connection 14 | makeFieldsNoPrefix ''NodePorts 15 | makeFieldsNoPrefix ''NodeAddress 16 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Networking/Internal/Client.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Networking.Internal.Client ( 2 | runClient 3 | ) where 4 | 5 | import Network.Socket 6 | import Enecuum.Domain as D 7 | import Enecuum.Prelude 8 | 9 | -- | Run client. 10 | runClient :: SocketType -> D.Address -> (Socket -> IO ()) -> IO () 11 | runClient connectType address handler = do 12 | connection <- openConnect' connectType address 13 | finally (handler connection) (close connection) 14 | 15 | openConnect' :: SocketType -> D.Address -> IO Socket 16 | openConnect' connectType (D.Address host port) = do 17 | address <- head <$> getAddrInfo Nothing (Just host) (Just $ show port) 18 | sock <- socket (addrFamily address) connectType defaultProtocol 19 | connect sock $ addrAddress address 20 | pure sock 21 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Networking/Internal/Datagram.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Framework.Networking.Internal.Datagram where 2 | 3 | import Enecuum.Prelude 4 | import Data.Serialize 5 | import qualified Network.Socket.ByteString.Lazy as S 6 | import qualified Network.Socket as S hiding (recv, send) 7 | import Control.Monad.Extra 8 | 9 | loopM :: Monad m => (a -> m (Either a b)) -> a -> m b 10 | loopM act x = do 11 | res <- act x 12 | case res of 13 | Left x -> loopM act x 14 | Right v -> return v 15 | 16 | sendDatagram :: S.Socket -> LByteString -> IO () 17 | sendDatagram sock msg = 18 | S.sendAll sock $ encodeLazy (toEnum $ length msg :: Word32) <> msg 19 | 20 | receiveDatagram :: S.Socket -> IO LByteString 21 | receiveDatagram sock = do 22 | datagramLength <- mconcat <$> replicateM 4 (S.recv sock 1) 23 | rawMsg <- readMsg sock $ decodeLazy datagramLength 24 | pure $ mconcat $ reverse rawMsg 25 | 26 | readMsg :: S.Socket -> Either String Word32 -> IO [LByteString] 27 | readMsg _ (Left _ ) = pure [] 28 | readMsg sock (Right len) = 29 | loopM (\(elemsOfMsg, restOfMsg) -> do 30 | msg <- S.recv sock ((toEnum.fromEnum) restOfMsg) 31 | let newLen = len - toEnum (length msg) 32 | pure $ if newLen == 0 33 | then Right $ msg : elemsOfMsg 34 | else Left (msg : elemsOfMsg, newLen) 35 | ) ([], len) 36 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Networking/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Enecuum.Framework.Networking.Language where 6 | 7 | import Enecuum.Prelude 8 | 9 | import qualified Data.Aeson as A 10 | import qualified Data.Text as Text 11 | import qualified Enecuum.Core.Language as L 12 | import qualified Enecuum.Framework.Domain as D 13 | import Language.Haskell.TH.MakeFunctor 14 | 15 | -- | Allows to work with network: open and close connections, send requests. 16 | data NetworkingF next where 17 | -- | Send RPC request and wait for the response. 18 | SendRpcRequest :: D.Address -> D.RpcRequest -> (Either Text D.RpcResponse -> next) -> NetworkingF next 19 | -- | Send message to the connection. 20 | SendTcpMsgByConnection :: D.Connection D.Tcp -> D.RawData -> (Either D.NetworkError () -> next)-> NetworkingF next 21 | SendUdpMsgByConnection :: D.Connection D.Udp -> D.RawData -> (Either D.NetworkError () -> next)-> NetworkingF next 22 | SendUdpMsgByAddress :: D.Address -> D.RawData -> (Either D.NetworkError () -> next)-> NetworkingF next 23 | 24 | makeFunctorInstance ''NetworkingF 25 | 26 | type NetworkingL = Free NetworkingF 27 | 28 | -- | Send RPC request and wait for the response. 29 | sendRpcRequest :: D.Address -> D.RpcRequest -> NetworkingL (Either Text D.RpcResponse) 30 | sendRpcRequest address request = liftF $ SendRpcRequest address request id 31 | 32 | -- | Send message to the reliable connection. 33 | -- TODO: distiguish reliable (TCP-like) connection from unreliable (UDP-like). 34 | -- TODO: make conversion to and from package. 35 | 36 | toNetworkMsg :: (Typeable a, ToJSON a) => a -> D.RawData 37 | toNetworkMsg msg = A.encode $ D.NetworkMsg (D.toTag msg) (toJSON msg) 38 | 39 | -- | Send message to the connection. 40 | class Send con m where 41 | send :: (Typeable a, ToJSON a) => con -> a -> m (Either D.NetworkError ()) 42 | 43 | instance Send (D.Connection D.Tcp) NetworkingL where 44 | send conn msg = liftF $ SendTcpMsgByConnection conn (toNetworkMsg msg) id 45 | 46 | instance Send (D.Connection D.Udp) NetworkingL where 47 | send conn msg = liftF $ SendUdpMsgByConnection conn (toNetworkMsg msg) id 48 | instance SendUdp NetworkingL where 49 | notify conn msg = liftF $ SendUdpMsgByAddress conn (toNetworkMsg msg) id 50 | 51 | class SendUdp m where 52 | notify :: (Typeable a, ToJSON a) => D.Address -> a -> m (Either D.NetworkError ()) 53 | 54 | makeRpcRequest' :: (Typeable a, ToJSON a, FromJSON b) => D.Address -> a -> NetworkingL (Either Text b) 55 | makeRpcRequest' address arg = responseValidation =<< sendRpcRequest address (D.toRpcRequest arg) 56 | 57 | responseValidation :: (FromJSON b, Applicative f) => Either Text D.RpcResponse -> f (Either Text b) 58 | responseValidation res = case res of 59 | Left txt -> pure $ Left txt 60 | Right (D.RpcResponseError (A.String txt) _) -> pure $ Left txt 61 | Right (D.RpcResponseError err _) -> pure $ Left (show err) 62 | Right (D.RpcResponseResult val _) -> case A.fromJSON val of 63 | A.Error txt -> pure $ Left (Text.pack txt) 64 | A.Success resp -> pure $ Right resp 65 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/RLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Lenses for Framework Runtime types. 7 | module Enecuum.Framework.RLens where 8 | 9 | import Control.Lens ( makeFieldsNoPrefix ) 10 | 11 | import Enecuum.Framework.Runtime 12 | 13 | makeFieldsNoPrefix ''DBHandle 14 | makeFieldsNoPrefix ''NodeRuntime 15 | -------------------------------------------------------------------------------- /src/Enecuum/Framework/Runtime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | module Enecuum.Framework.Runtime where 4 | 5 | import qualified Data.Map as Map 6 | import Data.Aeson (Value) 7 | import qualified "rocksdb-haskell" Database.RocksDB as Rocks 8 | import Enecuum.Core.HGraph.Internal.Impl (initHGraph) 9 | import Enecuum.Core.Runtime (CoreRuntime, VarHandle) 10 | import qualified Network.Socket as S 11 | import qualified Enecuum.Domain as D 12 | import Enecuum.Prelude 13 | import qualified Enecuum.Core.Runtime as R 14 | import Enecuum.Samples.Blockchain.Domain as D 15 | 16 | class AsNativeConnection a where 17 | data family NativeConnection a 18 | getConnection :: NativeConnection a -> D.Connection a 19 | getSocketVar :: NativeConnection a -> TMVar S.Socket 20 | getReaderId :: NativeConnection a -> ThreadId 21 | 22 | type Handler protocol = Value -> D.Connection protocol -> IO () 23 | type Handlers protocol = Map Text (Handler protocol) 24 | data ServerHandle = ServerHandle (TMVar S.Socket) ThreadId 25 | 26 | type ConnectCounter = IORef D.ConnectId 27 | 28 | type NodeState = TMVar (Map.Map D.VarId VarHandle) 29 | 30 | data DBHandle = DBHandle 31 | { _db :: Rocks.DB 32 | , _mutex :: MVar () 33 | } 34 | 35 | data WorkerFlow 36 | = WContinue 37 | | WFinish 38 | 39 | data WorkerState 40 | = WOk 41 | | WWarning Text 42 | | WError Text 43 | 44 | type WorkerAction = (WorkerFlow, WorkerState) 45 | 46 | type Connections protocol = Map (D.Connection protocol) (NativeConnection protocol) 47 | type ConnectionsVar protocol = TMVar (Connections protocol) 48 | type TcpConnections = Connections D.Tcp 49 | type UdpConnections = Connections D.Udp 50 | 51 | data NodeRuntime = NodeRuntime 52 | { _coreRuntime :: CoreRuntime 53 | , _graph :: D.TGraph D.NodeContent 54 | , _servers :: TMVar (Map D.PortNumber ServerHandle) 55 | , _connectCounter :: ConnectCounter 56 | , _nodeTag :: TVar Text 57 | , _processes :: TVar (Map D.ProcessId ThreadId) 58 | , _tcpConnects :: ConnectionsVar D.Tcp 59 | , _udpConnects :: ConnectionsVar D.Udp 60 | , _storyPaths :: Map Text String 61 | , _databases :: TVar (Map FilePath DBHandle) 62 | } 63 | 64 | createNodeRuntime :: CoreRuntime -> Map Text String -> IO NodeRuntime 65 | createNodeRuntime coreRt paths = 66 | NodeRuntime 67 | <$> pure coreRt 68 | <*> initHGraph 69 | <*> newTMVarIO mempty 70 | <*> newIORef 0 71 | <*> newTVarIO "" 72 | <*> newTVarIO mempty 73 | <*> newTMVarIO mempty 74 | <*> newTMVarIO mempty 75 | <*> pure paths 76 | <*> newTVarIO mempty 77 | 78 | showWorkerState :: R.RuntimeLogger -> WorkerState -> IO () 79 | showWorkerState _ WOk = pure () 80 | showWorkerState logger (WWarning msg) = R.logWarning' logger msg 81 | showWorkerState logger (WError msg) = R.logError' logger msg 82 | 83 | withWorkerAction :: R.RuntimeLogger -> WorkerAction -> IO () -> IO () 84 | withWorkerAction logger (WContinue, st) cont = showWorkerState logger st >> cont 85 | withWorkerAction logger (WFinish, st) _ = showWorkerState logger st 86 | 87 | -------------------------------------------------------------------------------- /src/Enecuum/Interpreters.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Interpreters 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Core.Interpreters as X 6 | import Enecuum.Framework.Interpreters as X 7 | -------------------------------------------------------------------------------- /src/Enecuum/Language.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Language 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Core.Language as X 6 | import Enecuum.Framework.Language as X 7 | import Enecuum.Core.ControlFlow.Language as X () 8 | -------------------------------------------------------------------------------- /src/Enecuum/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-orphans #-} 2 | 3 | module Enecuum.Prelude 4 | ( module X 5 | , trace 6 | , trace_ 7 | ) where 8 | 9 | import Control.Concurrent as X (ThreadId, forkIO, killThread, threadDelay) 10 | import Control.Concurrent.STM as X (retry) 11 | import Control.Concurrent.STM.TMVar as X (TMVar, newEmptyTMVar, newEmptyTMVarIO, newTMVar, newTMVarIO, 12 | putTMVar, readTMVar, takeTMVar, tryReadTMVar) 13 | import Control.Concurrent.STM.TVar as X (modifyTVar) 14 | import Control.Exception as X (SomeException (..)) 15 | import Control.Lens as X (at, (.=)) 16 | import Control.Lens.TH as X (makeFieldsNoPrefix, makeLenses) 17 | import Control.Monad as X (liftM, unless, void, when) 18 | import Control.Monad.Free as X (Free (..), foldFree, liftF) 19 | import Control.Newtype.Generics as X (Newtype, O, pack, unpack) 20 | import Data.Aeson as X (FromJSON, ToJSON, genericParseJSON, genericToJSON, parseJSON, 21 | toJSON) 22 | import Data.Maybe as X (fromJust, fromMaybe) 23 | import Data.Serialize as X (Serialize) 24 | import Data.TypeLevel as X (type (++)) 25 | import Fmt as X ((+|), (+||), (|+), (||+)) 26 | import GHC.Base as X (until) 27 | import GHC.Generics as X (Generic) 28 | import Text.Read as X (read, readsPrec) 29 | import Universum as X hiding (All, Option, Set, Type, head, init, last, set, tail, trace) 30 | import qualified Universum as U 31 | import Universum.Functor.Fmap as X ((<<$>>)) 32 | import Universum.Unsafe as X (head, init, last, tail, (!!)) 33 | 34 | 35 | trace :: Text -> m a -> m a 36 | trace = U.trace 37 | 38 | trace_ :: Applicative m => Text -> m () 39 | trace_ txt = trace txt (pure ()) 40 | -------------------------------------------------------------------------------- /src/Enecuum/Runtime.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Runtime 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Framework.Runtime as X 6 | import Enecuum.Core.Runtime as X 7 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Blockchain/Wallet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Enecuum.Samples.Assets.Blockchain.Wallet where 3 | 4 | import qualified Enecuum.Samples.Blockchain.Domain as D 5 | import Enecuum.Prelude 6 | 7 | -- | Wallets and keys for demo purpose 8 | 9 | publicKeys :: [D.PublicKey] 10 | publicKeys = map D.readPublicKey 11 | [ "8fM3up1pPDUgMnYZzKiBpsnrvNopjSoURSnpYbm5aZKz" 12 | , "4vCovnpyuooGBi7t4LcEGeiQYA2pEKc4hixFGRGADw4X" 13 | , "GS5xDwfTffg86Wyv8uy3H4vVQYqTXBFKPxGPy1Ksp2NS" 14 | , "Jh8vrASby8nrVG7N3PLZjqSpbrpXFGmfpMd1nrYifZou" 15 | , "8LZQhs3Z7WiBZbQvTTeXCcCtXfJYtk6RNxxBExo9PEQm" 16 | ] 17 | 18 | privateKeys :: [D.PrivateKey] 19 | privateKeys = map D.readPrivateKey 20 | [ "FDabUqrGEd1i3rfZpqHJkzhvqP9QEpKveoEwmknfJJFa" 21 | , "DKAJTFr1bFWHE7psYX976YZis1Fqwkh3ikFAgKaw6bWj" 22 | , "6uU38xA2ucJ2zEqgg1zs5j3U8hx8RL3thVFNmhk3Nbsq" 23 | , "3n8QPsZwUJxUK85VrgTEuybyj1zDnUeMeovntB5EdqWP" 24 | , "MzwHKfF4vGsQB2hgcK3MFKY9TaFaUe78NJwQehfjZ5s" 25 | ] 26 | 27 | hardcodedWallets :: [D.KeyPair] 28 | hardcodedWallets = uncurry D.KeyPair <$> zip publicKeys privateKeys 29 | 30 | type ClientName = String 31 | 32 | names :: [ClientName] 33 | names = ["me", "Alice", "Bob", "Carol", "David"] 34 | 35 | hardcodedWalletsWithNames :: [CLIWallet] 36 | hardcodedWalletsWithNames = [ CLIWallet {_id = walletId, _name = name, _publicKey = pub, _privateKey = Just priv} | walletId <- [1..], name <- names, pub <- publicKeys] 37 | where priv = head privateKeys 38 | 39 | data CLIWallet = CLIWallet 40 | { _id :: Int 41 | , _name :: ClientName 42 | , _publicKey :: D.PublicKey 43 | , _privateKey :: Maybe D.PrivateKey 44 | } deriving (Generic, Show, Eq, Ord, Read, ToJSON, FromJSON, Serialize) 45 | 46 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/ConfigParsing.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Assets.ConfigParsing where 2 | 3 | import Data.Yaml (ParseException, prettyPrintParseException) 4 | import qualified Enecuum.Samples.Assets.TstScenarios as Tst 5 | import qualified Enecuum.Config as Cfg 6 | import Enecuum.Prelude 7 | 8 | -- | runParser return exception (Left ParseException) or just dummy value (1) for convenience 9 | runParser 10 | :: Show node 11 | => Show (Cfg.NodeConfig node) 12 | => Show (Cfg.NodeScenario node) 13 | => Either ParseException (Cfg.Config node) 14 | -> IO (Either ParseException Int) 15 | runParser (Left e) = pure $ Left e 16 | runParser (Right _) = pure $ Right 1 17 | 18 | -- Try to parse config of unknown type (parseConfig failure invoke error) 19 | parseConfig :: LByteString -> IO () 20 | parseConfig configSrc = do 21 | let runners = 22 | [ runParser $ Cfg.tryParseConfig @Tst.ClientNode configSrc 23 | 24 | , runParser $ Cfg.tryParseConfig @Tst.TstGraphNode configSrc 25 | , runParser $ Cfg.tryParseConfig @Tst.TstGenPoWNode configSrc 26 | , runParser $ Cfg.tryParseConfig @Tst.TstGenPoANode configSrc 27 | 28 | , runParser $ Cfg.tryParseConfig @Tst.PingServerNode configSrc 29 | , runParser $ Cfg.tryParseConfig @Tst.PongClientNode configSrc 30 | ] 31 | 32 | results <- sequence runners 33 | let typeConfigMatch = rights results 34 | when (length typeConfigMatch == 0) $ do 35 | let exceptions = map prettyPrintParseException $ lefts results 36 | let exception = guessAppropriateException exceptions 37 | error $ show $ exception 38 | 39 | -- packFrequency "aaabccaac" == [(5,'a'),(1,'b'),(3,'c')] 40 | packFrequency :: (Eq a, Ord a) => [a] -> [(Int, a)] 41 | packFrequency xs = map (\x -> (length x, head x) ) $ group $ sort xs 42 | 43 | -- chooseSingleException [(5,'a'),(1,'b'),(3,'c')] == 'b' 44 | chooseSingleException :: [(Int, a)] -> a 45 | chooseSingleException [] = error "Impossible happend. Config is the same for all types of nodes" 46 | chooseSingleException [x] = snd x 47 | chooseSingleException (x:xs) = if fst x == 1 then snd x else chooseSingleException xs 48 | 49 | -- | Guess exception for config of unknown type (apparently it is the most rare exception) 50 | guessAppropriateException :: (Eq a, Ord a) => [a] -> a 51 | guessAppropriateException exceptions = chooseSingleException $ packFrequency exceptions 52 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/GenConfigs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE TypeInType #-} 3 | 4 | module Enecuum.Samples.Assets.GenConfigs where 5 | 6 | import Data.Aeson.Encode.Pretty (encodePretty) 7 | import qualified Data.ByteString.Lazy as B 8 | import qualified Enecuum.Samples.Assets.TstScenarios as Tst 9 | import qualified Enecuum.Config as Cfg 10 | import qualified Enecuum.Domain as D 11 | import Enecuum.Prelude 12 | 13 | genConfigs = forM_ configs (uncurry B.writeFile) 14 | 15 | configs = 16 | [ ("configs/default/tst_graph_node_receiver.json", encodePretty $ D.defConfig Tst.GN Tst.tstGraphNodeReceiverConfig) 17 | , ("configs/default/tst_graph_node_transmitter.json", encodePretty $ D.defConfig Tst.GN Tst.tstGraphNodeTransmitterConfig) 18 | ] 19 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/Address.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Enecuum.Samples.Assets.Nodes.Address where 8 | 9 | import Data.HGraph.StringHashable 10 | import Enecuum.Domain (Address (..), NodeAddress (..), NodeId, NodePorts (..)) 11 | import qualified Enecuum.Domain as D 12 | import qualified Enecuum.Framework.Lens as Lens 13 | import Enecuum.Prelude 14 | 15 | makeNodePorts1000 :: D.PortNumber -> NodePorts 16 | makeNodePorts1000 port = NodePorts (port - 1000) port (port + 1000) 17 | 18 | makeNodeAddress :: D.Host -> NodePorts -> NodeId -> NodeAddress 19 | makeNodeAddress = NodeAddress 20 | 21 | getUdpAddress :: NodeAddress -> Address 22 | getUdpAddress nodeAddress' = 23 | D.Address (nodeAddress' ^. Lens.nodeHost) (nodeAddress' ^. Lens.nodePorts . Lens.nodeUdpPort) 24 | 25 | getTcpAddress :: NodeAddress -> Address 26 | getTcpAddress nodeAddress' = 27 | D.Address (nodeAddress' ^. Lens.nodeHost) (nodeAddress' ^. Lens.nodePorts . Lens.nodeTcpPort) 28 | 29 | getRpcAddress :: NodeAddress -> Address 30 | getRpcAddress nodeAddress' = 31 | D.Address (nodeAddress' ^. Lens.nodeHost) (nodeAddress' ^. Lens.nodePorts . Lens.nodeRpcPort) 32 | 33 | localhost :: D.Host 34 | localhost = "127.0.0.1" 35 | 36 | makeAddressByPorts :: NodePorts -> NodeAddress 37 | makeAddressByPorts ports = NodeAddress localhost ports (D.toHashGeneric ports) 38 | 39 | -- Aggreement: 40 | -- udp ports from 4000 to 4999 41 | -- tcp ports from 5000 to 5999 42 | -- rpc ports from 6000 to 6999 43 | 44 | -- udp = nodePort - 1000 45 | -- tcp = nodePort 46 | -- rpc = nodePort + 1000 47 | 48 | -- client = [10 .. 19] 49 | clientPorts :: NodePorts 50 | clientPorts = makeNodePorts1000 5010 51 | 52 | clientAddress :: NodeAddress 53 | clientAddress = makeAddressByPorts clientPorts 54 | 55 | -- Test nodes 56 | tstGenPoANodePorts :: NodePorts 57 | tstGenPoANodePorts = makeNodePorts1000 5200 58 | 59 | tstGenPoANodeAddress :: NodeAddress 60 | tstGenPoANodeAddress = makeAddressByPorts tstGenPoANodePorts 61 | 62 | tstGenPoWNodePorts :: NodePorts 63 | tstGenPoWNodePorts = makeNodePorts1000 5020 64 | 65 | tstGenPoWNodeAddress :: NodeAddress 66 | tstGenPoWNodeAddress = makeAddressByPorts tstGenPoWNodePorts 67 | 68 | tstGraphNodeTransmitterPorts :: NodePorts 69 | tstGraphNodeTransmitterPorts = makeNodePorts1000 5050 70 | 71 | tstGraphNodeTransmitterAddress :: NodeAddress 72 | tstGraphNodeTransmitterAddress = makeAddressByPorts tstGraphNodeTransmitterPorts 73 | 74 | tstGraphNodeReceiverPorts :: NodePorts 75 | tstGraphNodeReceiverPorts = makeNodePorts1000 5051 76 | 77 | tstGraphNodeReceiverAddress :: NodeAddress 78 | tstGraphNodeReceiverAddress = makeAddressByPorts tstGraphNodeReceiverPorts 79 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/CLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | -- | Lenses for node configs. 6 | module Enecuum.Samples.Assets.Nodes.CLens where 7 | 8 | import Control.Lens (makeFieldsNoPrefix) 9 | import Enecuum.Prelude 10 | 11 | import Enecuum.Samples.Assets.Nodes.GraphService.Config 12 | import Enecuum.Config 13 | import qualified Enecuum.Domain as D 14 | 15 | makeFieldsNoPrefix ''DBConfig 16 | makeFieldsNoPrefix ''GraphWindowConfig 17 | makeFieldsNoPrefix ''GraphServiceConfig 18 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/GraphService/Config.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Assets.Nodes.GraphService.Config where 2 | 3 | import qualified Data.Aeson as A 4 | import Enecuum.Samples.Assets.Nodes.Address 5 | import Enecuum.Config 6 | import qualified Enecuum.Domain as D 7 | import Enecuum.Samples.Blockchain.Domain as D 8 | import Enecuum.Prelude 9 | 10 | data GraphWindowConfig = GraphWindowConfig 11 | { _shrinkingEnabled :: Bool 12 | , _shrinkingDelay :: Int 13 | , _windowSize :: D.BlockNumber 14 | } 15 | deriving (Show, Generic) 16 | 17 | data DBConfig = DBConfig 18 | { _useDatabase :: Bool 19 | -- ^ If True, DB will be used to restore the state on the start and dump the state during work. 20 | , _dbModelName :: String 21 | -- ^ DB model name. Can be a full path if useEnqHomeDir == False. 22 | , _useEnqHomeDir :: Bool 23 | -- ^ When True, ~/.enecuum/ path will be used. 24 | , _dbOptions :: D.DBOptions 25 | -- ^ DB options. 26 | , _stopOnDatabaseError :: Bool 27 | -- ^ The node will stop if something wrong with DB model. 28 | } 29 | deriving (Show, Generic) 30 | 31 | data GraphServiceConfig = GraphServiceConfig 32 | { _graphWindowConfig :: GraphWindowConfig 33 | , _dbConfig :: DBConfig 34 | , _rpcSynco :: Maybe D.Address 35 | } 36 | deriving (Show, Generic) 37 | 38 | instance ToJSON DBConfig where toJSON = A.genericToJSON nodeConfigJsonOptions 39 | instance FromJSON DBConfig where parseJSON = A.genericParseJSON nodeConfigJsonOptions 40 | instance ToJSON GraphWindowConfig where toJSON = A.genericToJSON nodeConfigJsonOptions 41 | instance FromJSON GraphWindowConfig where parseJSON = A.genericParseJSON nodeConfigJsonOptions 42 | instance ToJSON GraphServiceConfig where toJSON = A.genericToJSON nodeConfigJsonOptions 43 | instance FromJSON GraphServiceConfig where parseJSON = A.genericParseJSON nodeConfigJsonOptions 44 | 45 | noDBConfig :: DBConfig 46 | noDBConfig = DBConfig 47 | { _useDatabase = False 48 | , _dbModelName = "" 49 | , _useEnqHomeDir = False 50 | , _dbOptions = D.DBOptions True True 51 | , _stopOnDatabaseError = True 52 | } 53 | 54 | noGraphShrinking :: GraphWindowConfig 55 | noGraphShrinking = GraphWindowConfig 56 | { _shrinkingEnabled = False 57 | , _shrinkingDelay = 1000 * 1000 58 | , _windowSize = 10 59 | } 60 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/GraphService/DB/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Assets.Nodes.GraphService.DB.Helpers where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Enecuum.Samples.Blockchain.DB as D 6 | import qualified Enecuum.Samples.Blockchain.DB.Lens as Lens 7 | import qualified Enecuum.Samples.Blockchain.Lens as Lens 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Language as L 10 | 11 | import Enecuum.Samples.Assets.Nodes.GraphService.GraphServiceData (GraphServiceData (..)) 12 | 13 | withKBlocksDB 14 | :: forall s db a 15 | . Lens.HasKBlocksDB s (D.Storage db) 16 | => s 17 | -> L.DatabaseL db a 18 | -> L.NodeL a 19 | withKBlocksDB dbModel = L.withDatabase (dbModel ^. Lens.kBlocksDB) 20 | 21 | withKBlocksMetaDB 22 | :: forall s db a 23 | . Lens.HasKBlocksMetaDB s (D.Storage db) 24 | => s 25 | -> L.DatabaseL db a 26 | -> L.NodeL a 27 | withKBlocksMetaDB dbModel = L.withDatabase (dbModel ^. Lens.kBlocksMetaDB) 28 | 29 | withMBlocksDB 30 | :: forall s db a 31 | . Lens.HasMBlocksDB s (D.Storage db) 32 | => s 33 | -> L.DatabaseL db a 34 | -> L.NodeL a 35 | withMBlocksDB dbModel = L.withDatabase (dbModel ^. Lens.mBlocksDB) 36 | 37 | withMBlocksMetaDB 38 | :: forall s db a 39 | . Lens.HasMBlocksMetaDB s (D.Storage db) 40 | => s 41 | -> L.DatabaseL db a 42 | -> L.NodeL a 43 | withMBlocksMetaDB dbModel = L.withDatabase (dbModel ^. Lens.mBlocksMetaDB) 44 | 45 | withTransactionsDB 46 | :: forall s db a 47 | . Lens.HasTransactionsDB s (D.Storage db) 48 | => s 49 | -> L.DatabaseL db a 50 | -> L.NodeL a 51 | withTransactionsDB dbModel = L.withDatabase (dbModel ^. Lens.transactionsDB) 52 | 53 | withTransactionsMetaDB 54 | :: forall s db a 55 | . Lens.HasTransactionsMetaDB s (D.Storage db) 56 | => s 57 | -> L.DatabaseL db a 58 | -> L.NodeL a 59 | withTransactionsMetaDB dbModel = L.withDatabase (dbModel ^. Lens.transactionsMetaDB) 60 | 61 | withDBModel :: GraphServiceData -> (D.DBModel -> L.NodeL ()) -> L.NodeL () 62 | withDBModel (_db -> Just dbModel) act = act dbModel 63 | withDBModel _ _ = pure () 64 | 65 | -- | On `Right val`, evals `action` with `val`. 66 | -- On `Left err`, returns `Left err`. 67 | withResult 68 | :: Applicative f 69 | => Either a t 70 | -> (t -> f (Either a b)) 71 | -> f (Either a b) 72 | withResult (Left err) _ = pure $ Left err 73 | withResult (Right result) action = action result 74 | 75 | -- | On `Right val`, evals `action` with `val` and returns a list of successes. 76 | -- On `Left err`, logs error except it is KeyNotFound and returns empty list. 77 | materialize 78 | :: Monad m 79 | => L.Logger m 80 | => D.DBResult t 81 | -> (t -> m [b]) 82 | -> m [b] 83 | materialize (Right result) action = action result 84 | materialize (Left (D.DBError D.KeyNotFound _)) _ = pure [] 85 | materialize (Left err) _ = do 86 | L.logError $ show err 87 | pure [] 88 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/GraphService/GraphServiceData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Enecuum.Samples.Assets.Nodes.GraphService.GraphServiceData where 8 | 9 | import Enecuum.Prelude 10 | 11 | import Enecuum.Samples.Assets.Nodes.GraphService.Config 12 | import qualified Enecuum.Samples.Blockchain.DB as D 13 | import qualified Enecuum.Domain as D 14 | import Enecuum.Samples.Blockchain.Domain as D 15 | 16 | data GraphServiceData = GraphServiceData 17 | { _blockchain :: D.BlockchainData 18 | , _db :: Maybe D.DBModel 19 | , _dumpToDBSignal :: D.StateVar Bool 20 | , _restoreFromDBSignal :: D.StateVar Bool 21 | , _checkPendingSignal :: D.StateVar Bool 22 | } 23 | 24 | makeFieldsNoPrefix ''GraphServiceData 25 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/Methods.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Assets.Nodes.Methods where 2 | 3 | import qualified Enecuum.Samples.Assets.Nodes.Messages as M 4 | import qualified Enecuum.Domain as D 5 | import qualified Enecuum.Language as L 6 | import Enecuum.Prelude 7 | 8 | 9 | methodPing :: (L.Send con f, Functor f) => D.Ping -> con -> f () 10 | methodPing D.Ping conn = void $ L.send conn D.Pong 11 | 12 | rpcPingPong :: Applicative f => D.Ping -> f D.Pong 13 | rpcPingPong D.Ping = pure D.Pong 14 | 15 | handleStopNode 16 | :: L.HasStatus s (D.StateVar D.NodeStatus) 17 | => s -> D.Stop -> Free L.NodeF D.SuccessMsg 18 | handleStopNode nodeData D.Stop = L.stopNode nodeData >> pure D.SuccessMsg 19 | 20 | portError :: D.PortNumber -> Text -> Text 21 | portError port protocol = 22 | "Port " <> show port <> " (for " <> protocol <> " server) is alredy used." 23 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/TstNodes/GenPoA/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module Enecuum.Samples.Assets.Nodes.TstNodes.GenPoA.Config where 4 | 5 | import qualified Data.Aeson as A 6 | import Enecuum.Samples.Assets.Nodes.Address 7 | import Enecuum.Config 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Framework.Lens as Lens 10 | import Enecuum.Prelude 11 | 12 | 13 | data TstGenPoANode = TstGenPoANode 14 | deriving (Show, Generic) 15 | 16 | data instance NodeConfig TstGenPoANode = TstGenPoANodeConfig 17 | { _controlRpcPort :: D.PortNumber 18 | , _genPoaGraphNodeUDPAddress :: D.Address 19 | , _genPoaGraphNodeRPCAddress :: D.Address 20 | } 21 | deriving (Show, Generic) 22 | 23 | instance ToJSON TstGenPoANode where toJSON = A.genericToJSON nodeConfigJsonOptions 24 | instance FromJSON TstGenPoANode where parseJSON = A.genericParseJSON nodeConfigJsonOptions 25 | instance ToJSON (NodeConfig TstGenPoANode) where toJSON = A.genericToJSON nodeConfigJsonOptions 26 | instance FromJSON (NodeConfig TstGenPoANode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions 27 | 28 | tstGenPoANodeConfig :: NodeConfig TstGenPoANode 29 | tstGenPoANodeConfig = TstGenPoANodeConfig 30 | (tstGenPoANodePorts ^. Lens.nodeRpcPort) 31 | (getUdpAddress tstGraphNodeTransmitterAddress) 32 | (getRpcAddress tstGraphNodeTransmitterAddress) 33 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/TstNodes/GenPoW/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module Enecuum.Samples.Assets.Nodes.TstNodes.GenPoW.Config where 4 | 5 | import qualified Data.Aeson as J 6 | import qualified Enecuum.Samples.Assets.Blockchain.Generation as A 7 | import Enecuum.Samples.Assets.Nodes.Address 8 | import Enecuum.Config 9 | import qualified Enecuum.Domain as D 10 | import qualified Enecuum.Framework.Lens as Lens 11 | import Enecuum.Prelude 12 | 13 | type BlocksDelay = Int 14 | 15 | data TstGenPoWNode = TstGenPoWNode 16 | deriving (Show, Generic) 17 | 18 | data instance NodeConfig TstGenPoWNode = TstGenPoWNodeConfig 19 | { _defaultBlocksDelay :: BlocksDelay 20 | , _kblocksOrder :: A.Ordering 21 | , _genPowGraphNodeUDPAddress :: D.Address 22 | , _controlRpcPort :: D.PortNumber 23 | } 24 | deriving (Show, Generic) 25 | 26 | instance ToJSON (NodeConfig TstGenPoWNode) where toJSON = J.genericToJSON nodeConfigJsonOptions 27 | instance FromJSON (NodeConfig TstGenPoWNode) where parseJSON = J.genericParseJSON nodeConfigJsonOptions 28 | instance ToJSON TstGenPoWNode where toJSON = J.genericToJSON nodeConfigJsonOptions 29 | instance FromJSON TstGenPoWNode where parseJSON = J.genericParseJSON nodeConfigJsonOptions 30 | 31 | tstGenPoWNodeConfig :: NodeConfig TstGenPoWNode 32 | tstGenPoWNodeConfig = TstGenPoWNodeConfig 33 | { _defaultBlocksDelay = 1000 * 1000 34 | , _kblocksOrder = A.InOrder 35 | , _genPowGraphNodeUDPAddress = getUdpAddress tstGraphNodeTransmitterAddress 36 | , _controlRpcPort = tstGenPoWNodePorts ^. Lens.nodeRpcPort 37 | } 38 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/TstNodes/GraphNode/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | module Enecuum.Samples.Assets.Nodes.TstNodes.GraphNode.Config where 3 | 4 | import qualified Data.Aeson as A 5 | import Enecuum.Samples.Assets.Nodes.Address 6 | import Enecuum.Samples.Assets.Nodes.GraphService.Config 7 | import Enecuum.Config 8 | import Enecuum.Domain (NodePorts (..)) 9 | import qualified Enecuum.Domain as D 10 | import Enecuum.Prelude 11 | 12 | data TstGraphNode = TstGraphNode 13 | deriving (Show, Generic) 14 | 15 | data instance NodeConfig TstGraphNode = TstGraphNodeConfig 16 | { _graphServiceConfig :: GraphServiceConfig 17 | , _nodePorts :: NodePorts 18 | } 19 | deriving (Show, Generic) 20 | 21 | instance ToJSON TstGraphNode where toJSON = A.genericToJSON nodeConfigJsonOptions 22 | instance FromJSON TstGraphNode where parseJSON = A.genericParseJSON nodeConfigJsonOptions 23 | instance ToJSON (NodeConfig TstGraphNode) where toJSON = A.genericToJSON nodeConfigJsonOptions 24 | instance FromJSON (NodeConfig TstGraphNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions 25 | 26 | 27 | tstGraphNodeTransmitterConfig :: D.NodeConfig TstGraphNode 28 | tstGraphNodeTransmitterConfig = TstGraphNodeConfig 29 | { _graphServiceConfig = GraphServiceConfig 30 | { _graphWindowConfig = noGraphShrinking 31 | , _dbConfig = noDBConfig 32 | , _rpcSynco = Nothing 33 | } 34 | , _nodePorts = tstGraphNodeTransmitterPorts 35 | } 36 | 37 | tstGraphNodeReceiverConfig :: D.NodeConfig TstGraphNode 38 | tstGraphNodeReceiverConfig = TstGraphNodeConfig 39 | { _graphServiceConfig = GraphServiceConfig 40 | { _graphWindowConfig = noGraphShrinking 41 | , _dbConfig = noDBConfig 42 | , _rpcSynco = Just $ getRpcAddress tstGraphNodeTransmitterAddress 43 | } 44 | , _nodePorts = tstGraphNodeReceiverPorts 45 | } 46 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/TstNodes/PingPong/Messages.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | module Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.Messages where 4 | 5 | import Enecuum.Prelude 6 | 7 | newtype Ping = Ping Text 8 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 9 | 10 | newtype Pong = Pong Int 11 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 12 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/TstNodes/PingPong/PingServer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.PingServer where 5 | 6 | import qualified Data.Aeson as A 7 | import Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.Messages 8 | import Enecuum.Config 9 | import qualified Enecuum.Domain as D 10 | import qualified Enecuum.Language as L 11 | import Enecuum.Prelude 12 | 13 | data PingServerNode = PingServerNode 14 | deriving (Show, Generic) 15 | 16 | data instance NodeConfig PingServerNode = PingServerNodeConfig 17 | { _stopOnPing :: Int 18 | , _servingPort :: D.PortNumber 19 | } 20 | deriving (Show, Generic) 21 | 22 | instance Node PingServerNode where 23 | data NodeScenario PingServerNode = PingServer 24 | deriving (Show, Generic) 25 | getNodeScript _ = pingServerNode 26 | getNodeTag _ = PingServerNode 27 | 28 | instance ToJSON PingServerNode where toJSON = A.genericToJSON nodeConfigJsonOptions 29 | instance FromJSON PingServerNode where parseJSON = A.genericParseJSON nodeConfigJsonOptions 30 | instance ToJSON (NodeConfig PingServerNode) where toJSON = A.genericToJSON nodeConfigJsonOptions 31 | instance FromJSON (NodeConfig PingServerNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions 32 | instance ToJSON (NodeScenario PingServerNode) where toJSON = A.genericToJSON nodeConfigJsonOptions 33 | instance FromJSON (NodeScenario PingServerNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions 34 | 35 | -- Handling Ping messages. 36 | acceptPing 37 | :: D.StateVar D.NodeStatus 38 | -> D.StateVar Int 39 | -> Int 40 | -> Ping 41 | -> D.Connection D.Udp 42 | -> L.NodeL () 43 | acceptPing status pingsCount threshold (Ping clientName) conn = do 44 | pings <- L.atomically $ do 45 | L.modifyVar pingsCount (+1) 46 | L.readVar pingsCount 47 | 48 | let done = pings + 1 >= threshold 49 | when done $ do 50 | L.close conn 51 | L.writeVarIO status D.NodeFinished 52 | L.logInfo $ "Pings threshold reached: " +|| threshold ||+ ". Finishing." 53 | 54 | unless done $ do 55 | L.send conn (Pong pings) 56 | L.logInfo $ "Ping #" +|| pings ||+ " accepted from " +|| clientName ||+ "." 57 | 58 | -- Ping server definition node. 59 | pingServerNode :: NodeConfig PingServerNode -> L.NodeDefinitionL () 60 | pingServerNode cfg = do 61 | let threshold = _stopOnPing cfg 62 | let port = _servingPort cfg 63 | 64 | pingsCount <- L.newVarIO 0 65 | status <- L.newVarIO D.NodeActing 66 | 67 | -- Starting a separate process for serving on UDP port. 68 | L.serving D.Udp port $ 69 | L.handler $ acceptPing status pingsCount threshold 70 | 71 | L.awaitNodeFinished' status 72 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/Nodes/TstNodes/PingPong/PongClient.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.PongClient where 5 | 6 | import qualified Data.Aeson as A 7 | import Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.Messages 8 | import Enecuum.Config 9 | import qualified Enecuum.Domain as D 10 | import qualified Enecuum.Language as L 11 | import Enecuum.Prelude 12 | 13 | data PongClientNode = PongClientNode 14 | deriving (Show, Generic) 15 | 16 | data instance NodeConfig PongClientNode = PongClientNodeConfig 17 | { _clientName :: Text 18 | , _pingDelay :: Int 19 | , _pingServerAddress :: D.Address 20 | } 21 | deriving (Show, Generic) 22 | 23 | instance Node PongClientNode where 24 | data NodeScenario PongClientNode = PongClient 25 | deriving (Show, Generic) 26 | getNodeScript _ = pongClientNode 27 | getNodeTag _ = PongClientNode 28 | 29 | instance ToJSON PongClientNode where toJSON = A.genericToJSON nodeConfigJsonOptions 30 | instance FromJSON PongClientNode where parseJSON = A.genericParseJSON nodeConfigJsonOptions 31 | instance ToJSON (NodeConfig PongClientNode) where toJSON = A.genericToJSON nodeConfigJsonOptions 32 | instance FromJSON (NodeConfig PongClientNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions 33 | instance ToJSON (NodeScenario PongClientNode) where toJSON = A.genericToJSON nodeConfigJsonOptions 34 | instance FromJSON (NodeScenario PongClientNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions 35 | 36 | -- Accepting pong responses from the server. 37 | acceptPong :: Pong -> connection -> L.NodeL () 38 | acceptPong (Pong pingsCount) _ = 39 | L.logInfo $ "Pong accepted from server. Pings count: " <> show pingsCount 40 | 41 | -- Sending pings to the server. 42 | pingSending :: D.StateVar D.NodeStatus -> NodeConfig PongClientNode -> D.Connection D.Udp -> L.NodeL () 43 | pingSending status cfg conn = do 44 | L.delay $ _pingDelay cfg 45 | L.logInfo "Sending Ping to the server." 46 | eSent <- L.send conn (Ping $ _clientName cfg) 47 | case eSent of 48 | Right () -> pingSending status cfg conn 49 | Left _ -> do 50 | L.logInfo "Server is gone." 51 | L.close conn 52 | L.writeVarIO status D.NodeFinished 53 | 54 | -- Pong client definition node. 55 | pongClientNode :: NodeConfig PongClientNode -> L.NodeDefinitionL () 56 | pongClientNode cfg = do 57 | status <- L.newVarIO D.NodeActing 58 | 59 | -- Connecting to the server. 60 | mbConn <- L.open D.Udp (_pingServerAddress cfg) $ 61 | L.handler acceptPong 62 | 63 | case mbConn of 64 | Nothing -> L.logError "Ping Server not found" 65 | Just conn -> do 66 | -- Forking separate process of periodical pings. 67 | L.process (pingSending status cfg conn) 68 | -- Waiting when the node is finished. 69 | L.awaitNodeFinished' status 70 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/System/Directory.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Assets.System.Directory where 2 | 3 | import qualified Enecuum.Core.Language as L 4 | import Enecuum.Prelude 5 | import System.FilePath (()) 6 | 7 | getEnecuumDir :: (L.FileSystem m, Monad m) => m FilePath 8 | getEnecuumDir = L.createFilePath =<< ( ".enecuum") <$> L.getHomeDirectory 9 | 10 | keysFilePath :: (L.FileSystem m, Monad m) => m FilePath 11 | keysFilePath = ( "keys.json") <$> getEnecuumDir 12 | 13 | wrongKeysFilePath :: (L.FileSystem m, Monad m) => m FilePath 14 | wrongKeysFilePath = ( "wrongKeys.txt") <$> getEnecuumDir 15 | 16 | logFilePath :: (L.FileSystem m, Monad m) => m FilePath 17 | logFilePath = L.createFilePath =<< ( "data" "logs") <$> getEnecuumDir 18 | 19 | storyFilePath :: (L.FileSystem m, Monad m) => m FilePath 20 | storyFilePath = L.createFilePath =<< ( "story") <$> getEnecuumDir 21 | 22 | appFileName :: (L.FileSystem m, Monad m) => m FilePath 23 | appFileName = L.createFilePath =<< ( "data" "logs" "app.log") <$> getEnecuumDir 24 | 25 | clientStory :: (L.FileSystem m, Monad m) => m FilePath 26 | clientStory = ( "client.story") <$> storyFilePath 27 | 28 | configDir :: FilePath 29 | configDir = "configs" -------------------------------------------------------------------------------- /src/Enecuum/Samples/Assets/TstScenarios.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Assets.TstScenarios ( 2 | module X 3 | ) where 4 | 5 | import Enecuum.Samples.Assets.Nodes.Client as X 6 | 7 | import Enecuum.Samples.Assets.Nodes.TstNodes.GenPoA.Config as X 8 | import Enecuum.Samples.Assets.Nodes.TstNodes.GenPoA.Node as X 9 | import Enecuum.Samples.Assets.Nodes.TstNodes.GenPoW.Config as X 10 | import Enecuum.Samples.Assets.Nodes.TstNodes.GenPoW.Node as X 11 | import Enecuum.Samples.Assets.Nodes.TstNodes.GraphNode.Config as X 12 | import Enecuum.Samples.Assets.Nodes.TstNodes.GraphNode.Node as X 13 | 14 | import Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.PingServer as X 15 | import Enecuum.Samples.Assets.Nodes.TstNodes.PingPong.PongClient as X 16 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.DB 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Samples.Blockchain.DB.Entities as X 6 | import Enecuum.Samples.Blockchain.DB.Model as X 7 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Entities.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.DB.Entities 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Samples.Blockchain.DB.Entities.KBlock as X 6 | import Enecuum.Samples.Blockchain.DB.Entities.KBlockMeta as X 7 | import Enecuum.Samples.Blockchain.DB.Entities.MBlock as X 8 | import Enecuum.Samples.Blockchain.DB.Entities.MBlockMeta as X 9 | import Enecuum.Samples.Blockchain.DB.Entities.Transaction as X 10 | import Enecuum.Samples.Blockchain.DB.Entities.TransactionMeta as X 11 | import Enecuum.Samples.Blockchain.DB.Entities.Types as X 12 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Entities/KBlockMeta.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Blockchain.DB.Entities.KBlockMeta where 5 | 6 | import qualified Data.Aeson as A 7 | import qualified Data.ByteString.Lazy as LBS 8 | import Enecuum.Prelude 9 | 10 | import Enecuum.Samples.Blockchain.DB.Model (KBlocksMetaDB) 11 | import qualified Enecuum.Samples.Blockchain.Domain.KBlock as D 12 | import qualified Enecuum.Core.Types as D 13 | 14 | -- kBlocks_meta (kBlock_hash -> kBlock_meta) 15 | -- ----------------------------------------------------------------- 16 | -- AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA= (0, "") 17 | -- 4z9ADFAWehl6XGW2/N+2keOgNR921st3oPSVxv08hTY= (1, "") 18 | 19 | data KBlockMetaEntity 20 | 21 | instance D.DBModelEntity KBlocksMetaDB KBlockMetaEntity 22 | 23 | instance D.DBEntity KBlockMetaEntity where 24 | data DBKey KBlockMetaEntity = KBlockMetaKey D.StringHash 25 | deriving (Show, Eq, Ord) 26 | data DBValue KBlockMetaEntity = KBlockMetaValue D.BlockNumber 27 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 28 | 29 | instance D.ToDBKey KBlockMetaEntity D.KBlock where 30 | toDBKey = KBlockMetaKey . D._prevHash 31 | 32 | instance D.ToDBValue KBlockMetaEntity D.KBlock where 33 | toDBValue kBlock = KBlockMetaValue $ D._number kBlock 34 | 35 | instance D.ToDBKey KBlockMetaEntity D.StringHash where 36 | toDBKey = KBlockMetaKey 37 | 38 | instance D.RawDBEntity KBlocksMetaDB KBlockMetaEntity where 39 | toRawDBKey (KBlockMetaKey k) = D.fromStringHash k 40 | toRawDBValue = LBS.toStrict . A.encode 41 | fromRawDBValue = A.decode . LBS.fromStrict 42 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Entities/MBlock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Blockchain.DB.Entities.MBlock where 5 | 6 | import qualified Data.Aeson as A 7 | import qualified Data.ByteString.Lazy as LBS 8 | import Enecuum.Prelude 9 | import Text.Printf (printf) 10 | 11 | import Enecuum.Samples.Blockchain.DB.Entities.KBlock (toKBlockIdxBase) 12 | import Enecuum.Samples.Blockchain.DB.Entities.Types (KBlockIdx, MBlockIdx) 13 | import Enecuum.Samples.Blockchain.DB.Model (MBlocksDB) 14 | import qualified Enecuum.Samples.Blockchain.Domain.KBlock as D 15 | import qualified Enecuum.Samples.Blockchain.Domain.Microblock as D 16 | import qualified Enecuum.Samples.Blockchain.Domain.Transaction as D 17 | import qualified Enecuum.Samples.Blockchain.Lens as Lens 18 | import qualified Enecuum.Core.Types as D 19 | 20 | 21 | -- mBlocks (kBlock_idx|mBlock_idx -> mBlock_data) 22 | -- -------------------------------------------------------------------- 23 | -- 0000001|001 {publisher: 3, signature: } 24 | -- 0000001|002 {publisher: 5, signature: } 25 | -- 0000002|001 {publisher: 1, signature: } 26 | 27 | data MBlockEntity 28 | 29 | instance D.DBModelEntity MBlocksDB MBlockEntity 30 | 31 | instance D.DBEntity MBlockEntity where 32 | data DBKey MBlockEntity = MBlockKey (KBlockIdx, MBlockIdx) 33 | deriving (Show, Eq, Ord) 34 | 35 | data DBValue MBlockEntity = MBlockValue 36 | { publisher :: D.PublicKey -- Temporarily not an index 37 | , signature :: D.Signature 38 | } 39 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 40 | 41 | instance D.ToDBKey MBlockEntity (KBlockIdx, MBlockIdx) where 42 | toDBKey = MBlockKey 43 | 44 | instance D.ToDBValue MBlockEntity D.Microblock where 45 | toDBValue mBlock = MBlockValue (mBlock ^. Lens.publisher) (mBlock ^. Lens.signature) 46 | 47 | instance D.RawDBEntity MBlocksDB MBlockEntity where 48 | toRawDBKey (MBlockKey (kBlockIdx, mBlockIdx)) = encodeUtf8 $ toKBlockIdxBase kBlockIdx <> toMBlockIdxBase mBlockIdx 49 | toRawDBValue = LBS.toStrict . A.encode 50 | fromRawDBValue = A.decode . LBS.fromStrict 51 | 52 | toMBlockIdxBase :: MBlockIdx -> String 53 | toMBlockIdxBase = printf "%03d" 54 | 55 | fromDBMBlock 56 | :: D.DBValue MBlockEntity 57 | -> D.StringHash 58 | -> [D.Transaction] 59 | -> D.Microblock 60 | fromDBMBlock (MBlockValue publisher signature) kBlockHash txs = D.Microblock 61 | { D._keyBlock = kBlockHash 62 | , D._transactions = txs 63 | , D._publisher = publisher 64 | , D._signature = signature 65 | } 66 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Entities/MBlockMeta.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Blockchain.DB.Entities.MBlockMeta where 5 | 6 | import qualified Data.Aeson as A 7 | import qualified Data.ByteString.Lazy as LBS 8 | import Enecuum.Prelude 9 | import Text.Printf (printf) 10 | 11 | import Enecuum.Samples.Blockchain.DB.Entities.Types (KBlockIdx, MBlockIdx) 12 | import Enecuum.Samples.Blockchain.DB.Model (MBlocksMetaDB) 13 | import qualified Enecuum.Samples.Blockchain.Domain.KBlock as D 14 | import qualified Enecuum.Samples.Blockchain.Domain.Microblock as D 15 | import qualified Enecuum.Samples.Blockchain.Lens as Lens 16 | import qualified Enecuum.Core.Types as D 17 | 18 | 19 | -- mBlocks_meta (mBlock_hash -> mBlock_meta) 20 | -- mBlockMeta: (kBlock_idx, mBlock_idx, some_meta) 21 | -- -------------------------------------------------------------------- 22 | -- (1, 1, "") 23 | -- (1, 2, "") 24 | -- (2, 1, "") 25 | 26 | data MBlockMetaEntity 27 | 28 | instance D.DBModelEntity MBlocksMetaDB MBlockMetaEntity 29 | 30 | instance D.DBEntity MBlockMetaEntity where 31 | data DBKey MBlockMetaEntity = MBlockMetaKey D.StringHash 32 | deriving (Show, Eq, Ord) 33 | data DBValue MBlockMetaEntity = MBlockMetaValue (KBlockIdx, MBlockIdx) 34 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 35 | 36 | instance D.ToDBKey MBlockMetaEntity D.Microblock where 37 | toDBKey = MBlockMetaKey . D.toHash 38 | 39 | instance D.ToDBValue MBlockMetaEntity (KBlockIdx, MBlockIdx) where 40 | toDBValue = MBlockMetaValue 41 | 42 | instance D.RawDBEntity MBlocksMetaDB MBlockMetaEntity where 43 | toRawDBKey (MBlockMetaKey k) = D.fromStringHash k 44 | toRawDBValue = LBS.toStrict . A.encode 45 | fromRawDBValue = A.decode . LBS.fromStrict 46 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Entities/TransactionMeta.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Blockchain.DB.Entities.TransactionMeta where 5 | 6 | import qualified Data.Aeson as A 7 | import qualified Data.ByteString.Lazy as LBS 8 | import Enecuum.Prelude 9 | import Text.Printf (printf) 10 | 11 | import Enecuum.Samples.Blockchain.DB.Entities.Types (KBlockIdx, MBlockIdx, TransactionIdx) 12 | import Enecuum.Samples.Blockchain.DB.Model (TransactionsMetaDB) 13 | import qualified Enecuum.Samples.Blockchain.Domain.KBlock as D 14 | import qualified Enecuum.Samples.Blockchain.Domain.Microblock as D 15 | import qualified Enecuum.Samples.Blockchain.Domain.Transaction as D 16 | import qualified Enecuum.Samples.Blockchain.Lens as Lens 17 | import qualified Enecuum.Core.Types as D 18 | 19 | 20 | -- txs_meta (tx_hash -> tx_meta) 21 | -- tx_meta: (kBlock_idx, mBlock_idx, tx_idx, some_meta) 22 | -- -------------------------------------------------------------------- 23 | -- (1, 1, 1, "") 24 | -- (1, 1, 2, "") 25 | -- (2, 1, 1, "") 26 | 27 | data TransactionMetaEntity 28 | 29 | instance D.DBModelEntity TransactionsMetaDB TransactionMetaEntity 30 | 31 | instance D.DBEntity TransactionMetaEntity where 32 | data DBKey TransactionMetaEntity = TransactionMetaKey D.StringHash 33 | deriving (Show, Eq, Ord) 34 | data DBValue TransactionMetaEntity = TransactionMetaValue (KBlockIdx, MBlockIdx, TransactionIdx) 35 | deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON) 36 | 37 | instance D.ToDBKey TransactionMetaEntity D.Transaction where 38 | toDBKey = TransactionMetaKey . D.toHash 39 | 40 | instance D.ToDBValue TransactionMetaEntity (KBlockIdx, MBlockIdx, TransactionIdx) where 41 | toDBValue = TransactionMetaValue 42 | 43 | instance D.RawDBEntity TransactionsMetaDB TransactionMetaEntity where 44 | toRawDBKey (TransactionMetaKey k) = D.fromStringHash k 45 | toRawDBValue = LBS.toStrict . A.encode 46 | fromRawDBValue = A.decode . LBS.fromStrict 47 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Entities/Types.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.DB.Entities.Types where 2 | 3 | import Enecuum.Prelude 4 | import qualified Enecuum.Samples.Blockchain.Domain.KBlock as D 5 | 6 | type KBlockIdx = D.BlockNumber 7 | type MBlockIdx = D.BlockNumber 8 | type TransactionIdx = Word32 9 | type DBIndex = Word32 -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Enecuum.Samples.Blockchain.DB.Lens where 5 | 6 | import Enecuum.Prelude 7 | import Control.Lens (Getter, to, makeFieldsNoPrefix) 8 | 9 | import Enecuum.Samples.Blockchain.DB.Model 10 | import Enecuum.Samples.Blockchain.DB.Entities 11 | import qualified Enecuum.Core.Types as D 12 | import qualified Enecuum.Samples.Blockchain.Domain as D 13 | 14 | makeFieldsNoPrefix ''DBModel 15 | 16 | 17 | time' :: Getter (D.DBResult (D.DBValue KBlockEntity)) (D.DBResult D.BlockTime) 18 | time' = to (\eVal -> eVal >>= (\(KBlockValue t _ _ _) -> Right t)) 19 | 20 | number' :: Getter (D.DBResult (D.DBValue KBlockEntity)) (D.DBResult D.BlockNumber) 21 | number' = to (\eVal -> eVal >>= (\(KBlockValue _ n _ _) -> Right n)) 22 | 23 | nonce' :: Getter (D.DBResult (D.DBValue KBlockEntity)) (D.DBResult D.Nonce) 24 | nonce' = to (\eVal -> eVal >>= (\(KBlockValue _ _ n _) -> Right n)) 25 | 26 | solver' :: Getter (D.DBResult (D.DBValue KBlockEntity)) (D.DBResult D.Solver) 27 | solver' = to (\eVal -> eVal >>= (\(KBlockValue _ _ _ s) -> Right s)) 28 | 29 | prevHash' :: Getter (D.DBResult (D.DBValue KBlockPrevHashEntity)) (D.DBResult D.PrevHash) 30 | prevHash' = to (\eVal -> eVal >>= (\(KBlockPrevHashValue ph) -> Right ph)) 31 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/DB/Model.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.DB.Model where 2 | 3 | import qualified Enecuum.Core.Types as D 4 | 5 | data KBlocksDB 6 | instance D.DB KBlocksDB where 7 | getDbName = "kblocks" 8 | 9 | data KBlocksMetaDB 10 | instance D.DB KBlocksMetaDB where 11 | getDbName = "kblocks_meta" 12 | 13 | data MBlocksDB 14 | instance D.DB MBlocksDB where 15 | getDbName = "mblocks" 16 | 17 | data MBlocksMetaDB 18 | instance D.DB MBlocksMetaDB where 19 | getDbName = "mblocks_meta" 20 | 21 | data TransactionsDB 22 | instance D.DB TransactionsDB where 23 | getDbName = "txs" 24 | 25 | data TransactionsMetaDB 26 | instance D.DB TransactionsMetaDB where 27 | getDbName = "txs_meta" 28 | 29 | data DBModel = DBModel 30 | { _kBlocksDB :: D.Storage KBlocksDB 31 | , _kBlocksMetaDB :: D.Storage KBlocksMetaDB 32 | , _mBlocksDB :: D.Storage MBlocksDB 33 | , _mBlocksMetaDB :: D.Storage MBlocksMetaDB 34 | , _transactionsDB :: D.Storage TransactionsDB 35 | , _transactionsMetaDB :: D.Storage TransactionsMetaDB 36 | } 37 | 38 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.Domain 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Samples.Blockchain.Domain.KBlock as X 6 | import Enecuum.Samples.Blockchain.Domain.Transaction as X 7 | import Enecuum.Samples.Blockchain.Domain.Graph as X 8 | import Enecuum.Samples.Blockchain.Domain.Microblock as X 9 | import Enecuum.Core.Crypto.Crypto as X 10 | import Enecuum.Samples.Blockchain.Domain.Types as X 11 | import Enecuum.Samples.Blockchain.Domain.BlockchainData as X 12 | import Enecuum.Samples.Blockchain.Domain.Internal as X (signTransaction, signMicroblock) -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/BlockchainData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module Enecuum.Samples.Blockchain.Domain.BlockchainData where 4 | 5 | import Data.HGraph.StringHashable (StringHash) 6 | import qualified Data.Map as Map 7 | import Enecuum.Samples.Blockchain.Domain.Graph (GraphVar) 8 | import Enecuum.Samples.Blockchain.Domain.KBlock (BlockNumber, KBlock) 9 | import Enecuum.Samples.Blockchain.Domain.Transaction (Transaction) 10 | import Enecuum.Samples.Blockchain.Domain.Types (Amount) 11 | import Enecuum.Core.Crypto.Crypto (PublicKey) 12 | import Enecuum.Core.Types (StateVar) 13 | import Enecuum.Prelude 14 | 15 | type WalletID = PublicKey 16 | type Ledger = Map WalletID Amount 17 | type TransactionPending = Map StringHash Transaction 18 | 19 | -- Currently, pending allows only a single KBlock on each graph level (no forks) 20 | type KBlockPending = Map.Map BlockNumber KBlock 21 | 22 | data WindowedGraph = WindowedGraph 23 | { _graph :: GraphVar 24 | , _bottomKBlockHash :: StateVar StringHash 25 | , _topKBlockHash :: StateVar StringHash 26 | } 27 | 28 | data BlockchainData = BlockchainData 29 | { _windowedGraph :: WindowedGraph 30 | , _kBlockPending :: StateVar KBlockPending 31 | , _transactionPending :: StateVar TransactionPending 32 | , _ledger :: StateVar Ledger 33 | } 34 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Blockchain.Domain.Graph where 5 | 6 | import Data.HGraph.StringHashable (StringHashable, toHash) 7 | 8 | import qualified Enecuum.Samples.Blockchain.Domain.KBlock as D 9 | import qualified Enecuum.Samples.Blockchain.Domain.Microblock as D 10 | 11 | import Enecuum.Core.HGraph.Internal.Impl (initHGraph) 12 | import qualified Enecuum.Core.HGraph.Internal.Types as T 13 | import Enecuum.Core.HGraph.Interpreters.IO (runHGraphIO) 14 | import qualified Enecuum.Core.Language as L 15 | import qualified Enecuum.Core.Types as D 16 | import Enecuum.Prelude 17 | 18 | data NodeContent 19 | = KBlockContent D.KBlock 20 | | MBlockContent D.Microblock 21 | deriving (Show, Eq, Generic, ToJSON, FromJSON, Serialize) 22 | 23 | instance StringHashable NodeContent where 24 | toHash (KBlockContent block) = toHash block 25 | toHash (MBlockContent block) = toHash block 26 | 27 | type GraphVar = D.TGraph NodeContent 28 | type GraphL a = L.HGraphL NodeContent a 29 | type GraphNode = T.TNodeL NodeContent 30 | 31 | initGraph :: IO GraphVar 32 | initGraph = do 33 | graph <- initHGraph 34 | runHGraphIO graph $ L.newNode $ KBlockContent D.genesisKBlock 35 | pure graph 36 | 37 | isKBlockNode :: GraphNode -> Bool 38 | isKBlockNode (D.HNode _ _ (D.fromContent -> KBlockContent _) _ _) = True 39 | isKBlockNode _ = False 40 | 41 | isMBlockNode :: GraphNode -> Bool 42 | isMBlockNode (D.HNode _ _ (D.fromContent -> MBlockContent _) _ _) = True 43 | isMBlockNode _ = False 44 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Enecuum.Samples.Blockchain.Domain.Internal (signTransaction, transactionForSign, microblockForSign, signMicroblock) where 5 | 6 | import Data.HGraph.StringHashable (StringHash (..)) 7 | import Data.UUID 8 | import Enecuum.Samples.Blockchain.Domain.Microblock 9 | import Enecuum.Samples.Blockchain.Domain.Transaction 10 | import Enecuum.Samples.Blockchain.Domain.Types 11 | import Enecuum.Samples.Blockchain.Domain.UUID () 12 | import Enecuum.Core.Crypto.Crypto 13 | import qualified Enecuum.Core.Language as L 14 | import Enecuum.Prelude 15 | 16 | data TransactionForSign = TransactionForSign 17 | { _owner' :: PublicKey 18 | , _receiver' :: PublicKey 19 | , _amount' :: Amount 20 | , _currency' :: Currency 21 | } 22 | deriving ( Generic, Show, Eq, Ord, Read, ToJSON, FromJSON, Serialize) 23 | 24 | transactionForSign :: Transaction -> TransactionForSign 25 | transactionForSign (Transaction {..}) = TransactionForSign 26 | { _owner' = _owner 27 | , _receiver' = _receiver 28 | , _amount' = _amount 29 | , _currency' = _currency 30 | } 31 | 32 | signTransaction :: (Monad m, L.ERandom m) => OwnerPubKey -> OwnerPrivateKey -> Receiver -> Amount -> Currency -> UUID -> m Transaction 33 | signTransaction owner ownerPriv receiver amount currency uuid = do 34 | let tx = TransactionForSign 35 | { _owner' = owner 36 | , _receiver' = receiver 37 | , _amount' = amount 38 | , _currency' = currency 39 | } 40 | signature <- L.evalCoreCrypto $ L.sign ownerPriv tx 41 | pure $ Transaction 42 | { _owner = owner 43 | , _receiver = receiver 44 | , _amount = amount 45 | , _currency = currency 46 | , _signature = signature 47 | , _uuid = uuid 48 | } 49 | 50 | data MicroblockForSign = MicroblockForSign 51 | { _keyBlock :: StringHash 52 | , _transactions :: [Transaction] 53 | , _publisher :: PublicKey 54 | } 55 | deriving (Eq, Generic, Ord, Read, Show, ToJSON, FromJSON, Serialize) 56 | 57 | microblockForSign :: Microblock -> MicroblockForSign 58 | microblockForSign Microblock {..} = MicroblockForSign 59 | { _keyBlock = _keyBlock 60 | , _transactions = _transactions 61 | , _publisher = _publisher 62 | } 63 | 64 | signMicroblock :: (Monad m, L.ERandom m) => StringHash -> [Transaction] -> PublicKey -> PrivateKey -> m Microblock 65 | signMicroblock hashofKeyBlock tx publisherPubKey publisherPrivKey = do 66 | let mb = MicroblockForSign 67 | { _keyBlock = hashofKeyBlock 68 | , _transactions = tx 69 | , _publisher = publisherPubKey 70 | } 71 | signature <- L.evalCoreCrypto $ L.sign publisherPrivKey mb 72 | pure $ Microblock 73 | { _keyBlock = hashofKeyBlock 74 | , _transactions = tx 75 | , _publisher = publisherPubKey 76 | , _signature = signature 77 | } 78 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/Microblock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | 4 | module Enecuum.Samples.Blockchain.Domain.Microblock where 5 | 6 | import qualified Crypto.Hash.SHA256 as SHA 7 | import qualified Data.ByteString.Base64 as Base64 8 | import Data.HGraph.StringHashable (StringHash (..), StringHashable, toHash) 9 | import qualified Data.Serialize as S 10 | import Enecuum.Samples.Blockchain.Domain.Transaction (Transaction) 11 | import Enecuum.Core.Crypto.Crypto 12 | import Enecuum.Prelude 13 | 14 | 15 | data Microblock = Microblock 16 | { _keyBlock :: StringHash 17 | , _transactions :: [Transaction] 18 | , _publisher :: PublicKey 19 | , _signature :: Signature 20 | } 21 | deriving (Eq, Generic, Ord, Read, Show, ToJSON, FromJSON, Serialize) 22 | 23 | instance StringHashable Microblock where 24 | toHash = StringHash . Base64.encode . SHA.hash . S.encode -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/Transaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | 6 | module Enecuum.Samples.Blockchain.Domain.Transaction where 7 | 8 | import qualified Crypto.Hash.SHA256 as SHA 9 | import qualified Data.ByteString.Base64 as Base64 10 | import Data.HGraph.StringHashable (StringHash (..), StringHashable, toHash) 11 | import qualified Data.Serialize as S 12 | import Data.UUID 13 | import Enecuum.Samples.Blockchain.Domain.Types 14 | import Enecuum.Samples.Blockchain.Domain.UUID () 15 | import Enecuum.Core.Crypto.Crypto 16 | import Enecuum.Prelude hiding (show, unpack) 17 | 18 | type OwnerPubKey = PublicKey 19 | type OwnerPrivateKey = PrivateKey 20 | type Receiver = PublicKey 21 | 22 | data Transaction = Transaction 23 | { _owner :: PublicKey 24 | , _receiver :: PublicKey 25 | , _amount :: Amount 26 | , _currency :: Currency 27 | , _signature :: Signature 28 | , _uuid :: UUID 29 | } 30 | deriving ( Generic, Show, Eq, Ord, Read, ToJSON, FromJSON, Serialize) 31 | 32 | instance StringHashable Transaction where 33 | toHash = StringHash . Base64.encode . SHA.hash . S.encode 34 | 35 | showTransaction :: Transaction -> Text -> Text 36 | showTransaction tx t = 37 | t <> ("\n Tx: [" +|| ( showPublicKey $ _owner (tx :: Transaction)) ||+ "] -> [" +|| (showPublicKey $ _receiver (tx :: Transaction)) ||+ 38 | "], amount: " +|| _amount (tx :: Transaction) ||+ ".") 39 | 40 | showTxWithNewBalance :: Transaction -> Amount -> Amount -> Text 41 | showTxWithNewBalance tx ownerBalance receiverBalance = showTx tx ||+ 42 | ", owner balance: " +|| ownerBalance ||+ 43 | ", receiver balance: " +|| receiverBalance ||+ "." 44 | 45 | showTx :: Transaction -> Text 46 | showTx tx = 47 | " [" +|| ( showPublicKey $ _owner tx) ||+ "] -> [" +|| (showPublicKey $ _receiver (tx :: Transaction)) ||+ 48 | "], amount: " +|| _amount (tx :: Transaction) ||+ "" 49 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Enecuum.Samples.Blockchain.Domain.Types where 3 | 4 | import Enecuum.Prelude 5 | import qualified Data.Serialize as S 6 | 7 | 8 | data Currency = ENQ | ETH | DASH | BTC deriving (Ord, Eq, Read, Show, Generic, ToJSON, FromJSON, S.Serialize) 9 | type Time = Int -- UnixTimestamp 10 | type Amount = Integer 11 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Domain/UUID.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Enecuum.Samples.Blockchain.Domain.UUID where 4 | 5 | import Data.Semigroup 6 | import Data.Word 7 | import Prelude 8 | import Data.Serialize 9 | import Data.UUID (UUID, fromWords, toWords) 10 | 11 | uuidG :: Get Word32 -> Get UUID 12 | uuidG word32 = fromWords <$> word32 <*> word32 <*> word32 <*> word32 13 | 14 | uuidP :: Putter Word32 -> Putter UUID 15 | uuidP word32 x = case toWords x of 16 | (a, b, c, d) -> word32 a <> word32 b <> word32 c <> word32 d 17 | 18 | instance Serialize UUID where 19 | put = uuidP put 20 | get = uuidG get 21 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Language.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.Language 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Samples.Blockchain.Language.Ledger as X 6 | import Enecuum.Samples.Blockchain.Language.Pending as X 7 | import Enecuum.Samples.Blockchain.Language.Graph as X 8 | import Enecuum.Samples.Blockchain.Language.Verification as X -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Language/Ledger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module Enecuum.Samples.Blockchain.Language.Ledger where 4 | 5 | import Data.Map 6 | import qualified Data.Map as Map 7 | import qualified Enecuum.Samples.Blockchain.Domain as D 8 | import Enecuum.Samples.Blockchain.Language.Verification as L 9 | import Enecuum.Samples.Blockchain.Domain.BlockchainData (BlockchainData (..)) 10 | import Enecuum.Samples.Blockchain.Domain.Microblock (Microblock (..)) 11 | import Enecuum.Samples.Blockchain.Domain.Transaction (Transaction (..)) 12 | import qualified Enecuum.Core.Types as D 13 | import qualified Enecuum.Core.Language as L 14 | import qualified Enecuum.Framework.Domain as D 15 | import qualified Enecuum.Framework.Language as L 16 | import Enecuum.Prelude 17 | 18 | newWalletAmount :: D.Amount 19 | newWalletAmount = 100 20 | 21 | initializeWallet :: D.StateVar D.Ledger -> D.WalletID -> L.StateL () 22 | initializeWallet ledgerVar wallet = do 23 | ledgerW <- L.readVar ledgerVar 24 | unless (Map.member wallet ledgerW) $ L.modifyVar ledgerVar (Map.insert wallet newWalletAmount) 25 | 26 | getBalanceOrCrash :: D.WalletID -> D.Ledger -> D.Amount 27 | getBalanceOrCrash wallet ledger = fromMaybe 28 | (error $ "Impossible: wallet " +|| wallet ||+ " is not initialized.") 29 | (ledger ^. at wallet) 30 | 31 | calculateLedger :: BlockchainData -> Microblock -> L.StateL () 32 | calculateLedger bData mblock = 33 | 34 | forM_ (_transactions mblock) $ \tx -> do 35 | let ledgerVar = _ledger bData 36 | 37 | initializeWallet ledgerVar $ _owner tx 38 | initializeWallet ledgerVar $ _receiver tx 39 | 40 | ledgerW <- L.readVar ledgerVar 41 | 42 | let owner = _owner tx 43 | let receiver = _receiver tx 44 | let amount = _amount tx 45 | let ownerBalance = getBalanceOrCrash owner ledgerW 46 | let receiverBalance = getBalanceOrCrash receiver ledgerW 47 | let newOwnerBalance = ownerBalance - amount 48 | let newReceiverBalance = receiverBalance + amount 49 | 50 | let newLedger = insert owner 51 | newOwnerBalance 52 | (insert receiver newReceiverBalance ledgerW) 53 | let transactionValid = owner /= receiver && ownerBalance >= amount && L.verifyTransaction tx 54 | 55 | when transactionValid $ L.writeVar ledgerVar newLedger 56 | 57 | when transactionValid $ L.logInfo $ "Tx accepted: " +|| D.showTxWithNewBalance tx newOwnerBalance newReceiverBalance ||+ "." 58 | when (owner == receiver) $ L.logInfo $ "Tx rejected (same owner and receiver): " +| D.showPublicKey owner |+ "." 59 | unless (L.verifyTransaction tx) $ L.logInfo $ "Tx rejected (signature is not genuine for key): " +| D.showPublicKey owner |+ "." 60 | unless transactionValid $ L.logInfo $ "Tx rejected (negative balance): " +|| D.showTxWithNewBalance tx newOwnerBalance newReceiverBalance ||+ "." 61 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Language/Transaction.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Samples.Blockchain.Language.Transaction where 2 | 3 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Language/Verification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Enecuum.Samples.Blockchain.Language.Verification where 4 | 5 | import qualified Enecuum.Samples.Blockchain.Domain as D 6 | import qualified Enecuum.Samples.Blockchain.Lens as Lens 7 | import Enecuum.Core.Crypto.Crypto 8 | import Enecuum.Prelude 9 | import qualified Enecuum.Samples.Blockchain.Domain.Internal as D (transactionForSign, microblockForSign) 10 | 11 | type BlockValid = Bool 12 | type TransactionValid = Bool 13 | 14 | verifyMicroblock :: D.Microblock -> BlockValid 15 | verifyMicroblock mb@D.Microblock {..} = verifyEncodable _publisher _signature (D.microblockForSign mb) 16 | 17 | verifyTransaction :: D.Transaction -> TransactionValid 18 | verifyTransaction t@D.Transaction {..} = verifyEncodable _owner _signature (D.transactionForSign t) 19 | -------------------------------------------------------------------------------- /src/Enecuum/Samples/Blockchain/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# OPTIONS -Wno-orphans #-} 6 | 7 | -- | Lenses for Blockchain domain types. 8 | module Enecuum.Samples.Blockchain.Lens where 9 | 10 | import Control.Lens (makeFieldsNoPrefix) 11 | import Data.HGraph.StringHashable (StringHash) 12 | import Enecuum.Samples.Blockchain.Domain 13 | import Enecuum.Samples.Blockchain.Domain.KBlock (BlockNumber) 14 | import Enecuum.Core.Types (StateVar) 15 | import Enecuum.Framework.Language.Extra (HasGraph (..)) 16 | import Enecuum.Prelude 17 | 18 | makeFieldsNoPrefix ''Transaction 19 | makeFieldsNoPrefix ''Microblock 20 | makeFieldsNoPrefix ''KBlock 21 | makeFieldsNoPrefix ''WindowedGraph 22 | makeFieldsNoPrefix ''BlockchainData 23 | 24 | -- 25 | -- -- Short lenses: BlockchainData -> WindowedGraph 26 | 27 | wGraph :: Lens' BlockchainData GraphVar 28 | wGraph = windowedGraph . graph 29 | 30 | -- wWindowSize :: Lens' BlockchainData (StateVar BlockNumber) 31 | -- wWindowSize = windowedGraph . windowSize 32 | 33 | wBottomKBlockHash :: Lens' BlockchainData (StateVar StringHash) 34 | wBottomKBlockHash = windowedGraph . bottomKBlockHash 35 | 36 | wTopKBlockHash :: Lens' BlockchainData (StateVar StringHash) 37 | wTopKBlockHash = windowedGraph . topKBlockHash 38 | -------------------------------------------------------------------------------- /src/Language/Haskell/TH/MakeFunctor.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.TH.MakeFunctor where 2 | 3 | import Enecuum.Prelude 4 | -- import Control.Monad 5 | import qualified Data.List as L 6 | import Language.Haskell.TH 7 | import Language.Haskell.TH.Datatype 8 | 9 | makeFunctorInstance :: Name -> Q [Dec] 10 | makeFunctorInstance name = 11 | forM [1 :: Int] $ \_ -> instanceD (cxt []) (appT (conT $ mkName "Functor") (conT name)) [makeFmap name] 12 | 13 | makeFmap :: Name -> Q Dec 14 | makeFmap name = do 15 | constructors <- datatypeCons <$> reifyDatatype name 16 | funD (mkName "fmap") (makeFmapBody <$> constructors) 17 | 18 | makeFmapBody :: ConstructorInfo -> Q Clause 19 | makeFmapBody info = clause 20 | [varP $ mkName "g", conP consName (varP <$> varNames)] 21 | (normalB 22 | ( foldApp 23 | $ ConE consName 24 | : (VarE <$> L.init varNames) 25 | ++ [UInfixE (VarE $ mkName "g") (VarE $ mkName ".") (VarE lastArg)] 26 | ) 27 | ) 28 | [] 29 | where 30 | lastArg = last varNames 31 | varNames = (\a -> mkName $ "a" <> show a) <$> [1 .. argNum] 32 | consName = constructorName info 33 | argNum = length $ constructorFields info 34 | 35 | foldApp :: [Exp] -> Q Exp 36 | foldApp = pure . foldl1 AppE 37 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.22 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - base58-bytestring-0.1.0 8 | - rocksdb-haskell-1.0.1 9 | - time-units-1.0.0 10 | 11 | 12 | 13 | build: 14 | haddock-arguments: 15 | haddock-args: 16 | - "--odir=./../node-docs" 17 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Functional/Data/ByteStringSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module Enecuum.Tests.Functional.Data.ByteStringSpec where 4 | 5 | import qualified Data.Aeson as A 6 | import Data.ByteString.Base64.Extra 7 | import qualified Data.ByteString.Char8 as BS 8 | import Data.ByteString.Extra() 9 | import Enecuum.Prelude 10 | import Test.Hspec (Spec, describe, it) 11 | import Test.QuickCheck 12 | import Enecuum.Testing.Wrappers 13 | 14 | instance Arbitrary ByteString where 15 | arbitrary = fmap BS.pack $ arbitrary 16 | shrink = map BS.pack . shrink . BS.unpack 17 | 18 | spec :: Spec 19 | spec = stableTest $ fastTest $ 20 | describe "Bytestring property test" $ do 21 | it "Verify bytestring json serialization" $ property prop_JsonEncoding 22 | it "Verify bytestring Base64 serialization" $ property prop_Base64Encoding 23 | 24 | prop_JsonEncoding :: ByteString -> Bool 25 | prop_JsonEncoding bs = (A.decode . A.encode) bs == Just bs 26 | 27 | prop_Base64Encoding :: ByteString -> Bool 28 | prop_Base64Encoding bs = (textToBase64 . base64ToText) bs == bs 29 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Functional/DifficultySpec.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Tests.Functional.DifficultySpec where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Bits as Bit 6 | import qualified Data.ByteString as B 7 | import qualified Enecuum.Domain as D 8 | import Enecuum.Testing.Wrappers 9 | import Test.Hspec 10 | 11 | import qualified Enecuum.Samples.Blockchain.Language as L 12 | import qualified Enecuum.Samples.Blockchain.Domain as D 13 | 14 | spec :: Spec 15 | spec = stableTest $ fastTest $ describe "Difficulty test" $ do 16 | it "Count leading Zero Bits" $ do 17 | D.leadingZeroBitsCount 0 `shouldBe` 8 18 | D.leadingZeroBitsCount 1 `shouldBe` 7 19 | D.leadingZeroBitsCount 16 `shouldBe` 3 20 | D.leadingZeroBitsCount 17 `shouldBe` 3 21 | 22 | map D.leadingZeroBitsCount [(2 ^ i) :: Word8 | i <- [0..7]] 23 | `shouldBe` [7,6..0] 24 | 25 | it "Calculate hash difficulty" $ do 26 | D.calcHashDifficulty (D.RawHash $ B.pack [1, 121]) `shouldBe` 7 27 | D.calcHashDifficulty (D.RawHash $ B.pack [0, 1]) `shouldBe` 15 28 | 29 | it "Calculate some hashes difficulty" $ do 30 | D.calcHashDifficulty (D.RawHash $ B.pack [246,2,161,0,0]) `shouldBe` 0 31 | D.calcHashDifficulty (D.RawHash $ B.pack [0,246,2,161,0,0]) `shouldBe` 8 32 | D.calcHashDifficulty (D.RawHash $ B.pack [0,0,0,0,0,0]) `shouldBe` 48 33 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Functional/NodeSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Enecuum.Tests.Functional.NodeSpec where 3 | 4 | import Enecuum.Prelude 5 | 6 | import Test.Hspec 7 | import Enecuum.TestData.Nodes.Scenarios 8 | import Enecuum.Testing 9 | import qualified Enecuum.Testing.RLens as RLens 10 | import Enecuum.Testing.Wrappers 11 | 12 | spec :: Spec 13 | spec = unstableTest $ fastTest $ describe "Nodes test" $ do 14 | it "Master node interacts with boot node" $ do 15 | 16 | runtime <- createTestRuntime 17 | 18 | _ :: NodeRuntime <- startNode runtime bootNodeAddr bootNode 19 | _ :: NodeRuntime <- startNode runtime masterNode1Addr masterNode 20 | 21 | -- TODO: restore control requests 22 | -- Right (D.RpcResponseResult eResponse _) <- T.sendRequest runtime bootNodeAddr 23 | -- $ L.makeRpcRequest (HelloRequest1 (D.formatAddress masterNode1Addr)) 24 | -- A.fromJSON eResponse `shouldBe` (A.Success $ HelloResponse1 ("Hello, dear. " <> D.formatAddress masterNode1Addr)) 25 | 26 | let tMsgs = runtime ^. RLens.loggerRuntime . RLens.messages 27 | msgs <- readTVarIO tMsgs 28 | msgs `shouldBe` ["Master node got id: NodeID \"1\"."] 29 | {- 30 | it "Network node requests data from network node" $ do 31 | 32 | runtime <- createTestRuntime 33 | 34 | void $ startNodeWithGraph runtime networkNode1Addr networkNode1 35 | void $ startNode runtime networkNode2Addr networkNode2 36 | 37 | let tMsgs = runtime ^. RLens.loggerRuntime . RLens.messages 38 | msgs <- readTVarIO tMsgs 39 | msgs `shouldBe` 40 | [ "balance4 (should be 111): 111." 41 | , "balance3 (should be Just 111): Just 111." 42 | , "balance2 (should be Nothing): Nothing." 43 | , "balance1 (should be Just 10): Just 10." 44 | , "balance0 (should be 0): 0." 45 | ] 46 | -} 47 | it "Boot node validates requests from Network node" $ do 48 | 49 | runtime <- createTestRuntime 50 | 51 | _ :: NodeRuntime <- startNode runtime bootNodeAddr bootNodeValidation 52 | _ :: NodeRuntime <- startNode runtime masterNode1Addr masterNodeValidation 53 | 54 | let tMsgs = runtime ^. RLens.loggerRuntime . RLens.messages 55 | msgs <- readTVarIO tMsgs 56 | msgs 57 | `shouldBe` [ "Master node got id: NodeID \"1\"." 58 | , "For the invalid request recieved ValidationResponse (Left [\"invalid\"])." 59 | , "For the valid request recieved ValidationResponse (Right \"correct\")." 60 | ] 61 | 62 | it "Network node uses state" $ do 63 | 64 | runtime <- createTestRuntime 65 | 66 | void $ startNodeWithGraph runtime networkNode3Addr networkNode3 67 | void $ startNode runtime networkNode4Addr networkNode4 68 | 69 | let tMsgs = runtime ^. RLens.loggerRuntime . RLens.messages 70 | msgs <- readTVarIO tMsgs 71 | msgs `shouldBe` ["balance (should be 91): 91."] 72 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Functional/RandomSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Enecuum.Tests.Functional.RandomSpec where 3 | 4 | import Enecuum.Prelude 5 | 6 | import Test.Hspec 7 | 8 | import qualified Data.List as List 9 | 10 | import qualified Enecuum.Language as L 11 | import qualified Enecuum.Domain as D 12 | 13 | import Enecuum.Testing 14 | import Enecuum.Testing.Wrappers 15 | 16 | spec :: Spec 17 | spec = stableTest $ fastTest $ describe "Random spec" $ 18 | it "Get 100 random numbers in range" $ do 19 | loggerRuntime <- createLoggerRuntime 20 | 21 | numbers <- evaluateNode loggerRuntime (D.Address "" 1) $ replicateM 100 (L.getRandomInt (0, 10000)) 22 | 23 | length numbers `shouldBe` 100 24 | all (\x -> x >= 0 && x <= 10000) numbers `shouldBe` True 25 | 26 | -- Hopefully, from 100 numbers there will be 5 distinct. 27 | length (List.nub numbers) `shouldSatisfy` (>= 5) 28 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Functional/RetryAndTcpLikeSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Enecuum.Tests.Functional.RetryAndTcpLikeSpec where 3 | 4 | import Enecuum.Prelude 5 | 6 | import Test.Hspec 7 | import Test.HUnit 8 | import Test.Hspec.Contrib.HUnit ( fromHUnitTest ) 9 | 10 | import Enecuum.TestData.Nodes.Scenarios 11 | import Enecuum.Testing 12 | import qualified Enecuum.Testing.RLens as RLens 13 | import Enecuum.Testing.Wrappers 14 | 15 | -- Tests disabled 16 | spec :: Spec 17 | spec = stableTest $ fastTest $ describe "Retry & TCP-like connections test" $ fromHUnitTest $ TestList 18 | [TestLabel "Retry & TCP-like connections test (Ping-Pong 2)" pingPong2] 19 | 20 | pingPong2 :: Test 21 | pingPong2 = TestCase $ do 22 | runtime <- createTestRuntime 23 | 24 | void $ forkIO $ void $ startNode runtime pongServerAddress pongServingNode 25 | threadDelay $ 1000 * 1000 26 | void $ startNode runtime pingClientAddress pingSendingClientNode 27 | threadDelay $ 1000 * 1000 28 | 29 | let tMsgs = runtime ^. RLens.loggerRuntime . RLens.messages 30 | msgs <- readTVarIO tMsgs 31 | msgs `shouldContain` ["Pong handle received: Pong {pong = 3}. Sending Ping {ping = 4}."] 32 | msgs `shouldContain` ["Ping handle received: Ping {ping = 3}. Sending Pong {pong = 3}."] 33 | msgs `shouldContain` ["Pong handle received: Pong {pong = 2}. Sending Ping {ping = 3}."] 34 | msgs `shouldContain` ["Ping handle received: Ping {ping = 2}. Sending Pong {pong = 2}."] 35 | msgs `shouldContain` ["Pong handle received: Pong {pong = 1}. Sending Ping {ping = 2}."] 36 | msgs `shouldContain` ["Ping handle received: Ping {ping = 1}. Sending Pong {pong = 1}."] 37 | msgs `shouldContain` ["Pong handle received: Pong {pong = 0}. Sending Ping {ping = 1}."] 38 | msgs `shouldContain` ["Ping handle received: Ping {ping = 0}. Sending Pong {pong = 0}."] 39 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Functional/StateSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Enecuum.Tests.Functional.StateSpec where 3 | 4 | import Enecuum.Prelude 5 | 6 | import Test.Hspec 7 | 8 | import qualified Enecuum.Language as L 9 | import qualified Enecuum.Domain as D 10 | 11 | import Enecuum.Testing 12 | import Enecuum.Testing.Wrappers 13 | 14 | nodeAddress :: D.Address 15 | nodeAddress = D.Address "0.0.0.4" 1000 16 | 17 | spec :: Spec 18 | spec = stableTest $ fastTest $ describe "State spec" $ do 19 | 20 | it "Create & read var non-atomically" $ do 21 | loggerRuntime <- createLoggerRuntime 22 | res <- evaluateNode loggerRuntime nodeAddress 23 | $ L.newVarIO "abc" >>= L.readVarIO 24 | res `shouldBe` ("abc" :: String) 25 | 26 | it "Create & read var atomically" $ do 27 | loggerRuntime <- createLoggerRuntime 28 | res <- evaluateNode loggerRuntime nodeAddress 29 | $ L.atomically 30 | $ L.newVar "abc" >>= L.readVar 31 | res `shouldBe` ("abc" :: String) 32 | 33 | it "Create & write var non-atomically" $ do 34 | loggerRuntime <- createLoggerRuntime 35 | res <- evaluateNode loggerRuntime nodeAddress $ do 36 | var <- L.newVarIO "abc" 37 | _ <- L.writeVarIO var "cde" 38 | L.readVarIO var 39 | res `shouldBe` ("cde" :: String) 40 | 41 | it "Create & write var atomically" $ do 42 | loggerRuntime <- createLoggerRuntime 43 | res <- evaluateNode loggerRuntime nodeAddress 44 | $ L.atomically $ do 45 | var <- L.newVar "abc" 46 | L.writeVar var "cde" 47 | L.readVar var 48 | res `shouldBe` ("cde" :: String) 49 | 50 | it "Create & read 2 vars non-atomically" $ do 51 | loggerRuntime <- createLoggerRuntime 52 | res <- evaluateNode loggerRuntime nodeAddress $ do 53 | var1 <- L.newVarIO "abc" 54 | var2 <- L.newVarIO "cde" 55 | val1 <- L.readVarIO var1 56 | val2 <- L.readVarIO var2 57 | pure (val1, val2) 58 | res `shouldBe` ("abc" :: String, "cde" :: String) 59 | 60 | it "Create & read 2 vars atomically" $ do 61 | loggerRuntime <- createLoggerRuntime 62 | res <- evaluateNode loggerRuntime nodeAddress $ do 63 | vars <- L.atomically $ (,) <$> L.newVar "abc" <*> L.newVar "cde" 64 | val1 <- L.readVarIO $ fst vars 65 | val2 <- L.readVarIO $ snd vars 66 | pure (val1, val2) 67 | res `shouldBe` ("abc" :: String, "cde" :: String) 68 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Integration/ConfigsSpec.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Tests.Integration.ConfigsSpec where 2 | 3 | import qualified Enecuum.Framework.Node.Interpreter as I 4 | import qualified Enecuum.Language as L 5 | import Enecuum.Prelude 6 | import Enecuum.Samples.Assets.ConfigParsing (parseConfig) 7 | import Enecuum.Samples.Assets.System.Directory (configDir) 8 | import Enecuum.Tests.Helpers 9 | import Enecuum.Testing.Wrappers 10 | import System.Directory 11 | import System.FilePath (()) 12 | import Test.Hspec 13 | import Test.Hspec.Contrib.HUnit (fromHUnitTest) 14 | import Test.HUnit 15 | 16 | spec :: Spec 17 | spec = stableTest $ fastTest $ describe "Validate configs" $ do 18 | configFiles <- runIO getConfigNames 19 | fromHUnitTest $ TestList $ map (\file -> TestLabel ("Parse config " +|| file ||+ "") (parse file)) configFiles 20 | 21 | getConfigNames :: IO [FilePath] 22 | getConfigNames = do 23 | dirContent <- listDirectory configDir 24 | let isConfigFile filePath = doesFileExist $ configDir filePath 25 | filterM isConfigFile dirContent 26 | 27 | -- | Try to parse config of unknown type 28 | parse :: FilePath -> Test 29 | parse file = TestCase $ do 30 | let filename = configDir file 31 | configSrc <- I.runNodeL undefined $ L.readFile filename 32 | -- Try to parse config of unknown type (parseConfig failure invoke error) 33 | parseConfig configSrc 34 | -------------------------------------------------------------------------------- /test/spec/Enecuum/Tests/Integration/RpcServerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | 5 | module Enecuum.Tests.Integration.RpcServerSpec where 6 | 7 | import Enecuum.Prelude 8 | 9 | import qualified Data.Map as M 10 | import Test.Hspec 11 | import Test.Hspec.Contrib.HUnit (fromHUnitTest) 12 | import Test.HUnit 13 | 14 | import qualified Enecuum.Domain as D 15 | import Enecuum.Interpreters 16 | import qualified Enecuum.Language as L 17 | import qualified Enecuum.Runtime as R 18 | import Enecuum.Tests.Helpers 19 | import Enecuum.Testing.Wrappers 20 | 21 | createNodeRuntime :: IO R.NodeRuntime 22 | createNodeRuntime = R.createVoidLoggerRuntime >>= R.createCoreRuntime >>= (`R.createNodeRuntime` M.empty) 23 | 24 | data OkRequest = OkRequest deriving (Show, Eq, Generic, ToJSON, FromJSON) 25 | data OkResponse = OkResponse deriving (Show, Eq, Generic, ToJSON, FromJSON) 26 | 27 | data ErrRequest = ErrRequest deriving (Show, Eq, Generic, ToJSON, FromJSON) 28 | data ErrResponse = ErrResponse deriving (Show, Eq, Generic, ToJSON, FromJSON) 29 | 30 | -- Tests disabled 31 | spec :: Spec 32 | spec = stableTest $ fastTest $ describe "RpcServer" $ fromHUnitTest $ TestList 33 | [ TestLabel "Test of rpc server/ok" rpcServerTestOk 34 | , TestLabel "Test of rpc server/err" rpcServerTestErr 35 | ] 36 | 37 | okHandler :: OkRequest -> L.NodeL OkResponse 38 | okHandler _ = pure OkResponse 39 | 40 | errHandler :: ErrRequest -> L.NodeL ErrResponse 41 | errHandler _ = pure ErrResponse 42 | 43 | rpcServerTestOk :: Test 44 | rpcServerTestOk = TestCase $ do 45 | nr <- createNodeRuntime 46 | threadDelay 10000 47 | runNodeDefinitionL nr $ L.serving D.Rpc serverPort $ do 48 | L.method okHandler 49 | L.method errHandler 50 | threadDelay 10000 51 | res <- runNodeL nr $ L.makeRpcRequest localServer OkRequest 52 | runNodeDefinitionL nr $ L.stopServing serverPort 53 | assertBool "" (res == Right OkResponse) 54 | 55 | 56 | rpcServerTestErr :: Test 57 | rpcServerTestErr = TestCase $ do 58 | nr <- createNodeRuntime 59 | threadDelay 10000 60 | runNodeDefinitionL nr $ L.serving D.Rpc serverPort $ do 61 | L.method okHandler 62 | L.method errHandler 63 | threadDelay 10000 64 | res <- runNodeL nr $ L.makeRpcRequest localServer ErrRequest 65 | runNodeDefinitionL nr $ L.stopServing serverPort 66 | assertBool "" (res == Right ErrResponse) 67 | 68 | serverPort :: D.PortNumber 69 | serverPort = 2001 70 | 71 | localServer :: D.Address 72 | localServer = D.Address "127.0.0.1" serverPort 73 | -------------------------------------------------------------------------------- /test/spec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/Nodes/Address.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.TestData.Nodes.Address where 2 | 3 | import qualified Enecuum.Domain as D 4 | 5 | bootNodeAddr, masterNode1Addr :: D.Address 6 | bootNodeAddr = D.Address "0.0.0.0" 2000 7 | masterNode1Addr = D.Address "0.0.0.1" 2000 8 | 9 | networkNode1Addr, networkNode2Addr :: D.Address 10 | networkNode1Addr = D.Address "0.0.0.2" 2000 11 | networkNode2Addr = D.Address "0.0.0.3" 2000 12 | 13 | networkNode3Addr, networkNode4Addr :: D.Address 14 | networkNode3Addr = D.Address "0.0.0.4" 2000 15 | networkNode4Addr = D.Address "0.0.0.5" 2000 16 | 17 | bootNodeTag, masterNodeTag :: D.NodeTag 18 | bootNodeTag = "bootNode" 19 | masterNodeTag = "masterNode" 20 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/Nodes/Scenario1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module Enecuum.TestData.Nodes.Scenario1 where 4 | 5 | import Enecuum.Prelude 6 | 7 | import qualified Enecuum.Domain as D 8 | import qualified Enecuum.Language as L 9 | import Enecuum.TestData.RPC 10 | import Enecuum.TestData.Nodes.Address 11 | 12 | -- Scenario 1: master node can interact with boot node. 13 | 14 | bootNode :: L.NodeDefinitionL () 15 | bootNode = do 16 | L.setNodeTag bootNodeTag 17 | void $ L.serving D.Rpc 2000 $ do 18 | L.method acceptHello1 19 | L.method acceptGetHashId 20 | 21 | 22 | simpleBootNodeDiscovery :: L.NodeL D.Address 23 | simpleBootNodeDiscovery = pure bootNodeAddr 24 | 25 | masterNodeInitialization :: L.NodeL (Either Text D.NodeID) 26 | masterNodeInitialization = do 27 | addr <- simpleBootNodeDiscovery 28 | GetHashIDResponse eHashID <- L.makeRpcRequestUnsafe addr GetHashIDRequest 29 | pure $ Right (D.NodeID eHashID) 30 | 31 | masterNode :: L.NodeDefinitionL () 32 | masterNode = do 33 | L.setNodeTag masterNodeTag 34 | nodeId <- D.withSuccess $ L.initialization masterNodeInitialization 35 | L.logInfo $ "Master node got id: " +|| nodeId ||+ "." 36 | void $ L.serving D.Rpc 2000 $ do 37 | L.method acceptHello1 38 | L.method acceptHello2 39 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/Nodes/Scenario3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | 4 | module Enecuum.TestData.Nodes.Scenario3 where 5 | 6 | import Enecuum.Prelude 7 | 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Language as L 10 | import Enecuum.TestData.RPC 11 | import Enecuum.TestData.Nodes.Address 12 | import Enecuum.TestData.Validation 13 | 14 | -- Scenario 3: boot node can validate data recieved from master node 15 | 16 | bootNodeValidation :: L.NodeDefinitionL () 17 | bootNodeValidation = do 18 | L.setNodeTag bootNodeTag 19 | void $ L.initialization $ pure $ D.NodeID "abc" 20 | void $ L.serving D.Rpc 2000 $ do 21 | L.method acceptGetHashId 22 | L.method acceptValidationRequest 23 | 24 | masterNodeInitializeWithValidation :: L.NodeL (Either Text D.NodeID) 25 | masterNodeInitializeWithValidation = do 26 | GetHashIDResponse eHashID <- L.makeRpcRequestUnsafe bootNodeAddr GetHashIDRequest 27 | validRes :: ValidationResponse <- L.makeRpcRequestUnsafe bootNodeAddr ValidRequest 28 | L.logInfo $ "For the valid request recieved " +|| validRes ||+ "." 29 | invalidRes :: ValidationResponse <- L.makeRpcRequestUnsafe bootNodeAddr InvalidRequest 30 | L.logInfo $ "For the invalid request recieved " +|| invalidRes ||+ "." 31 | pure $ Right (D.NodeID eHashID) 32 | 33 | masterNodeValidation :: L.NodeDefinitionL () 34 | masterNodeValidation = do 35 | L.setNodeTag masterNodeTag 36 | nodeId <- D.withSuccess $ L.initialization masterNodeInitializeWithValidation 37 | L.logInfo $ "Master node got id: " +|| nodeId ||+ "." 38 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/Nodes/Scenario5.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | module Enecuum.TestData.Nodes.Scenario5 where 5 | 6 | import Enecuum.Prelude 7 | 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Language as L 10 | 11 | 12 | -- Scenario 5: Permanent connection Ping-Pong 13 | 14 | newtype Ping = Ping { ping :: Int } 15 | deriving (Show, Generic, ToJSON, FromJSON) 16 | 17 | newtype Pong = Pong { pong :: Int } 18 | deriving (Show, Generic, ToJSON, FromJSON) 19 | 20 | pongServerPort, pingClientPort :: D.PortNumber 21 | pongServerPort = 2000 22 | pingClientPort = 2001 23 | 24 | pongServerAddress, pingClientAddress :: D.Address 25 | pongServerAddress = D.Address "0.0.1.4" pongServerPort 26 | pingClientAddress = D.Address "0.0.1.5" pingClientPort 27 | 28 | pingPongThreshold :: Int 29 | pingPongThreshold = 3 30 | 31 | pingHandle :: D.StateVar Int -> Ping -> D.Connection D.Tcp -> L.NodeL () 32 | pingHandle countVar (Ping i) conn = do 33 | L.logInfo $ "Ping handle received: " +|| Ping i ||+ ". Sending " +|| Pong i ||+ "." 34 | void $ L.send conn $ Pong i 35 | when (i >= pingPongThreshold) $ L.close conn 36 | L.atomically $ L.writeVar countVar i 37 | 38 | pongHandle :: D.StateVar Int -> Pong -> D.Connection D.Tcp -> L.NodeL () 39 | pongHandle countVar (Pong i) conn = do 40 | L.logInfo $ "Pong handle received: " +|| Pong i ||+ ". Sending " +|| Ping (i + 1) ||+ "." 41 | void $ L.send conn $ Ping $ i + 1 42 | when (i + 1 >= pingPongThreshold) $ L.close conn 43 | L.atomically $ L.writeVar countVar $ i + 1 44 | 45 | 46 | pongServingNode :: L.NodeDefinitionL () 47 | pongServingNode = do 48 | countVar <- L.scenario $ L.atomically $ L.newVar 0 49 | 50 | L.servingMsg pongServerPort $ L.handler $ pingHandle countVar 51 | 52 | L.scenario $ L.atomically $ do 53 | pings <- L.readVar countVar 54 | when (pings < pingPongThreshold) L.retry 55 | 56 | L.stopServing pongServerPort 57 | 58 | pingSendingClientNode :: L.NodeDefinitionL () 59 | pingSendingClientNode = L.scenario $ do 60 | countVar <- L.atomically $ L.newVar 0 61 | 62 | mCon <- L.open D.Tcp pongServerAddress $ L.handler $ pongHandle countVar 63 | whenJust mCon $ \conn -> do 64 | void $ L.send conn $ Ping 0 65 | 66 | L.atomically $ do 67 | pongs <- L.readVar countVar 68 | when (pongs < pingPongThreshold) L.retry 69 | 70 | L.close conn 71 | 72 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/Nodes/Scenarios.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.TestData.Nodes.Scenarios 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.TestData.Nodes.Scenario1 as X 6 | import Enecuum.TestData.Nodes.Scenario3 as X 7 | import Enecuum.TestData.Nodes.Scenario4 as X 8 | import Enecuum.TestData.Nodes.Scenario5 as X 9 | import Enecuum.TestData.Nodes.Address as X 10 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/RPC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | 5 | module Enecuum.TestData.RPC where 6 | 7 | import Enecuum.Prelude 8 | 9 | import qualified Enecuum.Language as L 10 | 11 | -- Types for RPC requests. 12 | 13 | data GetHashIDRequest = GetHashIDRequest 14 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 15 | 16 | newtype GetHashIDResponse = GetHashIDResponse Text 17 | deriving (Show, Eq, Generic, Newtype, ToJSON, FromJSON) 18 | 19 | 20 | newtype HelloRequest1 = HelloRequest1 { helloMessage :: Text } 21 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 22 | 23 | newtype HelloResponse1 = HelloResponse1 { ackMessage :: Text } 24 | deriving (Show, Eq, Generic, Newtype, ToJSON, FromJSON) 25 | 26 | newtype HelloRequest2 = HelloRequest2 { helloMessage :: Text } 27 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 28 | 29 | newtype HelloResponse2 = HelloResponse2 { ackMessage :: Text } 30 | deriving (Show, Eq, Generic, Newtype, ToJSON, FromJSON) 31 | 32 | ------------------------------------------------------------------- 33 | 34 | data GetBalanceRequest = GetBalanceRequest 35 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 36 | 37 | newtype GetBalanceResponse = GetBalanceResponse { balance :: Int } 38 | deriving (Show, Eq, Generic, Newtype, ToJSON, FromJSON) 39 | 40 | newtype BalanceChangeRequest = BalanceChangeRequest Int 41 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 42 | 43 | newtype BalanceChangeResponse = BalanceChangeResponse { balance :: Maybe Int } 44 | deriving (Show, Eq, Generic, Newtype, ToJSON, FromJSON) 45 | 46 | -- RPC handlers. 47 | 48 | acceptHello1 :: HelloRequest1 -> L.NodeL HelloResponse1 49 | acceptHello1 (HelloRequest1 msg) = pure $ HelloResponse1 $ "Hello, dear. " +| msg |+ "" 50 | 51 | acceptHello2 :: HelloRequest2 -> L.NodeL HelloResponse2 52 | acceptHello2 (HelloRequest2 msg) = pure $ HelloResponse2 $ "Hello, dear2. " +| msg |+ "" 53 | 54 | acceptGetHashId :: GetHashIDRequest -> L.NodeL GetHashIDResponse 55 | acceptGetHashId GetHashIDRequest = pure $ GetHashIDResponse "1" 56 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/TestGraph.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Enecuum.TestData.TestGraph where 5 | 6 | import Enecuum.Prelude 7 | 8 | import Data.HGraph.StringHashable (StringHash (..), StringHashable, toHash) 9 | import Control.Lens.TH (makeLenses) 10 | 11 | import qualified Data.ByteString.Base64 as Base64 12 | import qualified Data.Serialize as S 13 | import qualified Crypto.Hash.SHA256 as SHA 14 | 15 | 16 | import qualified Enecuum.Language as L 17 | import qualified Enecuum.Domain as D 18 | import Enecuum.Core.HGraph.Interpreters.IO (runHGraphIO) 19 | import Enecuum.Core.HGraph.Internal.Impl (initHGraph) 20 | 21 | data Transaction = Transaction 22 | { _prevHash :: StringHash 23 | , _change :: BalanceChange 24 | } 25 | deriving ( Generic, Show, Eq, Ord, Read) 26 | type Balance = Int 27 | type BalanceChange = Int 28 | 29 | instance Serialize Transaction 30 | instance StringHashable Transaction where 31 | toHash = StringHash . Base64.encode . SHA.hash . S.encode 32 | 33 | makeLenses ''Transaction 34 | 35 | type TestGraphVar = D.TGraph Transaction 36 | type TestGraphL a = L.HGraphL Transaction a 37 | 38 | 39 | nilHash :: StringHash 40 | nilHash = toHash (Transaction (toHash (0 :: Int)) 0) 41 | 42 | nilTransaction :: Transaction 43 | nilTransaction = Transaction nilHash 0 44 | 45 | nilTransactionHash :: D.StringHash 46 | nilTransactionHash = D.toHash nilTransaction 47 | 48 | initTestGraph :: IO TestGraphVar 49 | initTestGraph = do 50 | graph <- initHGraph 51 | runHGraphIO graph $ L.newNode nilTransaction 52 | pure graph 53 | 54 | -- | Checks if new balance is valid and adds new transaction node. 55 | -- Returns new node hash and new balance. 56 | tryAddTransaction' :: D.StringHash -> Balance -> BalanceChange -> TestGraphL (Maybe (D.StringHash, Balance)) 57 | tryAddTransaction' lastNodeHash lastBalance change' 58 | | lastBalance + change' < 0 = pure Nothing 59 | | otherwise = do 60 | let newTrans = Transaction lastNodeHash change' 61 | let newTransHash = D.toHash newTrans 62 | L.newNode newTrans 63 | L.newLink lastNodeHash newTransHash 64 | pure $ Just (newTransHash, lastBalance + change') 65 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/TestData/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Enecuum.TestData.Validation where 7 | 8 | import Enecuum.Prelude 9 | import Data.Validation 10 | import Control.Lens 11 | 12 | import qualified Enecuum.Language as L 13 | 14 | data ValidationRequest = ValidRequest | InvalidRequest 15 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 16 | 17 | newtype ValidationResponse = ValidationResponse (Either [Text] Text) 18 | deriving (Show, Eq, Generic, Newtype, ToJSON, FromJSON) 19 | 20 | verifyRequest :: ValidationRequest -> Validation [Text] Text 21 | verifyRequest ValidRequest = _Success # "correct" 22 | verifyRequest InvalidRequest = _Failure # ["invalid"] 23 | 24 | makeResponse :: Validation [Text] Text -> ValidationResponse 25 | makeResponse = ValidationResponse . toEither 26 | 27 | acceptValidationRequest :: ValidationRequest -> L.NodeL ValidationResponse 28 | acceptValidationRequest req = pure $ makeResponse $ verifyRequest req 29 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Testing.Types as X 6 | import Enecuum.Testing.Core.LoggerRuntime as X 7 | import Enecuum.Testing.Core.Interpreters as X 8 | import Enecuum.Testing.Framework.NodeRuntime as X 9 | import Enecuum.Testing.Framework.Interpreters as X 10 | import Enecuum.Testing.TestRuntime as X 11 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Core/Interpreters.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Core.Interpreters 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Testing.Core.Interpreters.Logger as X 6 | import Enecuum.Testing.Core.Interpreters.CoreEffect as X 7 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Core/Interpreters/ControlFlow.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Core.Interpreters.ControlFlow where 2 | 3 | import Enecuum.Prelude 4 | import qualified Enecuum.Core.ControlFlow.Language as L 5 | 6 | interpretControlFlowF :: L.ControlFlowF a -> IO a 7 | interpretControlFlowF (L.Delay i next) = do 8 | threadDelay i 9 | pure $ next () 10 | 11 | runControlFlow :: Free L.ControlFlowF a -> IO a 12 | runControlFlow = foldFree interpretControlFlowF 13 | 14 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Core/Interpreters/CoreEffect.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Core.Interpreters.CoreEffect where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Enecuum.Core.Language as L 6 | 7 | import Enecuum.Testing.Core.Interpreters.ControlFlow 8 | import qualified Enecuum.Testing.Core.Interpreters.Logger as Impl 9 | import qualified Enecuum.Testing.Types as T 10 | -- Using real implementation 11 | import Enecuum.Core.Random.Interpreter (runERandomL) 12 | 13 | -- | Interprets core effect container language. 14 | interpretCoreEffectF :: T.LoggerRuntime -> L.CoreEffectF a -> IO a 15 | interpretCoreEffectF loggerRt (L.EvalLogger logger next) = next <$> Impl.runLoggerL loggerRt logger 16 | 17 | interpretCoreEffectF _ (L.EvalRandom eRnd next) = next <$> runERandomL eRnd 18 | 19 | interpretCoreEffectF _ (L.EvalControlFlow flow next) = next <$> runControlFlow flow 20 | interpretCoreEffectF _ L.EvalFileSystem{} = error "EvalFileSystem not implemented" 21 | 22 | -- | Runs core effect container language. 23 | runCoreEffectL :: T.LoggerRuntime -> L.CoreEffectL a -> IO a 24 | runCoreEffectL loggerRt = foldFree (interpretCoreEffectF loggerRt) 25 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Core/Interpreters/Logger.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Core.Interpreters.Logger where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Enecuum.Core.Language as L 6 | 7 | import qualified Enecuum.Testing.RLens as RLens 8 | import qualified Enecuum.Testing.Types as T 9 | 10 | 11 | -- | Interprets a LoggerL language. 12 | -- Just pushes the messages into the concurrent list-like storage. 13 | interpretLoggerL :: T.LoggerRuntime -> L.LoggerF a -> IO a 14 | interpretLoggerL loggerRt (L.LogMessage _ msg next) = do 15 | atomically $ modifyTVar (loggerRt ^. RLens.messages) (msg :) 16 | pure $ next () 17 | 18 | -- | Runs the LoggerL language 19 | -- save to memory 20 | runLoggerL :: T.LoggerRuntime -> L.LoggerL a -> IO a 21 | runLoggerL loggerRt = foldFree (interpretLoggerL loggerRt) 22 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Core/LoggerRuntime.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Core.LoggerRuntime where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Enecuum.Testing.Types as T 6 | 7 | createLoggerRuntime :: IO T.LoggerRuntime 8 | createLoggerRuntime = T.LoggerRuntime <$> newTVarIO [] 9 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Framework/Internal/RpcServer.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Framework.Internal.RpcServer where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Map as Map 6 | import qualified Data.Aeson as A 7 | 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Language as L 10 | 11 | import qualified Enecuum.Testing.Types as T 12 | import qualified Enecuum.Testing.RLens as RLens 13 | import qualified Enecuum.Testing.Framework.Interpreters.Node as Impl 14 | 15 | -- | Node RPC server worker. 16 | 17 | startNodeRpcServer :: T.NodeRuntime -> p -> TVar (Map Text (A.Value -> Int -> L.NodeL D.RpcResponse)) -> IO () 18 | startNodeRpcServer nodeRt _ methodVar = do 19 | methods <- readTVarIO methodVar 20 | control <- T.Control <$> newEmptyTMVarIO <*> newEmptyTMVarIO 21 | tId <- forkIO $ go 0 control methods 22 | 23 | let handle = T.RpcServerHandle tId control 24 | atomically $ putTMVar (nodeRt ^. RLens.rpcServer) handle 25 | where 26 | 27 | go iteration control methods = do 28 | act iteration control methods 29 | go (iteration + 1 :: Int) control methods 30 | 31 | act _ control methods = do 32 | controlReq <- atomically $ takeTMVar $ control ^. RLens.request 33 | case controlReq of 34 | T.RpcReq req -> do 35 | resp <- callRpc (Impl.runNodeL nodeRt) methods req 36 | atomically $ putTMVar (control ^. RLens.response) (T.AsRpcResp resp) 37 | _ -> error "Control request is not supported in RpcServer." 38 | 39 | callRpc :: Monad m => (t -> m D.RpcResponse) -> Map Text (A.Value -> Int -> t) -> D.RpcRequest -> m D.RpcResponse 40 | callRpc runner methods (D.RpcRequest method params reqId) = case method `Map.lookup` methods of 41 | Just justMethod -> runner $ justMethod params reqId 42 | Nothing -> pure $ D.RpcResponseError (A.String $ "The method " <> method <> " isn't supported.") reqId 43 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Framework/Internal/TcpLikeServer.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Framework.Internal.TcpLikeServer where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Map as Map 6 | import Control.Concurrent (killThread) 7 | 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Language as L 10 | import qualified Enecuum.Framework.Lens as Lens 11 | 12 | import qualified Enecuum.Testing.Types as T 13 | import qualified Enecuum.Testing.RLens as RLens 14 | import qualified Enecuum.Testing.Framework.Interpreters.Node as Impl 15 | import Enecuum.Testing.Framework.Internal.TcpLikeServerWorker (startNodeTcpLikeWorker) 16 | import Enecuum.Testing.Framework.Internal.TcpLikeServerBinding (bindServer) 17 | 18 | -- | Node TCP-like accepting server worker. 19 | startNodeTcpLikeServer :: T.NodeRuntime -> D.Address -> TVar (Map Text (L.NetworkHandler D.Tcp L.NodeL)) -> IO () 20 | startNodeTcpLikeServer nodeRt servingAddress handlersVar = do 21 | 22 | handlers <- readTVarIO handlersVar 23 | control <- T.Control <$> newEmptyTMVarIO <*> newEmptyTMVarIO 24 | tId <- forkIO $ go 0 control handlers 25 | 26 | let handle = T.ServerHandle tId control nodeRt 27 | atomically $ do 28 | serversRegistry <- takeTMVar (nodeRt ^. RLens.serversRegistry) 29 | putTMVar (nodeRt ^. RLens.serversRegistry) $ Map.insert servingAddress handle serversRegistry 30 | where 31 | 32 | go iteration control handlers = do 33 | void $ act iteration control handlers 34 | go (iteration + 1 :: Int) control handlers 35 | 36 | act _ control handlers = do 37 | controlReq <- atomically $ takeTMVar $ control ^. RLens.request 38 | controlResp <- case controlReq of 39 | T.EstablishConnectionReq -> do 40 | workerHandle <- startNodeTcpLikeWorker (Impl.runNodeL nodeRt) nodeRt handlers Nothing 41 | bindedServer <- bindServer nodeRt (servingAddress ^. Lens.host) T.Server workerHandle 42 | pure $ T.AsConnectionAccepted bindedServer 43 | _ -> error "Control request is not supported in accepting Tcp-like server." 44 | atomically $ putTMVar (control ^. RLens.response) controlResp 45 | 46 | 47 | 48 | -- | Node TCP-like accepting server worker. 49 | stopNodeTcpLikeServer :: T.NodeRuntime -> D.PortNumber -> IO () 50 | stopNodeTcpLikeServer nodeRt port = do 51 | let servingAddress = (nodeRt ^. RLens.address) & Lens.port .~ port 52 | serversRegistry <- atomically $ takeTMVar (nodeRt ^. RLens.serversRegistry) 53 | case Map.lookup servingAddress serversRegistry of 54 | Nothing -> pure () 55 | Just serverHandle -> killThread $ serverHandle ^. RLens.threadId 56 | atomically $ putTMVar (nodeRt ^. RLens.serversRegistry) $ Map.delete servingAddress serversRegistry 57 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Framework/Internal/TcpLikeServerBinding.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Framework.Internal.TcpLikeServerBinding where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Map as Map 6 | import Control.Concurrent (killThread) 7 | 8 | import qualified Enecuum.Domain as D 9 | import qualified Enecuum.Framework.Lens as Lens 10 | 11 | import qualified Enecuum.Testing.Types as T 12 | import qualified Enecuum.Testing.RLens as RLens 13 | 14 | 15 | 16 | -- | Register connection in the node connections list. 17 | -- TODO: check if connection exists. 18 | registerConnection :: T.NodeRuntime -> T.BindedServer -> IO () 19 | registerConnection nodeRt bindedServer = atomically $ do 20 | connections <- takeTMVar (nodeRt ^. RLens.connections) 21 | let newConnection = T.NodeConnection T.Server bindedServer 22 | let newConnections = Map.insert (bindedServer ^. RLens.address) newConnection connections 23 | putTMVar (nodeRt ^. RLens.connections) newConnections 24 | 25 | -- | Remove connection 26 | removeConnection :: T.NodeRuntime -> D.Connection D.Tcp -> IO (Maybe T.BindedServer) 27 | removeConnection nodeRt (D.Connection (D.BoundAddress address) _) = atomically $ do 28 | connections <- takeTMVar (nodeRt ^. RLens.connections) 29 | (mbNodeConn, newConnections) <- case Map.lookup address connections of 30 | Nothing -> pure (Nothing, connections) 31 | Just nodeConnection -> do 32 | let newConnections = Map.delete address connections 33 | pure (Just nodeConnection, newConnections) 34 | putTMVar (nodeRt ^. RLens.connections) newConnections 35 | pure $ mbNodeConn >>= Just . (^. RLens.bindedServer) 36 | 37 | 38 | bindServer :: T.NodeRuntime -> D.Host -> T.NodeRole -> T.ConnectionWorkerHandle -> IO T.BindedServer 39 | bindServer nodeRt host role workerHandle = do 40 | connections <- atomically $ takeTMVar $ nodeRt ^. RLens.connections 41 | let bindingAddress = D.Address host (fromIntegral (Map.size connections)) 42 | let bindedServer = T.BindedServer bindingAddress workerHandle 43 | let newConnection = T.NodeConnection role bindedServer 44 | let newConnections = Map.insert bindingAddress newConnection connections 45 | atomically $ putTMVar (nodeRt ^. RLens.connections) newConnections 46 | pure bindedServer 47 | 48 | 49 | -- TODO: this is probably wrong, because we have to wait all STM operations first. 50 | stopBindedServer :: T.BindedServer -> IO () 51 | stopBindedServer bindedServer = killThread $ bindedServer ^. RLens.handle . RLens.threadId 52 | 53 | -- | Establish connection with the server through test environment. 54 | -- TODO: check if connection exists. 55 | closeConnection :: T.NodeRuntime -> D.Connection D.Tcp -> IO () 56 | closeConnection nodeRt connection = removeConnection nodeRt connection >>= \case 57 | Nothing -> pure () 58 | Just bindedServer -> stopBindedServer bindedServer 59 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Framework/Internal/TcpLikeServerWorker.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Framework.Internal.TcpLikeServerWorker where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Data.Map as Map 6 | import qualified Data.Aeson as A 7 | import Data.Aeson 8 | 9 | import qualified Enecuum.Domain as D 10 | import qualified Enecuum.Language as L 11 | 12 | import qualified Enecuum.Testing.Types as T 13 | import qualified Enecuum.Testing.RLens as RLens 14 | 15 | import Enecuum.Testing.Framework.Internal.TcpLikeServerBinding (registerConnection) 16 | 17 | -- | Node TCP-like binded server worker. 18 | startNodeTcpLikeWorker 19 | :: (L.NodeL () -> IO ()) 20 | -> T.NodeRuntime 21 | -> Map Text (L.NetworkHandler D.Tcp L.NodeL) 22 | -> Maybe (D.Connection D.Tcp) 23 | -> IO T.ConnectionWorkerHandle 24 | startNodeTcpLikeWorker nodeLRunner nodeRt handlers mbBackConn = do 25 | 26 | control <- T.Control <$> newEmptyTMVarIO <*> newEmptyTMVarIO 27 | tBackConn <- maybe newEmptyTMVarIO newTMVarIO mbBackConn 28 | 29 | tId <- forkIO $ go 0 control tBackConn 30 | 31 | pure $ T.ConnectionWorkerHandle tId control nodeRt tBackConn 32 | where 33 | 34 | go iteration control tBackConn = do 35 | void $ act iteration control tBackConn 36 | go (iteration + 1 :: Int) control tBackConn 37 | 38 | act _ control tBackConn = do 39 | controlReq <- atomically $ takeTMVar $ control ^. RLens.request 40 | case controlReq of 41 | T.AcceptBackConnectionReq bindedServer -> do 42 | atomically $ putTMVar tBackConn (D.Connection (D.BoundAddress $ bindedServer ^. RLens.address) 0) 43 | registerConnection nodeRt bindedServer 44 | 45 | T.MessageReq msg -> do 46 | backConn <- atomically $ readTMVar tBackConn 47 | case decode msg of 48 | Nothing -> pure () -- TODO: error response here. 49 | Just val -> callHandler nodeLRunner backConn handlers val 50 | _ -> error "Control request is not supported in binded Tcp-like server." 51 | atomically $ putTMVar (control ^. RLens.response) T.AsSuccessResp 52 | 53 | 54 | callHandler 55 | :: (L.NodeL () -> IO ()) 56 | -> D.Connection D.Tcp 57 | -> Map Text (A.Value -> D.Connection D.Tcp -> L.NodeL ()) 58 | -> D.NetworkMsg 59 | -> IO () 60 | callHandler nodeLRunner backConn handlers (D.NetworkMsg tag val) = case Map.lookup tag handlers of 61 | Nothing -> pure () -- TODO: some error response here. 62 | Just method -> void $ forkIO $ nodeLRunner (method val backConn) 63 | 64 | 65 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Framework/Interpreters.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Framework.Interpreters 2 | ( module X 3 | ) where 4 | 5 | import Enecuum.Testing.Framework.Interpreters.Networking as X 6 | import Enecuum.Testing.Framework.Interpreters.Node as X 7 | import Enecuum.Testing.Framework.Interpreters.NodeDefinition as X 8 | import Enecuum.Testing.Framework.Interpreters.State as X 9 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Framework/Interpreters/State.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Framework.Interpreters.State where 2 | 3 | import Enecuum.Prelude 4 | 5 | import qualified Crypto.Hash.SHA256 as SHA 6 | import qualified Data.ByteString.Base64 as Base64 7 | import qualified Data.Map as Map 8 | import Data.HGraph.StringHashable (StringHash (..), StringHashable, toHash) 9 | import Unsafe.Coerce (unsafeCoerce) 10 | 11 | import qualified Enecuum.Language as L 12 | import qualified Enecuum.Domain as D 13 | import qualified Enecuum.Framework.Lens as Lens 14 | 15 | import qualified Enecuum.Testing.RLens as RLens 16 | import qualified Enecuum.Testing.Types as T 17 | import Enecuum.Core.HGraph.Interpreters.STM (runHGraphSTM) 18 | 19 | newtype VarNumber = VarNumber Int 20 | 21 | instance StringHashable VarNumber where 22 | toHash (VarNumber n) = StringHash . Base64.encode . SHA.hash $ show ("VarNumber " +|| n ||+ "" :: String) 23 | 24 | -- TODO: this is almost copy-pasted to real runtime. 25 | 26 | getVarNumber :: T.NodeRuntime -> STM VarNumber 27 | getVarNumber nodeRt = do 28 | number <- T.getNextId nodeRt 29 | pure $ VarNumber number 30 | 31 | newVar' :: T.NodeRuntime -> a -> STM D.VarId 32 | newVar' nodeRt a = do 33 | varNumber <- getVarNumber nodeRt 34 | tvar <- newTVar $ unsafeCoerce a 35 | nodeState <- takeTMVar $ nodeRt ^. RLens.state 36 | let varId = D.toHash varNumber 37 | putTMVar (nodeRt ^. RLens.state) $ Map.insert varId (T.VarHandle varId tvar) nodeState 38 | pure varId 39 | 40 | readVar' :: T.NodeRuntime -> D.StateVar a -> STM a 41 | readVar' nodeRt (D._varId -> varId) = do 42 | nodeState <- readTMVar $ nodeRt ^. RLens.state 43 | case Map.lookup varId nodeState of 44 | Nothing -> error $ "Var not found: " +|| varId ||+ "." 45 | Just (T.VarHandle _ tvar) -> unsafeCoerce <$> readTVar tvar 46 | 47 | writeVar' :: T.NodeRuntime -> D.StateVar a -> a -> STM () 48 | writeVar' nodeRt (D._varId -> varId) val = do 49 | nodeState <- readTMVar $ nodeRt ^. RLens.state 50 | case Map.lookup varId nodeState of 51 | Nothing -> error $ "Var not found: " +|| varId ||+ "." 52 | Just (T.VarHandle _ tvar) -> writeTVar tvar $ unsafeCoerce val 53 | 54 | 55 | -- | Interpret StateL as STM. 56 | interpretStateL :: T.NodeRuntime -> L.StateF a -> STM a 57 | 58 | interpretStateL nodeRt (L.NewVar val next ) = next . D.StateVar <$> newVar' nodeRt val 59 | 60 | interpretStateL nodeRt (L.ReadVar var next ) = next <$> readVar' nodeRt var 61 | 62 | interpretStateL nodeRt (L.WriteVar var val next) = next <$> writeVar' nodeRt var val 63 | 64 | interpretStateL _ (L.Retry _ ) = retry 65 | 66 | interpretStateL _ (L.EvalGraph gr act next) = 67 | next <$> runHGraphSTM gr act 68 | 69 | interpretStateL _ (L.EvalDelayedLogger _ next) = pure $ next () 70 | 71 | -- | Runs state model as STM. 72 | runStateL :: T.NodeRuntime -> L.StateL a -> STM a 73 | runStateL nodeRt = foldFree (interpretStateL nodeRt) 74 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/RLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Enecuum.Testing.RLens where 5 | 6 | import Enecuum.Prelude (makeFieldsNoPrefix) 7 | 8 | import Enecuum.Testing.Types 9 | 10 | makeFieldsNoPrefix ''LoggerRuntime 11 | makeFieldsNoPrefix ''Control 12 | makeFieldsNoPrefix ''RpcServerHandle 13 | makeFieldsNoPrefix ''ServerHandle 14 | makeFieldsNoPrefix ''ConnectionWorkerHandle 15 | makeFieldsNoPrefix ''BindedServer 16 | makeFieldsNoPrefix ''NodeRuntime 17 | makeFieldsNoPrefix ''TestRuntime 18 | makeFieldsNoPrefix ''NodeConnection 19 | -------------------------------------------------------------------------------- /test/test-framework/Enecuum/Testing/Wrappers.hs: -------------------------------------------------------------------------------- 1 | module Enecuum.Testing.Wrappers where 2 | 3 | import Test.Hspec (Spec, SpecWith, describe) 4 | 5 | fastTest :: SpecWith () -> Spec 6 | fastTest = describe "Fast" 7 | 8 | slowTest :: SpecWith () -> Spec 9 | slowTest = describe "Slow" 10 | 11 | stableTest :: SpecWith a -> SpecWith a 12 | stableTest = describe "Stable" 13 | 14 | unstableTest :: SpecWith a -> SpecWith a 15 | unstableTest = describe "Unstable" -------------------------------------------------------------------------------- /transfer: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ $# -eq 0 ]; then echo -e "No arguments specified. Usage:\necho transfer /tmp/test.md"; return 1; fi 4 | curl -H "Max-Downloads: 1" -H "Max-Days: 1" --progress-bar --upload-file "$1" "https://transfer.sh/" && echo -e "\n" 5 | --------------------------------------------------------------------------------