├── .gitattributes ├── .gitignore ├── .hlint.yaml ├── Blockchain-Fae-Contracts.html ├── Blockchain-Fae-Currency.html ├── Blockchain-Fae-FrontEnd.html ├── Blockchain-Fae-Internal-Contract.html ├── Blockchain-Fae-Internal-Crypto.html ├── Blockchain-Fae-Internal-Exceptions.html ├── Blockchain-Fae-Internal-GenericInstances.html ├── Blockchain-Fae-Internal-GetInputValues.html ├── Blockchain-Fae-Internal-IDs-Types.html ├── Blockchain-Fae-Internal-IDs.html ├── Blockchain-Fae-Internal-Messages.html ├── Blockchain-Fae-Internal-Monitors.html ├── Blockchain-Fae-Internal-Reward.html ├── Blockchain-Fae-Internal-Serialization.html ├── Blockchain-Fae-Internal-Storage.html ├── Blockchain-Fae-Internal-Suspend.html ├── Blockchain-Fae-Internal-TX.html ├── Blockchain-Fae-Internal-TXSummary.html ├── Blockchain-Fae-Internal-Transaction.html ├── Blockchain-Fae-Internal-Versions.html ├── Blockchain-Fae-Internal.html ├── Blockchain-Fae.html ├── LICENSE ├── README.md ├── bin ├── FaeServer.hs ├── FaeServer │ ├── App.hs │ ├── Args.hs │ ├── Concurrency.hs │ ├── Fae.hs │ ├── Faeth.hs │ ├── Git.hs │ ├── History.hs │ └── Modules.hs ├── PostTX.hs └── PostTX │ ├── Args.hs │ ├── Faeth.hs │ ├── ImportExport.hs │ ├── Keys.hs │ ├── Network.hs │ ├── Parser.hs │ ├── Submit.hs │ ├── TXSpec.hs │ └── View.hs ├── common └── Common │ ├── JSON.hs │ ├── Lens.hs │ └── ProtocolT.hs ├── demos ├── .gitignore ├── Auction │ ├── Auction.hs │ ├── Bid │ ├── Bid.hs │ ├── Collect │ ├── Collect.hs │ ├── Create │ └── Create.hs ├── GetCoins │ ├── GetCoin │ ├── GetCoin.hs │ ├── GetMoreCoins │ └── GetMoreCoins.hs ├── HelloWorld1 │ ├── HelloWorld1 │ ├── HelloWorld1.hs │ └── HelloWorld1.md ├── HelloWorld2 │ ├── CallHelloWorld2 │ ├── CallHelloWorld2.hs │ ├── HelloWorld2 │ ├── HelloWorld2.hs │ └── HelloWorld2.md ├── Swap │ ├── CreateSwap │ ├── CreateSwap.hs │ ├── GetOffering │ ├── GetOffering.hs │ ├── GiveOpinion │ └── GiveOpinion.hs └── talk-3 │ ├── FaethService │ ├── FaethService.hs │ ├── alice │ ├── bob │ ├── bob-fae │ ├── cmd1 │ ├── cmd2 │ ├── dev-address │ └── user-address ├── docker ├── faeServer │ ├── .dockerignore │ ├── Dockerfile │ ├── build │ ├── etc │ │ └── faeServer.sh │ └── tmp │ │ └── anchor └── postTX │ ├── .dockerignore │ ├── Dockerfile │ ├── build │ └── etc │ ├── .dockerignore │ └── postTX.sh ├── documentation ├── FAQ.html ├── design │ ├── architecture.html │ ├── claims.html │ ├── faeth.html │ ├── functional-principles.html │ ├── import-export.html │ └── specification.html ├── project-information.html └── tutorial │ ├── reference-manual.html │ ├── tutorial-1.html │ ├── tutorial-1 │ ├── CallHelloWorld2 │ ├── CallHelloWorld2.hs │ ├── CallHelloWorld3 │ ├── CallHelloWorld3.hs │ ├── CallHelloWorld4 │ ├── CallHelloWorld4.hs │ ├── HelloWorld │ ├── HelloWorld.hs │ ├── HelloWorld2 │ ├── HelloWorld2.hs │ ├── HelloWorld2a │ ├── HelloWorld2a.hs │ ├── HelloWorld3 │ ├── HelloWorld3.hs │ ├── HelloWorld4 │ └── HelloWorld4.hs │ ├── tutorial-2.html │ ├── tutorial-2 │ ├── CallEscrow1 │ ├── CallEscrow1.hs │ ├── CallEscrow3 │ ├── CallEscrow3.hs │ ├── CallRewardNametag │ ├── CallRewardNametag.hs │ ├── Escrow1 │ ├── Escrow1.hs │ ├── Escrow2 │ ├── Escrow2.hs │ ├── Escrow3 │ ├── Escrow3.hs │ ├── Nametag.hs │ ├── RewardNametag │ └── RewardNametag.hs │ ├── tutorial-3.html │ └── tutorial-3 │ ├── EnterLottery │ ├── EnterLottery.hs │ ├── ExitLottery │ ├── ExitLottery.hs │ ├── Lottery.hs │ ├── Nametag.hs │ ├── NewLottery │ ├── NewLottery.hs │ ├── RewardNametag │ └── RewardNametag.hs ├── fae.cabal ├── index.html ├── ocean.css ├── samples ├── Blockchain.Fae.Currency │ ├── ChangeCoin │ ├── ChangeCoin.hs │ ├── GetCoin │ ├── GetCoin.hs │ ├── RoundCoin │ ├── RoundCoin.hs │ ├── SplitCoin │ ├── SplitCoin.hs │ ├── ZeroCoin │ └── ZeroCoin.hs └── Blockchain.Fae │ ├── escrows │ ├── ReturnEscrowID1 │ ├── ReturnEscrowID1.hs │ ├── ReturnEscrowID2 │ └── ReturnEscrowID2.hs │ ├── materials │ ├── AggregateInputs │ ├── AggregateInputs.hs │ ├── MaterialAssignments1 │ ├── MaterialAssignments1.hs │ ├── MaterialAssignments2 │ ├── MaterialAssignments2.hs │ ├── PayMaterial1 │ ├── PayMaterial1.hs │ ├── PayMaterial2 │ └── PayMaterial2.hs │ ├── renaming │ ├── Renaming1 │ ├── Renaming1.hs │ ├── Renaming2 │ └── Renaming2.hs │ └── timeouts │ ├── Timeout1 │ ├── Timeout1.hs │ ├── Timeout2 │ └── Timeout2.hs ├── src └── Blockchain │ ├── Fae.hs │ └── Fae │ ├── Contracts.hs │ ├── Currency.hs │ ├── FrontEnd.hs │ ├── Internal.hs │ └── Internal │ ├── Contract.hs │ ├── Crypto.hs │ ├── Exceptions.hs │ ├── GenericInstances.hs │ ├── IDs.hs │ ├── IDs │ └── Types.hs │ ├── Messages.hs │ ├── Monitors.hs │ ├── Reward.hs │ ├── Serialization.hs │ ├── Storage.hs │ ├── Suspend.hs │ ├── TX.hs │ ├── TXSummary.hs │ └── Transaction.hs ├── stack.yaml ├── tools ├── CollectPackage.hs └── PackageInfo.hs └── txs ├── .gitignore ├── Acquaintance ├── Acquaintance.hs ├── CallCallLoopContract ├── CallCallLoopContract.hs ├── CallDuplicateInputs ├── CallDuplicateInputs.hs ├── CallDuplicateInputsOutputs ├── CallDuplicateInputsOutputs.hs ├── CallLoopContract ├── CallLoopContract.hs ├── CallParent ├── CallParent.hs ├── Contract1TX1 ├── Contract1TX1.hs ├── Contract1TX2 ├── Contract1TX2.hs ├── DuplicateInputs ├── DuplicateInputs.hs ├── Error ├── Error.hs ├── ErrorCall ├── ErrorCall.hs ├── Escrow1TX1 ├── Escrow1TX1.hs ├── Escrow1TX2 ├── Escrow1TX2.hs ├── Escrow2TX1 ├── Escrow2TX1.hs ├── Escrow2TX2 ├── Escrow2TX2.hs ├── FaethAddSignature ├── FallbackTX1 ├── FallbackTX1.hs ├── FallbackTX2 ├── FallbackTX2.hs ├── GetSecret ├── GetSecret.hs ├── HelloWorldTX ├── HelloWorldTX.hs ├── Loop ├── Loop.hs ├── LoopContract ├── LoopContract.hs ├── Parent ├── Parent.hs ├── RewardsTX ├── RewardsTX.hs ├── Secret ├── Secret.hs ├── SeeAcquaintance ├── SeeAcquaintance.hs ├── StateTX ├── StateTX.hs ├── TXError ├── TXError.hs ├── TwoDeposits ├── TwoDeposits.hs ├── TwoDeposits2 ├── TwoDeposits2.hs ├── TwoPartyTX1 ├── TwoPartyTX1.hs ├── TwoPartyTX2-3 ├── TwoPartyTX2-3.hs ├── TwoPartyTX4-5 ├── TwoPartyTX4-5.hs ├── VersionsTX1 ├── VersionsTX1.hs ├── VersionsTX2 └── VersionsTX2.hs /.gitattributes: -------------------------------------------------------------------------------- 1 | *.html linguist-generated=true 2 | *.css linguist-generated=true 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | txs/postTX.sh 2 | test/ 3 | *.sw* 4 | *~ 5 | dist 6 | dist-* 7 | cabal-dev 8 | *.o 9 | *.hi 10 | *.chi 11 | *.chs.h 12 | *.dyn_o 13 | *.dyn_hi 14 | .hpc 15 | .hsenv 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | *.prof 19 | *.aux 20 | *.hp 21 | *.eventlog 22 | .stack-work/ 23 | cabal.project.local 24 | report.html 25 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Warnings currently triggered by your code 10 | - ignore: {name: "Parse error"} 11 | - ignore: {name: "Use newtype instead of data"} 12 | - ignore: {name: "Eta reduce"} 13 | - ignore: {name: "Redundant flip"} 14 | 15 | 16 | # Specify additional command line arguments 17 | # 18 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 19 | 20 | 21 | # Control which extensions/flags/modules/functions can be used 22 | # 23 | # - extensions: 24 | # - default: false # all extension are banned by default 25 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 26 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 27 | # 28 | # - flags: 29 | # - {name: -w, within: []} # -w is allowed nowhere 30 | # 31 | # - modules: 32 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 33 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 34 | # 35 | # - functions: 36 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 37 | 38 | 39 | # Add custom hints for this project 40 | # 41 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 42 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 43 | 44 | 45 | # Turn on hints that are off by default 46 | # 47 | # Ban "module X(module X) where", to require a real export list 48 | # - warn: {name: Use explicit module export list} 49 | # 50 | # Replace a $ b $ c with a . b $ c 51 | # - group: {name: dollar, enabled: true} 52 | # 53 | # Generalise map to fmap, ++ to <> 54 | # - group: {name: generalise, enabled: true} 55 | 56 | 57 | # Ignore some builtin hints 58 | # - ignore: {name: Use let} 59 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 60 | 61 | 62 | # Define some custom infix operators 63 | # - fixity: infixr 3 ~^#^~ 64 | 65 | 66 | # To generate a suitable file for HLint do: 67 | # $ hlint --default > .hlint.yaml 68 | -------------------------------------------------------------------------------- /Blockchain-Fae-Internal-GenericInstances.html: -------------------------------------------------------------------------------- 1 | Blockchain.Fae.Internal.GenericInstances

fae-2.0.0.0

Copyright(c) Ryan Reich 2017-2018
LicenseMIT
Maintainerryan.reich@gmail.com
Stabilityexperimental
Safe HaskellNone
LanguageHaskell2010

Blockchain.Fae.Internal.GenericInstances

Contents

Description

 

Synopsis

Documentation

Orphan instances

(Generic a, Typeable * a, GHasEscrowIDs (Rep a)) => HasEscrowIDs a Source #

So undecidable

(Typeable * a, EGeneric a, Serialize (ERep a)) => Exportable a Source #

So undecidable

Serialize (ERep a) => ESerialize a Source #

So undecidable

(Generic a, EGeneric1 (Rep a), (~) * (ERep a) (SERep1 (Rep a))) => EGeneric a Source #

So undecidable

Methods

eFrom :: MonadState EscrowMap m => a -> m (ERep a) Source #

eTo :: MonadState EscrowMap m => ERep a -> m a Source #

-------------------------------------------------------------------------------- /Blockchain-Fae-Internal-Monitors.html: -------------------------------------------------------------------------------- 1 | Blockchain.Fae.Internal.Monitors

fae-2.0.0.0

Copyright(c) Ryan Reich 2017-2018
LicenseMIT
Maintainerryan.reich@gmail.com
Stabilityexperimental
Safe HaskellNone
LanguageHaskell2010

Blockchain.Fae.Internal.Monitors

Description

This module provides tools to limit the resource usage of transactions and contract calls. Currently it just has a timeout function (and a particularly inefficient one at that, due to a limitation of GHC's runtime) but it could have, in addition, at least a memory limit as well.

Synopsis

Documentation

data EvalF m Source #

An evaluate-like function, e.g. a timeout or memory usage limit.

Constructors

EvalF 

Fields

type EvalT m = ReaderT (EvalF m) m Source #

A global static EvalT.

evalArg :: (Monad m, NFData a) => a -> EvalT m a Source #

Apply a global function directly to an argument.

evalTimed :: MonadIO m => Int -> EvalT m a -> m a Source #

Initialize EvalT with a timeout EvalF.

timed :: (MonadIO m, NFData a) => Int -> a -> m a Source #

Basic impure timeout function.

posixTimeout :: NFData a => Int -> a -> IO (Maybe a) Source #

GHC has an actual bug in its concurrency that non-allocating 5 | evaluations can never be pre-empted, so the stock timeout function 6 | from System.Timeout does not work on completely general values. This 7 | implementation is much, much slower because it forks a process rather 8 | than sparking a thread, but it does not have that particular 9 | limitation.

The timeout is in half-milliseconds because the fork takes that order of 10 | magnitude of time, and in fact, it is incurred twice because (in order 11 | to avoid having to communicate the value between the processes) the 12 | evaluation happens twice: once to check that it terminates, and once to 13 | get the actual value.

-------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Ryan Reich (c) 2017 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 Ryan Reich 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. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Fae, a functional smart contract system 2 | 3 | Fae is a smart contract system and blockchain definition with equivalent power 4 | to Ethereum but with the following additional benefits: 5 | 6 | - Transaction execution is parallelizable and each network node need only 7 | execute transactions it wants. 8 | 9 | - There is no virtual machine, but rather a minimal execution environment that 10 | can run an existing, general-purpose programming language. 11 | 12 | - There is no native currency, only a simple token awarded to the participants 13 | that mine blocks. 14 | 15 | - Scarcity policy is left to the discretion of each smart contract. 16 | 17 | We provide an [implementation](src/) of this system in Haskell, for which we have included the [haddocks](https://consensys.github.io/Fae/). Prose documentation for various design aspects of Fae can be found in the [documentation](documentation) directory as HTML files. As of version 2.0.0.0, there are [docker images](https://cloud.docker.com/u/teamfae/repository/list) for the two executables `faeServer` and `postTX` that comprise a playground environment. 18 | 19 | For the curious, the name "Fae" is inspired by an element of the setting of Patrick Rothfuss' *The Kingkiller Chronicles*: an otherworldly realm that periodically verges on the natural world. This and other metaphorical parallels suggest the relationship between Fae and the physical world, or Fae and Ethereum. A more direct comparison lies in the acronym "Fae: functional alternative to Ethereum". 20 | 21 | -------------------------------------------------------------------------------- /bin/FaeServer.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer 3 | Description: Simple HTTP-based server for Fae transactions 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This program, which rises to slightly above the level of a utility, is 10 | a complete Fae node, excepting the part of that job that involves the 11 | blockchain. It exposes its functionality via a regular HTTP 12 | query-parameter interface (it would be misleading to call it a REST 13 | protocol) and returns the results, mostly, as JSON, both of which are 14 | hopefully standard enough to be interoperable with other things. 15 | -} 16 | 17 | import Control.Concurrent.Lifted 18 | import Control.Concurrent.STM 19 | 20 | import Control.Monad 21 | import Control.Monad.Reader 22 | 23 | import Data.List 24 | import Data.Maybe 25 | import Data.Proxy 26 | 27 | import FaeServer.App 28 | import FaeServer.Args 29 | import FaeServer.Concurrency 30 | import FaeServer.Fae 31 | import FaeServer.Faeth 32 | import FaeServer.Git 33 | 34 | import System.Directory 35 | import System.Environment 36 | import System.Exit 37 | import System.FilePath 38 | 39 | main :: IO () 40 | main = do 41 | userHome <- getHomeDirectory 42 | faeHome <- fromMaybe (userHome "fae") <$> lookupEnv "FAE_HOME" 43 | createDirectoryIfMissing True faeHome 44 | setCurrentDirectory faeHome 45 | setEnv "GIT_DIR" "git" 46 | 47 | tID <- myThreadId 48 | txQueue <- atomically newTQueue 49 | args <- parseArgs <$> getArgs 50 | 51 | flip runReaderT txQueue $ case args of 52 | ArgsServer args@ServerArgs{..} -> do 53 | let portDir = "port-" ++ show faePort 54 | liftIO $ do 55 | createDirectoryIfMissing False portDir 56 | setCurrentDirectory portDir 57 | void $ fork $ runFae tID args 58 | void $ fork $ runServer importExportPort importExportApp queueTXExecData 59 | case serverMode of 60 | FaeMode -> runServer faePort (serverApp $ Proxy @String) queueTXExecData 61 | FaethMode -> runFaeth args tID 62 | (ArgsUsage xs) -> liftIO $ case xs of 63 | [] -> do 64 | usage 65 | exitSuccess 66 | xs -> do 67 | putStrLn $ "Unrecognized option(s): " ++ intercalate ", " xs 68 | usage 69 | exitFailure 70 | 71 | usage :: IO () 72 | usage = do 73 | self <- getProgName 74 | putStrLn $ unlines 75 | [ 76 | "Usage: (standalone) " ++ self ++ " options", 77 | " (with stack) stack exec " ++ self ++ " -- options", 78 | "", 79 | "where the available options are:", 80 | " --help Print this message", 81 | " --normal-mode Operate as standalone Fae", 82 | " --faeth-mode Synonym for --faeth", 83 | " --faeth Receive transactions via Ethereum from", 84 | " a Parity client", 85 | " --faeth-hostname=string Connect to Parity at a given hostname", 86 | " (default: 127.0.0.1)", 87 | " --faeth-port=number Connect to Parity at a given port", 88 | " (default: 8546)", 89 | " --fae-port=number Listen on a given port for normal-mode", 90 | " requests (default: 27182)", 91 | " --import-export-port=number, Listen on a given port for import/export", 92 | " requests (default: 27183)", 93 | " --new-session Deletes previous transaction history", 94 | " --resume-session Reloads previous transaction history", 95 | " --eval-timeout Maximum contract or transaction call", 96 | " duration, in milliseconds", 97 | "", 98 | "Later options shadow earlier ones when they have the same domain.", 99 | "The Fae server listens on port 'fae-port' and accepts import/export data", 100 | "on 'import-export-port'.", 101 | "", 102 | "Recognized environment variables:", 103 | " FAE_HOME Directory where transaction modules and history are stored", 104 | "", 105 | "In normal-mode, it receives requests having the following parameters:", 106 | " parent: the transaction ID that this one should immediately follow", 107 | " view: just recall an existing transaction result", 108 | " lazy: don't evaluate the transaction result, just print a generic message", 109 | " fake: don't save the transaction in the history, just run it once", 110 | " reward: take this to be a 'reward transaction' getting a Reward argument", 111 | "and expecting, except if 'view = True', the following file parameters", 112 | "each one expected to have the filename matching its module name:", 113 | " message: the binary serialization of the 'TXMessage'", 114 | " body: the module defining 'body :: a -> b -> ... -> FaeTX c'", 115 | " other: each time it appears, contains another module that is part of the transaction", 116 | "In Faeth mode, these are also accepted, but 'fake' is forced to", 117 | "'True'; live transactions are only accepted through the Ethereum", 118 | "blockchain.", 119 | "", 120 | "The import/export server accepts requests of the form:", 121 | " for exporting:", 122 | " parent: as for normal mode", 123 | " export: a pair (transaction ID, index in its input list) to export", 124 | " for importing:", 125 | " parent: as for normal mode", 126 | " import: a quadruple (cID, status, names, type) where:", 127 | " cID = the contract ID to import, with an explicit version", 128 | " status = the Status of the call to the cID", 129 | " names = list of module names required to express the contract's ContractName", 130 | " type = the ContractName itself", 131 | " valuePackage: a file containing the binary serialization of the", 132 | " value to be imported" 133 | ] 134 | -------------------------------------------------------------------------------- /bin/FaeServer/Args.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer.Args 3 | Description: Handles command-line arguments for faeServer 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This very simple, ad-hoc command line parser is just explicit 10 | pattern-matching the flag strings; fortunately, we do not accept very 11 | complex flags, so this is appropriate and understandable. 12 | -} 13 | 14 | {-# LANGUAGE TemplateHaskell #-} 15 | module FaeServer.Args where 16 | 17 | import Common.Lens 18 | import Data.List 19 | import Data.Maybe 20 | import Text.Read 21 | 22 | -- | faeServer is either actually running a server of some kind, or 23 | -- printing the help text. 24 | data Args = 25 | ArgsServer ServerArgs | 26 | -- | The list contains unrecognized arguments. 27 | ArgsUsage [String] 28 | 29 | -- | This collection of data is passed around and various parts used all 30 | -- over, though not all in any one place. This kind of suggests that maybe 31 | -- just the one constructor is not appropriate, but it is not yet worth 32 | -- changing. 33 | data ServerArgs = 34 | ServerArgs 35 | { 36 | serverMode :: ServerMode, 37 | newSession :: Bool, 38 | evalTimeout :: Int, -- ^ microseconds, 0 is disabled 39 | faePort :: Int, 40 | importExportPort :: Int, 41 | faethHostname :: String, 42 | faethPort :: Int 43 | } 44 | 45 | -- | Either accepts transactions over HTTP, or from Parity via JSON-RPC. 46 | data ServerMode = FaeMode | FaethMode 47 | 48 | -- | This uses one of the several synonyms for @localhost@, chosen to 49 | -- prevent Parity from blocking the connection as unsafe. 50 | defaultFaethHost :: String 51 | defaultFaethHost = "127.0.0.1" 52 | 53 | -- | This is not our choice; Parity defaults to 8546. 54 | defaultFaethPort :: Int 55 | defaultFaethPort = 8546 56 | 57 | makeLenses ''Args 58 | makePrisms ''Args 59 | makeLenses ''ServerArgs 60 | 61 | -- | Fills in the structure by folding the argument list. Two comments on 62 | -- the defaults: first, the 'newSession' field defaults to 'False' now, 63 | -- whereas it used to be 'True', which will wipe out unsuspecting users' 64 | -- histories; and second, the default port of 27182 is chosen to be the 65 | -- initial decimal digits of the number e. 66 | parseArgs :: [String] -> Args 67 | parseArgs = foldl addArg $ 68 | ArgsServer ServerArgs 69 | { 70 | serverMode = FaeMode, 71 | newSession = False, 72 | evalTimeout = 1000, 73 | faePort = 27182, 74 | importExportPort = 27183, 75 | faethHostname = defaultFaethHost, 76 | faethPort = defaultFaethPort 77 | } 78 | 79 | -- | Adds to 'ArgsServer' until a bad argument occurs, then starts 80 | -- accumulating those in 'ArgsUsage'. 81 | addArg :: Args -> String -> Args 82 | addArg args x = getArgAction x & case args of 83 | ArgsServer{} -> maybe (ArgsUsage [x]) ($ args) 84 | (ArgsUsage xs) -> maybe (ArgsUsage $ x : xs) (const args) 85 | 86 | -- | There aren't really any conflicts between flags, so this just sets the 87 | -- appropriate fields for each one. 88 | getArgAction :: String -> Maybe (Args -> Args) 89 | getArgAction = \case 90 | x | x == "--faeth" || x == "--faeth-mode" -> Just setFaeth 91 | | ("--faeth-hostname", '=' : hostnameArgument) <- break (== '=') x -> 92 | Just $ 93 | (_ArgsServer . _faethHostname .~ hostnameArgument) . 94 | setFaeth 95 | | ("--faeth-port", '=' : portArgument) <- break (== '=') x -> 96 | let err = error $ "Could not read port argument: " ++ portArgument in 97 | Just $ 98 | (_ArgsServer . _faethPort .~ readErr err portArgument) . 99 | setFaeth 100 | | ("--fae-port", '=' : faePortArg) <- break (== '=') x -> 101 | let err = error $ "Could not read port argument: " ++ faePortArg in 102 | Just $ _ArgsServer . _faePort .~ readErr err faePortArg 103 | | ("--import-export-port", '=' : importExportPortArg) <- break (== '=') x -> 104 | let err=error $ "Could not read port argument: " ++ importExportPortArg in 105 | Just $ _ArgsServer . _importExportPort .~ readErr err importExportPortArg 106 | | ("--eval-timeout", '=' : evalTimeoutArg) <- break (== '=') x -> 107 | let err = error $ "Could not read timeout argument: " ++ evalTimeoutArg in 108 | Just $ _ArgsServer . _evalTimeout .~ readErr err evalTimeoutArg 109 | "--normal-mode" -> Just $ _ArgsServer . _serverMode .~ FaeMode 110 | "--resume-session" -> Just $ _ArgsServer . _newSession .~ False 111 | "--new-session" -> Just $ _ArgsServer . _newSession .~ True 112 | "--help" -> Just $ const $ ArgsUsage [] 113 | _ -> Nothing 114 | 115 | where 116 | readErr err = fromMaybe err . readMaybe 117 | setFaeth = _ArgsServer . _serverMode .~ FaethMode 118 | -------------------------------------------------------------------------------- /bin/FaeServer/Concurrency.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer.Concurrency 3 | Description: Concurrency-related constructs for faeServer 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | The concurrency aspects of @faeServer@ are all centered around the Fae 10 | interpreter, which runs in a dedicated thread that reads transactions (and 11 | other instructions) to execute from a queue defined here. 12 | -} 13 | 14 | module FaeServer.Concurrency where 15 | 16 | import Blockchain.Fae.FrontEnd 17 | 18 | import Common.ProtocolT 19 | 20 | import Control.Concurrent 21 | import Control.Concurrent.STM 22 | 23 | import Control.Monad.Cont 24 | import Control.Monad.Reader 25 | import Control.Monad.State 26 | import Control.Monad.Writer 27 | 28 | import Data.ByteString (ByteString) 29 | import qualified Data.ByteString.Char8 as C8 30 | 31 | import Data.Map (Map) 32 | 33 | import System.Exit 34 | 35 | -- | All the pieces of data that are required to execute a transaction in 36 | -- the dedicated interpreter thread. 37 | data TXExecData = 38 | TXExecData 39 | { 40 | mainFile :: Module, 41 | modules :: ModuleMap, 42 | parentM :: Maybe TransactionID, 43 | lazy :: Bool, 44 | fake :: Bool, 45 | tx :: TX, 46 | resultVar :: TMVar String, 47 | callerTID :: ThreadId 48 | } | 49 | View 50 | { 51 | viewTXID :: TransactionID, 52 | parentM :: Maybe TransactionID, 53 | resultVar :: TMVar String, 54 | callerTID :: ThreadId 55 | } | 56 | ExportValue 57 | { 58 | parentM :: Maybe TransactionID, 59 | calledInTX :: TransactionID, 60 | ixInTX :: Int, 61 | exportResultVar :: TMVar ExportData, 62 | callerTID :: ThreadId 63 | } | 64 | ImportValue 65 | { 66 | parentM :: Maybe TransactionID, 67 | exportData :: ExportData, 68 | signalVar :: TMVar (), 69 | callerTID :: ThreadId 70 | } 71 | 72 | -- | Communications channel with the interpreter thread 73 | type TXQueue = TQueue TXExecData 74 | 75 | -- | Context in which transactions can be placed for execution 76 | type TXQueueT = ReaderT TXQueue 77 | 78 | -- | An mtl-style class for things with a 'TXQueue'. Its instances are all 79 | -- trivially 'lift'ing in various monad transformers. 80 | class (MonadIO m) => TXQueueM m where 81 | liftTXQueueT :: TXQueueT IO a -> m a 82 | 83 | -- | - 84 | instance {-# OVERLAPPING #-} TXQueueM (TXQueueT IO) where 85 | liftTXQueueT = id 86 | 87 | -- | - 88 | instance (TXQueueM m) => TXQueueM (ReaderT r m) where 89 | liftTXQueueT = lift . liftTXQueueT 90 | 91 | -- | - 92 | instance (TXQueueM m, Monoid w) => TXQueueM (WriterT w m) where 93 | liftTXQueueT = lift . liftTXQueueT 94 | 95 | -- | - 96 | instance (TXQueueM m) => TXQueueM (StateT s m) where 97 | liftTXQueueT = lift . liftTXQueueT 98 | 99 | -- | - 100 | instance (TXQueueM m) => TXQueueM (ContT r m) where 101 | liftTXQueueT = lift . liftTXQueueT 102 | 103 | instance (TXQueueM m) => TXQueueM (FaeInterpretT m) where 104 | liftTXQueueT = lift . liftTXQueueT 105 | 106 | instance (TXQueueM m) => TXQueueM (ProtocolT m) where 107 | liftTXQueueT = ProtocolT . liftTXQueueT 108 | 109 | -- | Abstraction for "doing something with" a transaction 110 | type SendTXExecData m = TXExecData -> m () 111 | 112 | -- | Blocks on the result variable after sending off the TX. 113 | waitRunTXExecData :: 114 | (TXQueueM m) => 115 | SendTXExecData m -> (TXExecData -> TMVar a) -> TXExecData -> m a 116 | waitRunTXExecData sendOff tmVar txExecData = do 117 | sendOff txExecData 118 | ioAtomically $ takeTMVar $ tmVar txExecData 119 | 120 | -- | Sends the TX by simply placing it in the queue. 121 | queueTXExecData :: (TXQueueM m) => SendTXExecData m 122 | queueTXExecData txExecData = do 123 | txQueue <- liftTXQueueT ask 124 | ioAtomically $ writeTQueue txQueue txExecData 125 | 126 | -- | Checks the queue for a new item, blocking until it finds one. 127 | readTXExecData :: (TXQueueM m) => m TXExecData 128 | readTXExecData = do 129 | txQueue <- liftTXQueueT ask 130 | ioAtomically $ readTQueue txQueue 131 | 132 | -- | Handles exceptions in the mixed situation where /most/ of them have to 133 | -- go back to the calling thread (i.e. the one with the connection that 134 | -- created the present 'TXExecData' item), except the ones that would 135 | -- directly exit the process, which have to go to the main thread so that, 136 | -- e.g. Ctrl-C works on the terminal. 137 | reThrowExit :: (MonadIO m, MonadCatch m) => ThreadId -> ThreadId -> m () -> m () 138 | reThrowExit mainTID callerTID = 139 | reThrow callerTID . handle (liftIO . throwTo @ExitCode mainTID) 140 | 141 | -- | Just bounces exceptions to a different thread. The interpreter thread 142 | -- must never terminate, and the victim is whichever Warp thread 143 | -- corresponds to the presently executing item. 144 | reThrow :: (MonadIO m, MonadCatch m) => ThreadId -> m () -> m () 145 | reThrow tID = handleAll (liftIO . throwTo tID) 146 | 147 | -- | Though barely shorter than its definition, this does save having to 148 | -- reproduce the (trivial) particular logic each time. 149 | ioAtomically :: (MonadIO m) => STM a -> m a 150 | ioAtomically = liftIO . atomically 151 | 152 | -------------------------------------------------------------------------------- /bin/FaeServer/Fae.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer.Fae 3 | Description: The Fae interpreter in faeServer 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This module is essentially the interpreter thread. It reads from the 10 | 'TXQueue' to which all the Warp threads write, updating an in-memory 11 | history with each new state or import, or reading from that history for 12 | viewing or export. 13 | -} 14 | 15 | module FaeServer.Fae where 16 | 17 | import Blockchain.Fae.FrontEnd 18 | 19 | import Common.JSON 20 | 21 | import Control.Concurrent 22 | import Control.Concurrent.STM 23 | 24 | import Control.Exception.Base 25 | 26 | import Control.Monad 27 | import Control.Monad.IO.Class 28 | import Control.Monad.State 29 | import Control.Monad.Trans.Cont 30 | 31 | import Data.ByteString (ByteString) 32 | import qualified Data.ByteString as B 33 | import qualified Data.Map as Map 34 | import Data.Maybe 35 | import Data.Serialize (Serialize) 36 | import qualified Data.Serialize as S 37 | 38 | import FaeServer.Args 39 | import FaeServer.Concurrency 40 | import FaeServer.Git 41 | import FaeServer.History 42 | import FaeServer.Modules 43 | 44 | import System.Directory 45 | import System.FilePath 46 | import System.IO 47 | 48 | -- | Not just an infinite event loop, this also handles initializing the 49 | -- storage from cached transactions when a new session was not requested, 50 | -- or clearing that cache when it was. It is guaranteed never to die from 51 | -- an exception (unless that exception is actually uncatchable), though any 52 | -- exception that is only caught here is bounced to the main thread and, 53 | -- thus, ends the program. Once in the event loop, only actual 'ExitCode' 54 | -- exceptions can terminate the program. 55 | runFae :: ThreadId -> ServerArgs -> TXQueueT IO () 56 | runFae mainTID ServerArgs{..} = reThrow mainTID $ runFaeInterpretWithHistory $ do 57 | indexExists <- liftIO $ doesFileExist indexFileName 58 | if newSession || not indexExists 59 | then liftIO $ do 60 | removePathForcibly "Blockchain" 61 | removePathForcibly cacheDirName 62 | createDirectory cacheDirName 63 | gitInit 64 | -- Note that this case runs transactions but does not catch exceptions as 65 | -- the main loop does. This is because it runs them lazily, and so the 66 | -- exceptions are never thrown. 67 | else forM_TXCache $ \tx@TX{..} parentM -> do 68 | txCount <- innerRun tx parentM gitReset 69 | incrementHistory txID txCount 70 | liftIO $ putStrLn $ 71 | "Replayed transaction " ++ show txID ++ " (#" ++ show txCount ++ ")" 72 | forever $ do 73 | txExecData <- readTXExecData 74 | reThrowExit mainTID (callerTID txExecData) $ 75 | runTXExecData evalTimeout txExecData 76 | 77 | -- | Gives operational meaning to the various 'TXExecData' alternatives. 78 | runTXExecData :: 79 | (Typeable m, MonadIO m, MonadMask m) => 80 | Int -> TXExecData -> FaeInterpretWithHistoryT m () 81 | -- This, the normal case, surrounds actually running the transaction with 82 | -- a great deal of bookkeeping to build the longest chain and save and 83 | -- restore history from the correct point in time. 84 | runTXExecData evalTimeout TXExecData{tx=tx@TX{..}, ..} = do 85 | dup <- gets $ Map.member txID . txStorageAndCounts 86 | when dup $ throw $ ErrorCall $ "Duplicate transaction ID: " ++ show txID 87 | 88 | txCount <- innerRun tx parentM (writeModules mainFile modules) 89 | txResult <- 90 | if lazy 91 | then return $ "Transaction " ++ show txID ++ " (#" ++ show txCount ++ ")" 92 | else do 93 | txSummary <- lift . evalTimed evalTimeout $ collectTransaction txID 94 | -- Strict because I've seen a case where an exception is thrown so 95 | -- late that it isn't caught by the app and a response isn't even sent. 96 | return $! encodeJSON txSummary 97 | if fake 98 | then unless lazy $ liftIO gitClean 99 | else do 100 | incrementHistory txID txCount 101 | extendTXCache tx parentM 102 | liftIO $ gitCommit txID 103 | ioAtomically $ putTMVar resultVar txResult 104 | 105 | -- For a 'View', we just roll back the history and build the transaction 106 | -- summary. 107 | runTXExecData evalTimeout View{..} = do 108 | void $ recallHistory parentM 109 | txSummary <- lift . evalTimed evalTimeout $ collectTransaction viewTXID 110 | ioAtomically $ putTMVar resultVar (encodeJSON txSummary) 111 | 112 | -- 'ExportValue' is quite similar to 'View', except an 'ExportData' is 113 | -- built instead. 114 | runTXExecData _ ExportValue{..} = do 115 | void $ recallHistory parentM 116 | exportResult <- lift $ lift $ getExportedValue calledInTX ixInTX 117 | ioAtomically $ putTMVar exportResultVar exportResult 118 | 119 | -- 'ImportValue' is just the bookkeeping part of the 'TXExecData' case's 120 | -- operation, calling out to the interpreter to insert the imported value 121 | -- directly rather than running a new transaction. 122 | runTXExecData _ ImportValue{..} = do 123 | parentCount <- recallHistory parentM 124 | lift $ interpretImportedValue exportData 125 | updateHistory parentM parentCount 126 | ioAtomically $ putTMVar signalVar () 127 | 128 | -- | The interpreter is actually run here; this appears both in the initial 129 | -- fast-forward from the transaction cache and in 'runTXExecData'. 130 | innerRun :: 131 | (Typeable m, MonadIO m, MonadMask m) => 132 | TX -> Maybe TransactionID -> (TransactionID -> IO ()) -> 133 | FaeInterpretWithHistoryT m Integer 134 | innerRun tx@TX{..} parentM placeModules = do 135 | txCount <- recallHistory parentM 136 | liftIO $ placeModules txID 137 | lift $ interpretTX tx 138 | return txCount 139 | 140 | -- | Appends a new transaction to the cache. The cache is not very 141 | -- complicated: it has a file for each transaction object, and a line in 142 | -- a single file for each transaction ID, in order of appearance, 143 | -- regardless of how they depend on earlier ones. 144 | extendTXCache :: (MonadIO m) => TX -> Maybe TransactionID -> m () 145 | extendTXCache tx@TX{..} parentM = liftIO $ do 146 | B.writeFile (makeTXFileName txID) $ S.encode (tx, parentM) 147 | B.appendFile indexFileName $ S.encode txID 148 | 149 | -- | Does...something...to each transaction in the cache. Though the 150 | -- definition is somewhat extended, most of it is just handling filesystem 151 | -- stuff. 152 | forM_TXCache :: (MonadIO m) => (TX -> Maybe TransactionID -> m ()) -> m () 153 | forM_TXCache f = evalContT $ callCC $ \done -> do 154 | let 155 | act h = go where 156 | hGetS :: (Serialize a, MonadIO m) => Int -> m a 157 | hGetS = decodeFile (error "Bad TX cache") (liftIO . B.hGet h) 158 | go = do 159 | atEOF <- liftIO $ hIsEOF h 160 | when atEOF $ done () 161 | txID <- hGetS txIDLength 162 | let txErr = error $ "Bad transaction file for TX" ++ show txID 163 | (tx, parentM) <- getTX txErr $ makeTXFileName txID 164 | lift $ f tx parentM 165 | go 166 | isCache <- liftIO $ doesFileExist indexFileName 167 | unless isCache $ done () 168 | h <- liftIO $ openBinaryFile indexFileName ReadMode 169 | act h 170 | liftIO $ hClose h 171 | 172 | where 173 | decodeFile :: (Serialize a, Monad m) => a -> (b -> m ByteString) -> (b -> m a) 174 | decodeFile err getter = fmap (either (const err) id . S.decode) . getter 175 | getTX err = decodeFile err (liftIO . B.readFile) 176 | 177 | cacheDirName :: String 178 | cacheDirName = "txcache" 179 | 180 | -- | Establishes the location of the transaction cache's index file. 181 | indexFileName :: String 182 | indexFileName = cacheDirName "index" 183 | 184 | -- | Establishes the location of the transaction cache files. 185 | makeTXFileName :: TransactionID -> String 186 | makeTXFileName txID = cacheDirName show txID 187 | 188 | -- | A constant that, no doubt, is equal to 32 (bytes). 189 | txIDLength :: Int 190 | txIDLength = B.length $ S.encode nullID 191 | 192 | -------------------------------------------------------------------------------- /bin/FaeServer/Git.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer.Git 3 | Description: Git operations for keeping transaction modules 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | Fae transactions come along with their source code, which is a bunch of 10 | Haskell modules that may be visible to other, later transactions. 11 | Therefore the correct set of modules needs to be visible on disk (in the 12 | interpreter's search path) at each point in history. We achieve this by 13 | utilizing @git@ to record each post-transaction state as a commit tagged by 14 | the transaction ID, and to reset to each one when it is used as a parent 15 | transaction. 16 | -} 17 | 18 | module FaeServer.Git where 19 | 20 | import Blockchain.Fae.FrontEnd 21 | 22 | import Control.Monad 23 | 24 | import System.Directory 25 | import System.Environment 26 | import System.Exit 27 | import System.Process 28 | 29 | -- | More than just @git init@, this also ensures a truly fresh repo, sets 30 | -- up necessary user info, and creates the "genesis transaction" commit. 31 | gitInit :: IO () 32 | gitInit = do 33 | removePathForcibly "git" 34 | runGitWithArgs "init" ["--quiet"] 35 | runGitWithArgs "config" ["user.name", "Fae"] 36 | runGitWithArgs "config" ["user.email", "fae"] 37 | runGitWithArgs "commit" ["-q", "--allow-empty", "-m", "Transaction " ++ show nullID] 38 | runGitWithArgs "tag" [mkTXIDName nullID] 39 | 40 | -- | Commits and also tags the @Blockchain@ hierarchical directory. 41 | gitCommit :: TransactionID -> IO () 42 | gitCommit txID = do 43 | runGitWithArgs "add" ["Blockchain"] 44 | runGitWithArgs "commit" ["-q", "-m", "Transaction " ++ show txID] 45 | runGitWithArgs "tag" [mkTXIDName txID] 46 | 47 | -- | This is a /hard/ reset, because we really want to have exactly the 48 | -- correct set of modules on disk afterwards. 49 | gitReset :: TransactionID -> IO () 50 | gitReset oldTXID = runGitWithArgs "reset" ["--hard", "-q", mkTXIDName oldTXID] 51 | 52 | -- | @git clean@ removes untracked files, e.g. modules produced by fake 53 | -- transactions. These would otherwise persist across hard resets. 54 | gitClean :: IO () 55 | gitClean = runGitWithArgs "clean" ["-q", "-f", "Blockchain"] 56 | 57 | -- | Invokes @git --work-tree .@ since we intentionally use a nonstandardly 58 | -- named git directory; any output is helpfully reported. 59 | runGitWithArgs :: String -> [String] -> IO () 60 | runGitWithArgs cmd args = do 61 | let fullArgs = "--work-tree" : "." : cmd : args 62 | (exitCode, out, err) <- readProcessWithExitCode "git" fullArgs "" 63 | case exitCode of 64 | ExitSuccess -> unless (null out) $ putStrLn $ unlines 65 | [ 66 | "`git " ++ cmd ++ "` was successful with the following output:", 67 | out 68 | ] 69 | ExitFailure n -> do 70 | putStrLn $ unlines $ 71 | ("`git " ++ cmd ++ "` returned code " ++ show n) : 72 | if null err then [] else 73 | [ 74 | "Error message:", 75 | err 76 | ] 77 | exitFailure 78 | 79 | -------------------------------------------------------------------------------- /bin/FaeServer/History.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer.History 3 | Description: Stores and tracks successive Fae storage states 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | The entry point to the Fae core library is just `interpretTX`, i.e. running 10 | a single transaction with some preexisting storage state. This state is 11 | built up by @faeServer@'s event loop, but even that is not enough history, 12 | because we need to be able to roll back to previous parent transactions 13 | with the correct post-transaction state. This module manages 14 | a meta-history containing each such storage state for all transactions. 15 | (Due to sharing of immutable values in Haskell, successive entries in this 16 | history should only add an incremental amount of data, so the memory 17 | requirements will not be quadratic as they may seem.) 18 | -} 19 | 20 | module FaeServer.History where 21 | 22 | import Blockchain.Fae.FrontEnd 23 | 24 | import Common.Lens ((&)) 25 | 26 | import Control.Monad.IO.Class 27 | import Control.Monad.State 28 | import Control.Monad.Trans.Class 29 | 30 | import Data.Map (Map) 31 | import qualified Data.Map as Map 32 | 33 | import Data.Maybe 34 | 35 | import FaeServer.Concurrency 36 | import FaeServer.Git 37 | 38 | -- | Tracks all post-transaction states for the purpose of rolling back. 39 | data TXHistory = 40 | TXHistory 41 | { 42 | txStorageAndCounts :: Map TransactionID (Storage, Integer), 43 | bestTXID :: TransactionID, 44 | bestTXCount :: Integer 45 | } 46 | 47 | -- | Monad for tracking history 48 | type FaeInterpretWithHistoryT m = StateT TXHistory (FaeInterpretT m) 49 | 50 | -- | Marshals the several parallel operations that need to occur when 51 | -- a state rollback occurs: reset git /and/ fetch the old Fae storage. 52 | recallHistory :: 53 | (MonadIO m) => Maybe TransactionID -> FaeInterpretWithHistoryT m Integer 54 | recallHistory parentM = do 55 | TXHistory{..} <- get 56 | let parent = fromMaybe bestTXID parentM 57 | err = error $ "No transaction in history with ID: " ++ show parent 58 | -- Weird construct forces this lookup before git runs 59 | (s, n) <- return $ Map.findWithDefault err parent txStorageAndCounts 60 | liftIO $ gitReset parent 61 | lift $ put s 62 | return n 63 | 64 | -- | Not quite complementary to 'recallHistory', this merely updates the 65 | -- 'TXHistory' but does not run git, which will operate differently 66 | -- depending on transaction-specific parameters (e.g. @fake@). It also 67 | -- recomputes the "best", i.e. longest, chain of transactions, which is 68 | -- used as the default parent for transactions that don't specify one. 69 | -- 70 | -- The second, @Integer@ parameter gives the new transaction count; this is 71 | -- necessary because there is a fencepost problem in how this is calculated 72 | -- in the fast-forward from the transaction cache versus adding a new 73 | -- transaction. 74 | updateHistory :: 75 | (Monad m) => Maybe TransactionID -> Integer -> FaeInterpretWithHistoryT m () 76 | updateHistory txIDM newCount = do 77 | TXHistory{..} <- get 78 | s <- lift get 79 | let txID = fromMaybe bestTXID txIDM 80 | txStorageAndCounts' = Map.insert txID (s, newCount) txStorageAndCounts 81 | (bestTXID', bestTXCount') 82 | | newCount > bestTXCount = (txID, newCount) 83 | | otherwise = (bestTXID, bestTXCount) 84 | put $ TXHistory txStorageAndCounts' bestTXID' bestTXCount' 85 | 86 | -- | Updates with incremented count. 87 | incrementHistory :: 88 | (Monad m) => TransactionID -> Integer -> FaeInterpretWithHistoryT m () 89 | incrementHistory txID n = updateHistory (Just txID) (n + 1) 90 | 91 | -- | Runs the stack of monads with an empty history. The transaction count 92 | -- starts at 1, not 0. 93 | runFaeInterpretWithHistory :: 94 | (MonadMask m, MonadIO m) => FaeInterpretWithHistoryT m () -> m () 95 | runFaeInterpretWithHistory = runFaeInterpret . flip evalStateT emptyTXHistory where 96 | emptyTXHistory = 97 | TXHistory 98 | { 99 | txStorageAndCounts = 100 | Map.singleton nullID (Storage Map.empty Map.empty, 1), 101 | bestTXID = nullID, 102 | bestTXCount = 1 103 | } 104 | 105 | -------------------------------------------------------------------------------- /bin/FaeServer/Modules.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: FaeServer.Modules 3 | Description: A few functions for getting a transaction's modules 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | In addition to organizing the modules attached to a transaction message, 10 | this module also contains the logic to alter their headers, and create 11 | re-export versions, to match the interpreter's expectations. 12 | -} 13 | 14 | module FaeServer.Modules where 15 | 16 | import Blockchain.Fae.FrontEnd 17 | 18 | import Control.DeepSeq 19 | import Control.Monad 20 | 21 | import qualified Data.ByteString.Lazy.Char8 as LC8 22 | import qualified Data.ByteString.Char8 as C8 23 | 24 | import Data.Map (Map) 25 | import qualified Data.Map as Map 26 | 27 | import Data.Char 28 | import Data.List 29 | import Data.Maybe 30 | import Data.Monoid 31 | import Data.Proxy 32 | import Data.Serialize 33 | 34 | import FaeServer.Git 35 | 36 | import Network.Wai.Parse 37 | 38 | import System.Directory 39 | import System.FilePath 40 | 41 | -- | How files in a request are presented. 42 | type RequestFiles = [(Module, FileInfo LC8.ByteString)] 43 | 44 | -- | Extracts the transaction object from the full message and arranges the 45 | -- files into a name-contents mapping. 46 | makeFilesMap :: 47 | (Serialize a) => 48 | TXMessage a -> Module -> ModuleMap -> Bool -> Bool -> (TX, Module, ModuleMap) 49 | makeFilesMap txMessage mainFile0 modules0 reward isFake = (tx, mainFile, modules) where 50 | moduleNames = dropExtension <$> Map.keys modules0 51 | mainFile = fixImports txID moduleNames $ addHeader txID mainFile0 52 | modules = Map.mapWithKey (fixModule txID moduleNames . dropExtension) modules0 53 | tx@TX{..} = 54 | maybe (error "Invalid transaction message") force $ 55 | txMessageToTX reward txMessage isFake 56 | 57 | -- | Looks up a file or throws an error. 58 | getFile :: RequestFiles -> String -> Module 59 | getFile files name = fromMaybe (error $ "Missing " ++ name) $ 60 | getFileMaybe files name 61 | 62 | -- | Looks up a file, maybe. The one selected is the last one of that 63 | -- name. 64 | getFileMaybe :: RequestFiles -> String -> Maybe Module 65 | getFileMaybe files = last . (Nothing :) . map (Just . snd) . getFiles files 66 | 67 | -- | Gets all files with a given name, converting to regular data types. 68 | getFiles :: RequestFiles -> String -> [(String, Module)] 69 | getFiles files name = 70 | [ 71 | (C8.unpack fileName, LC8.toStrict fileContent) 72 | | (name', FileInfo{..}) <- files, name' == C8.pack name 73 | ] 74 | 75 | -- | Places the main module and the others into the required directory 76 | -- structure, along with "private" variants. 77 | writeModules :: Module -> ModuleMap -> TransactionID -> IO () 78 | writeModules mainFile modules txID = do 79 | let thisTXDir = foldr () "" $ mkTXPathParts txID 80 | writeModule fileName fileContents = 81 | C8.writeFile (thisTXDir fileName) fileContents 82 | createDirectoryIfMissing True thisTXDir 83 | C8.writeFile (thisTXDir <.> "hs") mainFile 84 | sequence_ $ Map.mapWithKey writeModule modules 85 | 86 | -- | Adds a module header to the body module (like @Main@ it does not have 87 | -- a header, nor could it even write one, as the TXID is not known until 88 | -- after the module is written!) 89 | addHeader :: TransactionID -> Module -> Module 90 | addHeader txID = C8.append header where 91 | header = moduleHeader (mkTXModuleName txID) Nothing "Blockchain.Fae" 92 | 93 | -- | Adjust an "other" module to have correctly qualified module names in 94 | -- the header and imports. 95 | fixModule :: TransactionID -> [String] -> String -> Module -> Module 96 | fixModule txID moduleNames fileName = 97 | fixImports txID moduleNames . 98 | fixHeader txID fileName 99 | 100 | -- | For each import of one of the "other" modules, qualify it with the 101 | -- transaction ID path. 102 | fixImports :: TransactionID -> [String] -> Module -> Module 103 | fixImports txID moduleNames = 104 | C8.unlines . fmap (fixImport txID moduleNames) . C8.lines 105 | 106 | -- | Determine if a line imports an "other" module and, if so, qualify the 107 | -- module name. 108 | fixImport :: TransactionID -> [String] -> C8.ByteString -> C8.ByteString 109 | fixImport txID moduleNames line 110 | | ("import", rest0) <- C8.break isSpace line, 111 | let rest = C8.dropWhile isSpace rest0 112 | (isQualified, rest') = 113 | maybe (False, rest) ((True,) . C8.dropWhile isSpace) $ 114 | C8.stripPrefix "qualified" rest 115 | (moduleNameBS, rest'') = C8.break isSpace rest' 116 | moduleName = C8.unpack moduleNameBS, 117 | moduleName `elem` moduleNames 118 | = C8.pack 119 | ( 120 | "import " ++ if isQualified then "qualified " else "" ++ 121 | qualify txID moduleName 122 | ) <> 123 | rest'' 124 | | otherwise = line 125 | 126 | -- | Adjusts the name of one of the imported modules to live under the Fae 127 | -- hierarchy (the original name is available as the private variant). 128 | fixHeader :: TransactionID -> String -> Module -> Module 129 | fixHeader txID fileName = replaceModuleNameWith (qualify txID fileName) 130 | 131 | -- | Creates a module header with given name, exports, and import. 132 | moduleHeader :: String -> Maybe [String] -> String -> C8.ByteString 133 | moduleHeader moduleName exportsM importModule = C8.pack $ 134 | "module " ++ moduleName ++ 135 | maybe " " (\exports -> " (" ++ intercalate "," exports ++ ") ") exportsM ++ 136 | "where\n\nimport " ++ importModule ++ "\n\n" 137 | 138 | -- | Actually does the module name adjustment. This does 139 | -- a...suspect...kind of parsing to figure out where the name should be: 140 | -- cut out the chunk of the file from the first "module" to the first 141 | -- subsequent "where". Assuming there are no weird comments above the 142 | -- module header, and that the exports do not include anything with "where" 143 | -- in the name, this should actually work. I wish there were an accessible 144 | -- Haskell parser I could use. 145 | replaceModuleNameWith :: String -> Module -> Module 146 | replaceModuleNameWith moduleName contents = 147 | pre `C8.append` C8.pack ("module " ++ moduleName ++ " ") `C8.append` post 148 | where 149 | (pre, post0) = C8.breakSubstring "module" contents 150 | (_, post) = C8.breakSubstring "where" post0 151 | 152 | -- | Adds "Blockchain.Fae.TX." in front of the module name. 153 | qualify :: TransactionID -> String -> String 154 | qualify txID moduleName = mkTXModuleName txID ++ "." ++ moduleName 155 | 156 | -------------------------------------------------------------------------------- /bin/PostTX/Faeth.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.Faeth 3 | Description: Handler for postTX's Faeth mode 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | The two 'submit' functions craft a JSON-RPC message for Parity describing 10 | the transaction to submit or to look up. All that logic, however, is in 11 | 'Common.ProtocolT'; we just fill in some blanks here. 12 | -} 13 | module PostTX.Faeth where 14 | 15 | import Blockchain.Fae.FrontEnd 16 | 17 | import Common.Lens 18 | import Common.ProtocolT 19 | 20 | import Control.Monad.Trans 21 | 22 | import Data.Aeson (ToJSON(..)) 23 | import Data.Maybe 24 | 25 | import PostTX.Args 26 | import PostTX.TXSpec 27 | 28 | import System.Console.Haskeline 29 | 30 | import Text.Read 31 | 32 | -- | Since an 'EthTXID' is actually just a byte string, this gives it 33 | -- a distinct identity so that it can have the following instances. 34 | newtype GetFaethTX = GetFaethTX EthTXID 35 | 36 | -- | - 37 | instance ToJSON GetFaethTX where 38 | toJSON (GetFaethTX ethTXID) = toJSON [ethTXID] 39 | 40 | -- | - 41 | instance ToRequest GetFaethTX where 42 | requestMethod _ = "eth_getTransactionByHash" 43 | 44 | -- | Sends a new Fae transaction to Parity, wrapped in an Ethereum 45 | -- transaction. The details of this are in 'Common.ProtocolT' and 46 | -- 'FaeServer.Faeth'. 47 | submitFaeth :: String -> Maybe Integer -> Maybe EthAddress -> TXSpec Salt -> IO () 48 | submitFaeth host valM faethTo TXSpec{specModules = LoadedModules{..}, ..} = do 49 | senderEthAccount <- inputAccount 50 | let (hostname, ':' : port) = break (== ':') host 51 | let portNum = fromMaybe (error $ "Bad port number: " ++ port) $ readMaybe port 52 | runProtocolT hostname portNum $ do 53 | ethTXID <- sendReceiveProtocolT 54 | FaethTXData 55 | { 56 | faeTX = 57 | EthArgFaeTX FaeTX 58 | { 59 | faeTXMessage = txMessage, 60 | faeMainModule = snd mainModule, 61 | faeOtherModules = otherModules 62 | }, 63 | faethEthValue = HexInteger <$> valM, 64 | faethEthAddress = fromMaybe (address senderEthAccount) faethTo, 65 | .. 66 | } 67 | liftIO . putStrLn $ 68 | "Ethereum transaction ID: " ++ ethTXID ++ 69 | "\nFae transaction ID: " ++ show (getTXID txMessage) 70 | 71 | -- | Requests a previously entered Faeth transaction from Parity (or 72 | -- rather, requests an Ethereum transaction and tries to extract a Fae 73 | -- transaction from it), then changes various parameters of the Ethereum 74 | -- transaction to match the ones required in the Fae transaction's 'Salt'. 75 | resubmitFaeth :: String -> EthTXID -> FaethArgs -> IO () 76 | resubmitFaeth host ethTXID FaethArgs{..} = do 77 | senderEthAccount <- inputAccount 78 | let (hostname, ':' : port) = break (== ':') host 79 | let portNum = fromMaybe (error $ "Bad port number: " ++ port) $ readMaybe port 80 | runProtocolT hostname portNum $ do 81 | faethTXData <- sendReceiveProtocolT $ GetFaethTX ethTXID 82 | newKeys <- liftIO $ mapM resolveKeyName newKeyNames 83 | let 84 | addSigners = 85 | foldr (.) id $ 86 | zipWith addSigner newNames newKeys 87 | txID = getTXID $ faeTXMessage $ getEthArgFaeTX $ faeTX faethTXData 88 | ethTXID <- sendReceiveProtocolT $ 89 | faethTXData 90 | & _faeTX . _getEthArgFaeTX . _faeTXMessage %~ addSigners 91 | & _senderEthAccount .~ senderEthAccount 92 | & _faethEthAddress .~ fromMaybe (address senderEthAccount) faethTo 93 | & _faethEthValue .~ (HexInteger <$> faethValue) 94 | liftIO . putStrLn $ 95 | "New Ethereum transaction ID: " ++ ethTXID ++ 96 | "\nfor Fae transaction: " ++ show txID 97 | 98 | where (newNames, newKeyNames) = unzip newSigners 99 | 100 | -- | Console routine to take Ethereum account information. 101 | inputAccount :: IO EthAccount 102 | inputAccount = runInputT defaultSettings $ 103 | EthAccount <$> inputAddress <*> inputPassphrase 104 | 105 | -- | Accepts the account address, echoing the input. 106 | inputAddress :: InputT IO EthAddress 107 | inputAddress = do 108 | addressSM <- getInputLine "Ethereum address: " 109 | let addressM = addressSM >>= readMaybe 110 | maybe (error "Bad address") return addressM 111 | 112 | -- | Accepts the account password, /not/ echoing it. 113 | inputPassphrase :: InputT IO String 114 | inputPassphrase = do 115 | passphraseM <- getInputLine "Passphrase: " 116 | maybe (error "Bad passphrase") return passphraseM 117 | -------------------------------------------------------------------------------- /bin/PostTX/ImportExport.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.ImportExport 3 | Description: Handler for postTX's import/export mode 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | Import/export mode is a pipe between two Fae servers, with no processing in between. 10 | -} 11 | module PostTX.ImportExport where 12 | 13 | import Blockchain.Fae.FrontEnd 14 | 15 | import Data.ByteString (ByteString) 16 | 17 | import Data.Serialize (Serialize) 18 | import qualified Data.Serialize as S 19 | 20 | import Network.HTTP.Client 21 | import Network.HTTP.Client.MultipartFormData 22 | 23 | import PostTX.Network 24 | 25 | -- | Requests a contract return value, then forwards the response. TODO: 26 | -- actually do a little processing to figure out if there are errors, 27 | -- rather than just printing the same message. 28 | importExport :: TransactionID -> Int -> String -> String -> IO () 29 | importExport exportTXID exportIx exportHost importHost = do 30 | exportRequest <- buildExportRequest (exportTXID, exportIx) exportHost 31 | exportResponse <- sendReceiveSerialize exportRequest 32 | importRequest <- buildImportRequest exportResponse importHost 33 | sendReceiveSerialize @() importRequest 34 | putStrLn $ 35 | "Transferred return value of contract call #" ++ show exportIx ++ 36 | " in transaction " ++ show exportTXID ++ 37 | " from " ++ exportHost ++ " to " ++ importHost 38 | 39 | -- | Requests a transaction's input result by index. 40 | buildExportRequest :: (TransactionID, Int) -> String -> IO Request 41 | buildExportRequest exportData exportHost = 42 | flip formDataBody (requestURL exportHost) $ 43 | modulePart "export" "export" (S.encode exportData) : [] 44 | 45 | -- | Forwards the exported value, doing only enough processing to separate 46 | -- the binary portion from the metadata. 47 | buildImportRequest :: ExportData -> String -> IO Request 48 | buildImportRequest ExportData{..} importHost = 49 | flip formDataBody (requestURL importHost) $ 50 | modulePart "import" "import" 51 | (S.encode (exportedCID, exportStatus, neededModules, exportValType)) : 52 | modulePart "valuePackage" "valuePackage" exportedValue : [] 53 | 54 | -------------------------------------------------------------------------------- /bin/PostTX/Keys.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.Keys 3 | Description: Handler for postTX's show-keys mode 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | Implements the key-lookup logic. 10 | -} 11 | module PostTX.Keys where 12 | 13 | import Blockchain.Fae.FrontEnd (PrivateKey, PublicKey, public) 14 | 15 | import Control.Applicative 16 | import Control.Exception 17 | import Control.Monad 18 | import Control.Lens 19 | 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Char8 as C8 22 | import qualified Data.Serialize as S 23 | import Data.List 24 | import Data.Maybe 25 | 26 | import PostTX.Args 27 | 28 | import System.Directory 29 | import System.Environment 30 | import System.Exit 31 | import System.FilePath 32 | 33 | 34 | -- | Prints a set of the stored public keys inside of the FaeHome directory. 35 | -- The empty list in the first pattern match denotes that all stored keys 36 | -- are to be shown. 37 | showKeys :: FilePath -> [String] -> IO () 38 | showKeys faeHome [] = do -- Empty list denotes that all keys should be shown 39 | storedKeys <- getHomeKeys faeHome 40 | if null storedKeys then print $ "No keys found at " ++ show faeHome else 41 | putStr . unlines $ 42 | storedKeys <&> \(keyName, privKey) -> 43 | keyName ++ ": " ++ 44 | maybe "Couldn't validate key" show (public privKey) 45 | showKeys faeHome keyNamesList = 46 | sequence_ $ showHomeKey faeHome <$> keyNamesList 47 | 48 | -- | Decodes and prints the contents of a given home key 49 | showHomeKey :: FilePath -> String -> IO () 50 | showHomeKey faeHome keyName = do 51 | maybeFile <- findFile [faeHome] keyName 52 | case maybeFile of 53 | Nothing -> 54 | putStrLn $ keyName ++ " " ++ "not found in " ++ faeHome 55 | Just file -> do 56 | keyBytes <- BS.readFile file 57 | case S.decode keyBytes of 58 | Left err -> putStrLn $ 59 | show faeHome ++ keyName ++ " could not be decoded" ++ " : " ++ show err 60 | Right key -> putStrLn $ 61 | maybe "Couldn't validate key" showKey $ public key 62 | where showKey key = takeBaseName file ++ ": " ++ show key 63 | 64 | -- | Retrieves all valid key files from the FaeHome directory. 65 | getHomeKeys :: FilePath -> IO [(String, PrivateKey)] 66 | getHomeKeys path = do 67 | dirList <- getDirectoryContents path 68 | fileList <- filterM doesFileExist dirList 69 | sortOn (view _1) . mapMaybe (_2 (preview _Right)) <$> 70 | traverse sequenceA [(takeBaseName a, S.decode <$> BS.readFile a) | a <- fileList] 71 | -------------------------------------------------------------------------------- /bin/PostTX/Network.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.Network 3 | Description: Handler for postTX's Faeth mode 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | The foundational module for all network-using modes, abstracting away the 10 | process of connecting to the server and interpreting its response. 11 | -} 12 | 13 | module PostTX.Network where 14 | 15 | import Blockchain.Fae.FrontEnd 16 | 17 | import Common.JSON() 18 | 19 | import Data.Aeson (FromJSON) 20 | import qualified Data.Aeson as A 21 | import Data.Bifunctor 22 | import qualified Data.ByteString.Lazy.Char8 as LC8 23 | import Data.Maybe 24 | import Data.Proxy 25 | import Data.Serialize (Serialize) 26 | 27 | import qualified Data.ByteString.Lazy.Char8 as LC8 28 | 29 | import qualified Data.Map as Map 30 | import Data.Map (Map) 31 | 32 | import qualified Data.Serialize as S 33 | 34 | import qualified Data.Text as T 35 | import qualified Data.Text.Encoding as T 36 | import Data.Typeable 37 | 38 | import Network.HTTP.Client hiding (Proxy) 39 | import Network.HTTP.Client.MultipartFormData 40 | 41 | import PostTX.TXSpec 42 | 43 | import Text.PrettyPrint.HughesPJClass 44 | 45 | -- | Makes a request from an HTTP URL (here, just the hostname). 46 | requestURL :: String -> Request 47 | requestURL host = fromMaybe (error $ "Bad host string: " ++ host) $ 48 | parseRequest $ "http://" ++ host 49 | 50 | -- | Performs the conversation with the server and handles the response as 51 | -- requested. 52 | sendReceive :: (LC8.ByteString -> a) -> Request -> IO a 53 | sendReceive decode request = do 54 | manager <- newManager defaultManagerSettings 55 | response <- httpLbs request manager 56 | return $ decode $ responseBody response 57 | 58 | -- | Specialization of 'sendReceive' that expects a 'String' response 59 | -- literally represented in UTF-8 format by the response bytestring. 60 | sendReceiveString :: Request -> IO String 61 | sendReceiveString = sendReceive LC8.unpack 62 | 63 | -- | Specialization of 'sendReceive' that expects a typed value encoded as 64 | -- the response bytestring. 65 | sendReceiveSerialize :: (Typeable a, Serialize a) => Request -> IO a 66 | sendReceiveSerialize = 67 | sendReceive $ \bs -> either (error $ LC8.unpack bs) id $ S.decodeLazy bs 68 | 69 | -- | Specialization of 'sendReceive' that expects a JSON value encoded as 70 | -- the response bytestring. 71 | sendReceiveJSON :: (Typeable a, FromJSON a) => Request -> IO (Either String a) 72 | sendReceiveJSON = sendReceive $ \bs -> 73 | bimap (\_ -> T.unpack $ T.decodeUtf8 $ LC8.toStrict bs) id $ A.eitherDecode bs 74 | 75 | -- | Combines the 'String' and 'JSON' variants, pretty-printing the latter 76 | -- if it is requested. 77 | sendReceiveJSONString :: Bool -> Request -> IO String 78 | sendReceiveJSONString isJson 79 | | isJson = sendReceiveString 80 | | otherwise = fmap (either id prettyShow) . sendReceiveJSON @TXSummary 81 | 82 | -- | Standard error format for this module. 83 | responseError :: forall a. (Typeable a) => String -> a 84 | responseError s = 85 | error $ "Couldn't parse response as type " ++ show tr ++ ": " ++ s 86 | where tr = typeRep $ Proxy @a 87 | 88 | -- | Creates a request part containing a module source code file. 89 | modulePart :: String -> String -> Module -> Part 90 | modulePart param name = partFileRequestBody (T.pack param) name . RequestBodyBS 91 | 92 | -- | Creates all parts from a module-name mapping. 93 | moduleParts :: String -> Modules -> [Part] 94 | moduleParts param = Map.foldrWithKey (\name -> (:) . modulePart param name) [] 95 | 96 | -------------------------------------------------------------------------------- /bin/PostTX/Submit.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.Submit 3 | Description: Handler for postTX's normal or view modes 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | Converts a 'TXSpec' to a request, sends it to the server, and prints the 10 | response to the screen. 11 | -} 12 | module PostTX.Submit where 13 | 14 | import qualified Data.ByteString.Char8 as C8 15 | import Data.Serialize (Serialize) 16 | import qualified Data.Serialize as S 17 | import qualified Data.Text as T 18 | 19 | import Network.HTTP.Client 20 | import Network.HTTP.Client.MultipartFormData 21 | 22 | import PostTX.Network 23 | import PostTX.TXSpec 24 | 25 | -- | If JSON formatting is not enabled through postTX CLI flag 26 | -- pretty print a summary of TX output. 27 | submit :: 28 | (Serialize a) => 29 | String -> Bool -> Bool -> Bool -> TXSpec a -> IO () 30 | submit host fake lazy isJson txSpec = 31 | buildRequest host fake lazy txSpec >>= sendReceiveJSONString isJson >>= putStrLn 32 | 33 | -- | Constructs a request whose parts are the various Haskell modules that 34 | -- are part of the transaction, and whose query parameters are the other 35 | -- pieces of metadata in the transaction file or from the command line. 36 | buildRequest :: 37 | (Serialize a) => 38 | String -> Bool -> Bool -> TXSpec a -> IO Request 39 | buildRequest host fake lazy TXSpec{specModules = LoadedModules{..}, ..} = 40 | flip formDataBody (requestURL host) $ 41 | modulePart "message" txName (S.encode txMessage) : 42 | modulePart "body" txName mainModuleBS : 43 | moduleParts "other" otherModules ++ 44 | fmap (uncurry partBS) (maybe id (:) parentArg [lazyArg, fakeArg, rewardArg]) 45 | 46 | where 47 | (txName, mainModuleBS) = mainModule 48 | lazyArg = ("lazy", ) $ if lazy then "True" else "False" 49 | fakeArg = ("fake", ) $ if fake then "True" else "False" 50 | rewardArg = ("reward", ) $ if isReward then "True" else "False" 51 | parentArg = ("parent", ) . C8.pack . show <$> parentM 52 | 53 | -------------------------------------------------------------------------------- /bin/PostTX/TXSpec.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.TXSpec 3 | Description: Handler for postTX's Faeth mode 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | A 'TXSpec' contains a complete Fae transaction message, the associated 10 | modules (which are not part of the basic message), and the metadata of 11 | whether this is a reward transaction and what its parent is. If and when 12 | Fae is managed by a blockchain, both of the latter will be inferred from 13 | the blocks, and the modules will be sent in a separate communication from 14 | the message. 15 | -} 16 | {-# LANGUAGE TemplateHaskell #-} 17 | module PostTX.TXSpec 18 | ( 19 | module PostTX.TXSpec, 20 | Input(..), Module, ModuleMap, Renames(..), TransactionID, getTXID 21 | ) where 22 | 23 | import Blockchain.Fae.FrontEnd 24 | 25 | import Common.Lens 26 | import Common.ProtocolT 27 | 28 | import Control.Monad.Reader 29 | 30 | import qualified Data.ByteString as BS 31 | import qualified Data.ByteString.Char8 as C8 32 | 33 | import qualified Data.Map as Map 34 | import Data.Map (Map) 35 | 36 | import qualified Data.Serialize as S 37 | import Data.Serialize (Serialize) 38 | 39 | import Data.Maybe 40 | import Data.Time.Clock 41 | 42 | import GHC.Generics 43 | 44 | import PostTX.Args 45 | 46 | import System.Directory 47 | 48 | import Text.Read 49 | 50 | -- * Spec types 51 | 52 | -- | The structure that 'PostTX.Parser' parses a transaction file into. 53 | data TXData = 54 | TXData 55 | { 56 | dataModules :: LoadedModules, 57 | fallback :: [String], 58 | materials :: InputMaterials, 59 | inputs :: [Input], 60 | keys :: [(String, String)], 61 | reward :: Bool, 62 | parent :: Maybe TransactionID 63 | } 64 | 65 | -- | All transaction information appropriately organized. Recall that the 66 | -- reason the modules are not part of the message is that it is designed to 67 | -- make it possible for a recipient to opt out of incurring significant 68 | -- data costs by discriminating based on file size. In one-off postTX 69 | -- operation, this dynamic is not present, so the modules are sent 70 | -- alongside the transaction. 71 | data TXSpec a = 72 | TXSpec 73 | { 74 | txMessage :: TXMessage a, 75 | specModules :: LoadedModules, 76 | isReward :: Bool, 77 | parentM :: Maybe TransactionID 78 | } 79 | deriving (Generic) 80 | 81 | -- | Modules having been read from disk 82 | data LoadedModules = 83 | LoadedModules 84 | { 85 | mainModule :: (FileName, Module), 86 | otherModules :: Modules 87 | } 88 | deriving (Generic) 89 | 90 | -- | Less generic. 91 | type FileName = String 92 | -- | Less generic. 93 | type Identifier = String 94 | -- | Convenient. 95 | type Modules = ModuleMap 96 | -- | Definitely convenient. 97 | type Keys = Map String (Either PublicKey PrivateKey) 98 | 99 | -- | This is a class in the sense of being actually an overloaded function 100 | -- more than an interface. Depending on the format of the transaction's 101 | -- "salt", constructing the message may require alternative steps. 102 | -- Presumably the rest of the message is constructed the same way. 103 | class (Monad m, Serialize a) => MakesTXSpec m a where 104 | txDataToTXSpec :: TXData -> m (TXSpec a) 105 | 106 | -- * Template Haskell 107 | makeLenses ''TXData 108 | makeLenses ''TXSpec 109 | 110 | -- | - 111 | instance Serialize LoadedModules 112 | -- | - 113 | instance (Serialize a) => Serialize (TXSpec a) 114 | 115 | -- | Just uses the time as the salt value. 116 | instance MakesTXSpec IO String where 117 | txDataToTXSpec = txSpecTimeSalt id 118 | 119 | -- | Makes a Faeth salt with Ethereum metadata. 120 | instance MakesTXSpec (ReaderT FaethArgs IO) Salt where 121 | txDataToTXSpec txData = do 122 | FaethArgs{..} <- ask 123 | let 124 | makeSalt faeSalt = 125 | Salt 126 | { 127 | ethArgument = maybe BS.empty getHex faethArgument, 128 | ethFee = HexInteger <$> faethFee, 129 | ethRecipient = faethRecipient, 130 | .. 131 | } 132 | liftIO $ txSpecTimeSalt makeSalt txData 133 | 134 | -- | Given a partially constructed salt, finishes it off by inserting the 135 | -- current time, then constructs the 'TXSpec' containing it. 136 | txSpecTimeSalt :: 137 | (Serialize a) => (String -> a) -> TXData -> IO (TXSpec a) 138 | txSpecTimeSalt makeSalt txData = do 139 | now <- getCurrentTime 140 | go <- getMakeTXSpec txData 141 | return $ go $ makeSalt $ show now 142 | 143 | -- | This higher-order function fills in the private keys requested in the 144 | -- 'TXData', then returns a partially constructed 'TXSpec' that expects 145 | -- only the salt, to be provided by 'txSpecTimeSalt'. 146 | getMakeTXSpec :: (Serialize a) => TXData -> IO (a -> TXSpec a) 147 | getMakeTXSpec TXData{..} = do 148 | let 149 | keys' = if null keys then [("self", "self")] else keys 150 | (signerNames, keyNames) = unzip keys' 151 | privKeys <- mapM resolveKeyName keyNames 152 | let keyMap = Map.fromList $ zip signerNames privKeys 153 | return $ makeTXSpec dataModules materials inputs keyMap fallback parent reward 154 | 155 | -- | Fills in the 'TXMessage' with the supplied parameters, and also 156 | -- extracts file previews for each module, then signs the whole thing with 157 | -- the provided keys. 158 | makeTXSpec :: 159 | (Serialize a) => 160 | LoadedModules -> InputMaterials -> [Input] -> Keys -> [Identifier] -> 161 | Maybe TransactionID -> Bool -> a -> 162 | TXSpec a 163 | makeTXSpec specModules materialsCalls inputCalls keys 164 | fallbackFunctions parentM isReward salt = 165 | TXSpec 166 | { 167 | txMessage = addSignatures keys 168 | TXMessage 169 | { 170 | mainModulePreview = uncurry makePreview mainModule, 171 | otherModulePreviews = Map.mapWithKey makePreview otherModules, 172 | signatures = (,Nothing) . either id (fromMaybe keyErr . public) <$> keys, 173 | .. 174 | }, 175 | .. 176 | } 177 | 178 | where 179 | LoadedModules{..} = specModules 180 | keyErr = error "Bad private key" 181 | 182 | -- | Just processes the module as a byte string 183 | makePreview :: FileName -> Module -> ModulePreview 184 | makePreview fName moduleBS = 185 | ModulePreview 186 | { 187 | moduleDigest = digest $ C8.pack fName `C8.append` moduleBS, 188 | moduleSize = toInteger $ BS.length moduleBS 189 | } 190 | 191 | addSignatures :: (Serialize a) => Keys -> TXMessage a -> TXMessage a 192 | addSignatures keys m = Map.foldrWithKey addSigner m keys 193 | 194 | -- | Signs a 'TXMessage' with a single key in a given role. This allows 195 | -- for the possibility that the role was /not/ provided with a key, thus 196 | -- producing an incomplete message. This will be, strictly speaking, 197 | -- invalid, but when sent with @--fake@ is admissible for testing purposes. 198 | addSigner :: 199 | (Serialize a) => 200 | String -> Either PublicKey PrivateKey -> TXMessage a -> TXMessage a 201 | addSigner _ (Left _) = id 202 | addSigner name (Right privKey) = 203 | fromMaybe (error $ "Not a signer role in this transaction: " ++ name) . 204 | signTXMessage name privKey 205 | 206 | -- | If the key "name" parses as a public key, then that is the result and 207 | -- the message will not be signed (by this key). Otherwise, it is looked 208 | -- up in @faeHome@ as a file containing a private key. 209 | resolveKeyName :: String -> IO (Either PublicKey PrivateKey) 210 | resolveKeyName pubKeyS | Just pubKey <- readMaybe pubKeyS = return $ Left pubKey 211 | resolveKeyName name = do 212 | keyExists <- doesFileExist name 213 | if keyExists 214 | then bimap (error $ "Couldn't decode private key: " ++ name) id . 215 | S.decode <$> BS.readFile name 216 | else do 217 | privKey <- newPrivateKey 218 | BS.writeFile name $ S.encode privKey 219 | return $ Right privKey 220 | -------------------------------------------------------------------------------- /bin/PostTX/View.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: PostTX.View 3 | Description: Handler for postTX's View mode 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | View mode is trivial: it sends a single transaction ID and prints the 10 | result that had already been obtained from running that transaction. 11 | -} 12 | module PostTX.View where 13 | 14 | import PostTX.Network 15 | 16 | import Blockchain.Fae.FrontEnd (TransactionID) 17 | 18 | import qualified Data.ByteString.Lazy.Char8 as LC8 19 | 20 | import Network.HTTP.Client.MultipartFormData 21 | 22 | -- | The view request just has a "view" query parameter containing the 23 | -- transaction ID. 24 | view :: TransactionID -> String -> Bool -> IO () 25 | view txID host isJSON = do 26 | request <- flip formDataBody (requestURL host) 27 | [partLBS "view" $ LC8.pack $ show txID] 28 | sendReceiveJSONString isJSON request >>= putStrLn 29 | -------------------------------------------------------------------------------- /common/Common/JSON.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Common.JSON 3 | Description: JSON instances for encoding transaction summaries 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This module exports (orphan) JSON instances and utilities for types that 10 | are generally useful both to the server (@faeServer@) and the client (@postTX@). 11 | -} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TupleSections #-} 16 | module Common.JSON where 17 | 18 | import Blockchain.Fae.FrontEnd 19 | 20 | import Control.Applicative 21 | import Control.DeepSeq 22 | 23 | import Data.Aeson (FromJSON, ToJSON, Object, toJSON, 24 | parseJSON, object, Value(..), withText, 25 | withObject, (.=), (.:)) 26 | import qualified Data.Aeson as A 27 | import Data.Aeson.Types 28 | import qualified Data.ByteString.Lazy as BS 29 | import Data.Maybe 30 | import qualified Data.Text as T 31 | import qualified Data.Text.Encoding as T 32 | import Data.Text (Text) 33 | 34 | import System.IO.Unsafe 35 | 36 | import Text.Read 37 | 38 | -- | - 39 | instance ToJSON TXInputSummary where 40 | toJSON TXInputSummary{..} = 41 | object [ 42 | "txInputStatus" .= wrapExceptions txInputStatus, 43 | "txInputOutputs" .= wrapExceptions txInputOutputs, 44 | "txInputMaterialsSummaries" .= txInputMaterialsSummaries, 45 | "txInputVersion" .= wrapExceptions txInputVersion ] 46 | 47 | -- | - 48 | instance ToJSON TXSummary where 49 | toJSON TXSummary{..} = object [ 50 | "transactionID" .= transactionID, 51 | "txResult" .= wrapExceptions txResult, 52 | "txOutputs" .= wrapExceptions txOutputs, 53 | "txInputSummaries" .= txInputSummaries, 54 | "txMaterialsSummaries" .= txMaterialsSummaries, 55 | "txSSigners" .= txSSigners ] 56 | 57 | -- | - 58 | instance FromJSON TXInputSummary where 59 | parseJSON = withObject "TXInputSummary" $ \o -> do 60 | TXInputSummary 61 | <$> readJSONField "txInputStatus" o 62 | <*> readJSONField "txInputOutputs" o 63 | <*> o .: "txInputMaterialsSummaries" 64 | <*> readJSONField "txInputVersion" o 65 | 66 | -- | - 67 | instance FromJSON TXSummary where 68 | parseJSON = withObject "TXSummary" $ \o -> 69 | TXSummary 70 | <$> o .: "transactionID" 71 | <*> readJSONField "txResult" o 72 | <*> readJSONField "txOutputs" o 73 | <*> o .: "txInputSummaries" 74 | <*> o .: "txMaterialsSummaries" 75 | <*> o .: "txSSigners" 76 | 77 | -- | - 78 | instance FromJSON PublicKey where 79 | parseJSON = readJSONText "PublicKey" 80 | 81 | -- | - 82 | instance ToJSON PublicKey where 83 | toJSON = toJSON . T.pack . show 84 | 85 | -- | - 86 | instance ToJSON ContractID where 87 | toJSON = toJSON . show 88 | 89 | -- | - 90 | instance FromJSON ContractID where 91 | parseJSON = readJSONText "ContractID" 92 | 93 | -- | - 94 | instance ToJSON Digest where 95 | toJSON = toJSON . show 96 | 97 | -- | - 98 | instance FromJSON Digest where 99 | parseJSON = readJSONText "Digest" 100 | 101 | -- | - 102 | instance ToJSON UnquotedString where 103 | toJSON = toJSON . show 104 | 105 | -- | - 106 | instance FromJSON UnquotedString where 107 | parseJSON = fmap UnquotedString . parseJSON 108 | 109 | -- | - 110 | instance ToJSON Status 111 | -- | - 112 | instance FromJSON Status 113 | 114 | -- | Chains a couple conversions to get a readable json string. 115 | encodeJSON :: (ToJSON a) => a -> String 116 | encodeJSON = T.unpack . T.decodeUtf8 . BS.toStrict . A.encode 117 | 118 | -- | If an exception is found then we tag the value as an exception. 119 | -- By forcing evaluation of exceptions we prevent uncaught exceptions being thrown 120 | -- and crashing faeServer. 121 | wrapExceptions :: forall a. (ToJSON a) => a -> Value 122 | wrapExceptions val = 123 | unsafePerformIO $ catchAll (evaluate $ force $ toJSON val) 124 | (return . object . pure . ("exception",) . A.String . T.pack . show) 125 | 126 | -- | If parsing fails then we look for the tagged exception. 127 | readJSONField :: forall a. (FromJSON a) => Text -> Object -> Parser a 128 | readJSONField fieldName obj = 129 | obj .: fieldName <|> (obj .: fieldName >>= exceptionValue) 130 | 131 | -- | Reads a value from a JSON text expression. 132 | readJSONText :: (Read a) => String -> Value -> Parser a 133 | readJSONText l = withText l $ \t -> return $ 134 | let s = T.unpack t in 135 | fromMaybe (throw $ JSONException s) $ readMaybe s 136 | 137 | -- | Parses a tagged exception. 138 | exceptionValue :: Object -> Parser a 139 | exceptionValue x = throw . TXFieldException <$> x .: "exception" 140 | 141 | -------------------------------------------------------------------------------- /common/Common/Lens.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Common.Lens 3 | Description: Wrapper library for "Control.Lens" 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This module just re-exports "Control.Lens", replacing 'makeLenses' with one 10 | that works exactly oppositely to the default one regarding underscored 11 | names, and including a utility function. 12 | -} 13 | module Common.Lens 14 | ( 15 | module Common.Lens, 16 | module Control.Lens 17 | ) where 18 | 19 | import Control.Lens hiding (makeLenses) 20 | 21 | import Data.Maybe 22 | 23 | import Language.Haskell.TH 24 | 25 | -- | Defined as 26 | -- 27 | -- > makeLensesWith myLensRules 28 | -- 29 | -- where 'myLensRules' /adds/ an underscore to names, rather than removes 30 | -- one that exists. Because the default behavior is backwards. 31 | makeLenses :: Name -> Q [Dec] 32 | makeLenses = makeLensesWith myLensRules 33 | where 34 | myLensRules = lensRules & lensField .~ myFieldNamer 35 | -- The inverse of the default field namer: ignores _-prefixed fields, 36 | -- otherwise prepends a _. 37 | myFieldNamer _ _ fName = 38 | case nameBase fName of 39 | ('_' : _) -> [] 40 | x -> [TopName $ mkName $ '_' : x] 41 | 42 | -- | Useful when using 'at', say 43 | -- 44 | -- > someMapLens . at index . defaultLens (error $ show index ++ " not found!") 45 | -- 46 | -- I'm pretty sure this can be replaced with some 'Traversal'-related 47 | -- function, but I am not familiar enough with @lens@ yet to figure out 48 | -- how. 49 | defaultLens :: a -> Lens' (Maybe a) a 50 | defaultLens x = lens (fromMaybe x) (flip $ const . Just) 51 | 52 | -------------------------------------------------------------------------------- /demos/.gitignore: -------------------------------------------------------------------------------- 1 | postTX.sh 2 | faeServer.sh 3 | -------------------------------------------------------------------------------- /demos/Auction/Auction.hs: -------------------------------------------------------------------------------- 1 | module Auction where 2 | 3 | import Blockchain.Fae 4 | import Blockchain.Fae.Currency 5 | 6 | import Control.Monad.State 7 | 8 | import qualified Data.Map as Map 9 | import Data.Map (Map) 10 | 11 | import Data.Maybe 12 | 13 | data AuctionAction = Bid | Collect deriving (Read) 14 | data AuctionResult coin a = BidAccepted | Remit coin | Prize a deriving (Generic) 15 | 16 | data AuctionError = 17 | NoBids | Can'tBid | Can'tCollect | MustBeat Natural | 18 | UnauthorizedSeller PublicKey 19 | deriving (Show) 20 | 21 | instance Exception AuctionError 22 | 23 | data AuctionState coin = 24 | BidState 25 | { 26 | bids :: Container (Map PublicKey coin), 27 | highBid :: Valuation coin, 28 | seller :: PublicKey, 29 | bidsLeft :: Natural 30 | } | 31 | CollectState (Container (Map PublicKey coin)) 32 | deriving (Generic) 33 | 34 | auction :: 35 | (ContractVal a, Currency coin, MonadTX m) => 36 | a -> Valuation coin -> Natural -> m () 37 | auction _ _ 0 = throw NoBids 38 | auction x bid0 maxBids = do 39 | seller <- signer "self" 40 | let state0 = BidState (Container Map.empty) bid0 seller maxBids 41 | newContract $ Auction state0 x 42 | 43 | data Auction coin a = Auction (AuctionState coin) a deriving (Generic) 44 | 45 | instance (ContractVal a, Currency coin) => ContractName (Auction coin a) where 46 | type ArgType (Auction coin a) = AuctionAction 47 | type ValType (Auction coin a) = AuctionResult coin a 48 | theContract (Auction state0 x) = usingState state0 $ feedback $ \act -> do 49 | aState <- get 50 | case (aState, act) of 51 | (CollectState{}, Bid) -> throw Can'tBid 52 | (BidState{}, Bid) -> bidStage x 53 | (_, Collect) -> collectStage 54 | 55 | bidStage :: 56 | (ContractVal a, Currency coin, MonadTX m) => 57 | a -> StateT (AuctionState coin) m (AuctionResult coin a) 58 | bidStage x = do 59 | -- Because of this, we have to assure that 'BidState' is the only 60 | -- possible constructor. 61 | BidState{..} <- get 62 | -- The seller has to sign on to a bid, lest someone pass a malicious 63 | -- "coin" 64 | claimedSeller <- signer "seller" 65 | unless (claimedSeller == seller) $ throw (UnauthorizedSeller claimedSeller) 66 | -- We look for an amount supplied by the bidder to /raise/ their previous 67 | -- bid (starting from 0), because we hold on to the bids until the 68 | -- auction is finished. 69 | raise <- material "raise" 70 | -- Look up the bidder's previous bid, if any, and add the new coin amount 71 | -- to get the new bid 72 | bidder <- signer "self" 73 | 74 | let bidsMap = getContainer bids 75 | oldBidM = Map.lookup bidder bidsMap 76 | newBidCoin <- maybe (return raise) (add raise) oldBidM 77 | newBid <- value newBidCoin 78 | -- Make sure they are actually raising 79 | unless (newBid > highBid) $ throw (MustBeat $ fromIntegral highBid) 80 | let bidsLeft' = bidsLeft - 1 81 | if (bidsLeft' > 0) 82 | then do 83 | let bidsMap' = Map.insert bidder newBidCoin bidsMap 84 | put $ BidState (Container bidsMap') newBid seller bidsLeft' 85 | return BidAccepted 86 | else do 87 | put $ CollectState $ Container $ 88 | -- The winning bid is earmarked for the seller 89 | Map.insert seller newBidCoin $ 90 | -- The winning bidder doesn't get money back 91 | Map.delete bidder bidsMap 92 | return $ Prize x 93 | 94 | collectStage :: 95 | (Currency coin, HasEscrowIDs a, MonadTX m) => 96 | StateT (AuctionState coin) m (AuctionResult coin a) 97 | collectStage = do 98 | sender <- signer "self" 99 | aState <- get 100 | Remit <$> case aState of 101 | BidState{bids = Container bidsMap,..} -> do 102 | let bid = Map.findWithDefault (throw Can'tCollect) sender bidsMap 103 | bidVal <- value bid 104 | when (bidVal == highBid) $ throw Can'tCollect 105 | let bidsMap' = Map.delete sender bidsMap 106 | put aState{bids = Container bidsMap'} 107 | return bid 108 | CollectState (Container bidsMap) -> do 109 | let bid = Map.findWithDefault (throw Can'tCollect) sender bidsMap 110 | bidsMap' = Map.delete sender bidsMap 111 | put $ CollectState $ Container bidsMap' 112 | return bid 113 | -------------------------------------------------------------------------------- /demos/Auction/Bid: -------------------------------------------------------------------------------- 1 | body = Bid 2 | keys 3 | self = $key 4 | seller = seller 5 | inputs 6 | $aucTX/Body/0/Current : Bid 7 | self = self 8 | seller = seller 9 | raise = $coinTX/Body/0/Current : () 10 | self = self 11 | -------------------------------------------------------------------------------- /demos/Auction/Bid.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | import Blockchain.Fae.Transactions.TX$aucTX.Auction 5 | 6 | body :: AuctionResult Coin String -> FaeTX String 7 | body BidAccepted = return "Bid accepted" 8 | body (Prize s) = return s 9 | body _ = error "unexpected response" 10 | 11 | -------------------------------------------------------------------------------- /demos/Auction/Collect: -------------------------------------------------------------------------------- 1 | body = Collect 2 | keys 3 | self = $key 4 | inputs 5 | $aucTX/Body/0/Current : Collect 6 | self = self 7 | -------------------------------------------------------------------------------- /demos/Auction/Collect.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | import Blockchain.Fae.Transactions.TX$aucTX.Auction 5 | 6 | body :: AuctionResult Coin String -> FaeTX String 7 | body (Remit c) = do 8 | deposit c "self" 9 | return "Collected" 10 | body _ = error "unexpected result" 11 | -------------------------------------------------------------------------------- /demos/Auction/Create: -------------------------------------------------------------------------------- 1 | body = Create 2 | keys 3 | self = seller 4 | others 5 | - Auction 6 | -------------------------------------------------------------------------------- /demos/Auction/Create.hs: -------------------------------------------------------------------------------- 1 | import Auction 2 | import Blockchain.Fae.Currency 3 | 4 | body :: FaeTX () 5 | body = do 6 | let price = 1 :: Valuation Coin 7 | let numBids = 3 8 | auction ("You won!" :: String) price numBids 9 | 10 | -------------------------------------------------------------------------------- /demos/GetCoins/GetCoin: -------------------------------------------------------------------------------- 1 | body = GetCoin 2 | reward = True 3 | keys 4 | self = $self 5 | -------------------------------------------------------------------------------- /demos/GetCoins/GetCoin.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | body :: Reward -> FaeTX () 5 | body rID = do 6 | coin <- reward rID 7 | deposit coin "self" 8 | -------------------------------------------------------------------------------- /demos/GetCoins/GetMoreCoins: -------------------------------------------------------------------------------- 1 | body = GetMoreCoins 2 | reward = True 3 | keys 4 | self = $self 5 | inputs 6 | $coinTX / Body / 0 / $ver : () 7 | -------------------------------------------------------------------------------- /demos/GetCoins/GetMoreCoins.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | body :: Reward -> Coin -> FaeTX () 5 | body rID oldCoin = do 6 | coin <- reward rID 7 | newCoin <- add oldCoin coin 8 | deposit newCoin "self" 9 | -------------------------------------------------------------------------------- /demos/HelloWorld1/HelloWorld1: -------------------------------------------------------------------------------- 1 | body = HelloWorld1 2 | -------------------------------------------------------------------------------- /demos/HelloWorld1/HelloWorld1.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void String 2 | body _ = return "Hello, world 1!" 3 | -------------------------------------------------------------------------------- /demos/HelloWorld1/HelloWorld1.md: -------------------------------------------------------------------------------- 1 | # HelloWorld1 2 | 3 | ## Step1: Build and start the server 4 | ``` 5 | stack build 6 | stack exec faeServer 7 | ``` 8 | 9 | ## Step2: Execute HelloWorld1 10 | ``` 11 | cd demos/HelloWorld1/ 12 | stack exec POSTTX HelloWorld1 13 | ``` 14 | The result should look something like this: 15 | ``` 16 | Transaction f6df16bc11a23a66a2be5fadbd2470cf39abfb6de0d08f780223d48f8b3eb4f0: 17 | result: "Hello, world 1!" 18 | outputs: 19 | txSigners: 20 | self: 800725c2cbf8c17ef4244222ae12308cebd6d111cee08fd5a4300688ae833a52 21 | ``` 22 | -------------------------------------------------------------------------------- /demos/HelloWorld2/CallHelloWorld2: -------------------------------------------------------------------------------- 1 | body = CallHelloWorld2 2 | inputs 3 | TransactionOutput $txID 0 = () 4 | -------------------------------------------------------------------------------- /demos/HelloWorld2/CallHelloWorld2.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction String String 2 | body = return 3 | -------------------------------------------------------------------------------- /demos/HelloWorld2/HelloWorld2: -------------------------------------------------------------------------------- 1 | body = HelloWorld2 2 | -------------------------------------------------------------------------------- /demos/HelloWorld2/HelloWorld2.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = newContract [] c where 3 | c :: Contract () String 4 | c _ = spend "Hello, world!" 5 | -------------------------------------------------------------------------------- /demos/HelloWorld2/HelloWorld2.md: -------------------------------------------------------------------------------- 1 | # HelloWorld2 2 | 3 | ## Step1: Build and start the server 4 | ``` 5 | stack build 6 | stack exec faeServer 7 | ``` 8 | 9 | ## Step2: Execute HelloWorld2 10 | ``` 11 | cd demos/HelloWorld2/ 12 | stack exec POSTTX HelloWorld2 13 | ``` 14 | 15 | The result should look something like this: 16 | ``` 17 | Transaction 1685a9d0c34639f47b152849b0b5984f8f3b37ee1203635154955869bdc8883d: 18 | result: () 19 | outputs: 20 | 0: 00b628bdff52ad413d19b094646ee0685e22931037fbca595dd4e066f10bf431 21 | txSigners: 22 | self: 800725c2cbf8c17ef4244222ae12308cebd6d111cee08fd5a4300688ae833a52 23 | ``` 24 | 25 | Now execute CallHelloWorld2 to print it's contents: 26 | ``` 27 | stack exec txID=1685a9d0c34639f47b152849b0b5984f8f3b37ee1203635154955869bdc8883d CallHelloWorld2 28 | ``` 29 | -------------------------------------------------------------------------------- /demos/Swap/CreateSwap: -------------------------------------------------------------------------------- 1 | body = CreateSwap 2 | reward = True 3 | 4 | inputs 5 | TransactionOutput $bobCoinTX 0 = () 6 | 7 | keys 8 | partyA = alice 9 | partyB = bob 10 | self = bob 11 | -------------------------------------------------------------------------------- /demos/Swap/CreateSwap.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | body :: Transaction (RewardEscrowID, Coin) () 5 | body (rwd, coin) = twoPartySwap rwd coin 6 | 7 | -------------------------------------------------------------------------------- /demos/Swap/GetOffering: -------------------------------------------------------------------------------- 1 | body = GetOffering 2 | 3 | inputs 4 | TransactionOutput $swapTX 0 = Nothing 5 | 6 | keys 7 | self = $self 8 | -------------------------------------------------------------------------------- /demos/Swap/GetOffering.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Currency 2 | 3 | body :: 4 | Transaction (Maybe (Either (Versioned RewardEscrowID) (Versioned Coin))) String 5 | body Nothing = error "Swap is incomplete" 6 | body (Just (Left (Versioned !rwd))) = return "Got reward" 7 | body (Just (Right (Versioned !coin))) = return "Got coin" 8 | -------------------------------------------------------------------------------- /demos/Swap/GiveOpinion: -------------------------------------------------------------------------------- 1 | body = GiveOpinion 2 | 3 | inputs 4 | TransactionOutput $swapTX 0 = Just $opinion 5 | 6 | keys 7 | self = $self 8 | -------------------------------------------------------------------------------- /demos/Swap/GiveOpinion.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = return () 3 | -------------------------------------------------------------------------------- /demos/talk-3/FaethService: -------------------------------------------------------------------------------- 1 | keys 2 | alice = $alice 3 | bob = $bob 4 | -------------------------------------------------------------------------------- /demos/talk-3/FaethService.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void String 2 | body _ = return "Hello from Fae, Ethereum!" 3 | -------------------------------------------------------------------------------- /demos/talk-3/alice: -------------------------------------------------------------------------------- 1 | user-address -------------------------------------------------------------------------------- /demos/talk-3/bob: -------------------------------------------------------------------------------- 1 | dev-address -------------------------------------------------------------------------------- /demos/talk-3/bob-fae: -------------------------------------------------------------------------------- 1 | ca5e0c648f45086fb1847ab483a38b84f324748c684328e20f51532553f34a91 2 | -------------------------------------------------------------------------------- /demos/talk-3/cmd1: -------------------------------------------------------------------------------- 1 | cmd="alice=alice bob=$(/dev/null 24 | } 25 | trap cleanup EXIT 26 | 27 | # Stack stanza 28 | $makedir bin/ 29 | $stack build :$exeName :collectPackage 30 | $stack --local-bin-path $PWD/bin install :$exeName 31 | $stack exec collectPackage 32 | 33 | # GHC stanza 34 | ghcDir=$(stack ghc -- --print-libdir) 35 | $makedir lib/ 36 | $cp $ghcDir/settings $ghcDir/platformConstants lib/ 37 | 38 | # Dynamic loading stanza 39 | awkexp () 40 | { 41 | field=$1 42 | echo "\$$field ~ /^\// {print \$$field;}" 43 | } 44 | exePath=bin/$exeName 45 | ldlinux=$(ldd $exePath | awk "$(awkexp 1)") 46 | libdeps=$(\ 47 | LD_LIBRARY_PATH=$PWD/lib ldd $exePath \ 48 | | awk "$(awkexp 3)" \ 49 | | grep -v ^$PWD/lib 50 | ) 51 | $makedir lib64/ 52 | $cp $ldlinux lib64/ 53 | for lib in $libdeps; do 54 | libname=$(basename $lib) 55 | newlibname=${libname/%.so.*/.so} 56 | $cp $lib lib 57 | if [[ $libname != $newlibname ]] 58 | then 59 | echoeval ln -sf $libname lib/$newlibname 60 | fi 61 | done 62 | 63 | # Git stanza 64 | git=$(which git) 65 | $cp $git bin/git 66 | gitdeps=$(\ 67 | LD_LIBRARY_PATH=$PWD/lib ldd ./bin/git \ 68 | | awk "$(awkexp 3)" \ 69 | | grep -v ^$PWD/lib\ 70 | ) 71 | $cp -r $gitdeps lib/ 72 | 73 | # Docker coda 74 | $docker build -t teamfae/faeserver . 75 | -------------------------------------------------------------------------------- /docker/faeServer/etc/faeServer.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | imgName=teamfae/faeserver 3 | if [[ -n $FAE_VERSION ]] 4 | then imgName=$imgName:$FAE_VERSION 5 | fi 6 | 7 | faeDir=${FAE_HOME:-~/fae} 8 | [[ -d $faeDir ]] || mkdir -p $faeDir 9 | 10 | FAE_UID=$(id -u) 11 | FAE_GID=$(id -g) 12 | 13 | docker run -it --rm \ 14 | --user $FAE_UID:$FAE_GID \ 15 | --network host \ 16 | --mount type=bind,src=$faeDir,dst=/var/lib/fae/ \ 17 | $imgName $@ 18 | -------------------------------------------------------------------------------- /docker/faeServer/tmp/anchor: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ConsenSysMesh/Fae/3ff023f70fa403e9cef80045907e415ccd88d7e8/docker/faeServer/tmp/anchor -------------------------------------------------------------------------------- /docker/postTX/.dockerignore: -------------------------------------------------------------------------------- 1 | Dockerfile 2 | build 3 | **/*~ 4 | **/.gitignore 5 | **/.dockerignore 6 | -------------------------------------------------------------------------------- /docker/postTX/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM scratch 2 | ENV FAE_HOME=/fae\ 3 | LD_LIBRARY_PATH=/lib:/lib64 4 | WORKDIR $FAE_HOME 5 | WORKDIR /txs 6 | ENTRYPOINT ["/bin/postTX"] 7 | ADD . / 8 | -------------------------------------------------------------------------------- /docker/postTX/build: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | exeName=postTX 5 | repoName=${exeName,,} 6 | imgName=teamfae/$repoName 7 | cp="cp --preserve=all --dereference" 8 | gai_lib=$( \ 9 | ldconfig -p | \ 10 | grep libnss | \ 11 | awk --field-separator '=>' '$2 ~ /x86_64/ {print $2;}' \ 12 | ) 13 | gai_etc="/etc/nsswitch.conf /etc/gai.conf" 14 | 15 | awkexp () 16 | { 17 | field=$1 18 | echo "\$$field ~ /^\// {print \$$field;}" 19 | } 20 | 21 | mkdir -p bin/ lib/ lib64/ 22 | stack --local-bin-path $PWD/bin install :$exeName 23 | exePath="./bin/$exeName" 24 | libdeps=$(ldd $exePath | awk "$(awkexp 3)") 25 | ldlinux=$(ldd $exePath | awk "$(awkexp 1)") 26 | $cp $gai_lib $libdeps lib/ 27 | $cp $ldlinux lib64/ 28 | $cp $gai_etc etc/ 29 | { docker build -t $imgName . ; s=$?; } || true 30 | rm -r ./bin ./lib ./lib64/ ./etc/*.conf 31 | exit $s 32 | -------------------------------------------------------------------------------- /docker/postTX/etc/.dockerignore: -------------------------------------------------------------------------------- 1 | postTX.cmd 2 | -------------------------------------------------------------------------------- /docker/postTX/etc/postTX.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | if [[ $# -eq 0 ]] 3 | then echo >&2 "Must supply a transaction spec file name"; exit 1 4 | fi 5 | 6 | imgName=teamfae/posttx 7 | if [[ -n $FAE_VERSION ]] 8 | then imgName=$imgName:$FAE_VERSION 9 | fi 10 | 11 | faeDir=${FAE_HOME:-~/fae} 12 | [[ -d $faeDir ]] || mkdir -p $faeDir 13 | 14 | FAE_UID=$(id -u) 15 | FAE_GID=$(id -g) 16 | 17 | declare -a envlist 18 | n=0 19 | while true; do 20 | case $1 in 21 | -e|--env-list|--env-file) 22 | envlist[$n]=$1 23 | envlist[$n + 1]=$2 24 | let n+=2 25 | shift 2 26 | ;; 27 | -*) 28 | echo >&2 "Got regular option: " $1 29 | echo >&2 "Only environment variable assignments (-e var=val) allowed before the main argument" 30 | exit 1 31 | ;; 32 | *) break ;; 33 | esac 34 | done 35 | 36 | cd $(dirname $1) 37 | txfile=$(basename $1) 38 | shift 39 | 40 | docker run \ 41 | --rm \ 42 | --interactive --tty \ 43 | --network host \ 44 | --user $FAE_UID:$FAE_GID \ 45 | --mount type=bind,src=$PWD,dst=/txs/,readonly \ 46 | --mount type=bind,src=$faeDir,dst=/fae/ \ 47 | "${envlist[@]}" $imgName $txfile $@ 48 | 49 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/CallHelloWorld2: -------------------------------------------------------------------------------- 1 | body = CallHelloWorld2 2 | inputs 3 | $txID/Body/0/Current = () 4 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/CallHelloWorld2.hs: -------------------------------------------------------------------------------- 1 | body :: String -> FaeTX String 2 | body = return 3 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/CallHelloWorld3: -------------------------------------------------------------------------------- 1 | body = CallHelloWorld3 2 | inputs 3 | $txID/Body/0/Current = () 4 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/CallHelloWorld3.hs: -------------------------------------------------------------------------------- 1 | body :: String -> FaeTX String 2 | body = return 3 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/CallHelloWorld4: -------------------------------------------------------------------------------- 1 | body = CallHelloWorld4 2 | inputs 3 | $txID/Body/0/Current = () 4 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/CallHelloWorld4.hs: -------------------------------------------------------------------------------- 1 | body :: String -> FaeTX String 2 | body = return 3 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld: -------------------------------------------------------------------------------- 1 | body = HelloWorld 2 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX String 2 | body = return "Hello, world!" 3 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld2: -------------------------------------------------------------------------------- 1 | body = HelloWorld2 2 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld2.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX () 2 | body = newContract c where 3 | c :: Contract () String 4 | -- The underscore here means "there is an argument, which is ignored" 5 | c _ = spend "Hello, world!" 6 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld2a: -------------------------------------------------------------------------------- 1 | body = HelloWorld2a 2 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld2a.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX () 2 | body = newContract (Echo "Hello, world!") 3 | 4 | data Echo = Echo String deriving (Generic) 5 | 6 | instance ContractName Echo where 7 | type ArgType Echo = () 8 | type ValType Echo = String 9 | theContract (Echo s) = \_ -> spend s 10 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld3: -------------------------------------------------------------------------------- 1 | body = HelloWorld3 2 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld3.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX () 2 | body = newContract (Echo2 "Hello, world!" "Goodbye!") 3 | 4 | data Echo2 = Echo2 String String deriving (Generic) 5 | 6 | instance ContractName Echo2 where 7 | type ArgType Echo2 = () 8 | type ValType Echo2 = String 9 | theContract (Echo2 s1 s2) = \_ -> do 10 | release s1 11 | spend s2 12 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld4: -------------------------------------------------------------------------------- 1 | body = HelloWorld4 2 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-1/HelloWorld4.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad (forever) 2 | 3 | body :: FaeTX () 4 | body = newContract (EchoForever "Hello, world!") 5 | 6 | data EchoForever = EchoForever String deriving (Generic) 7 | 8 | instance ContractName EchoForever where 9 | type ArgType EchoForever = () 10 | type ValType EchoForever = String 11 | theContract (EchoForever s) = \_ -> forever (release s) 12 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/CallEscrow1: -------------------------------------------------------------------------------- 1 | body = CallEscrow1 2 | inputs 3 | $txID/Body/0/Current = "Ryan Reich" 4 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/CallEscrow1.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$txID 2 | 3 | body :: EscrowID EType -> FaeTX String 4 | body eID = useEscrow [] eID () 5 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/CallEscrow3: -------------------------------------------------------------------------------- 1 | body = CallEscrow3 2 | inputs 3 | $txID/Body/0/Current = "Ryan Reich" 4 | keys 5 | self = $self 6 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/CallEscrow3.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$tx1ID 2 | 3 | body :: EscrowID EType -> FaeTX String 4 | body eID = useEscrow [] eID () 5 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/CallRewardNametag: -------------------------------------------------------------------------------- 1 | body = CallRewardNametag 2 | inputs 3 | $txID/Body/0/Current = () 4 | keys 5 | self = $self 6 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/CallRewardNametag.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$txID.Nametag 2 | 3 | body :: Nametag -> FaeTX String 4 | body = checkNametag 5 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Escrow1: -------------------------------------------------------------------------------- 1 | body = Escrow1 2 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Escrow1.hs: -------------------------------------------------------------------------------- 1 | type EType = Contract () String 2 | 3 | body :: FaeTX () 4 | body = newContract c where 5 | c :: Contract String (EscrowID EType) 6 | c name = do 7 | eID <- newEscrow e 8 | spend eID 9 | 10 | where 11 | e :: EType 12 | e _ = spend ("Property of: " ++ name) 13 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Escrow2: -------------------------------------------------------------------------------- 1 | body = Escrow2 2 | inputs 3 | $txID/Body/0/Current = "Ryan Reich" 4 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Escrow2.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$txID 2 | 3 | body :: EscrowID EType -> FaeTX () 4 | body eID = newContract (Spend eID) 5 | 6 | data Spend a = Spend a deriving (Generic) 7 | 8 | instance (ContractVal a) => ContractName (Spend a) where 9 | type ArgType (Spend a) = () 10 | type ValType (Spend a) = a 11 | theContract (Spend x) = \_ -> spend x 12 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Escrow3: -------------------------------------------------------------------------------- 1 | body = Escrow3 2 | inputs 3 | $txID/Body/0/Current = "Ryan Reich" 4 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Escrow3.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$txID 2 | import Control.Monad (unless) 3 | 4 | body :: EscrowID EType -> FaeTX () 5 | body eID = do 6 | us <- signer "self" 7 | newContract (Restricted us eID) 8 | 9 | data Restricted a = Restricted PublicKey a deriving (Generic) 10 | 11 | instance (ContractVal a) => ContractName (Restricted a) where 12 | type ArgType (Restricted a) = () 13 | type ValType (Restricted a) = a 14 | theContract (Restricted us x) = \_ -> do 15 | them <- signer "self" 16 | unless (us == them) (error "Wrong sender") 17 | spend x 18 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/Nametag.hs: -------------------------------------------------------------------------------- 1 | module Nametag (Nametag, getNametag, checkNametag) where 2 | 3 | import Blockchain.Fae 4 | import Control.Monad (forever) 5 | 6 | data NametagName = NametagName String deriving (Generic) 7 | newtype Nametag = Nametag (EscrowID NametagName) deriving (Generic) 8 | 9 | instance ContractName NametagName where 10 | type ArgType NametagName = () 11 | type ValType NametagName = String 12 | theContract (NametagName name) = \_ -> forever $ release $ "Property of: " ++ name 13 | 14 | getNametag :: (MonadTX m) => Reward -> String -> m Nametag 15 | getNametag rwd name = do 16 | claimReward rwd 17 | Nametag <$> newEscrow (NametagName name) 18 | 19 | checkNametag :: (MonadTX m) => Nametag -> m String 20 | checkNametag (Nametag eID) = useEscrow [] eID () 21 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/RewardNametag: -------------------------------------------------------------------------------- 1 | body = RewardNametag 2 | others 3 | - Nametag 4 | reward = True 5 | keys 6 | self = ryan 7 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-2/RewardNametag.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Nametag 3 | 4 | body :: Reward -> FaeTX () 5 | body rwd = do 6 | nt <- getNametag rwd "Ryan Reich" 7 | deposit nt "self" 8 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/EnterLottery: -------------------------------------------------------------------------------- 1 | body = EnterLottery 2 | keys 3 | self = $self 4 | inputs 5 | $lotteryID/Body/0/Current : Enter 6 | self = self 7 | nametag = $nametagID/Body/0/Current : () 8 | self = self 9 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/EnterLottery.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$lotteryID.Lottery 2 | 3 | body :: LotteryResult -> FaeTX (Natural, String) 4 | body EnterResult{..} = return (enterCount, message) 5 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/ExitLottery: -------------------------------------------------------------------------------- 1 | body = ExitLottery 2 | keys 3 | self = $self 4 | inputs 5 | $lotteryID/Body/0/Current : Exit 6 | self = self 7 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/ExitLottery.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$lotteryID.Lottery 2 | 3 | body :: LotteryResult -> FaeTX String 4 | body WinResult{..} = return $ "Won with " ++ show others ++ " other" ++ plural where 5 | others = winnersCount - 1 6 | plural | others == 1 = "" 7 | | otherwise = "s" 8 | body ExitResult{..} = return $ "Did not win out of " ++ show lotteryLimit ++ " entries" 9 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/Lottery.hs: -------------------------------------------------------------------------------- 1 | module Lottery 2 | ( 3 | Lottery(..), LotteryAction(..), LotteryResult(..), Nametags 4 | ) where 5 | 6 | import Blockchain.Fae 7 | 8 | import Control.Monad 9 | import Control.Monad.Trans.State 10 | 11 | import Data.Maybe 12 | 13 | import Nametag 14 | 15 | import Data.Map.Strict (Map) 16 | import qualified Data.Map.Strict as Map 17 | 18 | import Data.Sequence (Seq) 19 | import qualified Data.Sequence as Seq 20 | 21 | data Lottery = 22 | Lottery 23 | { 24 | limit :: Natural, 25 | owner :: PublicKey 26 | } 27 | deriving (Generic) 28 | 29 | data LotteryAction = Enter | Exit deriving (Generic, Read) 30 | 31 | data LotteryResult = 32 | EnterResult 33 | { 34 | enterCount :: !Natural, 35 | message :: !String 36 | } | 37 | ExitResult 38 | { 39 | lotteryLimit :: Natural, 40 | returned :: !Nametags 41 | } | 42 | WinResult 43 | { 44 | winnersCount :: Natural, 45 | returned :: !Nametags 46 | } 47 | deriving (Generic) 48 | 49 | data LotteryState = 50 | RunningState 51 | { 52 | nametags :: Entries, 53 | count :: Natural, 54 | winningCount :: Natural 55 | } | 56 | FinishedState 57 | { 58 | winners :: Entries, 59 | totalWinners :: Natural, 60 | nonWinners :: Entries 61 | } 62 | 63 | type Entries = Map PublicKey (Seq Nametag) 64 | type Nametags = Container (Seq Nametag) 65 | 66 | data LotteryError = NotAuthorized | Finished | NotFound | BothMaps 67 | 68 | instance Show LotteryError where 69 | show NotAuthorized = "This action was not authorized by the lottery owner" 70 | show Finished = "The lottery is finished; no new entries accepted" 71 | show NotFound = "Not an entrant or already exited" 72 | show BothMaps = "Internal error; entrant is in both maps" 73 | 74 | instance Exception LotteryError 75 | 76 | startingState :: LotteryState 77 | startingState = RunningState Map.empty 0 0 78 | 79 | addEntry :: Nametag -> PublicKey -> Entries -> (Natural, Entries) 80 | addEntry tag = Map.alterF $ finish . maybe (Seq.singleton tag) (tag Seq.<|) 81 | where finish set = (fromIntegral $ Seq.length set, Just set) 82 | 83 | takeEntry :: PublicKey -> Entries -> (Maybe Nametags, Entries) 84 | takeEntry = Map.alterF $ (,Nothing) . fmap Container 85 | 86 | splitEntries :: Natural -> Entries -> (Entries, Entries) 87 | splitEntries n = Map.partition ((== n) . fromIntegral . Seq.length) 88 | 89 | instance ContractName Lottery where 90 | type ArgType Lottery = LotteryAction 91 | type ValType Lottery = LotteryResult 92 | theContract Lottery{..} = usingState startingState $ feedback $ \case 93 | Enter -> newEntry limit owner 94 | Exit -> getEntry limit 95 | 96 | newEntry :: 97 | Natural -> PublicKey -> 98 | StateT LotteryState (Fae LotteryAction LotteryResult) LotteryResult 99 | newEntry limit owner = do 100 | signedBy <- signer "owner" 101 | unless (signedBy == owner) $ throw NotAuthorized 102 | 103 | lotteryState <- get 104 | case lotteryState of 105 | FinishedState{} -> throw Finished 106 | RunningState{..} -> do 107 | nametag <- material "nametag" 108 | message <- checkNametag nametag 109 | entrant <- signer "self" 110 | let (enterCount, nametags') = addEntry nametag entrant nametags 111 | count' = count + 1 112 | winningCount' 113 | | enterCount > winningCount = enterCount 114 | | otherwise = winningCount 115 | put $ 116 | if count' == limit 117 | then let (winners, nonWinners) = splitEntries winningCount' nametags' in 118 | FinishedState{totalWinners = fromIntegral $ Map.size winners, ..} 119 | else RunningState 120 | { 121 | nametags = nametags', 122 | count = count', 123 | winningCount = winningCount' 124 | } 125 | return $! EnterResult{..} 126 | 127 | getEntry :: 128 | Natural -> StateT LotteryState (Fae LotteryAction LotteryResult) LotteryResult 129 | getEntry lotteryLimit = do 130 | entrant <- signer "self" 131 | lotteryState <- get 132 | (result, newState) <- case lotteryState of 133 | RunningState{..} -> do 134 | let (returnedM, nametags') = takeEntry entrant nametags 135 | returned = fromMaybe (throw NotFound) returnedM 136 | result = ExitResult{..} 137 | count' = count - 1 138 | winningCount' 139 | | count < winningCount = winningCount 140 | | otherwise = fromIntegral $ maximum $ fmap Seq.length nametags' 141 | newState = 142 | RunningState 143 | { 144 | nametags = nametags', 145 | count = count', 146 | winningCount = winningCount' 147 | } 148 | return (result, newState) 149 | FinishedState{..} -> do 150 | let (wSetM, winners') = takeEntry entrant winners 151 | (nwSetM, nonWinners') = takeEntry entrant nonWinners 152 | case (wSetM, nwSetM) of 153 | (Nothing, Nothing) -> throw NotFound 154 | (Just _, Just _) -> throw BothMaps 155 | (Just returned, _) -> do 156 | let result = WinResult{winnersCount = totalWinners, ..} 157 | newState = lotteryState{winners = winners'} 158 | return (result, newState) 159 | (_, Just returned) -> do 160 | let result = ExitResult{..} 161 | newState = lotteryState{nonWinners = nonWinners'} 162 | return (result, newState) 163 | put newState 164 | return $! result 165 | 166 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/Nametag.hs: -------------------------------------------------------------------------------- 1 | ../tutorial-2/Nametag.hs -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/NewLottery: -------------------------------------------------------------------------------- 1 | body = NewLottery 2 | others 3 | - Nametag 4 | - Lottery 5 | keys 6 | self = $self 7 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/NewLottery.hs: -------------------------------------------------------------------------------- 1 | import Lottery 2 | 3 | body :: FaeTX () 4 | body = do 5 | owner <- signer "self" 6 | newContract $ Lottery 5 owner 7 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/RewardNametag: -------------------------------------------------------------------------------- 1 | body = RewardNametag 2 | reward = True 3 | keys 4 | self = $self 5 | -------------------------------------------------------------------------------- /documentation/tutorial/tutorial-3/RewardNametag.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Transactions.TX$nametagID.Nametag 3 | 4 | body :: Reward -> FaeTX () 5 | body rwd = do 6 | nt <- getNametag rwd "Ryan Reich" 7 | deposit nt "self" 8 | -------------------------------------------------------------------------------- /fae.cabal: -------------------------------------------------------------------------------- 1 | name: fae 2 | -- My take on semantic versioning: 3 | -- a.*.*.* -> (a + 1).0.0.0 : Breaking API changes 4 | -- *.b.*.* -> *.(b + 1).0.0 : Compatible but major new features 5 | -- *.*.c.* -> *.*.(c + 1).0 : Bugfixes that may change the (incorrect) behavior of existing code 6 | -- or minor, compatible new features 7 | -- *.*.*.d -> *.*.*.(d + 1) : Adding omitted exports, GHC extensions, cosmetic stuff, demos ... 8 | version: 2.0.0.0 9 | -- synopsis: 10 | -- description: 11 | homepage: https://github.com/Consensys/Fae 12 | license: BSD3 13 | license-file: LICENSE 14 | author: Ryan Reich 15 | maintainer: ryan.reich@consensys.net 16 | copyright: MIT 17 | category: none 18 | build-type: Simple 19 | extra-source-files: README.md 20 | cabal-version: >=1.10 21 | 22 | library 23 | hs-source-dirs: src, common 24 | exposed-modules: 25 | Blockchain.Fae 26 | Blockchain.Fae.FrontEnd 27 | Blockchain.Fae.Internal 28 | Blockchain.Fae.Contracts 29 | Blockchain.Fae.Currency 30 | other-modules: 31 | Blockchain.Fae.Internal.Contract 32 | Blockchain.Fae.Internal.Crypto 33 | Blockchain.Fae.Internal.Exceptions 34 | Blockchain.Fae.Internal.GenericInstances 35 | Blockchain.Fae.Internal.IDs 36 | Blockchain.Fae.Internal.IDs.Types 37 | Blockchain.Fae.Internal.Messages, 38 | Blockchain.Fae.Internal.Monitors, 39 | Blockchain.Fae.Internal.TXSummary 40 | Blockchain.Fae.Internal.Reward 41 | Blockchain.Fae.Internal.Serialization 42 | Blockchain.Fae.Internal.Storage 43 | Blockchain.Fae.Internal.Suspend 44 | Blockchain.Fae.Internal.Transaction 45 | Blockchain.Fae.Internal.TX 46 | Common.Lens 47 | build-depends: 48 | base >= 4.10 && < 5, 49 | base16-bytestring, 50 | bytestring, 51 | cereal, 52 | containers, 53 | cryptonite >= 0.24, 54 | deepseq, 55 | exceptions, 56 | filepath, 57 | hint, 58 | lens, 59 | memory, 60 | mtl, 61 | pretty, 62 | template-haskell, 63 | text, 64 | transformers, 65 | unix, 66 | vector 67 | default-language: Haskell2010 68 | default-extensions: 69 | BangPatterns 70 | ConstraintKinds 71 | DefaultSignatures 72 | DeriveGeneric 73 | ExistentialQuantification 74 | FlexibleContexts 75 | FlexibleInstances 76 | FunctionalDependencies 77 | GeneralizedNewtypeDeriving 78 | LambdaCase 79 | MultiParamTypeClasses 80 | MultiWayIf 81 | NamedFieldPuns 82 | OverloadedStrings 83 | PatternGuards 84 | RankNTypes 85 | RecordWildCards 86 | ScopedTypeVariables 87 | StandaloneDeriving 88 | TupleSections 89 | TypeApplications 90 | TypeFamilies 91 | TypeFamilyDependencies 92 | TypeOperators 93 | 94 | executable faeServer 95 | buildable: True 96 | hs-source-dirs: bin, common 97 | main-is: FaeServer.hs 98 | ghc-options: -dynamic -threaded -rtsopts -with-rtsopts=-N 99 | other-modules: 100 | Common.JSON 101 | Common.Lens 102 | Common.ProtocolT 103 | FaeServer.App 104 | FaeServer.Args 105 | FaeServer.Concurrency 106 | FaeServer.Fae 107 | FaeServer.Faeth 108 | FaeServer.Git 109 | FaeServer.History 110 | FaeServer.Modules 111 | build-depends: 112 | aeson, 113 | base, 114 | base16-bytestring, 115 | bytestring, 116 | cereal, 117 | containers, 118 | deepseq, 119 | directory, 120 | fae, 121 | filepath, 122 | http-types, 123 | lens, 124 | lifted-base, 125 | mtl, 126 | pretty, 127 | process, 128 | stm, 129 | template-haskell, 130 | text, 131 | transformers, 132 | unix, 133 | wai, 134 | wai-extra, 135 | warp, 136 | websockets, 137 | zlib 138 | default-language: Haskell2010 139 | default-extensions: 140 | DeriveGeneric 141 | FlexibleContexts 142 | FlexibleInstances 143 | GeneralizedNewtypeDeriving 144 | LambdaCase 145 | MultiParamTypeClasses 146 | NamedFieldPuns 147 | OverloadedStrings 148 | RankNTypes 149 | RecordWildCards 150 | ScopedTypeVariables 151 | TupleSections 152 | TypeApplications 153 | 154 | executable postTX 155 | buildable: True 156 | hs-source-dirs: bin, common 157 | main-is: PostTX.hs 158 | other-modules: 159 | Common.JSON 160 | Common.Lens 161 | Common.ProtocolT 162 | PostTX.Args 163 | PostTX.Faeth 164 | PostTX.ImportExport 165 | PostTX.Keys 166 | PostTX.Network 167 | PostTX.Parser 168 | PostTX.Submit 169 | PostTX.TXSpec 170 | PostTX.View 171 | build-depends: 172 | aeson, 173 | base, 174 | base16-bytestring, 175 | bytestring, 176 | cereal, 177 | containers, 178 | deepseq, 179 | directory, 180 | fae, 181 | filepath, 182 | haskeline, 183 | http-client, 184 | lens, 185 | megaparsec, 186 | mtl, 187 | pretty, 188 | process, 189 | template-haskell, 190 | text, 191 | time, 192 | websockets, 193 | zlib 194 | default-language: Haskell2010 195 | default-extensions: 196 | DeriveGeneric 197 | FlexibleContexts 198 | FlexibleInstances 199 | GeneralizedNewtypeDeriving 200 | RankNTypes 201 | RecordWildCards 202 | MultiParamTypeClasses 203 | NamedFieldPuns 204 | OverloadedStrings 205 | ScopedTypeVariables 206 | TupleSections 207 | TypeApplications 208 | 209 | executable collectPackage 210 | buildable: True 211 | hs-source-dirs: tools, common 212 | main-is: CollectPackage.hs 213 | other-modules: 214 | Common.Lens 215 | PackageInfo 216 | build-depends: 217 | base, 218 | bytestring, 219 | Cabal, 220 | containers, 221 | directory, 222 | filepath, 223 | ghc-boot, 224 | lens, 225 | mtl, 226 | process, 227 | template-haskell, 228 | unix 229 | default-language: Haskell2010 230 | default-extensions: 231 | FlexibleContexts 232 | FlexibleInstances 233 | MultiParamTypeClasses 234 | NamedFieldPuns 235 | RankNTypes 236 | RecordWildCards 237 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | fae-2.0.0.0

fae-2.0.0.0

fae-2.0.0.0

 

Signatures

Modules

-------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/ChangeCoin: -------------------------------------------------------------------------------- 1 | body = ChangeCoin 2 | inputs 3 | $coinTX/Body/0/$ver = () 4 | keys 5 | self = $self 6 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/ChangeCoin.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Currency 2 | import Data.Maybe 3 | 4 | body :: Coin -> FaeTX (Valuation Coin, Valuation Coin) 5 | body coin = do 6 | resultPairM <- change coin 2 7 | case resultPairM of 8 | Nothing -> do 9 | coinVal <- value coin 10 | return (0, coinVal) 11 | Just (result, changeM) -> do 12 | resultVal <- value result 13 | changeValM <- traverse value changeM 14 | return (resultVal, fromMaybe 0 changeValM) 15 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/GetCoin: -------------------------------------------------------------------------------- 1 | body = GetCoin 2 | reward = True 3 | inputs 4 | $coinTX/Body/0/$ver : () 5 | keys 6 | self = $self 7 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/GetCoin.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | body :: Reward -> Coin -> FaeTX (Valuation Coin) 5 | body rToken coin = do 6 | rCoin <- reward rToken 7 | coin' <- add rCoin coin 8 | val <- value coin' 9 | deposit coin' "self" 10 | return val 11 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/RoundCoin: -------------------------------------------------------------------------------- 1 | body = RoundCoin 2 | inputs 3 | $coinTX/Body/0/$ver = () 4 | keys 5 | self = $self 6 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/RoundCoin.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Currency 2 | import Data.Maybe 3 | import Prelude hiding (round) 4 | 5 | body :: Coin -> FaeTX (Valuation Coin, Valuation Coin) 6 | body c = do 7 | (c', rM) <- round c 3 8 | roundVal <- value c' 9 | remainderVal <- fromMaybe (return 0) $ value <$> rM 10 | return (roundVal, remainderVal) 11 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/SplitCoin: -------------------------------------------------------------------------------- 1 | body = SplitCoin 2 | inputs 3 | $coinTX/Body/0/$ver = () 4 | keys 5 | self = $self 6 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/SplitCoin.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Currency 2 | import Data.Maybe 3 | 4 | body :: Coin -> FaeTX ([Valuation Coin], Valuation Coin) 5 | body coin = do 6 | (pieces, remainderM) <- split coin [3,2,2] 7 | values <- traverse value pieces 8 | remainder <- fromMaybe 0 <$> traverse value remainderM 9 | return (values, remainder) 10 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/ZeroCoin: -------------------------------------------------------------------------------- 1 | body = ZeroCoin 2 | 3 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae.Currency/ZeroCoin.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | import Control.Monad 4 | 5 | body :: FaeTX () 6 | body = newContract @(Contract () Coin) $ 7 | \_ -> forever $ zero >>= release 8 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/escrows/ReturnEscrowID1: -------------------------------------------------------------------------------- 1 | body = ReturnEscrowID1 2 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/escrows/ReturnEscrowID1.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX () 2 | body = newContract @CName $ \() -> do 3 | eID <- newEscrow @EName $ const $ spend "Hello!" 4 | spend eID 5 | 6 | type EName = Contract () String 7 | type CName = Contract () (EscrowID EName) 8 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/escrows/ReturnEscrowID2: -------------------------------------------------------------------------------- 1 | body = ReturnEscrowID2 2 | inputs 3 | $txID/Body/0/Current = () 4 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/escrows/ReturnEscrowID2.hs: -------------------------------------------------------------------------------- 1 | body :: EscrowID (Contract () String) -> FaeTX String 2 | body eID = useEscrow [] eID () 3 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/AggregateInputs: -------------------------------------------------------------------------------- 1 | body = AggregateInputs 2 | materials 3 | pay1 = $paymentID/Body/0/Current : () 4 | pay2 = $paymentID/Body/0/Current : () 5 | pay3 = $paymentID/Body/0/Current : () 6 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/AggregateInputs.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX Int 2 | body = do 3 | payments <- materials @(EscrowID (Contract () Int)) 4 | sum <$> mapM (\eID -> useEscrow [] eID ()) payments 5 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/MaterialAssignments1: -------------------------------------------------------------------------------- 1 | body = MaterialAssignments1 2 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/MaterialAssignments1.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX () 2 | body = newContract C 3 | 4 | data C = C deriving (Generic) 5 | data E' = E' deriving (Generic) 6 | 7 | instance ContractName C where 8 | type ArgType C = () 9 | type ValType C = EscrowID E' 10 | theContract C () = newEscrow E' >>= spend 11 | 12 | instance ContractName E' where 13 | type ArgType E' = Int 14 | type ValType E' = Int 15 | theContract E' n = spend $ n + 1 16 | 17 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/MaterialAssignments2: -------------------------------------------------------------------------------- 1 | body = MaterialAssignments2 2 | materials 3 | theMaterial = $txID/Body/0/Current : () 4 | 5 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/MaterialAssignments2.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | import Blockchain.Fae.Transactions.TX$txID 4 | 5 | body :: FaeTX Int 6 | body = do 7 | eID <- newEscrow E 8 | eID' <- newEscrow E' 9 | useEscrow ["txMaterial" <=| "theMaterial", "newMaterial" *<- eID'] eID 1 10 | 11 | data E = E deriving (Generic) 12 | 13 | instance ContractName E where 14 | type ArgType E = Int 15 | type ValType E = Int 16 | theContract E n = do 17 | txEID <- material "txMaterial" 18 | newEID <- material "newMaterial" 19 | useEscrow @E' [] txEID n >>= useEscrow @E' [] newEID >>= spend 20 | 21 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/PayMaterial1: -------------------------------------------------------------------------------- 1 | body = PayMaterial1 2 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/PayMaterial1.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX () 2 | body = do 3 | newContract @(Contract () (EscrowID (Contract () Int))) $ 4 | feedback $ \_ -> newEscrow (\_ -> traverse release [1 ..] >> spend 0) >>= release 5 | newContract @(Contract () (EscrowID (Contract () Int))) $ 6 | let f _ = do 7 | eID <- material "eID" 8 | _ <- useEscrow [] eID () 9 | release eID 10 | f () 11 | in f 12 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/PayMaterial2: -------------------------------------------------------------------------------- 1 | body = PayMaterial2 2 | inputs 3 | $paymentID/Body/0/Current : () 4 | materials 5 | payment = $paymentID/Body/1/Current : () 6 | eID = $paymentID/Body/1/Current : () 7 | eID = $paymentID/Body/1/Current : () 8 | eID = $paymentID/Body/0/Current : () 9 | payment' = $paymentID/Body/1/Current : () 10 | eID = $paymentID/Body/0/Current : () 11 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/materials/PayMaterial2.hs: -------------------------------------------------------------------------------- 1 | body :: EscrowID (Contract () Int) -> FaeTX Int 2 | body eID0 = do 3 | eID <- material @(EscrowID (Contract () Int)) "payment" 4 | eID' <- material @(EscrowID (Contract () Int)) "payment'" 5 | n <- useEscrow [] eID () 6 | n' <- useEscrow [] eID' () 7 | n0 <- useEscrow [] eID0 () 8 | return $ n + n' + n0 9 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/renaming/Renaming1: -------------------------------------------------------------------------------- 1 | body = Renaming1 2 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/renaming/Renaming1.hs: -------------------------------------------------------------------------------- 1 | -- Create a valuable (escrow) and deposit it with contract A 2 | -- Also create contract B that can have that valuable transfered to it 3 | body :: FaeTX () 4 | body = do 5 | eID <- newEscrow $ Val 0 6 | newContract $ C eID -- Owns eID, when called, calls the escrow and returns it 7 | 8 | data Val = Val Integer deriving (Generic) 9 | 10 | instance ContractName Val where 11 | type ArgType Val = () 12 | type ValType Val = (Integer, PublicKey) 13 | theContract (Val n) = \() -> do 14 | key <- signer "valRole" 15 | _ <- release (n, key) 16 | theContract (Val $ n + 1) () 17 | 18 | data C = C (EscrowID Val) deriving (Generic) 19 | 20 | instance ContractName C where 21 | type ArgType C = () 22 | type ValType C = (Integer, PublicKey, EscrowID Val) 23 | theContract (C eID) = \() -> do 24 | (n, key) <- useEscrow ["valRole" <-| "cRole"] eID () 25 | spend (n, key, eID) 26 | 27 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/renaming/Renaming2: -------------------------------------------------------------------------------- 1 | body = Renaming2 2 | keys 3 | ryan = $ryan 4 | tom = $tom 5 | inputs 6 | -- Should return (0, $ryan, eID) 7 | $txID/Body/0/$ver : () 8 | cRole = ryan 9 | 10 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/renaming/Renaming2.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$txID 2 | 3 | body :: (Integer, PublicKey, EscrowID Val) -> FaeTX String 4 | body (n1, k1, cE) = do 5 | eID <- newEscrow E 6 | (n2, k2) <- useEscrow ["eRole" <-| "tom"] eID cE 7 | return $ 8 | "C: escrow saw " ++ show k1 ++ ", returned " ++ show n1 ++ "; " ++ 9 | "E: escrow saw " ++ show k2 ++ ", returned " ++ show n2 10 | 11 | data E = E deriving (Generic) 12 | 13 | instance ContractName E where 14 | type ArgType E = EscrowID Val 15 | type ValType E = (Integer, PublicKey) 16 | theContract E = \eID -> do 17 | (n, key) <- useEscrow ["valRole" <-| "eRole"] eID () 18 | spend (n, key) 19 | 20 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/timeouts/Timeout1: -------------------------------------------------------------------------------- 1 | body = Timeout1 2 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/timeouts/Timeout1.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | body :: FaeTX () 4 | body = do 5 | newContract @(Contract () ()) $ \() -> forever (return 0) >> spend () 6 | newContract @(Contract () ()) $ feedback $ const $ release () 7 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/timeouts/Timeout2: -------------------------------------------------------------------------------- 1 | body = Timeout2 2 | inputs 3 | $txID/Body/0/Current : () 4 | $txID/Body/1/Current : () 5 | material = $txID/Body/0/Current : () 6 | -------------------------------------------------------------------------------- /samples/Blockchain.Fae/timeouts/Timeout2.hs: -------------------------------------------------------------------------------- 1 | body :: () -> () -> FaeTX () 2 | body _ _ = return () 3 | -------------------------------------------------------------------------------- /src/Blockchain/Fae.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, Trustworthy #-} 2 | {- | 3 | Module: Blockchain.Fae 4 | Description: A functional smart contract system 5 | Copyright: (c) Ryan Reich, 2017-2018 6 | License: MIT 7 | Maintainer: ryan.reich@gmail.com 8 | Stability: experimental 9 | 10 | Fae is a functional smart contract system, a "functional alternative to 11 | Ethereum". This module exposes the contract authoring API. 12 | 13 | In Fae, a /contract/ is a function from "valued input" to "valued output". 14 | The value is backed by /escrows/, which are contracts within contracts, and 15 | which are transferred along with the output they back when it is returned 16 | from the containing contract. While escrows may be called by ID and input 17 | argument anywhere in contract code, a non-escrow contract (one that does 18 | not belong to any other contract) may only be called in the preamble to 19 | a /transaction/. The reason for this will be explained later. 20 | 21 | Contracts are modeled as /coroutines/, or functions that may be suspended 22 | and resumed. Suspension, in the form of "releasing" a value, causes 23 | contract execution to end, returning the value, and causing the contract to 24 | be updated in storage to refer to the subsequent portion, which is resumed 25 | when the contract is next called. Contracts are therefore entirely 26 | responsible for the nature of their persistent state, and may indeed be 27 | written in a monad with various state effects (reader, writer, and state 28 | being the obvious ones), or with none at all. 29 | 30 | Contract storage is /lazy/, in that no entries are evaluated unless 31 | strictly required. No activity within Fae strictly requires this 32 | evaluation, because ultimately, all contract executions are reflected in 33 | transaction results or new contracts, which are themselves stored lazily. 34 | It is expected that parties interested in the contents of the storage will 35 | access it in a sandbox, only upon which will its entries finally be 36 | evaluated to the extent necessary. Therefore, submitting new transactions 37 | to Fae is very cheap, as only a minimal amount of bookkeeping computation 38 | is done. 39 | 40 | Unlike Ethereum, Fae has no computational fees ("gas"). The reason for 41 | this is that, because of the lazy design, one is never forced to execute 42 | untrusted code. This is facilitated by the requirement that non-escrow 43 | contracts only be called in advance of transaction execution; in addition, 44 | the arguments to these contracts are limited to literals or outputs of 45 | trusted other contracts. Therefore no untrusted code, either in the 46 | surrounding transaction or in the argument, intervenes in contract 47 | execution. 48 | 49 | Fae is not a completely pure functional system: it has exceptions. This is 50 | both because contract code, being Haskell, may throw exceptions for 51 | syntactic reasons, and because the system itself may raise exceptions. 52 | Although contracts may throw exceptions, they may never catch them, lest 53 | they hide an error that shouldn't be recoverable. 54 | -} 55 | module Blockchain.Fae 56 | ( 57 | -- * Transactions 58 | -- | Transactions are handled outside of Fae's Haskell API, but their 59 | -- definitions are still within it. When processed, a transaction must 60 | -- be accompanied by a list of @(ContractID, String)@ pairs denoting 61 | -- the literal arguments passed to the contracts with the given IDs. 62 | -- These are then 'read' into Haskell types, to prevent malicious 63 | -- authors from inserting nonterminating code into the contract calls. 64 | TransactionBody, 65 | PublicKey, FaeTX, MonadTX, 66 | -- * Contracts and escrows 67 | Contract, ContractM, ContractName(..), 68 | Fae, MonadContract, WithEscrows, EscrowID, Reward, 69 | -- ** Contract API 70 | spend, release, useEscrow, newEscrow, 71 | newContract, usingState, usingReader, feedback, 72 | lookupSigner, signer, signers, 73 | lookupMaterial, material, materials, 74 | Assignment, (<-|), (<=|), (*<-), (↤), (⤆ ), (⤝), claimReward, 75 | -- * Opaque types and classes 76 | HasEscrowIDs, Exportable, EGeneric, Container(..), ContractArg, ContractVal, 77 | -- * Re-exports 78 | Natural, Typeable, Exception, throw, evaluate, 79 | Generic, Identity(..), Void 80 | ) where 81 | 82 | import Blockchain.Fae.Internal.Contract 83 | import Blockchain.Fae.Internal.Crypto 84 | import Blockchain.Fae.Internal.GenericInstances 85 | import Blockchain.Fae.Internal.IDs 86 | import Blockchain.Fae.Internal.Reward 87 | import Blockchain.Fae.Internal.Serialization 88 | import Blockchain.Fae.Internal.Transaction 89 | 90 | import Common.Lens 91 | 92 | import Control.Monad.Fix 93 | import Control.Monad.Reader 94 | import Control.Monad.State 95 | 96 | import Control.Exception (Exception, throw, evaluate) 97 | import Data.Typeable (Typeable) 98 | import Data.Void (Void) 99 | import GHC.Generics (Generic) 100 | import Numeric.Natural (Natural) 101 | 102 | -- * Types 103 | 104 | -- | Constraint collection synonym 105 | type ContractVal a = (HasEscrowIDs a, EGeneric a, ESerialize a, Exportable a) 106 | -- | Constraint collection synonym 107 | type ContractArg a = (HasEscrowIDs a, Read a) 108 | 109 | -- | A contract transformer to apply effects to 'Fae'. Concretely, it is 110 | -- 111 | -- >>> type ContractM t name = ArgType name -> t (Fae (ArgType name) (ValType name)) (ValType name) 112 | -- 113 | -- To demystify the kind signature, it is used like 114 | -- 115 | -- >>> type StateContract s argType valType = ContractM (StateT s) argType valType 116 | -- 117 | -- with the first component being a monad /transformer/. This can then be 118 | -- evaluated back down to a @Contract argType valType@ via 'usingState'. 119 | type ContractM (t :: (* -> *) -> (* -> *)) argType valType = 120 | ContractT (t (Fae argType valType)) argType valType 121 | 122 | -- | A transaction transformer to apply effects to 'FaeTX'. To demystify the 123 | -- kind signature, it is used like 124 | -- 125 | -- >>> type StateTransaction s a b = TransactionM (StateT s) a b 126 | -- 127 | -- with the first component being a monad /transformer/. This can then be 128 | -- evaluated back down to a @Transaction a b@ via 'usingState'. 129 | type TransactionM (t :: (* -> *) -> (* -> *)) a b = a -> t FaeTX b 130 | 131 | -- | A simple utility for adding mutable state to a contract or 132 | -- transaction, since the manual way of doing this is a little awkward. 133 | -- The second argument should be a @ContractM StateT@ or @TransactionM 134 | -- StateT@. 135 | usingState :: 136 | (Monad m) => 137 | s -> 138 | (a -> StateT s m b) -> 139 | (a -> m b) 140 | usingState s f = flip evalStateT s . f 141 | 142 | -- | A simple utility for adding constant state to a contract or 143 | -- transaction, since the manual way of doing this is a little awkward. 144 | -- The second argument should be a @ContractM StateT@ or @TransactionM 145 | -- ReaderT@. 146 | usingReader :: 147 | (Monad m) => 148 | r -> 149 | (a -> ReaderT r m b) -> 150 | (a -> m b) 151 | usingReader r f = flip runReaderT r . f 152 | 153 | -- | A shorthand for defining a contract that is, essentially, a state 154 | -- machine: each evaluation is passed to 'release' and the return value 155 | -- (the next argument) is fed back into the same contract function. Used 156 | -- like this: 157 | -- 158 | -- >>> c :: Contract Bool Int 159 | -- >>> c = feedback $ \case 160 | -- >>> True -> 42 161 | -- >>> False -> 57 162 | -- 163 | -- it defines a contract that forever accepts a 'Bool' and returns one of 164 | -- the two numbers. 165 | feedback :: 166 | (ContractVal b, MonadContract a b m) => (a -> m b) -> (a -> m (WithEscrows b)) 167 | feedback f = (>=> spend) . fix . (>=>) $ f >=> release 168 | 169 | -- | This little hack allows you to write a state machine that /doesn't/ 170 | -- loop endlessly, but has halting states that return a value. 171 | halt :: (HasEscrowIDs a, MonadContract b a m) => a -> m a 172 | halt x = spend x >> return x 173 | 174 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/FrontEnd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | {- | 3 | Module: Blockchain.Fae.FrontEnd 4 | Description: The API for implementors of a Fae front-end 5 | Copyright: (c) Ryan Reich, 2017-2018 6 | License: MIT 7 | Maintainer: ryan.reich@gmail.com 8 | Stability: experimental 9 | 10 | If you are writing a Fae client, this module is for you. It exposes the 11 | functions for running blocks and transactions, and for showing the storage. 12 | Most of the re-exported modules were imported with restricted lists, but 13 | due to a deficiency in Haddock this is not reflected in the generated 14 | document. 15 | -} 16 | module Blockchain.Fae.FrontEnd 17 | ( 18 | -- * Messages 19 | module Blockchain.Fae.Internal.Messages, 20 | -- * Interpreting transactions 21 | module Blockchain.Fae.Internal.TX, 22 | -- * Running transactions without interpreting 23 | module Blockchain.Fae.Internal.Transaction, 24 | -- * Fae storage types and storage access 25 | module Blockchain.Fae.Internal.Storage, 26 | exportValue, importValue, 27 | -- * Transaction evaluation 28 | module Blockchain.Fae.Internal.TXSummary, 29 | module Blockchain.Fae.Internal.Monitors, 30 | -- * Cryptography types and functions 31 | module Blockchain.Fae.Internal.Crypto, 32 | -- * Fae exceptions 33 | module Blockchain.Fae.Internal.Exceptions, 34 | -- * Fae ID types 35 | module Blockchain.Fae.Internal.IDs.Types 36 | ) where 37 | 38 | import Blockchain.Fae.Internal.Contract (exportValue, importValue) 39 | import Blockchain.Fae.Internal.Crypto hiding 40 | ( 41 | Serialize, PassFail, PartialSerialize, 42 | compareSerialize, putPartialSerialize, 43 | getPartialSerialize, readsPrecSer, 44 | EdPublicKey 45 | ) 46 | import Blockchain.Fae.Internal.Exceptions hiding (unsafeIsDefined) 47 | import Blockchain.Fae.Internal.GenericInstances 48 | import Blockchain.Fae.Internal.IDs hiding 49 | ( 50 | GHasEscrowIDs, 51 | defaultTraverseEscrowIDs 52 | ) 53 | import Blockchain.Fae.Internal.IDs.Types 54 | import Blockchain.Fae.Internal.Messages hiding 55 | ( 56 | unsignedTXMessage, unsignTXMessage 57 | ) 58 | import Blockchain.Fae.Internal.TXSummary 59 | ( 60 | TXSummary(..), TXInputSummary(..), 61 | InputSummary, MaterialsSummaries, 62 | collectTransaction 63 | ) 64 | import Blockchain.Fae.Internal.Monitors 65 | import Blockchain.Fae.Internal.Storage hiding 66 | ( 67 | txPartLens, txInputLens, vectorAt, joinUncertainty, uncertain, onlyJust 68 | ) 69 | import Blockchain.Fae.Internal.Transaction 70 | ( 71 | Input(..), InputMaterials, TXStorageM, TransactionBody(..), runTransaction 72 | ) 73 | import Blockchain.Fae.Internal.TX 74 | 75 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | {- | 3 | Module: Blockchain.Fae.Internal 4 | Description: Omnibus module for all Fae internals 5 | Copyright: (c) Ryan Reich, 2017-2018 6 | License: MIT 7 | Maintainer: ryan.reich@gmail.com 8 | Stability: experimental 9 | 10 | This undiscriminatingly re-exports all the internal modules for ease of import. 11 | -} 12 | module Blockchain.Fae.Internal 13 | ( 14 | module Blockchain.Fae.Internal.Contract, 15 | module Blockchain.Fae.Internal.Crypto, 16 | module Blockchain.Fae.Internal.Exceptions, 17 | module Blockchain.Fae.Internal.GenericInstances, 18 | module Blockchain.Fae.Internal.IDs, 19 | module Blockchain.Fae.Internal.Messages, 20 | module Blockchain.Fae.Internal.Reward, 21 | module Blockchain.Fae.Internal.Serialization, 22 | module Blockchain.Fae.Internal.Storage, 23 | module Blockchain.Fae.Internal.Suspend, 24 | module Blockchain.Fae.Internal.TX, 25 | module Blockchain.Fae.Internal.TXSummary, 26 | module Blockchain.Fae.Internal.Transaction 27 | ) where 28 | 29 | import Blockchain.Fae.Internal.Contract 30 | import Blockchain.Fae.Internal.Crypto 31 | import Blockchain.Fae.Internal.Exceptions 32 | import Blockchain.Fae.Internal.GenericInstances 33 | import Blockchain.Fae.Internal.IDs 34 | import Blockchain.Fae.Internal.Messages 35 | import Blockchain.Fae.Internal.Reward 36 | import Blockchain.Fae.Internal.Serialization 37 | import Blockchain.Fae.Internal.Storage 38 | import Blockchain.Fae.Internal.Suspend 39 | import Blockchain.Fae.Internal.TX 40 | import Blockchain.Fae.Internal.TXSummary 41 | import Blockchain.Fae.Internal.Transaction 42 | 43 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/Exceptions.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Blockchain.Fae.Internal.Exceptions 3 | Description: Wrapper library for "Control.Monad.Catch" 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This module just re-exports "Control.Monad.Catch", as well as 'Typeable' so that we can derive 'Exception' with just this module imported, and also 'throw' and 'evaluate' from "Control.Exception", which seem not to be re-exported elsewhere. 10 | -} 11 | module Blockchain.Fae.Internal.Exceptions 12 | ( 13 | module Blockchain.Fae.Internal.Exceptions, 14 | module Control.Monad.Catch, 15 | Ex.throw, Ex.evaluate, 16 | T.Typeable 17 | ) where 18 | 19 | import Blockchain.Fae.Internal.Crypto 20 | import Blockchain.Fae.Internal.IDs.Types 21 | import qualified Control.Exception as Ex 22 | import Control.Monad.Catch hiding (displayException) 23 | import Data.ByteString (ByteString) 24 | import Data.Typeable as T 25 | 26 | import System.IO.Unsafe 27 | 28 | -- * Functions 29 | 30 | -- | Obviously not pure at all, but intended to be used only in extremely 31 | -- limited circumstances; namely, to decide what to do with the global 32 | -- update of a contract function or nonce, or escrow function, in the event 33 | -- of an exception. 34 | unsafeIsDefined :: a -> Bool 35 | unsafeIsDefined act = unsafePerformIO $ catchAll 36 | (Ex.evaluate act >> return True) 37 | (const $ return False) 38 | 39 | -- * Types 40 | 41 | -- | Exceptions for storage-related errors. 42 | data StorageException = 43 | BadTransactionID TransactionID | 44 | BadContractID ContractID | 45 | BadInputID TransactionID Int | 46 | BadVersion ContractID Int Int | 47 | InvalidVersionAt ContractID | 48 | ContractOmitted TransactionID String | 49 | CantImport ByteString TypeRep | 50 | ImportWithoutVersion ContractID | 51 | NotExportable TypeRep | 52 | DeletedEntry 53 | 54 | -- | Exceptions for contract-related errors. 55 | data ContractException = 56 | ContractDeleted ContractID | 57 | BadContractVersion VersionID ContractID | 58 | BadInputParse String TypeRep | 59 | BadArgType TypeRep TypeRep | 60 | BadValType TypeRep TypeRep | 61 | BadMaterialType String TypeRep TypeRep | 62 | MissingMaterial String | 63 | BadEscrowID EntryID | 64 | BadEscrowName EntryID TypeRep TypeRep | 65 | MissingSigner String | 66 | NotStartState EntryID VersionID 67 | 68 | -- | Exceptions for transaction-related errors. 69 | data TransactionException = 70 | NotEnoughInputs | 71 | UnexpectedInput | 72 | ExpectedReward | 73 | UnexpectedReward | 74 | BadSignature | 75 | InputFailed ContractID | 76 | EmptyInputStack | 77 | RepeatedMaterial String 78 | 79 | -- | Exceptions arising non-core UI components. 80 | data DisplayException = 81 | InterpretException String | 82 | TXFieldException String | 83 | JSONException String | 84 | MonitorException String | 85 | Timeout Int 86 | 87 | -- * Instances 88 | 89 | -- | - 90 | instance Show StorageException where 91 | show (BadTransactionID tID) = "Not a transaction ID: " ++ show tID 92 | show (BadContractID cID) = "Not a contract ID: " ++ prettyContractID cID 93 | show (BadInputID txID ix) = 94 | "No input contract with index " ++ show ix ++ 95 | " for transaction " ++ show txID 96 | show (BadVersion cID bad good) = 97 | "Contract " ++ prettyContractID cID ++ 98 | " has nonce " ++ show good ++ "; got: " ++ show bad 99 | show (InvalidVersionAt cID) = "Can't look up contract ID: " ++ prettyContractID cID 100 | show (ContractOmitted txID descr) = 101 | descr ++ " in transaction " ++ show txID ++ 102 | " was replaced with an imported return value." 103 | show (CantImport bs ty) = 104 | "Can't decode value of type " ++ show ty ++ " from bytes: " ++ printHex bs 105 | show (ImportWithoutVersion cID) = 106 | "Rejecting imported value for " ++ prettyContractID cID ++ 107 | " that lacks a nonce value." 108 | show (NotExportable ty) = 109 | "Type " ++ show ty ++ " cannot be imported or exported." 110 | show (DeletedEntry) = 111 | "(internal error) Tried to delete an entry of the transaction results!" 112 | 113 | -- | - 114 | instance Show ContractException where 115 | show (ContractDeleted cID) = 116 | "Contract " ++ prettyContractID cID ++ " was deleted" 117 | show (BadContractVersion ver cID) = 118 | "Incorrect version in contract ID: " ++ prettyContractID cID ++ 119 | "; correct version is: " ++ show ver 120 | show (BadInputParse input inputType) = 121 | "Unable to parse '" ++ input ++ "' as type: " ++ show inputType 122 | show (BadArgType bad good) = 123 | "Expected argument type: " ++ show good ++ "; got: " ++ show bad 124 | show (BadValType bad good) = 125 | "Expected value type: " ++ show good ++ "; got: " ++ show bad 126 | show (BadMaterialType name bad good) = 127 | "Expected material '" ++ name ++ "' of type: " ++ show good ++ 128 | "; got: " ++ show bad 129 | show (MissingMaterial name) = "No material named " ++ show name 130 | show (BadEscrowID eID) = "No escrow found in this contract with ID: " ++ show eID 131 | show (BadEscrowName entID bad good) = 132 | "Wrong contract name for escrow " ++ show entID ++ 133 | "; got " ++ show bad ++ "; expected " ++ show good 134 | show (MissingSigner name) = "No signer named " ++ show name 135 | show (NotStartState entID vID) = 136 | "Escrow " ++ show entID ++ 137 | " with version " ++ show vID ++ 138 | " is not in its starting state" 139 | 140 | -- | - 141 | instance Show TransactionException where 142 | show NotEnoughInputs = "Transaction expected more inputs" 143 | show UnexpectedInput = "Excess input given transaction body's signature" 144 | show ExpectedReward = "Transaction expected a reward as its first argument" 145 | show UnexpectedReward = "Transaction passed an unexpected reward" 146 | show BadSignature = "Transaction signature does not match contract return types" 147 | show (InputFailed cID) = 148 | "Used the result of failed input contract " ++ prettyContractID cID 149 | show EmptyInputStack = "(internal error) Tried to use an empty stack!" 150 | show (RepeatedMaterial name) = "Repeated material name '" ++ name ++ "'" 151 | 152 | -- | - 153 | instance Show DisplayException where 154 | show (InterpretException s) = s 155 | show (TXFieldException s) = s 156 | show (JSONException s) = "Error in JSON serialization: " ++ s 157 | show (MonitorException s) = "Error in monitor operation: " ++ s 158 | show (Timeout t) = "Exceeded timeout of " ++ show t ++ " milliseconds" 159 | 160 | -- | - 161 | instance Exception StorageException 162 | -- | - 163 | instance Exception ContractException 164 | -- | - 165 | instance Exception TransactionException 166 | -- | - 167 | instance Exception DisplayException 168 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/GenericInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {- | 3 | Module: Blockchain.Fae.Internal.GenericInstances 4 | Description: Automatic instances for generic types 5 | Copyright: (c) Ryan Reich, 2017-2018 6 | License: MIT 7 | Maintainer: ryan.reich@gmail.com 8 | Stability: experimental 9 | -} 10 | module Blockchain.Fae.Internal.GenericInstances where 11 | 12 | import Blockchain.Fae.Internal.Contract 13 | import Blockchain.Fae.Internal.Exceptions 14 | import Blockchain.Fae.Internal.IDs 15 | import Blockchain.Fae.Internal.Serialization 16 | 17 | import Control.Monad.State 18 | 19 | import Data.Maybe 20 | import Data.Typeable 21 | 22 | import Data.Serialize (Serialize, GSerializePut, GSerializeGet) 23 | import qualified Data.Serialize as S 24 | 25 | import GHC.Generics 26 | 27 | -- | /So/ undecidable 28 | instance {-# OVERLAPPABLE #-} 29 | (Generic a, Typeable a, GHasEscrowIDs (Rep a)) => HasEscrowIDs a where 30 | 31 | traverseEscrowIDs f x = to <$> gTraverseEscrowIDs f (from x) 32 | 33 | -- | /So/ undecidable 34 | instance {-# OVERLAPPABLE #-} 35 | (Typeable a, EGeneric a, Serialize (ERep a)) => Exportable a where 36 | 37 | exportValue = fmap S.encode . eFrom 38 | importValue = either (const $ return Nothing) (fmap Just . eTo) . S.decode 39 | 40 | -- | /So/ undecidable 41 | instance {-# OVERLAPPABLE #-} 42 | (Generic a, EGeneric1 (Rep a), ERep a ~ SERep1 (Rep a)) => EGeneric a where 43 | 44 | eFrom = fmap SERep1 . eFrom1 @_ @_ @() . from 45 | eTo (SERep1 x) = to <$> eTo1 @_ @_ @() x 46 | 47 | -- | /So/ undecidable 48 | instance {-# OVERLAPPABLE #-} (Serialize (ERep a)) => ESerialize a 49 | 50 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/IDs/Types.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Blockchain.Fae.Internal.IDs.Types 3 | Description: Identifier types 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | There are several identifier types in Fae: contract IDs, transaction IDs, 10 | escrow IDs, and version IDs. Previously there was also a "short contract 11 | ID" that was the hash of the regular one, but this was rendered unnecessary 12 | and has been removed. 13 | -} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | module Blockchain.Fae.Internal.IDs.Types where 16 | 17 | import Blockchain.Fae.Internal.Crypto 18 | 19 | import Common.Lens 20 | 21 | import Control.DeepSeq 22 | 23 | import Data.List 24 | import Data.Map (Map) 25 | import Data.Serialize 26 | import Data.String 27 | 28 | import GHC.Generics 29 | 30 | import Text.ParserCombinators.ReadP 31 | 32 | -- | This identifier locates a contract in storage. It is not intended to 33 | -- be used in contract code, as indeed, a contract can never be called 34 | -- explicitly but only as a transaction input, for which there is a special 35 | -- syntax outside Haskell. 36 | data ContractID = 37 | ContractID 38 | { 39 | parentTransaction :: TransactionID, 40 | transactionPart :: TransactionPart, 41 | creationIndex :: Int, 42 | contractVersion :: Version 43 | } 44 | deriving (Read, Show, Eq, Ord, Generic) 45 | 46 | -- | Contracts may be created either in the transaction body or in the body 47 | -- of a previous contract called by the transaction. 48 | data TransactionPart = Body | InputCall Int 49 | deriving (Read, Show, Eq, Ord, Generic) 50 | 51 | -- | A contract ID can be specified without a version, meaning that whatever 52 | -- the current version of the contract is should be used. 53 | data Version = Current | Version VersionID 54 | deriving (Read, Show, Eq, Ord, Generic) 55 | -- 56 | -- | Transactions can have many named signatories, which are available in 57 | -- all contract code. It has to be a newtype so that we don't need to 58 | -- import more modules in the interpreter to get 'Map'. 59 | newtype Signers = Signers { getSigners :: Map String PublicKey } 60 | deriving (Serialize, NFData) 61 | 62 | -- | Contract calls may also declare local renaming of signatories, which 63 | -- this records in the structure @newName -> oldName@. 64 | newtype Renames = Renames { getRenames :: Map String String } 65 | deriving (Serialize, NFData) 66 | 67 | -- | For simplicity 68 | type TransactionID = Digest 69 | -- | For simplicity 70 | type EntryID = Digest 71 | -- | Previously a newtype, no longer necessary. 72 | type VersionID = Digest 73 | 74 | -- | This identifier locates an escrow. Escrow IDs are assigned when the 75 | -- escrow is first created and are guaranteed to be globally unique and 76 | -- immutable. Each escrow ID is valid only within a contract or other 77 | -- escrow that actually holds the escrow, which must have been created with 78 | -- a "name" type matching the phantom type parameter. Escrow IDs may only 79 | -- be constructed by the 'newEscrow' function; in contract calls, they can 80 | -- also be referenced by version (see "Versions"). However, they should 81 | -- appear type-correct in contract signatures to formally verify that the 82 | -- contract receives and returns a particular kind of opaque value, e.g. 83 | -- a currency. 84 | newtype EscrowID name = EscrowID { entID :: EntryID } 85 | deriving (NFData) 86 | 87 | -- | A wrapper for defining general instances of classes for types that 88 | -- can't use the generic ones, but are in some general sense a container 89 | -- for values that can. 90 | newtype Container a = Container { getContainer :: a } deriving (Serialize) 91 | 92 | -- Instances 93 | 94 | -- | - 95 | instance Serialize ContractID 96 | -- | - 97 | instance Digestible ContractID 98 | -- | - 99 | instance NFData ContractID 100 | 101 | -- | - 102 | instance Serialize TransactionPart 103 | -- | - 104 | instance NFData TransactionPart 105 | 106 | -- | - 107 | instance Serialize Version 108 | -- | - 109 | instance NFData Version 110 | 111 | -- | Useful for debugging 112 | instance Show (EscrowID name) where 113 | show = show . entID 114 | 115 | -- * Template Haskell 116 | 117 | makeLenses ''Signers 118 | makeLenses ''Renames 119 | makeLenses ''ContractID 120 | makeLenses ''TransactionPart 121 | makePrisms ''Version 122 | 123 | -- * Functions 124 | 125 | -- | The transaction ID of the "genesis transaction" 126 | nullID :: TransactionID 127 | nullID = nullDigest 128 | 129 | -- | Prints a contract ID as a "path" `txID/txPart/index/version`, with the 130 | -- two hex strings abbreviated. 131 | prettyContractID :: ContractID -> String 132 | prettyContractID ContractID{..} = intercalate "/" $ 133 | [ 134 | printShortHex parentTransaction, 135 | show transactionPart, 136 | show creationIndex, 137 | case contractVersion of 138 | Current -> "Current" 139 | Version vID -> "Version " ++ printShortHex vID 140 | ] 141 | 142 | -- | A semantic equality for versions; the 'Current' version always matches 143 | -- whatever is there. 144 | matchesVersion :: Version -> Version -> Bool 145 | matchesVersion (Version vID1) (Version vID2) = vID1 == vID2 146 | matchesVersion _ _ = True 147 | 148 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/Messages.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Blockchain.Fae.Internal.MEssages 3 | Description: Message types for Fae 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | The structure of blocks and transactions as they are transmitted, plus 10 | cryptography. 11 | -} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | module Blockchain.Fae.Internal.Messages where 14 | 15 | import Blockchain.Fae.Internal.Crypto 16 | import Blockchain.Fae.Internal.IDs 17 | import Blockchain.Fae.Internal.Transaction 18 | import Blockchain.Fae.Internal.TX 19 | 20 | import Common.Lens 21 | 22 | import Control.Monad 23 | 24 | import qualified Data.ByteString.Char8 as C8 25 | 26 | import qualified Data.Map as Map 27 | import Data.Map (Map) 28 | 29 | import GHC.Generics 30 | 31 | -- * Types 32 | 33 | -- | The transaction message as transmitted. This does not include the 34 | -- full module files, but only their "previews", containing sufficient 35 | -- information for the client to decide if the memory cost of requesting 36 | -- the module is acceptable, and to request it if so. 37 | data TXMessage a = 38 | TXMessage 39 | { 40 | salt :: a, -- ^ Needs to be the first field, for Faeth 41 | mainModulePreview :: ModulePreview, 42 | otherModulePreviews :: Map String ModulePreview, 43 | materialsCalls :: InputMaterials, 44 | inputCalls :: [Input], 45 | fallbackFunctions :: [String], 46 | signatures :: Map String (PublicKey, Maybe Signature) 47 | } 48 | deriving (Generic) 49 | 50 | -- | The digest uniquely identifies the module, and the size indicates how 51 | -- heavy it is. 52 | data ModulePreview = 53 | ModulePreview 54 | { 55 | moduleDigest :: Digest, 56 | moduleSize :: Integer 57 | } 58 | deriving (Generic) 59 | 60 | -- | The actual contents of a module file 61 | type Module = C8.ByteString 62 | -- | Named modules 63 | type ModuleMap = Map String Module 64 | 65 | {- Instances -} 66 | 67 | -- | - 68 | instance (Serialize a) => Serialize (TXMessage a) 69 | -- | - 70 | instance (Serialize a) => Digestible (TXMessage a) 71 | 72 | -- | - 73 | instance Serialize ModulePreview 74 | -- | - 75 | instance Digestible ModulePreview 76 | 77 | -- * Template Haskell 78 | 79 | makeLenses ''TXMessage 80 | makeLenses ''ModulePreview 81 | 82 | -- * Functions 83 | 84 | -- | Gets the "base" transaction message without validation 85 | unsignedTXMessage :: TXMessage a -> TXMessage a 86 | unsignedTXMessage = over _signatures $ fmap (_2 .~ Nothing) 87 | 88 | -- | Adds a single signature, overwriting one that's already there. This 89 | -- does not ensure that the new signature is /valid/, though; that is the 90 | -- job of 'unsignTXMessage'. 91 | signTXMessage :: 92 | (Serialize a) => String -> PrivateKey -> TXMessage a -> Maybe (TXMessage a) 93 | signTXMessage name privKey txm = do 94 | p <- Map.lookup name $ signatures txm 95 | let p' = p & _2 ?~ sig (sign utxm privKey) 96 | return (txm & _signatures . at name ?~ p') 97 | 98 | where utxm = unsignedTXMessage txm 99 | 100 | -- | Validates a message (all signatures present, correct, and the right 101 | -- identity) and returns the base message 102 | unsignTXMessage :: (Serialize a) => TXMessage a -> Maybe (TXMessage a) 103 | unsignTXMessage txm = do 104 | checked <- traverse (uncurry checkSignature) $ signatures txm 105 | guard $ and checked 106 | return utxm 107 | 108 | where 109 | checkSignature pubKey = fmap $ verify pubKey . Signed utxm 110 | utxm = unsignedTXMessage txm 111 | 112 | -- | The transaction ID is its hash. This has to be the hash of the 113 | -- 'TXMessage' structure, rather than 'TX', because only the former 114 | -- contains complete information identifying the transaction uniquely. The 115 | -- hash is taken of the unsigned message, without validating the 116 | -- signatures. 117 | getTXID :: (Serialize a) => TXMessage a -> TransactionID 118 | getTXID = digest . unsignedTXMessage 119 | 120 | -- | Extracts the portion of the transaction that is useful for 121 | -- constructing the transaction call. Modules must be placed in the 122 | -- appropriate directory structure by the client. 123 | txMessageToTX :: (Serialize a) => Bool -> TXMessage a -> Bool -> Maybe TX 124 | txMessageToTX isReward txm unchecked = do 125 | TXMessage{..} <- unsign txm 126 | let 127 | txID = getTXID txm 128 | pubKeys = Signers $ fst <$> signatures 129 | fallback = fallbackFunctions 130 | txMaterials = materialsCalls 131 | inputs = inputCalls 132 | return TX{..} 133 | where unsign | unchecked = Just . unsignedTXMessage 134 | | otherwise = unsignTXMessage 135 | 136 | -- | Checks the hashes of the received module files against the ones 137 | -- promised in the transaction. This does /not/ validate the modules as 138 | -- Haskell source code. 139 | validateModules :: Module -> ModuleMap -> TXMessage a -> Bool 140 | validateModules mainModule otherModules TXMessage{..} = 141 | validateModule mainModulePreview mainModule && 142 | Map.keys otherModules == Map.keys otherModulePreviews && 143 | and (Map.intersectionWith validateModule otherModulePreviews otherModules) 144 | where 145 | validateModule ModulePreview{..} file = digest file == moduleDigest 146 | 147 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/Monitors.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Blockchain.Fae.Internal.Monitors 3 | Description: Resource monitoring tools (timeouts, etc.) 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This module provides tools to limit the resource usage of transactions and contract calls. Currently it just has a timeout function (and a particularly inefficient one at that, due to a limitation of GHC's runtime) but it could have, in addition, at least a memory limit as well. 10 | -} 11 | module Blockchain.Fae.Internal.Monitors where 12 | 13 | import Blockchain.Fae.Internal.Exceptions 14 | 15 | import Control.Concurrent 16 | import Control.DeepSeq 17 | 18 | import Control.Monad 19 | import Control.Monad.IO.Class 20 | import Control.Monad.Reader 21 | 22 | import Data.Maybe 23 | 24 | import System.Posix.Process 25 | import System.Posix.Signals 26 | 27 | import System.Exit 28 | import System.Timeout 29 | 30 | -- | An 'evaluate'-like function, e.g. a timeout or memory usage limit. 31 | data EvalF m = EvalF { getEvalF :: forall a. (NFData a) => a -> m a } 32 | -- | A global static 'EvalT'. 33 | type EvalT m = ReaderT (EvalF m) m 34 | 35 | -- | Apply a global function directly to an argument. 36 | evalArg :: (Monad m, NFData a) => a -> EvalT m a 37 | evalArg x = asks getEvalF >>= lift . ($ x) 38 | 39 | -- | Initialize 'EvalT' with a timeout 'EvalF'. 40 | evalTimed :: (MonadIO m) => Int -> EvalT m a -> m a 41 | evalTimed evalTimeout = flip runReaderT (EvalF $ timed evalTimeout) where 42 | 43 | -- | Basic impure timeout function. 44 | timed :: (MonadIO m, NFData a) => Int -> a -> m a 45 | timed evalTimeout = liftIO . fmap (fromMaybe err) . posixTimeout evalTimeout 46 | where err = throw $ Timeout evalTimeout 47 | 48 | -- | GHC has an actual /bug/ in its concurrency that non-allocating 49 | -- evaluations can never be pre-empted, so the stock @timeout@ function 50 | -- from @System.Timeout@ does not work on completely general values. This 51 | -- implementation is much, much slower because it forks a process rather 52 | -- than sparking a thread, but it does not have that particular 53 | -- limitation. 54 | -- 55 | -- The timeout is in half-milliseconds because the fork takes that order of 56 | -- magnitude of time, and in fact, it is incurred /twice/ because (in order 57 | -- to avoid having to communicate the value between the processes) the 58 | -- evaluation happens twice: once to check that it terminates, and once to 59 | -- get the actual value. 60 | posixTimeout :: (NFData a) => Int -> a -> IO (Maybe a) 61 | posixTimeout mSec x = do 62 | pID <- forkProcess $ handleAll (const exitFailure) $ void $ evaluate $ force x 63 | stMM <- timeout (mSec * halfMillisecond) $ getProcessStatus True True pID 64 | case stMM of 65 | Nothing -> do 66 | signalProcess killProcess pID 67 | return Nothing 68 | _ -> return $ Just x 69 | where halfMillisecond = 500 70 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/Reward.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Blockchain.Fae.Internal.Reward 3 | Description: Fae rewards 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | Fae does not have an associated currency, but it does provide a very 10 | minimal valuable to certain transactions that can be exchanged for currency 11 | or other derived values. 12 | -} 13 | module Blockchain.Fae.Internal.Reward where 14 | 15 | import Blockchain.Fae.Internal.Contract 16 | import Blockchain.Fae.Internal.GenericInstances 17 | import Blockchain.Fae.Internal.IDs 18 | 19 | import GHC.Generics 20 | 21 | -- * Types 22 | 23 | -- | The system-managed reward value. Not constructible directly. 24 | data RewardValue = Value deriving (Generic) 25 | -- | Private token controlling a 'RewardEscrowID'. 26 | data RewardToken = Token deriving (Generic) 27 | -- | The identifier for reward escrows 28 | data RewardName = RewardName deriving (Generic) 29 | -- | An opaque type containing the escrow ID of a reward token provided by 30 | -- the system. 31 | newtype Reward = Reward (EscrowID RewardName) deriving (Generic) 32 | 33 | -- | The argument and value types are both private types (not exported by 34 | -- "Blockchain.Fae"), so that a reward contract cannot be called directly 35 | -- by users; instead, they must use the interface, which consists only of 36 | -- 'claimReward', which only destroys a reward and does not create them. 37 | -- So the supply of 'Reward's is limited to those transactions that are 38 | -- marked to receive them as special input values. 39 | instance ContractName RewardName where 40 | type ArgType RewardName = RewardToken 41 | type ValType RewardName = RewardValue 42 | theContract RewardName = \Token -> spend Value 43 | 44 | -- | This function destroys a reward token, validating it in the process. 45 | -- As the only interface to the `Reward` type, this /must/ be used by any 46 | -- contract that intends to accept rewards as payment. 47 | claimReward :: (MonadTX m) => Reward -> m () 48 | claimReward (Reward eID) = do 49 | Value <- useEscrow [] eID Token 50 | return () 51 | 52 | -------------------------------------------------------------------------------- /src/Blockchain/Fae/Internal/Suspend.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Blockchain.Fae.Internal.Suspend 3 | Description: Suspend and resume for contracts 4 | Copyright: (c) Ryan Reich, 2017-2018 5 | License: MIT 6 | Maintainer: ryan.reich@gmail.com 7 | Stability: experimental 8 | 9 | This module implements functions that can be suspended and resumed, using 10 | the continuation monad. 11 | -} 12 | module Blockchain.Fae.Internal.Suspend where 13 | 14 | import Control.DeepSeq 15 | 16 | import Control.Monad 17 | import Control.Monad.Trans 18 | import Control.Monad.Trans.Cont 19 | import Control.Monad.Trans.Writer 20 | 21 | import Data.Monoid 22 | 23 | -- * Types 24 | 25 | -- | A monad transformer suitable for creating a suspendable function. 26 | newtype SuspendT a b m c = SuspendT { getSuspendT :: ContT b (NextT a b m) c } 27 | deriving (Functor, Applicative, Monad) 28 | -- | The precursor to a 'SuspendStepF', the form in which a suspendable 29 | -- function will actually be written. 30 | type SuspendPreF a b m = a -> SuspendT a b m b 31 | 32 | -- | The monad that stores the next suspension 33 | type NextT a b m = WriterT (Last (SuspendF a b m)) m 34 | -- | An abstract suspendable function 35 | newtype SuspendF a b m = SuspendF { getSuspendF :: a -> NextT a b m b } 36 | 37 | -- | A concrete suspendable function 38 | newtype SuspendStepF a b m = 39 | SuspendStepF { getSuspendStepF :: a -> m (b, Maybe (SuspendStepF a b m)) } 40 | deriving (NFData) 41 | 42 | {- Instances -} 43 | 44 | -- | - 45 | instance MonadTrans (SuspendT a b) where 46 | lift = SuspendT . lift . lift 47 | 48 | -- * Actions 49 | 50 | -- | This allows you to mark the boundaries of the successive runs of the 51 | -- function. The current call will end when it reaches a 'suspend', 52 | -- returning the argument to 'suspend', and evaluating to the argument of 53 | -- the next call. 54 | suspend :: (Monad m) => b -> SuspendT a b m a 55 | suspend y = SuspendT . ContT $ \cont -> do 56 | tell . Last . Just . SuspendF $ cont 57 | return y 58 | 59 | -- | This allows you to mark the end of the computation, returning a value 60 | -- immediately and ignoring subsequent code. 61 | terminate :: (Monad m) => b -> SuspendT a b m b 62 | terminate y = SuspendT . ContT . const . pass $ return (y, const $ Last Nothing) 63 | 64 | -- * Meta-operations 65 | 66 | -- | Transforms a monadically-defined suspendable function into a concrete 67 | -- one. 68 | startSuspendF :: (Monad m) => SuspendPreF a b m -> SuspendStepF a b m 69 | startSuspendF f = stepSuspendF . SuspendF $ evalContT . getSuspendT . f 70 | 71 | -- | Utility function: makes the abstract concrete. 72 | stepSuspendF :: (Functor m) => SuspendF a b m -> SuspendStepF a b m 73 | stepSuspendF f = SuspendStepF $ 74 | fmap (fmap (fmap stepSuspendF . getLast)) . runWriterT . getSuspendF f 75 | 76 | -- | Alters the parameters of the suspended function. 77 | alterSuspendStepF :: 78 | (Monad m, Monad m') => 79 | (a' -> m' a) -> (b' -> m' b'') -> 80 | (m (b, Maybe (SuspendStepF a b m)) -> m' (b', Maybe (SuspendStepF a b m))) -> 81 | SuspendStepF a b m -> SuspendStepF a' b'' m' 82 | alterSuspendStepF fArg fVal fMon g = 83 | SuspendStepF $ fArg >=> fMon . getSuspendStepF g >=> fVal' 84 | where fVal' (y, sfM) = (, alterSuspendStepF fArg fVal fMon <$> sfM) <$> fVal y 85 | 86 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-11.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - Cabal-2.0.1.0 44 | - unix-compat-0.5.1 45 | 46 | ghc-options: {} 47 | 48 | # Override default flag values for local packages and extra-deps 49 | flags: {} 50 | 51 | # Extra package databases containing global packages 52 | extra-package-dbs: [] 53 | 54 | # Control whether we use the GHC we find on the path 55 | # system-ghc: true 56 | # 57 | # Require a specific version of stack, using version ranges 58 | # require-stack-version: -any # Default 59 | # require-stack-version: ">=1.1" 60 | # 61 | # Override the architecture used by stack, especially useful on Windows 62 | # arch: i386 63 | # arch: x86_64 64 | # 65 | # Extra directories used by stack for building 66 | # extra-include-dirs: [/path/to/dir] 67 | # extra-lib-dirs: [/path/to/dir] 68 | # 69 | # Allow a newer minor version of GHC than the snapshot specifies 70 | # compiler-check: newer-minor 71 | -------------------------------------------------------------------------------- /tools/CollectPackage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | import Common.Lens hiding ((<.>)) 3 | 4 | import Control.Monad 5 | import Control.Monad.Reader 6 | import Control.Monad.Zip 7 | 8 | import Data.Bits 9 | import Data.Bool 10 | import Data.Char 11 | import Data.Function 12 | import Data.List 13 | import qualified Data.Map as Map 14 | import Data.Maybe 15 | import Data.Monoid 16 | 17 | import Distribution.InstalledPackageInfo 18 | import Distribution.Simple.Compiler 19 | import Distribution.Simple.Configure 20 | import Distribution.Simple.PackageIndex 21 | import Distribution.Text 22 | import Distribution.Types.ComponentName 23 | import Distribution.Types.LocalBuildInfo 24 | import Distribution.Types.ComponentLocalBuildInfo 25 | import Distribution.Types.UnitId 26 | 27 | import GHC.PackageDb hiding (InstalledPackageInfo) 28 | import PackageInfo 29 | 30 | import System.Directory 31 | import System.Environment 32 | import System.FilePath 33 | import System.Posix.Files 34 | 35 | import Text.Read 36 | 37 | data Info = 38 | Info 39 | { 40 | newRoot :: FilePath, 41 | ghcVersion :: String 42 | } 43 | 44 | type InfoM = ReaderT Info IO 45 | 46 | makeLenses ''InstalledPackageInfo 47 | makeLenses ''Info 48 | 49 | main :: IO () 50 | main = do 51 | newRoot <- getCurrentDirectory 52 | projectRoot <- getProjectRoot newRoot 53 | createDirectoryIfMissing True (libSubdir newRoot) 54 | createDirectoryIfMissing True (libSubdir newRoot) 55 | createDirectoryIfMissing True (packageDBSubdir newRoot) 56 | (ghcVersion, packageInfo, packageIndex) <- getBuildInfo projectRoot 57 | let packageInfos = packageInfo : allPackages packageIndex 58 | flip runReaderT Info{..} $ do 59 | forM_ packageInfos copyPackage 60 | createPackageDB packageInfos 61 | 62 | createPackageDB :: [InstalledPackageInfo] -> InfoM () 63 | createPackageDB packageInfos = do 64 | Info{..} <- ask 65 | let newPackageInfos = minimalize . moveRoot <$> packageInfos 66 | ghcPackageInfos = convertPackageInfoToCacheFormat <$> newPackageInfos 67 | cacheFilename = packageDBSubdir newRoot "package.cache" 68 | liftIO $ do 69 | lock <- lockPackageDb cacheFilename 70 | writePackageDb cacheFilename ghcPackageInfos newPackageInfos 71 | unlockPackageDb lock 72 | 73 | copyPackage :: InstalledPackageInfo -> InfoM () 74 | copyPackage packageInfo@InstalledPackageInfo{installedUnitId} = do 75 | Info{..} <- ask 76 | copyLibraryDirs packageInfo 77 | copyDynLibs packageInfo 78 | 79 | copyLibraryDirs :: InstalledPackageInfo -> InfoM () 80 | copyLibraryDirs InstalledPackageInfo{libraryDirs, importDirs} = do 81 | Info{..} <- ask 82 | liftIO $ forM_ (libraryDirs `union` importDirs) $ \libDir -> do 83 | let newDir = replaceDirectory libDir (libSubdir newRoot) 84 | alreadyCopied <- doesDirectoryExist newDir 85 | let cond file = takeExtension file == ".dyn_hi" 86 | unless alreadyCopied $ fastCopyDir cond newDir libDir 87 | 88 | copyDynLibs :: InstalledPackageInfo -> InfoM () 89 | copyDynLibs InstalledPackageInfo{libraryDirs,libraryDynDirs,hsLibraries} = do 90 | Info{..} <- ask 91 | liftIO $ forM_ nonCLibraries $ \libName -> do 92 | let prefixedLib = "lib" ++ libName 93 | libBaseName = addSO $ prefixedLib ++ "-" ++ ghcVersion 94 | altLibBaseName = addSO prefixedLib 95 | oldLibPathM <- altFileExistsInPath libBaseName altLibBaseName & 96 | sequencePath (libraryDirs `union` libraryDynDirs) 97 | case oldLibPathM of 98 | Nothing -> error $ "Dynamic library not found for: " ++ libName 99 | Just oldLibPath -> do 100 | let newLibPath = replaceDirectory oldLibPath (libSubdir newRoot) 101 | alreadyCopied <- doesFileExist newLibPath 102 | unless alreadyCopied $ createLink oldLibPath newLibPath 103 | where 104 | altFileExistsInPath fileName1 fileName2 path = 105 | getFirst <$> liftM2 ((<>) `on` First) 106 | (maybeFileExists $ path fileName1) 107 | (maybeFileExists $ path fileName2) 108 | maybeFileExists path = 109 | bool Nothing (Just path) <$> doesFileExist path 110 | nonCLibraries = nub $ removeC <$> hsLibraries 111 | removeC x = fromMaybe x (stripPrefix "C" x) 112 | 113 | fastCopyDir :: (FilePath -> Bool) -> FilePath -> FilePath -> IO () 114 | fastCopyDir cond newDir oldDir = do 115 | createDirectory newDir 116 | allFiles <- listDirectory oldDir 117 | forM_ allFiles $ \file -> do 118 | let oldFilePath = oldDir file 119 | newFilePath = newDir file 120 | isDirectory <- doesDirectoryExist oldFilePath 121 | if isDirectory 122 | then fastCopyDir cond newFilePath oldFilePath 123 | else when (cond file) $ createLink oldFilePath newFilePath 124 | 125 | getBuildInfo :: 126 | FilePath -> IO (String, InstalledPackageInfo, InstalledPackageIndex) 127 | getBuildInfo projectRoot = do 128 | distDir <- getEnv "HASKELL_DIST_DIR" 129 | lbi@LocalBuildInfo{compiler, installedPkgs} <- 130 | getPersistBuildConfig (projectRoot distDir) 131 | packageInfo <- getLibComponent lbi 132 | let CompilerId flavor version = compilerId compiler 133 | ghcVersion = display flavor ++ display version 134 | return (ghcVersion, packageInfo, installedPkgs) 135 | 136 | getLibComponent :: LocalBuildInfo -> IO InstalledPackageInfo 137 | getLibComponent LocalBuildInfo{componentNameMap, withPackageDB} = do 138 | case Map.lookup CLibName componentNameMap of 139 | Nothing -> error $ "Local project does not define a library" 140 | Just [cLocalBuildInfo] -> do 141 | let unitID = componentUnitId cLocalBuildInfo 142 | pkgdb = pkgdbPath $ registrationPackageDB withPackageDB 143 | confFilePath = pkgdb display unitID <.> "conf" 144 | parseResult <- parseInstalledPackageInfo <$> readFile confFilePath 145 | case parseResult of 146 | ParseFailed err -> error $ 147 | "Couldn't parse package install configuration file: " ++ confFilePath 148 | ParseOk _ packageInfo -> return packageInfo 149 | _ -> error $ "Local project (somehow) defines multiple libraries" 150 | 151 | where 152 | pkgdbPath (SpecificPackageDB path) = path 153 | pkgdbPath _ = error "Registration db isn't the project's" 154 | 155 | getProjectRoot :: FilePath -> IO FilePath 156 | getProjectRoot [pathSeparator] = error "No stack project found" 157 | getProjectRoot dir = do 158 | atRoot <- doesFileExist $ dir "stack" <.> "yaml" 159 | if atRoot 160 | then return dir 161 | else getProjectRoot (takeDirectory dir) 162 | 163 | sequencePath :: (Monad m) => [FilePath] -> (FilePath -> m (Maybe a)) -> m (Maybe a) 164 | sequencePath paths f = go paths Nothing where 165 | go [] Nothing = return Nothing 166 | go _ (Just x) = return $ Just x 167 | go (path : rest) Nothing = f path >>= go rest 168 | 169 | moveRoot :: InstalledPackageInfo -> InstalledPackageInfo 170 | moveRoot pkgInfo = pkgInfo 171 | & _importDirs %~ map chroot 172 | & _libraryDirs %~ map chroot 173 | & _includeDirs %~ map chroot 174 | & _dataDir %~ chroot 175 | & _libraryDynDirs .~ [libDir] 176 | & _pkgRoot .~ Just libDir 177 | where 178 | chroot = flip replaceDirectory libDir 179 | libDir = libSubdir root 180 | root = [pathSeparator] 181 | 182 | minimalize :: InstalledPackageInfo -> InstalledPackageInfo 183 | minimalize pkgInfo = pkgInfo 184 | & _haddockInterfaces .~ [] 185 | & _haddockHTMLs .~ [] 186 | 187 | libSubdir :: FilePath -> FilePath 188 | libSubdir = ( "lib") 189 | 190 | packageDBSubdir :: FilePath -> FilePath 191 | packageDBSubdir = ( "ghc-pkgdb") . libSubdir 192 | 193 | addSO :: FilePath -> FilePath 194 | addSO = (<.> "so") 195 | -------------------------------------------------------------------------------- /tools/PackageInfo.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copied wholesale from 3 | - https://github.com/ghc/ghc/blob/master/utils/ghc-pkg/Main.hs#L1226-L1308 4 | -} 5 | module PackageInfo where 6 | 7 | import qualified Data.ByteString.Char8 as BS 8 | import qualified Data.Map as Map 9 | import Data.Maybe 10 | import qualified Data.Version as Version 11 | 12 | import Distribution.Backpack 13 | import Distribution.InstalledPackageInfo 14 | import qualified Distribution.ModuleName as ModuleName 15 | import Distribution.ModuleName (ModuleName) 16 | import Distribution.Package hiding (installedUnitId) 17 | import Distribution.Simple.Utils 18 | import Distribution.Text 19 | import Distribution.Types.UnqualComponentName 20 | import Distribution.Version 21 | 22 | import qualified GHC.PackageDb as GhcPkg 23 | import GHC.PackageDb (BinaryStringRep(..)) 24 | 25 | type PackageCacheFormat = GhcPkg.InstalledPackageInfo 26 | ComponentId 27 | PackageIdentifier 28 | PackageName 29 | UnitId 30 | OpenUnitId 31 | ModuleName 32 | OpenModule 33 | 34 | convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat 35 | convertPackageInfoToCacheFormat pkg = 36 | GhcPkg.InstalledPackageInfo { 37 | GhcPkg.unitId = installedUnitId pkg, 38 | GhcPkg.componentId = installedComponentId pkg, 39 | GhcPkg.instantiatedWith = instantiatedWith pkg, 40 | GhcPkg.sourcePackageId = sourcePackageId pkg, 41 | GhcPkg.packageName = packageName pkg, 42 | GhcPkg.packageVersion = Version.Version (versionNumbers (packageVersion pkg)) [], 43 | GhcPkg.sourceLibName = 44 | fmap (mkPackageName . unUnqualComponentName) (sourceLibName pkg), 45 | GhcPkg.depends = depends pkg, 46 | GhcPkg.abiDepends = map (\(AbiDependency k v) -> (k,unAbiHash v)) (abiDepends pkg), 47 | GhcPkg.abiHash = unAbiHash (abiHash pkg), 48 | GhcPkg.importDirs = importDirs pkg, 49 | GhcPkg.hsLibraries = hsLibraries pkg, 50 | GhcPkg.extraLibraries = extraLibraries pkg, 51 | GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg, 52 | GhcPkg.libraryDirs = libraryDirs pkg, 53 | GhcPkg.libraryDynDirs = libraryDynDirs pkg, 54 | GhcPkg.frameworks = frameworks pkg, 55 | GhcPkg.frameworkDirs = frameworkDirs pkg, 56 | GhcPkg.ldOptions = ldOptions pkg, 57 | GhcPkg.ccOptions = ccOptions pkg, 58 | GhcPkg.includes = includes pkg, 59 | GhcPkg.includeDirs = includeDirs pkg, 60 | GhcPkg.haddockInterfaces = haddockInterfaces pkg, 61 | GhcPkg.haddockHTMLs = haddockHTMLs pkg, 62 | GhcPkg.exposedModules = map convertExposed (exposedModules pkg), 63 | GhcPkg.hiddenModules = hiddenModules pkg, 64 | GhcPkg.indefinite = indefinite pkg, 65 | GhcPkg.exposed = exposed pkg, 66 | GhcPkg.trusted = trusted pkg 67 | } 68 | where 69 | convertExposed (ExposedModule n reexport) = (n, reexport) 70 | 71 | instance GhcPkg.BinaryStringRep ComponentId where 72 | fromStringRep = mkComponentId . fromStringRep 73 | toStringRep = toStringRep . display 74 | 75 | instance GhcPkg.BinaryStringRep PackageName where 76 | fromStringRep = mkPackageName . fromStringRep 77 | toStringRep = toStringRep . display 78 | 79 | instance GhcPkg.BinaryStringRep PackageIdentifier where 80 | fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier") 81 | . simpleParse . fromStringRep 82 | toStringRep = toStringRep . display 83 | 84 | instance GhcPkg.BinaryStringRep ModuleName where 85 | fromStringRep = ModuleName.fromString . fromStringRep 86 | toStringRep = toStringRep . display 87 | 88 | instance GhcPkg.BinaryStringRep String where 89 | fromStringRep = fromUTF8 . BS.unpack 90 | toStringRep = BS.pack . toUTF8 91 | 92 | instance GhcPkg.BinaryStringRep UnitId where 93 | fromStringRep = mkUnitId . fromStringRep 94 | toStringRep = toStringRep . display 95 | 96 | instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where 97 | fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name 98 | fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name 99 | toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name 100 | toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name 101 | fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts) 102 | fromDbUnitId (GhcPkg.DbInstalledUnitId uid) 103 | = DefiniteUnitId (unsafeMkDefUnitId uid) 104 | toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts) 105 | toDbUnitId (DefiniteUnitId def_uid) 106 | = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid) 107 | 108 | -------------------------------------------------------------------------------- /txs/.gitignore: -------------------------------------------------------------------------------- 1 | postTX.sh 2 | faeServer.sh 3 | -------------------------------------------------------------------------------- /txs/Acquaintance: -------------------------------------------------------------------------------- 1 | body = Acquaintance 2 | keys 3 | person1 = key1 4 | person2 = key2 5 | -------------------------------------------------------------------------------- /txs/Acquaintance.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | body :: FaeTX () 4 | body = do 5 | key1 <- signer "person1" 6 | key2 <- signer "person2" 7 | newContract $ C key1 key2 8 | 9 | data C = C PublicKey PublicKey deriving (Generic) 10 | 11 | instance ContractName C where 12 | type ArgType C = () 13 | type ValType C = (PublicKey, PublicKey) 14 | theContract (C key1 key2) = \() -> forever $ release (key1, key2) 15 | -------------------------------------------------------------------------------- /txs/CallCallLoopContract: -------------------------------------------------------------------------------- 1 | inputs 2 | InputOutput $callLoopTX $scID 0 = () 3 | -------------------------------------------------------------------------------- /txs/CallCallLoopContract.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction () () 2 | body = return 3 | -------------------------------------------------------------------------------- /txs/CallDuplicateInputs: -------------------------------------------------------------------------------- 1 | body = CallDuplicateInputs 2 | inputs 3 | $tx1ID/Body/0/Current = () 4 | $tx1ID/Body/0/Current = () 5 | -------------------------------------------------------------------------------- /txs/CallDuplicateInputs.hs: -------------------------------------------------------------------------------- 1 | body :: String -> String -> FaeTX (String, String) 2 | body x y = return (x,y) 3 | -------------------------------------------------------------------------------- /txs/CallDuplicateInputsOutputs: -------------------------------------------------------------------------------- 1 | body = CallDuplicateInputsOutputs 2 | inputs 3 | $tx2ID/InputCall 0/0/Current = () 4 | $tx2ID/InputCall 0/0/Current = () 5 | $tx2ID/InputCall 0/0/Current = () 6 | $tx2ID/InputCall 0/0/Current = () 7 | -------------------------------------------------------------------------------- /txs/CallDuplicateInputsOutputs.hs: -------------------------------------------------------------------------------- 1 | body :: String -> String -> String -> String -> FaeTX (String, String, String, String) 2 | body w x y z = return (w,x,y,z) 3 | -------------------------------------------------------------------------------- /txs/CallLoopContract: -------------------------------------------------------------------------------- 1 | inputs 2 | TransactionOutput $loopTX 0 = () 3 | TransactionOutput $loopTX 1 = () 4 | -------------------------------------------------------------------------------- /txs/CallLoopContract.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction ((), ()) () 2 | body _ = return () 3 | -------------------------------------------------------------------------------- /txs/CallParent: -------------------------------------------------------------------------------- 1 | body = CallParent 2 | inputs 3 | TransactionOutput $txID 0 = () 4 | parent = $txID 5 | -------------------------------------------------------------------------------- /txs/CallParent.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction String String 2 | body = return 3 | -------------------------------------------------------------------------------- /txs/Contract1TX1: -------------------------------------------------------------------------------- 1 | body = Contract1TX1 2 | -------------------------------------------------------------------------------- /txs/Contract1TX1.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = newContract [] c 3 | where 4 | c :: Contract String String 5 | c = spend 6 | 7 | -------------------------------------------------------------------------------- /txs/Contract1TX2: -------------------------------------------------------------------------------- 1 | body = Contract1TX2 2 | inputs 3 | TransactionOutput $tx1 0 = "Hello, world!" 4 | -------------------------------------------------------------------------------- /txs/Contract1TX2.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction String String 2 | body = return 3 | 4 | -------------------------------------------------------------------------------- /txs/DuplicateInputs: -------------------------------------------------------------------------------- 1 | body = DuplicateInputs 2 | -------------------------------------------------------------------------------- /txs/DuplicateInputs.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | body :: FaeTX () 4 | body = newContract C 5 | 6 | data C = C deriving (Generic) 7 | 8 | instance ContractName C where 9 | type ArgType C = () 10 | type ValType C = String 11 | theContract C = \() -> forever $ do 12 | newContract C1 13 | newContract C2 14 | release ("Created 2 outputs") 15 | 16 | data C1 = C1 deriving (Generic) 17 | 18 | instance ContractName C1 where 19 | type ArgType C1 = () 20 | type ValType C1 = String 21 | theContract C1 = \() -> forever $ release ("Output 0") 22 | 23 | data C2 = C2 deriving (Generic) 24 | 25 | instance ContractName C2 where 26 | type ArgType C2 = () 27 | type ValType C2 = String 28 | theContract C2 = \() -> spend ("Output 1" :: String) 29 | 30 | -------------------------------------------------------------------------------- /txs/Error: -------------------------------------------------------------------------------- 1 | body = Error 2 | -------------------------------------------------------------------------------- /txs/Error.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = newContract @() @() [] $ \_ -> error "error" 3 | -------------------------------------------------------------------------------- /txs/ErrorCall: -------------------------------------------------------------------------------- 1 | body = ErrorCall 2 | inputs 3 | TransactionOutput $tx 0 = () 4 | -------------------------------------------------------------------------------- /txs/ErrorCall.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction () () 2 | body _ = return () 3 | -------------------------------------------------------------------------------- /txs/Escrow1TX1: -------------------------------------------------------------------------------- 1 | body = Escrow1TX1 2 | -------------------------------------------------------------------------------- /txs/Escrow1TX1.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = newContract [] c 3 | where 4 | c :: Contract String String 5 | c s = do 6 | eID <- newEscrow [] $ \() -> spend s 7 | result <- useEscrow eID () 8 | spend result 9 | -------------------------------------------------------------------------------- /txs/Escrow1TX2: -------------------------------------------------------------------------------- 1 | body = Escrow1TX2 2 | inputs 3 | TransactionOutput $tx1 0 = "Hello, world!" 4 | -------------------------------------------------------------------------------- /txs/Escrow1TX2.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction String String 2 | body = return 3 | -------------------------------------------------------------------------------- /txs/Escrow2TX1: -------------------------------------------------------------------------------- 1 | body = Escrow2TX1 2 | -------------------------------------------------------------------------------- /txs/Escrow2TX1.hs: -------------------------------------------------------------------------------- 1 | inputs :: [(ContractID, String)] 2 | inputs = [] 3 | 4 | body :: Transaction Void () 5 | body _ = newContract [] c 6 | where 7 | c :: Contract String (EscrowID () String) 8 | c s = do 9 | eID <- newEscrow [] $ \() -> spend s 10 | spend eID 11 | 12 | -------------------------------------------------------------------------------- /txs/Escrow2TX2: -------------------------------------------------------------------------------- 1 | body = Escrow2TX2 2 | inputs 3 | TransactionOutput $tx1 0 = "Hello, world!" 4 | -------------------------------------------------------------------------------- /txs/Escrow2TX2.hs: -------------------------------------------------------------------------------- 1 | inputs :: [(ContractID, String)] 2 | inputs = [(TransactionOutput "4eb29f4262087e9a890524a5a381942276e2447702b8b9979a4c84202479b1d6" 0, "\"Hello, world!\"")] 3 | 4 | body :: Transaction (EscrowID () String) String 5 | body = flip useEscrow () 6 | -------------------------------------------------------------------------------- /txs/FaethAddSignature: -------------------------------------------------------------------------------- 1 | body = HelloWorldTX 2 | keys 3 | buyer = $buyer 4 | seller = ryan 5 | -------------------------------------------------------------------------------- /txs/FallbackTX1: -------------------------------------------------------------------------------- 1 | body = FallbackTX1 2 | fallback 3 | - fb 4 | -------------------------------------------------------------------------------- /txs/FallbackTX1.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | 3 | body :: FaeTX () 4 | body = error "TX error" 5 | 6 | fb :: FaeTX () 7 | fb = deposit ("Fallback" :: String) "self" 8 | -------------------------------------------------------------------------------- /txs/FallbackTX2: -------------------------------------------------------------------------------- 1 | body = FallbackTX2 2 | inputs 3 | $tx1/Body/0/Current = () 4 | -------------------------------------------------------------------------------- /txs/FallbackTX2.hs: -------------------------------------------------------------------------------- 1 | body :: String -> FaeTX String 2 | body = return 3 | -------------------------------------------------------------------------------- /txs/GetSecret: -------------------------------------------------------------------------------- 1 | body = GetSecret 2 | inputs 3 | $txID/Body/0/Current = () 4 | keys 5 | self = $key 6 | -------------------------------------------------------------------------------- /txs/GetSecret.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Transactions.TX$txID 2 | 3 | body :: Secret -> FaeTX Secret 4 | body = return 5 | -------------------------------------------------------------------------------- /txs/HelloWorldTX: -------------------------------------------------------------------------------- 1 | body = HelloWorldTX 2 | -------------------------------------------------------------------------------- /txs/HelloWorldTX.hs: -------------------------------------------------------------------------------- 1 | body :: FaeTX String 2 | body = return "Hello, World!" 3 | 4 | -------------------------------------------------------------------------------- /txs/Loop: -------------------------------------------------------------------------------- 1 | body = Loop 2 | -------------------------------------------------------------------------------- /txs/Loop.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | body :: FaeTX () 4 | body = forever $ return () 5 | -------------------------------------------------------------------------------- /txs/LoopContract: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ConsenSysMesh/Fae/3ff023f70fa403e9cef80045907e415ccd88d7e8/txs/LoopContract -------------------------------------------------------------------------------- /txs/LoopContract.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | body :: Transaction Void () 4 | body _ = do 5 | newContract [] $ \() -> forever @_ @_ @() (return ()) >> spend () 6 | newContract [] $ \() -> newContract [] (\() -> spend ()) >> spend () 7 | -------------------------------------------------------------------------------- /txs/Parent: -------------------------------------------------------------------------------- 1 | body = Parent 2 | -------------------------------------------------------------------------------- /txs/Parent.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = newContract ParentContract 3 | 4 | data ParentContract = ParentContract deriving (Generic) 5 | 6 | instance ContractName ParentContract where 7 | type ArgType ParentContract = () 8 | type ValType ParentContract = String 9 | theContract ParentContract = \() -> spend "Called" 10 | 11 | -------------------------------------------------------------------------------- /txs/RewardsTX: -------------------------------------------------------------------------------- 1 | body = RewardsTX 2 | reward = True 3 | -------------------------------------------------------------------------------- /txs/RewardsTX.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | import Blockchain.Fae.Currency 3 | 4 | body :: Transaction RewardEscrowID Integer 5 | body rID = do 6 | eID <- reward rID 7 | v <- value eID 8 | deposit eID "self" 9 | return $ toInteger v 10 | -------------------------------------------------------------------------------- /txs/Secret: -------------------------------------------------------------------------------- 1 | body = Secret 2 | keys 3 | self = $key 4 | -------------------------------------------------------------------------------- /txs/Secret.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | 3 | data Secret = Secret deriving (Generic, Show) 4 | 5 | body :: FaeTX () 6 | body = deposit Secret "self" 7 | -------------------------------------------------------------------------------- /txs/SeeAcquaintance: -------------------------------------------------------------------------------- 1 | body = SeeAcquaintance 2 | inputs 3 | $txID/Body/0/Current : () 4 | -------------------------------------------------------------------------------- /txs/SeeAcquaintance.hs: -------------------------------------------------------------------------------- 1 | body :: (PublicKey, PublicKey) -> FaeTX (PublicKey, PublicKey) 2 | body = return 3 | -------------------------------------------------------------------------------- /txs/StateTX: -------------------------------------------------------------------------------- 1 | body = StateTX 2 | 3 | -------------------------------------------------------------------------------- /txs/StateTX.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans.State 2 | 3 | body :: Transaction Void String 4 | body = usingState 0 $ \_ -> do 5 | n <- get 6 | return $ show n 7 | -------------------------------------------------------------------------------- /txs/TXError: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ConsenSysMesh/Fae/3ff023f70fa403e9cef80045907e415ccd88d7e8/txs/TXError -------------------------------------------------------------------------------- /txs/TXError.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = error "TXError" 3 | -------------------------------------------------------------------------------- /txs/TwoDeposits: -------------------------------------------------------------------------------- 1 | body = TwoDeposits 2 | keys 3 | me = $me 4 | you = $you 5 | -------------------------------------------------------------------------------- /txs/TwoDeposits.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | 3 | body :: Transaction Void () 4 | body _ = do 5 | deposit True "me" 6 | deposit False "you" 7 | -------------------------------------------------------------------------------- /txs/TwoDeposits2: -------------------------------------------------------------------------------- 1 | body = TwoDeposits2 2 | keys 3 | me = $me 4 | you = $you 5 | inputs 6 | TransactionOutput $txID 0 = () 7 | self = me 8 | 9 | TransactionOutput $txID 1 = () 10 | self = you 11 | -------------------------------------------------------------------------------- /txs/TwoDeposits2.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction (Bool, Bool) (Bool, Bool) 2 | body = return 3 | -------------------------------------------------------------------------------- /txs/TwoPartyTX1: -------------------------------------------------------------------------------- 1 | body = TwoPartyTX1 2 | keys 3 | partyA = key1 4 | partyB = key2 5 | -------------------------------------------------------------------------------- /txs/TwoPartyTX1.hs: -------------------------------------------------------------------------------- 1 | import Blockchain.Fae.Contracts 2 | 3 | body :: Transaction Void () 4 | body _ = twoPartySwap x y where 5 | x = "Hello from A!" :: String 6 | y = "Hello from B!" :: String 7 | -------------------------------------------------------------------------------- /txs/TwoPartyTX2-3: -------------------------------------------------------------------------------- 1 | body = TwoPartyTX2-3 2 | inputs 3 | TransactionOutput $tx1 0 = Just True 4 | keys 5 | self = $key 6 | -------------------------------------------------------------------------------- /txs/TwoPartyTX2-3.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = return () 3 | -------------------------------------------------------------------------------- /txs/TwoPartyTX4-5: -------------------------------------------------------------------------------- 1 | body = TwoPartyTX4-5 2 | inputs 3 | TransactionOutput $tx1 0 = Nothing 4 | keys 5 | self = $key 6 | -------------------------------------------------------------------------------- /txs/TwoPartyTX4-5.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction (Maybe (Either (Versioned String) (Versioned String))) String 2 | body (Just (Left (Versioned s))) = return s 3 | body (Just (Right (Versioned s))) = return s 4 | body _ = return "" 5 | -------------------------------------------------------------------------------- /txs/VersionsTX1: -------------------------------------------------------------------------------- 1 | body = VersionsTX1 2 | -------------------------------------------------------------------------------- /txs/VersionsTX1.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction Void () 2 | body _ = do 3 | newContract VersionC1 4 | newContract VersionC2 5 | 6 | data VersionC1 = VersionC1 deriving (Generic) 7 | data VersionC2 = VersionC2 deriving (Generic) 8 | 9 | instance ContractName VersionC1 where 10 | type ArgType VersionC1 = () 11 | type ValType VersionC1 = Versioned String 12 | theContract VersionC1 = \() -> spend $ Versioned ("Hello, world!" :: String) 13 | 14 | instance ContractName VersionC2 where 15 | type ArgType VersionC2 = Versioned String 16 | type ValType VersionC2 = String 17 | theContract VersionC2 = spend . getVersioned 18 | 19 | -------------------------------------------------------------------------------- /txs/VersionsTX2: -------------------------------------------------------------------------------- 1 | body = VersionsTX2 2 | inputs 3 | TransactionOutput $tx1 0 :# 0 = () 4 | TransactionOutput $tx1 1 = $txOut0sID ::: $version 5 | -------------------------------------------------------------------------------- /txs/VersionsTX2.hs: -------------------------------------------------------------------------------- 1 | body :: Transaction (Versioned String, String) String 2 | body = return . snd 3 | --------------------------------------------------------------------------------