commit 5d54d6e5acd0cf4364d7ee553f5b345668082a1d Author: Adriaan Leijnse Date: Fri Dec 16 00:00:00 2022 +0000 Initial commit (wip) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6178278 --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +.attr-cache +.cabal-sandbox +*.hi +*.o +cabal.project.local +cabal.sandbox.config +ctags +dist-newstyle/ +dist/ +ghcid-output.txt +profile/ +result +result-* +tags +TAGS +static.out +/.env diff --git a/.obelisk/impl/default.nix b/.obelisk/impl/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/.obelisk/impl/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/.obelisk/impl/github.json b/.obelisk/impl/github.json new file mode 100644 index 0000000..2842353 --- /dev/null +++ b/.obelisk/impl/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "obelisk", + "branch": "develop", + "private": false, + "rev": "56f2ea5ec06d59e08e6111c374dd0142200860ee", + "sha256": "1x07av9ayiaj3b3qknk3rd7k6gv19s27a4iz0wmi75xdg788r6x0" +} diff --git a/.obelisk/impl/thunk.nix b/.obelisk/impl/thunk.nix new file mode 100644 index 0000000..20f2d28 --- /dev/null +++ b/.obelisk/impl/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..85e6ff1 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# WIP diff --git a/backend/backend.cabal b/backend/backend.cabal new file mode 100644 index 0000000..15d0f4b --- /dev/null +++ b/backend/backend.cabal @@ -0,0 +1,74 @@ +name: backend +version: 0.1 +cabal-version: >= 1.10 +build-type: Simple + +library + hs-source-dirs: src + if impl(ghcjs) + buildable: False + build-depends: base + , common + , frontend + , obelisk-backend + , obelisk-route + , process + , async + , which + , monad-logger + , logging-effect + , prettyprinter + , string-interpolate + , containers + , text + , witherable + , snap-core + , websockets-snap + , websockets + , some + , directory + , reflex-gadt-api + , aeson + , bytestring + , base64-bytestring + , case-insensitive + , lens + , uuid + , http-client + , http-conduit + , temporary + , stm + , monad-loops + , mtl + , transformers + , time + , time-compat + , transformers + , obelisk-executable-config-lookup + + default-extensions: + OverloadedStrings + LambdaCase + GADTs + ScopedTypeVariables + OverloadedStrings + FlexibleContexts + QuasiQuotes + DeriveGeneric + + exposed-modules: + Backend + + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits + +executable backend + main-is: main.hs + hs-source-dirs: src-bin + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -threaded -fno-show-valid-hole-fits + if impl(ghcjs) + buildable: False + build-depends: base + , backend + , common + , frontend + , obelisk-backend diff --git a/backend/src-bin/main.hs b/backend/src-bin/main.hs new file mode 100644 index 0000000..00f1994 --- /dev/null +++ b/backend/src-bin/main.hs @@ -0,0 +1,6 @@ +import Backend +import Frontend +import Obelisk.Backend + +main :: IO () +main = runBackend backend frontend diff --git a/backend/src/Backend.hs b/backend/src/Backend.hs new file mode 100644 index 0000000..c2f43a1 --- /dev/null +++ b/backend/src/Backend.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Backend + +(backend) + +where + +import Obelisk.Backend + +backend :: Backend BackendRoute FrontendRoute +backend = Backend + { _backend_run = \serve -> do + pure () + , _backend_routeEncoder = fullRouteEncoder + } diff --git a/backend/static b/backend/static new file mode 120000 index 0000000..4dab164 --- /dev/null +++ b/backend/static @@ -0,0 +1 @@ +../static \ No newline at end of file diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..fe0438b --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +optional-packages: + * +write-ghc-environment-files: never diff --git a/common/common.cabal b/common/common.cabal new file mode 100644 index 0000000..c0a3ef4 --- /dev/null +++ b/common/common.cabal @@ -0,0 +1,39 @@ +name: common +version: 0.1 +cabal-version: >= 1.10 +build-type: Simple + +library + hs-source-dirs: src + build-depends: base + , obelisk-route + , mtl + , text + , reflex-gadt-api + , aeson + , aeson-gadt-th + , constraints-extras + , containers + , time + , lens + + default-extensions: + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + LambdaCase + MultiParamTypeClasses + OverloadedStrings + QuantifiedConstraints + RecursiveDo + ScopedTypeVariables + TypeFamilies + UndecidableInstances + + exposed-modules: + Common.Route + Common.Helpers + Hydra.Types + + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits diff --git a/common/src/Common/Helpers.hs b/common/src/Common/Helpers.hs new file mode 100644 index 0000000..4c9747f --- /dev/null +++ b/common/src/Common/Helpers.hs @@ -0,0 +1,10 @@ +-- | + +module Common.Helpers where + +headMay :: [a] -> Maybe a +headMay (a:_) = Just a +headMay _ = Nothing + +seconds :: Int -> Int +seconds = (* 1000000) diff --git a/common/src/Common/Route.hs b/common/src/Common/Route.hs new file mode 100644 index 0000000..9e1e6fc --- /dev/null +++ b/common/src/Common/Route.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Common.Route where + +import Prelude hiding (id, (.)) + +import Data.Text (Text) +import Data.Functor.Identity + +import Obelisk.Route +import Obelisk.Route.TH + + +data BackendRoute :: * -> * where + -- | Used to handle unparseable routes. + BackendRoute_Missing :: BackendRoute () + BackendRoute_Api :: BackendRoute () + -- You can define any routes that will be handled specially by the backend here. + -- i.e. These do not serve the frontend, but do something different, such as serving static files. + +data FrontendRoute :: * -> * where + FrontendRoute_Home :: FrontendRoute () + -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend. + +fullRouteEncoder + :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName +fullRouteEncoder = mkFullRouteEncoder + (FullRoute_Backend BackendRoute_Missing :/ ()) + (\case + BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty + BackendRoute_Api -> PathSegment "api" $ unitEncoder mempty + ) + (\case + FrontendRoute_Home -> PathEnd $ unitEncoder mempty + ) + +concat <$> mapM deriveRouteComponent + [ ''BackendRoute + , ''FrontendRoute + ] diff --git a/common/src/Hydra/Types.hs b/common/src/Hydra/Types.hs new file mode 100644 index 0000000..40a30a7 --- /dev/null +++ b/common/src/Hydra/Types.hs @@ -0,0 +1,81 @@ +-- | + +module Hydra.Types where + +import GHC.Generics +import Data.Aeson + +import Data.Map (Map) +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Map as Map +import Numeric.Natural (Natural) + +-- | Cardano address +type Address = T.Text + +type Lovelace = Integer + +type NodeId = T.Text + +type TxIn = T.Text +type WholeUTXO = Map TxIn TxInInfo + +ada :: Num a => a -> a +ada = (* 1000000) + +lovelaceToAda :: Integer -> Float +lovelaceToAda n = fromIntegral n / 1000000 + +filterOutFuel :: WholeUTXO -> WholeUTXO +filterOutFuel = Map.filter (not . isFuel) + +filterFuel :: WholeUTXO -> WholeUTXO +filterFuel = Map.filter (isFuel) + +isFuel :: TxInInfo -> Bool +isFuel txinfo = datumhash txinfo == Just fuelMarkerDatumHash + +data TxInInfo = TxInInfo + { address :: Address + , datumhash :: Maybe T.Text + , value :: Map T.Text Int + } + deriving (Eq, Show, Generic) + +instance FromJSON TxInInfo +instance ToJSON TxInInfo + +fuelMarkerDatumHash :: T.Text +fuelMarkerDatumHash = "a654fb60d21c1fed48db2c320aa6df9737ec0204c0ba53b9b94a09fb40e757f3" + + +-- REVIEW(SN): This is also used in hydra-tui + +-- Below various types copied/adapted from hydra-poc code + +data Host = Host + { hostname :: Text + , port :: PortNumber + } + deriving (Ord, Generic, Eq, Show) + +instance ToJSON Host +instance FromJSON Host + + +newtype Party = Party {vkey :: T.Text} + deriving (Eq, Show, Read, Generic) + +instance ToJSON Party +instance FromJSON Party + +type UTxOType tx = Value +type Snapshot tx = Value +type MultiSignature x = Value +type PostChainTx tx = Value +type PostTxError tx = Value +type ValidationError = Value +type SnapshotNumber = Natural +type PortNumber = Natural +type ContestationPeriod = Natural diff --git a/config/common/route b/config/common/route new file mode 100644 index 0000000..c52883e --- /dev/null +++ b/config/common/route @@ -0,0 +1 @@ +http://localhost:8002 \ No newline at end of file diff --git a/config/readme.md b/config/readme.md new file mode 100644 index 0000000..7ca5a54 --- /dev/null +++ b/config/readme.md @@ -0,0 +1,9 @@ +### Config + +Obelisk projects should contain a config folder with the following subfolders: common, frontend, and backend. + +Things that should never be transmitted to the frontend belong in backend/ (e.g., email credentials) + +Frontend-only configuration belongs in frontend/. + +Shared configuration files (e.g., the route config) belong in common/ diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..1777a0b --- /dev/null +++ b/default.nix @@ -0,0 +1,55 @@ +{ system ? builtins.currentSystem +# , rpSetup ? import ((import ./.obelisk/impl {}).path + "/dep/reflex-platform") {} +# , android-build ? false +, obelisk ? import ./.obelisk/impl { + inherit system; + iosSdkVersion = "13.2"; + + # You must accept the Android Software Development Kit License Agreement at + # https://developer.android.com/studio/terms in order to build Android apps. + # Uncomment and set this to `true` to indicate your acceptance: + config.android_sdk.accept_license = true; + + # In order to use Let's Encrypt for HTTPS deployments you must accept + # their terms of service at https://letsencrypt.org/repository/. + # Uncomment and set this to `true` to indicate your acceptance: + terms.security.acme.acceptTerms = true; + + # Override reflex-platform-func in order to get access to haskellOverlaysPre + # for adding mobile support. + # reflex-platform-func = args@{...}: + # import ((import ./.obelisk/impl {}).path + "/dep/reflex-platform") (args // { __useNewerCompiler = true; }); + } +}: +with obelisk; +let + foldExtensions = lib.foldr lib.composeExtensions (_: _: {}); + deps = obelisk.nixpkgs.thunkSet ./dep; + hydra-pay = import deps.hydra-pay {}; + + pkgs = obelisk.nixpkgs; + # cardano-libs-overlay = import ./cardano-libs.nix { inherit deps; hydra-poc = deps.hydra-poc; lib = pkgs.lib; }; +in +project ./. ({ pkgs, ... }: let + haskellLib = pkgs.haskell.lib; + +in +{ + android.applicationId = "systems.obsidian.obelisk.examples.minimal"; + android.displayName = "Obelisk Minimal Example"; + ios.bundleIdentifier = "systems.obsidian.obelisk.examples.minimal"; + ios.bundleName = "Obelisk Minimal Example"; + + overrides = foldExtensions [ + (self: super: { + string-interpolate = haskellLib.doJailbreak (haskellLib.dontCheck super.string-interpolate); + + backend = haskellLib.overrideCabal super.backend (drv: { + librarySystemDepends = (drv.librarySystemDepends or []) ++ [ + pkgs.coreutils + hydra-pay.exe + ]; + }); + }) + ]; +}) diff --git a/dep/aeson-gadt-th/default.nix b/dep/aeson-gadt-th/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/aeson-gadt-th/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/aeson-gadt-th/github.json b/dep/aeson-gadt-th/github.json new file mode 100644 index 0000000..c2c4c18 --- /dev/null +++ b/dep/aeson-gadt-th/github.json @@ -0,0 +1,7 @@ +{ + "owner": "obsidiansystems", + "repo": "aeson-gadt-th", + "private": false, + "rev": "71a315a4873c2875ad737a3320320849bdcf8a2a", + "sha256": "1sjl0a0ig0xfssl4bglakk1b7sj8wqz8hwbg7k2fk10qi7z5hb50" +} diff --git a/dep/aeson-gadt-th/thunk.nix b/dep/aeson-gadt-th/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/aeson-gadt-th/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/aeson/default.nix b/dep/aeson/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/aeson/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/aeson/github.json b/dep/aeson/github.json new file mode 100644 index 0000000..51c742f --- /dev/null +++ b/dep/aeson/github.json @@ -0,0 +1,8 @@ +{ + "owner": "haskell", + "repo": "aeson", + "branch": "aeson-1.5", + "private": false, + "rev": "78e838df44288ac7d7ac2cd77863d2c026d86dbb", + "sha256": "181v1nz05jq992wgmz6ns7iwqx0c5w003hv5ki1kvc9zlg5dh3vf" +} diff --git a/dep/aeson/thunk.nix b/dep/aeson/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/aeson/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/browser-extension/default.nix b/dep/browser-extension/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/browser-extension/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/browser-extension/git.json b/dep/browser-extension/git.json new file mode 100644 index 0000000..ddd82e6 --- /dev/null +++ b/dep/browser-extension/git.json @@ -0,0 +1,8 @@ +{ + "url": "ssh://git@code.obsidian.systems/lodewallet/browser-extension", + "rev": "ae6f9202e35ce74c630da763a95071eeb337ebc8", + "sha256": "0hp1a6a219j1l8jikhp7yya6c55l23rw2360q0vzifgg7fjrd8i3", + "private": true, + "fetchSubmodules": false, + "branch": "aa/createwindow-sim" +} diff --git a/dep/browser-extension/thunk.nix b/dep/browser-extension/thunk.nix new file mode 100644 index 0000000..e3b8c83 --- /dev/null +++ b/dep/browser-extension/thunk.nix @@ -0,0 +1,14 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}: + let realUrl = let firstChar = builtins.substring 0 1 url; in + if firstChar == "/" then /. + url + else if firstChar == "." then ./. + url + else url; + in if !fetchSubmodules && private then builtins.fetchGit { + url = realUrl; inherit rev; + ${if branch == null then null else "ref"} = branch; + } else (import {}).fetchgit { + url = realUrl; inherit rev sha256; + }; + json = builtins.fromJSON (builtins.readFile ./git.json); +in fetch json \ No newline at end of file diff --git a/dep/cardano-node/default.nix b/dep/cardano-node/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/cardano-node/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/cardano-node/github.json b/dep/cardano-node/github.json new file mode 100644 index 0000000..7e76dfa --- /dev/null +++ b/dep/cardano-node/github.json @@ -0,0 +1,7 @@ +{ + "owner": "input-output-hk", + "repo": "cardano-node", + "private": false, + "rev": "ebc7be471b30e5931b35f9bbc236d21c375b91bb", + "sha256": "1j01m2cp2vdcl26zx9xmipr551v3b2rz9kfn9ik8byfwj1z7652r" +} diff --git a/dep/cardano-node/thunk.nix b/dep/cardano-node/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/cardano-node/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/constraints-extras/default.nix b/dep/constraints-extras/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/constraints-extras/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/constraints-extras/github.json b/dep/constraints-extras/github.json new file mode 100644 index 0000000..19bf5b3 --- /dev/null +++ b/dep/constraints-extras/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "constraints-extras", + "branch": "release/0.3.2.0", + "private": false, + "rev": "42835fd9e1b4b3c4a72cd1237c04789f01c92dd0", + "sha256": "0z7yfxxi4jywzhlkphs8ss3hd7fll8c90bbl6nr2bj63c87jx6sw" +} diff --git a/dep/constraints-extras/thunk.nix b/dep/constraints-extras/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/constraints-extras/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/entropy/default.nix b/dep/entropy/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/entropy/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/entropy/github.json b/dep/entropy/github.json new file mode 100644 index 0000000..6aa8b23 --- /dev/null +++ b/dep/entropy/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "entropy", + "branch": "aa/nonwindow-contexts", + "private": false, + "rev": "ddda007c44390d0ec8cad58810710864dee60ddd", + "sha256": "00b7cqdqbjf953r5gmwmkn2mn36zdxqwx90xih925cni94vi4vw9" +} diff --git a/dep/entropy/thunk.nix b/dep/entropy/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/entropy/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/hspec-webdriver-clone/default.nix b/dep/hspec-webdriver-clone/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/hspec-webdriver-clone/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/hspec-webdriver-clone/github.json b/dep/hspec-webdriver-clone/github.json new file mode 100644 index 0000000..8fadd4f --- /dev/null +++ b/dep/hspec-webdriver-clone/github.json @@ -0,0 +1,8 @@ +{ + "owner": "luigy", + "repo": "hspec-webdriver-clone", + "branch": "hspec-2.8", + "private": false, + "rev": "2cbe58872304d2332dfc61efaa9e0432862459d7", + "sha256": "1hm8cgw28v6g5xi25i3h1rmac7p4kh340qd5dx0ndjyxjl1lvb0p" +} diff --git a/dep/hspec-webdriver-clone/thunk.nix b/dep/hspec-webdriver-clone/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/hspec-webdriver-clone/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/hydra-pay/default.nix b/dep/hydra-pay/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/hydra-pay/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/hydra-pay/github.json b/dep/hydra-pay/github.json new file mode 100644 index 0000000..b89a0d7 --- /dev/null +++ b/dep/hydra-pay/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "hydra-pay", + "branch": "develop", + "private": false, + "rev": "9d21eb40673da38b0e57af3ea25d41135872b405", + "sha256": "1pqnjq2w0njcw4iicmkm1s3d627lspg3s65dfjlc22g9lxpaxs1q" +} diff --git a/dep/hydra-pay/thunk.nix b/dep/hydra-pay/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/hydra-pay/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/hydra-poc/default.nix b/dep/hydra-poc/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/hydra-poc/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/hydra-poc/github.json b/dep/hydra-poc/github.json new file mode 100644 index 0000000..68a2719 --- /dev/null +++ b/dep/hydra-poc/github.json @@ -0,0 +1,7 @@ +{ + "owner": "input-output-hk", + "repo": "hydra-poc", + "private": false, + "rev": "d4f242b68069765117e7c615101df17708de40a2", + "sha256": "0h0ymcw6h3lggvsmyxyvj5582mhmkv6d937qmz0px40gwjjcly05" +} diff --git a/dep/hydra-poc/thunk.nix b/dep/hydra-poc/thunk.nix new file mode 100644 index 0000000..20f2d28 --- /dev/null +++ b/dep/hydra-poc/thunk.nix @@ -0,0 +1,12 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; + sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; +}) {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/juicy.pixels.ghcjs/default.nix b/dep/juicy.pixels.ghcjs/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/juicy.pixels.ghcjs/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/juicy.pixels.ghcjs/github.json b/dep/juicy.pixels.ghcjs/github.json new file mode 100644 index 0000000..4fc90dc --- /dev/null +++ b/dep/juicy.pixels.ghcjs/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "juicy.pixels.ghcjs", + "branch": "main", + "private": false, + "rev": "a1c516493c674dba64e8eadb8a65b829477f302d", + "sha256": "06dm7kw5p1df0j0mf2wp9yyqxxzx9lih1y3l2ym8dcl1cklrnx57" +} diff --git a/dep/juicy.pixels.ghcjs/thunk.nix b/dep/juicy.pixels.ghcjs/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/juicy.pixels.ghcjs/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/qrcode/default.nix b/dep/qrcode/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/qrcode/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/qrcode/github.json b/dep/qrcode/github.json new file mode 100644 index 0000000..8bec2f2 --- /dev/null +++ b/dep/qrcode/github.json @@ -0,0 +1,8 @@ +{ + "owner": "obsidiansystems", + "repo": "qrcode", + "branch": "master", + "private": false, + "rev": "f33abef0451982ae7769b24e9031753ef2c4d826", + "sha256": "044bi6fnrzpzam0zyd6yijpkphjnn3z751nnxb3zz2w93wzi6nkd" +} diff --git a/dep/qrcode/thunk.nix b/dep/qrcode/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/qrcode/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/reflex-gadt-api/default.nix b/dep/reflex-gadt-api/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/reflex-gadt-api/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/reflex-gadt-api/github.json b/dep/reflex-gadt-api/github.json new file mode 100644 index 0000000..469864f --- /dev/null +++ b/dep/reflex-gadt-api/github.json @@ -0,0 +1,8 @@ +{ + "owner": "reflex-frp", + "repo": "reflex-gadt-api", + "branch": "develop", + "private": false, + "rev": "69aca72b57a74fbf0d06a1b2ac1d247ce9aa207f", + "sha256": "116c6lna8pkas95lclm4halagc4f6rxv5hmf7rnl10lxqi9m48qw" +} diff --git a/dep/reflex-gadt-api/thunk.nix b/dep/reflex-gadt-api/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/reflex-gadt-api/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/reflex/default.nix b/dep/reflex/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/reflex/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/reflex/github.json b/dep/reflex/github.json new file mode 100644 index 0000000..b2465f1 --- /dev/null +++ b/dep/reflex/github.json @@ -0,0 +1,8 @@ +{ + "owner": "reflex-frp", + "repo": "reflex", + "branch": "release/0.8.2.0", + "private": false, + "rev": "823afd9424234cbe0134051f09a6710e54509cec", + "sha256": "1zh8v28issyh8sww9aw6y4dqd2qql25nrxxzxg9ky0vrwmhw295c" +} diff --git a/dep/reflex/thunk.nix b/dep/reflex/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/reflex/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/secp256k1-haskell/default.nix b/dep/secp256k1-haskell/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/secp256k1-haskell/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/secp256k1-haskell/github.json b/dep/secp256k1-haskell/github.json new file mode 100644 index 0000000..e1cf1e2 --- /dev/null +++ b/dep/secp256k1-haskell/github.json @@ -0,0 +1,8 @@ +{ + "owner": "haskoin", + "repo": "secp256k1-haskell", + "branch": "master", + "private": false, + "rev": "3df963ab6ae14ec122691a97af09a7331511a387", + "sha256": "1phnj7wzprrgdhji80rh16savmqq1z9q3z5yi72x8w5v42lf5f2y" +} diff --git a/dep/secp256k1-haskell/thunk.nix b/dep/secp256k1-haskell/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/secp256k1-haskell/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/snap-core/default.nix b/dep/snap-core/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/snap-core/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/snap-core/github.json b/dep/snap-core/github.json new file mode 100644 index 0000000..e15b972 --- /dev/null +++ b/dep/snap-core/github.json @@ -0,0 +1,8 @@ +{ + "owner": "snapframework", + "repo": "snap-core", + "branch": "master", + "private": false, + "rev": "2dc0cab7d4ec48cc690898700c7e9f9db8d1d54d", + "sha256": "1k5gwhgf489c44mv38wawv3nwl7dxr7zrsg1112s0adbavsjdbxn" +} diff --git a/dep/snap-core/thunk.nix b/dep/snap-core/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/snap-core/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/dep/vessel/default.nix b/dep/vessel/default.nix new file mode 100644 index 0000000..2b4d4ab --- /dev/null +++ b/dep/vessel/default.nix @@ -0,0 +1,2 @@ +# DO NOT HAND-EDIT THIS FILE +import (import ./thunk.nix) \ No newline at end of file diff --git a/dep/vessel/github.json b/dep/vessel/github.json new file mode 100644 index 0000000..99fff59 --- /dev/null +++ b/dep/vessel/github.json @@ -0,0 +1,7 @@ +{ + "owner": "obsidiansystems", + "repo": "vessel", + "private": false, + "rev": "03b1465abeb2dea16d32feb0963f11d0ed00f2f8", + "sha256": "18vyh4ds2mng9lmn435dpbf9rj3fh9z1rimk4f2s3war9j4j5wnq" +} diff --git a/dep/vessel/thunk.nix b/dep/vessel/thunk.nix new file mode 100644 index 0000000..bbf2dc1 --- /dev/null +++ b/dep/vessel/thunk.nix @@ -0,0 +1,9 @@ +# DO NOT HAND-EDIT THIS FILE +let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }: + if !fetchSubmodules && !private then builtins.fetchTarball { + url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256; + } else (import {}).fetchFromGitHub { + inherit owner repo rev sha256 fetchSubmodules private; + }; + json = builtins.fromJSON (builtins.readFile ./github.json); +in fetch json \ No newline at end of file diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal new file mode 100644 index 0000000..e644225 --- /dev/null +++ b/frontend/frontend.cabal @@ -0,0 +1,59 @@ +name: frontend +version: 0.1 +cabal-version: >= 1.10 +build-type: Simple + +library + hs-source-dirs: src + build-depends: base + , common + , obelisk-frontend + , obelisk-route + , jsaddle + , reflex-dom-core + , obelisk-executable-config-lookup + , obelisk-generated-static + , text + , string-interpolate + , containers + , aeson + , bytestring + , witherable + , transformers + , time + , lens + , random + default-extensions: + RecursiveDo + RankNTypes + FlexibleContexts + PartialTypeSignatures + ScopedTypeVariables + OverloadedStrings + TypeFamilies + RecursiveDo + LambdaCase + DeriveGeneric + exposed-modules: + Frontend + other-modules: + HydraPay.Config + HydraPay.Api + ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits + +executable frontend + main-is: main.hs + hs-source-dirs: src-bin + build-depends: base + , common + , obelisk-frontend + , obelisk-route + , reflex-dom + , obelisk-generated-static + , frontend + ghc-options: -threaded -O -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -fno-show-valid-hole-fits + if impl(ghcjs) + ghc-options: -dedupe + cpp-options: -DGHCJS_BROWSER + if os(darwin) + ghc-options: -dynamic diff --git a/frontend/src-bin/main.hs b/frontend/src-bin/main.hs new file mode 100644 index 0000000..9408dc3 --- /dev/null +++ b/frontend/src-bin/main.hs @@ -0,0 +1,10 @@ +import Frontend +import Common.Route +import Obelisk.Frontend +import Obelisk.Route.Frontend +import Reflex.Dom + +main :: IO () +main = do + let Right validFullEncoder = checkEncoder fullRouteEncoder + run $ runFrontend validFullEncoder frontend diff --git a/frontend/src/Frontend.hs b/frontend/src/Frontend.hs new file mode 100644 index 0000000..6765a44 --- /dev/null +++ b/frontend/src/Frontend.hs @@ -0,0 +1,890 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecursiveDo #-} + +module Frontend + ( frontend + ) +where + +import Prelude hiding (filter) + +import Hydra.Types +import HydraPay.Api as HydraPayApi +import Text.Read (readMaybe) +import Text.Printf (printf) +import System.Random +import qualified Data.Map as Map +import Data.Fixed +import qualified Data.Text as T + +import Obelisk.Frontend +import Obelisk.Route +import Obelisk.Route.Frontend +import Reflex.Dom.Core +import Common.Route +import Control.Lens +import Control.Monad.Fix +import Control.Monad.IO.Class +-- import Common.Api as ChannelsApi +import Control.Monad.Trans.Class + +import Language.Javascript.JSaddle (jsg, js, liftJSM, fromJSValUnchecked) +import Data.Int (Int64) +import Data.Monoid +import Data.Witherable (catMaybes) +import Data.Maybe (isJust) + +default (T.Text) + +-- This runs in a monad that can be run on the client or the server. +-- To run code in a pure client or pure server context, use one of the +-- `prerender` functions. +frontend :: Frontend (R FrontendRoute) +frontend = Frontend + { _frontend_head = do + el "title" $ text "Hydra Pay Payment Channel Demo" + + elAttr "meta" ("name"=:"viewport" <> "content"=:"width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=no") blank + elAttr "link" ("rel" =: "preconnect" <> "href" =: "https://fonts.googleapis.com") blank + elAttr "link" ("rel" =: "preconnect" <> "href" =: "https://fonts.gstatic.com") blank + elAttr "link" ("href"=:"https://fonts.googleapis.com/css2?family=Inria+Sans:wght@300&family=Inter:wght@100;200;300;400;500;600;700;800;900&family=Krona+One&family=Rajdhani:wght@300;400;500;600;700&display=swap" <> "rel"=:"stylesheet") blank + elAttr "link" ("rel"=:"stylesheet" <> "href"=:"https://fonts.googleapis.com/css2?family=Material+Symbols+Rounded:opsz,wght,FILL,GRAD@48,400,0,0") blank + elAttr "script" ("src"=:"https://cdn.tailwindcss.com") blank + , _frontend_body = elAttr "div" ("class" =: "w-screen h-screen overflow-hidden flex flex-col bg-gray-100" <> "style" =: "font-family: 'Inter', sans-serif;") $ do + elClass "div" "flex-shrink-0 px-8 py-4 text-xl font-semibold" $ el "h1" $ text "Hydra Pay" + prerender_ (text "Loading Payment Channel Demo") $ elClass "div" "w-full h-full mt-10 flex-grow px-8 overflow-hidden" $ do + pb <- getPostBuild + endpoint <- liftJSM $ do + let + webSocketProtocol :: T.Text -> T.Text + webSocketProtocol "https:" = "wss:" + webSocketProtocol _ = "ws:" + + wsProtocol <- fmap webSocketProtocol $ fromJSValUnchecked =<< jsg "location" ^. js "protocol" + + theHostname <- fromJSValUnchecked =<< jsg "location" ^. js "hostname" + let thePort = "8000" -- fromJSValUnchecked =<< jsg "location" ^. js "port" + + pure $ mconcat [ wsProtocol + , "//" + , theHostname + , ":" + , thePort + , "/hydra/api" + ] + rec + lastTagId <- foldDyn (+) 0 $ fromIntegral . length <$> sendToHydraPay + + let + sendToHydraPay = + attachWith (\tid msgs -> uncurry Tagged <$> zip [tid..] msgs) (current lastTagId) sendMsg + + serverMsg = fmapMaybe id $ rws ^. webSocket_recv + + subscriptions = fmapMaybe (preview _PlainMsg) serverMsg + responses = fmapMaybe (preview _TaggedMsg) serverMsg + + authResponse = fmapMaybe (preview (_AuthResult) . tagged_payload) responses + + rws :: RawWebSocket t (Maybe ApiMsg) <- jsonWebSocket endpoint $ def + & webSocketConfig_send .~ sendToHydraPay + + (_, sendMsg :: Event t [ClientMsg]) <- runEventWriterT $ elClass "div" "w-full h-full flex flex-row text-gray-700" $ do + -- managedDevnetReply <- requester lastTagId responses (GetIsManagedDevnet <$ pb) + -- _ <- runWithReplace blank $ + -- mapMaybe ((\case + -- IsManagedDevnet x -> Just (monitorView lastTagId responses x) + -- _ -> Nothing) + -- . tagged_payload) + -- managedDevnetReply + elClass "div" "flex-grow" $ elClass "div" "max-w-lg" $ mdo + (_, authenticatedE) <- + runEventWriterT + . runWithReplace (tellEvent =<< lift (authentication lastTagId responses)) + . ffor authenticatedE $ \() -> do + text "You're authenticated" + blank + runWithReplace blank (fundCreateInit lastTagId responses <$ authenticatedE) + pure () + pure () + } + + +requestPb :: (PostBuild t m, EventWriter t [ClientMsg] m, MonadHold t m) => + Dynamic t Int64 + -> Event t (Tagged ServerMsg) + -> ClientMsg + -> m (Event t ServerMsg) +requestPb lastId serverMsg msg = do + pb <- getPostBuild + requester lastId serverMsg (msg <$ pb) + + +requestPbExpected :: (PostBuild t m, EventWriter t [ClientMsg] m, MonadHold t m) => + Dynamic t Int64 + -> Event t (Tagged ServerMsg) + -> Getting (Data.Monoid.First b) ServerMsg b + -> ClientMsg + -> m (Event t (Maybe b)) +requestPbExpected lastId serverMsg sel msg = do + fmap (preview sel) <$> requestPb lastId serverMsg msg + +requestPbExact :: (PostBuild t m, EventWriter t [ClientMsg] m, MonadHold t m) => + Dynamic t Int64 + -> Event t (Tagged ServerMsg) + -> Getting (Data.Monoid.First b) ServerMsg b + -> ClientMsg + -> m (Event t b) +requestPbExact lastId serverMsg sel msg = do + catMaybes <$> requestPbExpected lastId serverMsg sel msg + +getAddresses :: (PostBuild t m, EventWriter t [ClientMsg] m, MonadHold t m) => + Dynamic t Int64 + -> Event t (Tagged ServerMsg) -> m (Event t [Address]) +getAddresses lastId serverMsg = + requestPbExact lastId serverMsg _DevnetAddresses (GetDevnetAddresses 2) + +viewUntil :: _ => Workflow t m (Maybe a) -> m (Event t a) +viewUntil = fmap catMaybes . workflowView + +doFundingTx :: + ( NotReady t m, + Adjustable t m, + PostBuild t m, + EventWriter t [ClientMsg] m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Int64 -> + Event t (Tagged ServerMsg) -> + Lovelace -> + TxType -> + Address -> + m (Event t Bool) +doFundingTx lastId serverMsg amnt typ addr = viewUntil $ Workflow $ do + fundsTxE <- requestPbExact lastId serverMsg _FundsTx (GetAddTx typ addr amnt) + pure . (Nothing,) . ffor fundsTxE $ \tx -> Workflow $ do + submitSuccessE <- requestPbExpected lastId serverMsg _OperationSuccess (LiveDocEzSubmitTx tx addr) + pure . (Nothing,) . ffor submitSuccessE $ \v -> Workflow . pure $ (Just (isJust v), never) + +-- TODO: Use Either instead of Bool to get the errors/unexpected values reported back +andWhen :: _ => m (Event t Bool) -> m (Event t Bool) -> m (Event t Bool) +andWhen me mc = viewUntil . Workflow $ do + e <- me + pure . (Nothing,) . ffor e $ \case + False -> Workflow $ pure (Just False, never) + True -> Workflow $ do + c <- mc + pure . (Nothing,) . ffor c $ Workflow . pure . (, never) . Just + +doAllFunding :: + ( NotReady t m, + Adjustable t m, + PostBuild t m, + EventWriter t [ClientMsg] m, + MonadHold t m, + MonadFix m, _ + ) => + Dynamic t Int64 -> + Event t (Tagged ServerMsg) -> + Lovelace -> + [Address] -> + m (Event t Bool) +doAllFunding lastId serverMsg amnt [one, two] = + (text "Funding Alice" >> doFundingTx lastId serverMsg amnt Funds one) + `andWhen` (text "Fueling Alice" >> doFundingTx lastId serverMsg amnt Fuel one) + `andWhen` (text "Funding Bob" >> doFundingTx lastId serverMsg amnt Funds two) + `andWhen` (text "Fueling Bob" >> doFundingTx lastId serverMsg amnt Fuel one) + +singletonWorkflow :: _ => a -> Workflow t m a +singletonWorkflow = Workflow . pure . (,never) + +createAndInitHead :: _ => _ -> _ -> [_] -> m (Event t Bool) +createAndInitHead lastId serverMsg addrs = do + ((True <$) <$> requestPbExact lastId serverMsg _OperationSuccess (CreateHead (HeadCreate theHeadName addrs))) + `andWhen` + ((True <$) <$> requestPbExact lastId serverMsg _OperationSuccess (InitHead (HeadInit theHeadName 3))) + + + + +fundCreateInit :: (NotReady t m, Adjustable t m, PostBuild t m, + EventWriter t [ClientMsg] m, MonadHold t m, MonadFix m, _) => + Dynamic t Int64 -> Event t (Tagged ServerMsg) -> m (Event t [Address]) +fundCreateInit lastId serverMsg = do + addrE <- getAddresses lastId serverMsg + viewUntil . Workflow . pure . (Nothing,) . ffor addrE $ \addrs -> Workflow $ do + res <- doAllFunding lastId serverMsg (ada 100) addrs + `andWhen` createAndInitHead lastId serverMsg addrs + -- TODO: This just assumes all went well, it should check for errors and abort. + -- (I.e. check whether res == False.) + pure . (Nothing,) $ Workflow (do + text "Head created" + pure . (,never) . Just $ addrs) + <$ res + + + + -- gotAddrs <- fmap switchDyn $ prerender (pure never) $ do + -- rec + -- jsBuild <- getPostBuild + -- -- FIXME: something changed here + -- result <- getAndDecode $ "/demo-addresses" <$ leftmost [jsBuild] + -- --, () <$ failedToLoad] + -- let + -- -- If we failed it is likely the server just hot reloaded in development + -- -- and we just try again immediately + -- failedToLoad = fmapMaybe (preview _Nothing) result + -- addrsRecv = fmapMaybe (preview _Just) result + -- pure addrsRecv + + -- rec + -- addrs <- holdDyn (Nothing :: Maybe [Address]) gotAddrs + -- nextId <- foldDyn (+) (0 :: Int) $ 1 <$ newTx + + -- let + -- insertNewTx = (current $ Map.insert <$> nextId) <@> newTx + + -- latestPopupTxs <- foldDyn ($) mempty $ mergeWith (.) $ [ insertNewTx + -- , removeStaleTxs + -- ] + -- latestTxs <- foldDyn ($) mempty $ mergeWith (.) $ [ insertNewTx + -- ] + -- let + -- totalTxDisplayTime = 4 + -- -- We assume the first and second index to be Bob and Alice respectively + -- bobAddress = ffor addrs $ join . fmap (^? ix 0) + -- aliceAddress = ffor addrs $ join . fmap (^? ix 1) + + -- newTxPopup tx = do + -- transitionIn <- getPostBuild >>= delay 0.1 + -- transitionOut <- tickLossyFromPostBuildTime totalTxDisplayTime + -- removeThisPopup <- tickLossyFromPostBuildTime $ totalTxDisplayTime + 2 + -- visible <- holdDyn False $ mergeWith (&&) [True <$ transitionIn, False <$ transitionOut] + -- let + -- mkClasses b = + -- mconcat [ "transition pointer-events-none duration-1000 px-8 py-4 rounded-lg bg-white mb-4 drop-shadow-lg " + -- , bool "opacity-0" "opacity-100" b + -- ] + -- elDynClass "div" (mkClasses <$> visible) $ do + -- elClass "div" "text-xs text-gray-500 mb-2" $ text "New Transaction" + + -- elClass "div" "flex flex-row justify-between items-center" $ do + -- elClass "div" "flex flex-col mr-16" $ do + -- elClass "div" "text-gray-600" $ do + -- text "To " + -- dynText $ demoTx_to <$> tx + -- elClass "div" "text-xl" $ do + -- dynText $ T.pack . printf "%.2f" . lovelaceToAda . demoTx_amount <$> tx + -- text "ADA" + + -- elClass "div" "flex flex-row text-gray-400" $ do + -- elClass "div" "flex flex-col" $ do + -- elClass "div" "text-xs" $ text "Time" + -- elClass "div" "" $ do + -- dynText $ showAsMs . demoTx_time <$> tx + -- text "ms" + -- pure $ () <$ removeThisPopup + + -- -- When we get a server response, go to open a channel + -- newTx <- appView bobAddress aliceAddress latestTxs + + -- removeStaleTxs <- elClass "div" "pointer-events-none absolute top-0 right-0 p-4 h-full overflow-hidden leading-none" $ elClass "div" "flex flex-col-reverse" $ do + -- eventList <- listWithKey latestPopupTxs $ \txid tx -> do + -- removalEv <- newTxPopup tx + -- pure $ Map.delete txid <$ removalEv + + -- pure $ switchDyn $ mergeWith (.) . Map.elems <$> eventList + -- subRoute_ $ \case + -- _ -> do + -- setRoute $ FrontendRoute_OpenChannel :/ () <$ gotAddrs + -- setRoute $ FrontendRoute_Setup :/ () <$ postBuild + -- setRoute $ FrontendRoute_PaymentChannel :/ () <$ newTx + -- pure () + +data DemoTx = DemoTx + { demoTx_to :: T.Text + , demoTx_amount :: Lovelace + , demoTx_time :: Pico + } + deriving (Eq, Show) + +showAsMs :: Pico -> T.Text +showAsMs = T.pack . printf "%.2f" . (realToFrac :: Pico -> Float) . (*1000) + + +-- TODO(skylar): Use Requester from reflex +requester :: (Reflex t, EventWriter t [ClientMsg] m, MonadHold t m) => Dynamic t Int64 -> Event t (Tagged ServerMsg) -> Event t ClientMsg -> m (Event t ServerMsg) +requester lastTagId serverMsg clientMsg = do + waitingTag <- holdDyn Nothing $ current (Just <$> lastTagId) <@ clientMsg + + let + isWhatWeAreWaitingFor (Just nid) msg@(Tagged nid' _) | nid == nid' = Just msg + isWhatWeAreWaitingFor _ _ = Nothing + + properServerMsg = attachWithMaybe isWhatWeAreWaitingFor (current waitingTag) serverMsg + + tellEvent $ pure <$> clientMsg + pure (tagged_payload <$> properServerMsg) + + +authentication :: + ( PostBuild t m + , SetRoute t (R FrontendRoute) m + , SetRoute t (R FrontendRoute) m + , RouteToUrl (R FrontendRoute) m + , MonadIO (Performable m) + , PerformEvent t m + , TriggerEvent t m + , DomBuilder t m + , MonadFix m + , MonadHold t m + , EventWriter t [ClientMsg] m + ) => Dynamic t Int64 -> Event t (Tagged ServerMsg) -> m (Event t ()) +authentication lastTagId serverMsg = do + apiKeyInput <- inputElement $ def + & initialAttributes .~ ("class" =: "pl-4 pr-2 py-1 bg-transparent text-right" <> "placeholder" =: "Hydra Pay API Key") + let + pressedEnter = keypress Enter apiKeyInput + + authReply <- requester lastTagId serverMsg $ + Authenticate <$> current (_inputElement_value apiKeyInput) <@ pressedEnter + pure . mapMaybe (\case + (AuthResult True) -> Just () + _ -> Nothing) + $ authReply + +initialBalances :: _ => _ -> _ -> (_,_) -> m () +initialBalances lastTagId serverMsg (bobAddress, aliceAddress)= do + -- Page Title + elClass "div" "mb-2 font-semibold" $ text "Open a Payment Channel" + -- Divider + elClass "div" "mt-2 w-full h-px bg-gray-200" blank + + -- Balances + elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "Current Balances" + + elClass "div" "flex flex-row mt-4" $ do + balanceWidget lastTagId serverMsg "Bob" bobAddress never L1B + balanceWidget lastTagId serverMsg "Alice" aliceAddress never L1B + + -- Divider + elClass "div" "mt-2 w-full h-px bg-gray-200" blank + + -- Open Payment Channel UI + elClass "div" "mt-8" $ do + elClass "div" "text-sm mb-1" $ text "Amount to Spend" + _ :: Dynamic t (Maybe Float) <- el "div" $ elClass "div" "w-fit border-2 border-gray-200 flex flex-row items-center" $ do + amountInput <- inputElement $ def + & initialAttributes .~ ("class" =: "pl-4 pr-2 py-1 bg-transparent text-right" <> "placeholder" =: "1 ADA" <> "type" =: "number") + & inputElementConfig_initialValue .~ "1000" + elClass "span" "mx-2 my-1" $ text "ADA" + pure $ readMaybe . T.unpack <$> _inputElement_value amountInput + elClass "div" "text-xs my-1" $ text "100 ADA in fast payment collateral will also be held in hydra pay" + pure () + + todo_CONTINUE_WITH_THIS_BUTTON <- elClass "button" "rounded mt-4 p-4 text-center w-full bg-gray-800 text-white font-bold" $ text "Open Payment Channel" + pure () + pure () + + +data BalanceType = L1B | HdB + +theHeadName = "channelsHead" + +balanceWidget :: _ => _ -> _ -> _ -> _ -> Event t () -> _ -> m (Dynamic t _) +balanceWidget lastTagId serverMsg name addr refetch btype = do + elClass "div" "text-lg flex flex-col mr-10" $ do + elClass "div" "font-semibold" $ text name + -- NOTE(skylar): We assume we have loaded bobAddress if this is visible, so we don't worry about the outer Nothing + fmap (fmap getFirst . snd) . runDynamicWriterT . elClass "div" "font-semibold" $ mdo + balanceResult' <- requestPb lastTagId serverMsg ((case btype of + L1B -> GetL1Balance + HdB -> GetHeadBalance theHeadName) + addr) + + let balanceResult = fmap (\case + L1Balance b -> Just b + HeadBalance b -> Just b + _ -> Nothing) + balanceResult' + let + gotBalance = fmapMaybe (preview _Just) balanceResult + reqFailed = fmapMaybe (preview _Nothing) balanceResult + + delayedFail <- delay 1 reqFailed + mBalance <- holdDyn (Nothing :: Maybe Float) $ Just . lovelaceToAda <$> gotBalance + tellDyn (First <$> mBalance) + + dyn_ $ ffor mBalance $ \case + Nothing -> elClass "div" "animate-pulse bg-gray-700 w-16 h-4" blank + Just balance -> do + text $ T.pack . printf "%.2f" $ balance + text " ADA" + + pure $ maybe 0 id <$> mBalance + + +paymentChannel :: _ => _ -> _ -> [Address] -> _ -> m (Event t DemoTx) +paymentChannel lastTagId serverMsg [aliceAddress, bobAddress] latestTxs = do + -- Page Title + elClass "div" "w-full flex flex-row items-baseline justify-between" $ do + elClass "div" "mb-2 font-semibold" $ text "Bob & Alice's Payment Channel" + todo_CONTINUE_WITH_THIS_BUTTON <- elClass "button" "rounded mt-4 px-6 py-2 text-center bg-gray-800 text-white font-semibold" $ text "Close Payment Channel" + pure () + + -- Divider + elClass "div" "mt-2 w-full h-px bg-gray-200" blank + + elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "L1 Balance" + + elClass "div" "flex flex-row mt-4" $ do + balanceWidget lastTagId serverMsg "Bob" bobAddress never L1B + balanceWidget lastTagId serverMsg "Alice" aliceAddress never L1B + + -- Divider + elClass "div" "mt-2 w-full h-px bg-gray-200" blank + + -- Balances + elClass "div" "text-2xl mb-2 font-semibold mt-8" $ do + text "Payment Channel Balance" + + rec + (bobBalance, aliceBalance) <- elClass "div" "flex flex-row mt-4" $ do + bb <- balanceWidget lastTagId serverMsg "Bob" bobAddress autoTx HdB + ab <- balanceWidget lastTagId serverMsg "Alice" aliceAddress autoTx HdB + pure (bb, ab) + + -- Divider + elClass "div" "mt-2 w-full h-px bg-gray-200" blank + + -- Statistics + elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "Statistics" + + elClass "div" "flex flex-row mt-4" $ do + elClass "div" "mr-16" $ do + elClass "div" "text-lg font-semibold" $ text "Total Transactions" + elClass "div" "text-3xl text-gray-600" $ dynText $ T.pack . show . Map.size <$> latestTxs + + elClass "div" "mr-16" $ do + elClass "div" "text-lg font-semibold" $ text "Total Time" + elClass "div" "text-3xl text-gray-600" $ do + dynText $ showAsMs . Map.foldr ((+) . demoTx_time) 0 <$> latestTxs + text "ms" + + -- Divider + elClass "div" "mt-2 w-full h-px bg-gray-200" blank + + -- Action buttons: Send & Automate + (automateButton, _) <- elClass "div" "" $ do + todo_CONTINUE_WITH_THIS_BUTTON <- elClass "button" "rounded mt-4 px-6 py-2 text-center bg-gray-800 text-white font-semibold mr-4" $ text "Send ADA" + elClass' "button" "rounded mt-4 px-6 py-2 text-center bg-gray-800 text-white font-semibold" $ dynText $ ffor automating $ \case + True -> "Automating" + False -> "Automate" + + let + toggleAutomate = domEvent Click automateButton + + automating <- foldDyn ($) False $ not <$ toggleAutomate + + fmap (getFirst . snd) . runEventWriterT . dyn $ ffor automating $ \case + False -> pure () + True -> do + tick <- tickLossyFromPostBuildTime 1 + randomAmount :: Event t Lovelace <- performEvent $ (liftIO $ ada <$> randomRIO (1,10)) <$ tick + let + nextToAddr :: Dynamic t Address = ffor2 bobBalance aliceBalance $ \bb ab -> + if bb > ab then aliceAddress else bobAddress + + nextFromAddr = ffor2 bobBalance aliceBalance $ \bb ab -> + if bb > ab then bobAddress else aliceAddress + + bobIsTo = (fmap (== bobAddress) nextToAddr) + toName = ffor bobIsTo $ \case + True -> "Bob" + False -> "Alice" + + sendAdaResponse <- requester lastTagId serverMsg $ + (\from to am -> SubmitHeadTx from $ HeadSubmitTx theHeadName to am) + <$> current nextFromAddr + <*> current nextToAddr + <@> randomAmount + + -- picoToLatestTx <- holdDyn Nothing $ Just <$> changeDemoBuildTxFunc + + let + sendSuccess = fmapMaybe (preview _TxConfirmed) $ sendAdaResponse + +-- changeDemoBuildTxFunc :: _ = attachWith DemoTx <$> current toName <@> randomAmount + + -- pure $ attachWithMaybe (<*>) (current picoToLatestTx) $ Just <$> sendSuccess + tellEvent never -- TODO: put DemoTxes here + pure () + + -- Transaction History + elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "History" + + let + historyItem tx = do + elClass "div" "transition pointer-events-none duration-1000 px-4 py-2 rounded bg-white mb-4 drop-shadow " $ do + elClass "div" "flex flex-row justify-between items-center" $ do + elClass "div" "flex flex-col mr-16" $ do + elClass "div" "text-gray-600" $ do + text "To " + dynText $ demoTx_to <$> tx + elClass "div" "text-xl" $ do + dynText $ T.pack . printf "%.2f" . lovelaceToAda . demoTx_amount <$> tx + text "ADA" + + elClass "div" "flex flex-row text-gray-400" $ do + elClass "div" "flex flex-col" $ do + elClass "div" "text-xs" $ text "Time" + elClass "div" "" $ do + dynText $ showAsMs . demoTx_time <$> tx + text "ms" + + let + noHistory = Map.null <$> latestTxs + + elDynClass "div" "overflow-y-scroll flex-grow" $ dyn_ $ ffor noHistory $ \case + True -> elClass "div" "text-gray-500" $ text "There is no history yet for this payment channel" + False -> do + _ <- elClass "div" "flex flex-col-reverse w-full" $ listWithKey latestTxs $ \_ tx -> historyItem tx + pure () + + pure never -- TODO: PUT AUTO TX BACK HERE + + + +-- mapMaybe + + -- dyn_ $ ffor mApiKey $ \case + -- Nothing -> text "Please enter your API Key" + -- Just apiKey -> mdo + -- (authEl, _) <- elClass' "button" "rounded mt-4 p-4 text-center w-full bg-gray-800 text-white font-bold" $ text "Authenticate" + + -- lastTagId <- foldDyn (+) 0 $ fromIntegral . length <$> sendToHydraPay + + -- let + -- authenticate = Authenticate apiKey <$ domEvent Click authEl + + -- sendMsg = + -- mergeWith (<>) $ (fmap . fmap) pure $ [authenticate] + + -- sendToHydraPay = + -- attachWith (\tid msgs -> fmap (uncurry Tagged) $ zip [tid..] msgs) (current lastTagId) sendMsg + + -- serverMsg = fmapMaybe id $ rws ^. webSocket_recv + +-- appView :: forall t m. +-- ( PostBuild t m +-- , Prerender t m +-- , SetRoute t (R FrontendRoute) (Client m) +-- , SetRoute t (R FrontendRoute) m +-- , RouteToUrl (R FrontendRoute) m +-- , MonadIO (Performable m) +-- , PerformEvent t m +-- , TriggerEvent t m +-- , DomBuilder t m +-- , MonadFix m +-- , MonadHold t m +-- ) => Dynamic t (Maybe T.Text) -> Dynamic t (Maybe T.Text) -> Dynamic t (Map Int DemoTx) -> RoutedT t (R FrontendRoute) m (Event t DemoTx) +-- appView bobAddress aliceAddress latestTxs = do +-- fmap switchDyn $ elClass "div" "w-full h-full text-gray-700 max-w-4xl mx-auto p-4 rounded flex flex-col" $ subRoute $ \case +-- FrontendRoute_Home -> homeView >> pure never +-- FrontendRoute_Setup -> do +-- elClass "div" "text-3xl flex flex-col justify-center items-center" $ do +-- el "div" $ text "Fast Payments Demo" +-- elClass "div" "text-lg" $ text "populating addresses..." +-- pure never + +-- FrontendRoute_OpeningChannel -> do +-- elClass "div" "text-3xl flex flex-col justify-center items-center" $ do +-- el "div" $ text "Fast Payments Demo" + +-- let +-- messages = [ "Sending funds from Bob and Alice into Hydra Pay" +-- , "Creating payment channel" +-- , "Waiting for payment channel" +-- ] + +-- tick <- tickLossyFromPostBuildTime 2 +-- rec +-- currentIndex <- holdDyn (0 :: Int) $ fmap (min (length messages - 1) . (+1)) $ current currentIndex <@ tick +-- elClass "div" "text-lg" $ do +-- dynText $ (messages !!) <$> currentIndex +-- text "..." + +-- prerender_ blank $ mdo +-- ws :: RawWebSocket t (Maybe ChannelsApi.ServerMsg) <- lift $ jsonWebSocket "ws://localhost:8000/api" $ (WebSocketConfig @t @ChannelsApi.ClientMsg) wssend never True [] +-- let wssend = [DemoInit] <$ _webSocket_open ws +-- setRoute $ FrontendRoute_PaymentChannel :/ () <$ ffilter (== Just InitDone) (_webSocket_recv ws) +-- pure never + +-- FrontendRoute_ClosingChannel -> do +-- elClass "div" "text-3xl flex flex-col justify-center items-center" $ do +-- el "div" $ text "Fast Payments Demo" + +-- let +-- messages = [ "Closing payment channel" +-- , "Settling payment channel on L1" +-- , "Withdrawing funds from payment channel" +-- ] + +-- tick <- tickLossyFromPostBuildTime 5 +-- rec +-- currentIndex <- holdDyn (0 :: Int) $ fmap (min (length messages - 1) . (+1)) $ current currentIndex <@ tick +-- elClass "div" "text-lg" $ do +-- dynText $ (messages !!) <$> currentIndex +-- text "..." + +-- prerender_ blank $ mdo +-- ws :: RawWebSocket t (Maybe ChannelsApi.ServerMsg) <- lift $ jsonWebSocket "ws://localhost:8000/api" $ (WebSocketConfig @t @ChannelsApi.ClientMsg) wssend never True [] +-- let wssend = [CloseFanout] <$ _webSocket_open ws +-- setRoute $ FrontendRoute_OpenChannel :/ () <$ ffilter (== Just CloseFanoutDone) (_webSocket_recv ws) +-- pure never + +-- FrontendRoute_OpenChannel -> do +-- -- Page Title +-- elClass "div" "mb-2 font-semibold" $ text "Open a Payment Channel" +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- -- Balances +-- elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "Current Balances" + +-- elClass "div" "flex flex-row mt-4" $ do +-- balanceWidget "Bob" bobAddress never "l1-balance" +-- balanceWidget "Alice" aliceAddress never "l1-balance" + +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- -- Open Payment Channel UI +-- elClass "div" "mt-8" $ do +-- elClass "div" "text-sm mb-1" $ text "Amount to Spend" +-- _ :: Dynamic t (Maybe Float) <- el "div" $ elClass "div" "w-fit border-2 border-gray-200 flex flex-row items-center" $ do +-- amountInput <- inputElement $ def +-- & initialAttributes .~ ("class" =: "pl-4 pr-2 py-1 bg-transparent text-right" <> "placeholder" =: "1 ADA" <> "type" =: "number") +-- & inputElementConfig_initialValue .~ "1000" +-- elClass "span" "mx-2 my-1" $ text "ADA" +-- pure $ readMaybe . T.unpack <$> _inputElement_value amountInput +-- elClass "div" "text-xs my-1" $ text "100 ADA in fast payment collateral will also be held in hydra pay" +-- pure () + +-- routeLink (FrontendRoute_OpeningChannel :/ ()) $ elClass "button" "rounded mt-4 p-4 text-center w-full bg-gray-800 text-white font-bold" $ text "Open Payment Channel" +-- pure never + +-- FrontendRoute_SendFunds -> mdo +-- -- Page Header +-- elClass "div" "relative w-full flex flex-row items-baseline justify-between" $ do +-- elClass "div" "mb-2 font-semibold" $ text "Bob & Alice's Payment Channel" +-- (backButton, _) <- elClass' "button" "absolute -left-8 rounded w-6 h-6 bg-gray-300 text-center font-semibold" $ text "<" +-- -- NOTE(skylar): Route link prevents the absolute-ness being applied properly, so we just use setRoute! +-- setRoute $ FrontendRoute_PaymentChannel :/ () <$ domEvent Click backButton + +-- -- Divider +-- elClass "div" "w-full h-px bg-gray-200" blank + +-- -- Balances +-- elClass "div" "text-2xl mb-2 font-semibold mt-8" $ do +-- text "Current Balances " +-- elClass "span" "text-sm" $ text " In payment channel" + +-- elClass "div" "flex flex-row mt-4" $ do +-- balanceWidget "Bob" bobAddress never "head-balance" +-- balanceWidget "Alice" aliceAddress never "head-balance" + +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- -- Send +-- elClass "div" "text-2xl mb-4 font-semibold mt-8" $ text "Send ADA" + +-- -- To/From Selector +-- rec +-- (selectorButton, _) <- elClass' "button" "w-fit bg-gray-300 px-4 py-2 rounded flex gap-6 flex-row" $ do +-- elClass "div" "" $ do +-- elClass "div" "text-left text-xs" $ text "From" +-- elClass "div" "font-semibold" $ dynText $ ffor bobIsTo $ \case +-- True -> "Alice" +-- False -> "Bob" + +-- elClass "div" "" $ do +-- elClass "div" "text-left text-xs" $ text "To" +-- elClass "div" "font-semibold" $ dynText $ toName + +-- let +-- toName = ffor bobIsTo $ \case +-- True -> "Bob" +-- False -> "Alice" + +-- bobIsTo = ((==) <$> toAddr <*> bobAddress) +-- changeSelection = current nextSelection <@ domEvent Click selectorButton +-- fromAddr = ffor3 bobIsTo bobAddress aliceAddress $ \isBob bob alice -> +-- if isBob then alice else bob +-- nextSelection = fromAddr + +-- sendBuild <- getPostBuild +-- toAddr <- holdDyn Nothing $ leftmost [current bobAddress <@ sendBuild, changeSelection] +-- pure () + +-- lovelaceSendAmount :: Dynamic t (Maybe Integer) <- el "div" $ elClass "div" "mt-4 w-full border-2 border-gray-200 flex flex-row items-center" $ do +-- amountInput <- inputElement $ def +-- & initialAttributes .~ ("class" =: "text-gray-500 w-full px-8 py-6 bg-transparent text-center text-xl" <> "placeholder" =: "1 ADA" <> "type" =: "number") +-- & inputElementConfig_initialValue .~ "10" +-- elClass "span" "mx-2 my-1" $ text "ADA" +-- pure $ fmap ((round :: Float -> Integer) . ada) . readMaybe . T.unpack <$> _inputElement_value amountInput + +-- (sendButton, _) <- elClass' "button" "rounded mt-4 p-4 text-center w-full bg-gray-800 text-white font-bold" $ text "Send ADA" + +-- let +-- txSendPayload = liftA2 (HeadSubmitTx "demo") <$> toAddr <*> lovelaceSendAmount +-- sendAda = fmapMaybe (preview _Just) $ current txSendPayload <@ domEvent Click sendButton +-- sendUrl = (fmap ("/submit-tx/"<>) <$> fromAddr) +-- sendReq = liftA2 postJson <$> sendUrl <*> txSendPayload + +-- sendSuccess = fmapMaybe (preview _Just) $ (decodeText <=< _xhrResponse_responseText) <$> sendAdaResponse + +-- latestTxFunc = liftA2 DemoTx <$> (Just <$> toName) <*> lovelaceSendAmount + +-- -- Dynamic function to construct the last transaction +-- picoToLatestTx <- holdDyn Nothing $ attachPromptlyDynWith const latestTxFunc sendAda + +-- sendAdaResponse <- fmap switchDyn $ prerender (pure never) $ do +-- performRequestAsync $ fmapMaybe (preview _Just) $ current sendReq <@ sendAda + +-- pure $ attachWithMaybe (\mf a -> mf <*> Just a) (current picoToLatestTx) sendSuccess + +-- FrontendRoute_PaymentChannel -> do +-- -- Page Title +-- elClass "div" "w-full flex flex-row items-baseline justify-between" $ do +-- elClass "div" "mb-2 font-semibold" $ text "Bob & Alice's Payment Channel" +-- routeLink (FrontendRoute_ClosingChannel :/ ()) $ elClass "button" "rounded mt-4 px-6 py-2 text-center bg-gray-800 text-white font-semibold" $ text "Close Payment Channel" + +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "L1 Balance" + +-- elClass "div" "flex flex-row mt-4" $ do +-- balanceWidget "Bob" bobAddress never "l1-balance" +-- balanceWidget "Alice" aliceAddress never "l1-balance" + +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- -- Balances +-- elClass "div" "text-2xl mb-2 font-semibold mt-8" $ do +-- text "Payment Channel Balance" + +-- rec +-- (bobBalance, aliceBalance) <- elClass "div" "flex flex-row mt-4" $ do +-- bb <- balanceWidget "Bob" bobAddress autoTx "head-balance" +-- ab <- balanceWidget "Alice" aliceAddress autoTx "head-balance" +-- pure (bb, ab) + +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- -- Statistics +-- elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "Statistics" + +-- elClass "div" "flex flex-row mt-4" $ do +-- elClass "div" "mr-16" $ do +-- elClass "div" "text-lg font-semibold" $ text "Total Transactions" +-- elClass "div" "text-3xl text-gray-600" $ dynText $ T.pack . show . Map.size <$> latestTxs + +-- elClass "div" "mr-16" $ do +-- elClass "div" "text-lg font-semibold" $ text "Total Time" +-- elClass "div" "text-3xl text-gray-600" $ do +-- dynText $ showAsMs . Map.foldr ((+) . demoTx_time) 0 <$> latestTxs +-- text "ms" + +-- -- Divider +-- elClass "div" "mt-2 w-full h-px bg-gray-200" blank + +-- -- Action buttons: Send & Automate +-- (automateButton, _) <- elClass "div" "" $ do +-- routeLink (FrontendRoute_SendFunds :/ ()) $ elClass "button" "rounded mt-4 px-6 py-2 text-center bg-gray-800 text-white font-semibold mr-4" $ text "Send ADA" +-- elClass' "button" "rounded mt-4 px-6 py-2 text-center bg-gray-800 text-white font-semibold" $ dynText $ ffor automating $ \case +-- True -> "Automating" +-- False -> "Automate" + +-- let +-- toggleAutomate = domEvent Click automateButton + +-- automating <- foldDyn ($) False $ not <$ toggleAutomate + +-- autoTxEv <- dyn $ ffor automating $ \case +-- False -> pure never +-- True -> fmap switchDyn $ prerender (pure never) $ do +-- tick <- tickLossyFromPostBuildTime 1 +-- randomAmount :: Event t Lovelace <- performEvent $ (liftIO $ ada <$> randomRIO (1,10)) <$ tick +-- let +-- nextToAddr = join $ ffor2 bobBalance aliceBalance $ \bb ab -> +-- if bb > ab then aliceAddress else bobAddress + +-- nextFromAddr = join $ ffor2 bobBalance aliceBalance $ \bb ab -> +-- if bb > ab then bobAddress else aliceAddress + +-- sendUrl = (fmap ("/submit-tx/"<>) <$> nextFromAddr) + +-- bobIsTo = ((==) <$> nextToAddr <*> bobAddress) +-- toName = ffor bobIsTo $ \case +-- True -> "Bob" +-- False -> "Alice" + +-- changeDemoBuildTxFunc = attachWith DemoTx (current toName) randomAmount + +-- submitPayload = attachWith (<*>) (current $ fmap (HeadSubmitTx "demo") <$> nextToAddr) $ Just <$> randomAmount +-- submitReq = attachWithMaybe (<*>) (current $ fmap postJson <$> sendUrl) submitPayload + +-- picoToLatestTx <- holdDyn Nothing $ Just <$> changeDemoBuildTxFunc +-- sendAdaResponse <- performRequestAsync submitReq + +-- let +-- sendSuccess = fmapMaybe (preview _Just) $ (decodeText <=< _xhrResponse_responseText) <$> sendAdaResponse + +-- pure $ attachWithMaybe (<*>) (current picoToLatestTx) $ Just <$> sendSuccess + +-- autoTx <- switchHold never autoTxEv + +-- -- Transaction History +-- elClass "div" "text-2xl mb-2 font-semibold mt-8" $ text "History" + +-- let +-- historyItem tx = do +-- elClass "div" "transition pointer-events-none duration-1000 px-4 py-2 rounded bg-white mb-4 drop-shadow " $ do +-- elClass "div" "flex flex-row justify-between items-center" $ do +-- elClass "div" "flex flex-col mr-16" $ do +-- elClass "div" "text-gray-600" $ do +-- text "To " +-- dynText $ demoTx_to <$> tx +-- elClass "div" "text-xl" $ do +-- dynText $ T.pack . printf "%.2f" . lovelaceToAda . demoTx_amount <$> tx +-- text "ADA" + +-- elClass "div" "flex flex-row text-gray-400" $ do +-- elClass "div" "flex flex-col" $ do +-- elClass "div" "text-xs" $ text "Time" +-- elClass "div" "" $ do +-- dynText $ showAsMs . demoTx_time <$> tx +-- text "ms" + +-- let +-- noHistory = Map.null <$> latestTxs + +-- elDynClass "div" "overflow-y-scroll flex-grow" $ dyn_ $ ffor noHistory $ \case +-- True -> elClass "div" "text-gray-500" $ text "There is no history yet for this payment channel" +-- False -> do +-- _ <- elClass "div" "flex flex-col-reverse w-full" $ listWithKey latestTxs $ \_ tx -> historyItem tx +-- pure () + +-- pure autoTx diff --git a/frontend/src/HydraPay/Api.hs b/frontend/src/HydraPay/Api.hs new file mode 100644 index 0000000..00c299d --- /dev/null +++ b/frontend/src/HydraPay/Api.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE TemplateHaskell #-} + +module HydraPay.Api where + +import Data.Map +import Data.Int +import GHC.Generics +import Data.Aeson as Aeson +import qualified Data.Text as T +import Control.Applicative((<|>)) + +import Control.Lens.TH + +import Data.Fixed (Pico) +import Hydra.Types +import qualified HydraPay.Config as Config + +type HeadName = T.Text + +data HydraPayStats = HydraPayStats + { _hydraPayStats_heads :: Integer + , _hydraPayStats_nodes :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON HydraPayStats +instance FromJSON HydraPayStats + +data HeadCreate = HeadCreate + { headCreate_name :: HeadName + , headCreate_participants :: [Address] + } + deriving (Eq, Show, Generic) + +instance ToJSON HeadCreate +instance FromJSON HeadCreate + +data HeadInit = HeadInit + { headInit_name :: HeadName + , headInit_contestation :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON HeadInit +instance FromJSON HeadInit + +data HeadCommit = HeadCommit + { headCommit_name :: HeadName + , headCommit_participant :: Address + , headCommit_amount :: Lovelace + } + deriving (Eq, Show, Generic) + +instance ToJSON HeadCommit +instance FromJSON HeadCommit + +data HeadSubmitTx = HeadSubmitTx + { headSubmitTx_name :: HeadName + , headSubmitTx_toAddr :: Address + , amount :: Lovelace + } + deriving (Eq, Show, Generic) + +instance ToJSON HeadSubmitTx +instance FromJSON HeadSubmitTx + +-- This is the API json type that we need to send back out +data HeadStatus = HeadStatus + { headStatus_name :: HeadName + , headStatus_running :: Bool + , headStatus_status :: Status + , headStatus_balances :: Map Address Lovelace + } + deriving (Eq, Show, Generic) + +instance ToJSON HeadStatus +instance FromJSON HeadStatus + + +data Tagged a = Tagged + { tagged_id :: Int64 + , tagged_payload :: a + } + deriving (Eq, Show, Generic) + +instance ToJSON a => ToJSON (Tagged a) +instance FromJSON a => FromJSON (Tagged a) + +data HydraPayError + = InvalidPayload + | HeadCreationFailed + | NotEnoughParticipants + | HeadExists HeadName + | HeadDoesn'tExist + | NetworkIsn'tRunning + | FailedToBuildFundsTx + | NodeCommandFailed + -- ^ Anytime a command fails + | NotAParticipant + | ProcessError String + | NoValidUTXOToCommit + | InsufficientFunds + | FanoutNotPossible + | TxInvalid {utxo :: WholeUTXO, transaction :: Value, validationError :: ValidationError} + deriving (Eq, Show, Generic) + +instance ToJSON HydraPayError +instance FromJSON HydraPayError + +-- | State the head can be in, progressing linearly though the states. +data Status + = Status_Pending + | Status_Init + | Status_Committing + | Status_Open + | Status_Closed + | Status_Fanout + | Status_Finalized + deriving (Eq, Ord, Show, Generic) + +instance ToJSON Status +instance FromJSON Status + +data ClientMsg + = ClientHello + | Authenticate T.Text + | DoesHeadExist T.Text + | CreateHead HeadCreate + | InitHead HeadInit + | CommitHead HeadCommit + | CloseHead HeadName + + | TearDownHead HeadName + -- ^ Kills network and removes head + + | CheckFuel Address + | Withdraw Address + | GetAddTx TxType Address Lovelace + + | SubscribeTo HeadName + | SubmitHeadTx Address HeadSubmitTx + + | RestartDevnet + | GetStats + + | GetDevnetAddresses Integer -- Amount of addresses + + | GetL1Balance Address + | GetHeadBalance HeadName Address + + | LiveDocEzSubmitTx Tx Address + | GetIsManagedDevnet + | GetHydraPayMode + | GetProxyInfo Address + deriving (Eq, Show, Generic) + +instance ToJSON ClientMsg +instance FromJSON ClientMsg + +type Version = T.Text + +versionStr :: Version +versionStr = "0.1.0" + +data ServerMsg + = ServerHello Version + | OperationSuccess + | HeadInfo HeadStatus + | TxConfirmed Pico + | FundsTx Tx + | FuelAmount Lovelace + | SubscriptionStarted HeadName + | AlreadySubscribed HeadName + | InvalidMessage T.Text + | UnhandledMessage + | HeadExistsResult Bool + | DevnetRestarted + | ServerError HydraPayError + | HeadStatusChanged HeadName Status (Map Address Lovelace) + | NodeMessage Value + | DevnetAddresses [Address] + | CurrentStats HydraPayStats + | RequestError T.Text + | NotAuthenticated + | AuthResult Bool + | L1Balance Lovelace + | HeadBalance Lovelace + | BalanceChange HeadName (Map Address Lovelace) + | HeadRemoved HeadName + | ApiError T.Text + | HydraPayMode Config.HydraPayMode + | IsManagedDevnet Bool + | ProxyAddressInfo ProxyInfo + deriving (Eq, Show, Generic) + +instance ToJSON ServerMsg +instance FromJSON ServerMsg + +-- | Information about the managed proxy-address +-- for a specific address +data ProxyInfo = ProxyInfo + { proxyInfo_address :: Address + , proxyInfo_proxyAddress :: Address + , proxyInfo_balance :: Lovelace + , proxyInfo_fuel :: Lovelace + } + deriving (Eq, Show, Generic) + +instance ToJSON ProxyInfo +instance FromJSON ProxyInfo + +data ApiMsg + = TaggedMsg (Tagged ServerMsg) + | PlainMsg ServerMsg + +instance FromJSON ApiMsg where + parseJSON v = (TaggedMsg <$> parseJSON v) <|> (PlainMsg <$> parseJSON v) + +data Tx = Tx + { txType :: T.Text + , txDescription :: T.Text + , txCborHex :: T.Text + } + deriving (Eq, Show, Generic) + +instance ToJSON Tx where + toJSON (Tx t d c) = + object [ "type" .= t + , "description" .= d + , "cborHex" .= c + ] + +instance FromJSON Tx where + parseJSON = withObject "Tx" $ \v -> Tx + <$> v .: "type" + <*> v .: "description" + <*> v .: "cborHex" + +data TxType = + Funds | Fuel + deriving (Eq, Show, Generic) + +instance ToJSON TxType +instance FromJSON TxType + +isFuelType :: TxType -> Bool +isFuelType Fuel = True +isFuelType _ = False + +makeLenses ''HydraPayStats +makePrisms ''ApiMsg +makePrisms ''ServerMsg diff --git a/frontend/src/HydraPay/Config.hs b/frontend/src/HydraPay/Config.hs new file mode 100644 index 0000000..ad94778 --- /dev/null +++ b/frontend/src/HydraPay/Config.hs @@ -0,0 +1,45 @@ +module HydraPay.Config where + +import Data.Aeson.Types (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data HydraPayConfig = HydraPayConfig + { _hydraPayMode :: HydraPayMode + , _port :: Int + , _bind :: String + } + deriving (Show,Read) + +-- | Configure Cardano (L1) and Hydra networks. This is either an +-- explicit configuration for Cardano Node and Hydra Nodes, or the +-- default mode which runs a devnet for live documentation. +data HydraPayMode + = ManagedDevnetMode + | ConfiguredMode + { _cardanoNodeParams :: CardanoNodeParams + , _hydraNodeParams :: HydraNodeParams + } + deriving (Eq,Show,Read,Generic) + +instance ToJSON HydraPayMode +instance FromJSON HydraPayMode + +data CardanoNodeParams = CardanoNodeParams + { _testnetMagic :: Int + , _nodeSocket :: FilePath + , _ledgerGenesis :: FilePath + } + deriving (Eq,Show,Read,Generic) + +instance ToJSON CardanoNodeParams +instance FromJSON CardanoNodeParams + +data HydraNodeParams = HydraNodeParams + { _hydraScriptsTxId :: String + , _hydraLedgerProtocolParameters :: FilePath + , _hydraLedgerGenesis :: FilePath + } + deriving (Eq,Show,Read,Generic) + +instance ToJSON HydraNodeParams +instance FromJSON HydraNodeParams diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..a635e15 --- /dev/null +++ b/release.nix @@ -0,0 +1,5 @@ +let self = import ./. {}; +in +{ + inherit (self) exe; +} diff --git a/static/main.css b/static/main.css new file mode 100644 index 0000000..57c2d53 --- /dev/null +++ b/static/main.css @@ -0,0 +1,3 @@ +p { + color: red; +} \ No newline at end of file diff --git a/static/obelisk.jpg b/static/obelisk.jpg new file mode 100644 index 0000000..68c8682 Binary files /dev/null and b/static/obelisk.jpg differ