initial commit

.gitignore

@@ -0,0 +1,23 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for prototype-forwarder-contract
+
+## Unreleased changes

LICENSE

@@ -0,0 +1,7 @@
+Copyright 2019 Michael J. Klein
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

README.md

@@ -0,0 +1 @@
+# prototype-forwarder-contract

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Main where
+
+-- import Lib
+import Control.Monad
+
+-- import System.IO
+
+-- main :: IO ()
+main = return ()

package.yaml

@@ -0,0 +1,57 @@
+name:                prototype-forwarder-contract
+version:             0.1.0.0
+github:              "githubuser/prototype-forwarder-contract"
+license:             MIT
+author:              "Michael J. Klein"
+maintainer:          "[email protected]"
+copyright:           "2019 Michael J. Klein"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/tqtezos/prototype-forwarder-contract#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- morley
+# - morley-prelude
+- named
+- singletons
+- text
+- constraints
+- lorentz-contracts
+
+library:
+  source-dirs: src
+
+executables:
+  prototype-forwarder-contract-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - prototype-forwarder-contract
+    - morley
+    # - morley-prelude
+
+tests:
+  prototype-forwarder-contract-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - prototype-forwarder-contract

prototype-forwarder-contract.cabal

@@ -0,0 +1,80 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.1.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 076f5d1024a4f9f907713b66affffeaa7c8af97d60bcc337ac47fb6c62fbaca4
+
+name:           prototype-forwarder-contract
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/tqtezos/prototype-forwarder-contract#readme>
+homepage:       https://github.com/githubuser/prototype-forwarder-contract#readme
+bug-reports:    https://github.com/githubuser/prototype-forwarder-contract/issues
+author:         Michael J. Klein
+maintainer:     [email protected]
+copyright:      2019 Michael J. Klein
+license:        MIT
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/githubuser/prototype-forwarder-contract
+
+library
+  exposed-modules:
+      Lorentz.Contracts.Forwarder
+  other-modules:
+      Paths_prototype_forwarder_contract
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.7 && <5
+    , constraints
+    , lorentz-contracts
+    , morley
+    , named
+    , singletons
+    , text
+  default-language: Haskell2010
+
+executable prototype-forwarder-contract-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_prototype_forwarder_contract
+  hs-source-dirs:
+      app
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , constraints
+    , lorentz-contracts
+    , morley
+    , named
+    , prototype-forwarder-contract
+    , singletons
+    , text
+  default-language: Haskell2010
+
+test-suite prototype-forwarder-contract-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Paths_prototype_forwarder_contract
+  hs-source-dirs:
+      test
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , constraints
+    , lorentz-contracts
+    , morley
+    , named
+    , prototype-forwarder-contract
+    , singletons
+    , text
+  default-language: Haskell2010

src/Lorentz/Contracts/Forwarder.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE OverloadedLabels #-}
+
+{-# OPTIONS -Wall -Wno-unused-do-bind -Wno-orphans #-}
+
+module Lorentz.Contracts.Forwarder where
+
+import Lorentz
+import qualified Lorentz.Contracts.ManagedLedger.Athens as Athens
+import qualified Lorentz.Contracts.ManagedLedger.Types as Athens
+
+import Prelude (Show(..), Enum(..))
+
+deriving instance Show Athens.Parameter
+deriving instance (Show a, Show r) => Show (View a r)
+deriving instance Show a => Show (ContractAddr a)
+
+-- | We need the addresses of:
+-- - The sub-token contract, assumed to accept `Athens.Parameter`
+-- - The Tezos Wallet to process refunds (assuming this contract is authorized to call it)
+-- - The central wallet to transfer sub-tokens to
+data Storage = Storage
+  { subTokenContract :: ContractAddr Athens.Parameter
+  , tezosWallet :: ContractAddr RefundParameters
+  , centralWallet :: Address
+  }
+  deriving stock Eq
+  deriving stock Show
+  deriving stock Generic
+  deriving anyclass IsoValue
+
+-- | What's required to refund mutez from the Tezos Wallet
+type RefundParameters = ("amount" :! Mutez, "to" :! Address)
+
+-- | The number of sub-tokens to transfer
+type Parameter = Natural
+
+-- | `coerce_` to `Athens.TransferParams`
+toTransferParams :: (Address & Address & Natural & s) :-> (Athens.TransferParams & s)
+toTransferParams = do
+  dip pair
+  pair
+  coerce_ @(Address, (Address, Natural)) @Athens.TransferParams
+
+-- | Run `Athens.TransferParams` with a @`ContractAddr` `Athens.Parameter`@,
+-- from `Address`, to `Address`, and number of sub-tokens
+runTransferParams :: (ContractAddr Athens.Parameter & Address & Address & Natural & s) :-> (Operation & s)
+runTransferParams = do
+  dip toTransferParams
+  swap
+  dip (push (toEnum 0 :: Mutez))
+  wrap_ @Athens.Parameter #cTransfer
+  transferTokens
+
+-- | Run `Athens.TransferParams` on the given `Parameter` and `Storage`, where
+-- from is `sender` and to is `centralWallet`
+runStorageTransferParams :: (Parameter & Storage & s) :-> (Operation & Storage & s)
+runStorageTransferParams = do
+  swap
+  getField #subTokenContract
+  dip (getField #centralWallet >> dip swap >> sender)
+  runTransferParams
+
+-- | Derive `RefundParameters` and transfer arguments from
+-- the number of `Mutez` to refund and `Storage`
+toRefundParameters :: (Mutez & Storage & s) :-> (RefundParameters & Mutez & ContractAddr RefundParameters & Storage & s)
+toRefundParameters = do
+  dip sender
+  pair
+  coerce_ @(Mutez, Address) @RefundParameters
+  dip (do
+    push (toEnum 0 :: Mutez)
+    dip (getField #tezosWallet)
+      )
+
+-- | Process a refund, given the refund amount in `Mutez` and `Storage`
+processRefund :: (Mutez & Storage & s) :-> (Operation & Storage & s)
+processRefund = do
+  toRefundParameters
+  transferTokens
+
+-- | Given a method to calculate the number of `Mutez` to refund from the number
+-- of sub-tokens transferred, produce a forwarder contract.
+forwarderContract :: (forall s. (Natural & s) :-> (Mutez & s)) -> Contract Parameter Storage
+forwarderContract calculateGasCost = do
+  unpair
+  dup
+  dip runStorageTransferParams
+  swap
+  dip (do
+    calculateGasCost
+    processRefund
+    dip nil
+    cons
+      )
+  cons
+  pair
+

stack.yaml

@@ -0,0 +1,34 @@
+resolver: lts-13.22
+
+packages:
+- .
+# - prelude
+# - lorentz-contracts
+# - indigo
+
+extra-deps:
+- aeson-options-0.1.0
+- base58-bytestring-0.1.0
+- hex-text-0.1.0.0
+- show-type-0.1.1
+# - qm-interpolated-string-0.3.0.0
+
+- git:
+    https://gitlab.com/morley-framework/morley.git
+    # ^ CI cannot use ssh, so we use http clone here
+  commit:
+    0f5d400a5d66b2b84b18b2d9dee72bf3eb48db58  # master
+  subdirs:
+    - .
+    - indigo
+    - lorentz-contracts
+    - prelude
+# - git:
+#     [email protected]:tqtezos/morley-dstoken.git
+#   commit:
+#     c4ac0a80d2a6bf97ee88600cd575f63af0e26676 # master
+#   subdirs:
+#     - .
+
+nix:
+  shell-file: shell.nix

test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"