From d3c5d60f077814ac8ef68c66f2146b5a751dbb83 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Thu, 28 Nov 2019 15:46:14 -0800 Subject: [PATCH 01/10] Major module reorg --- .gitignore | 1 + bag-of-holding.cabal | 5 + exec/BOH.hs | 443 +------------------------------------------ exec/BOH/CLI.hs | 72 +++++++ exec/BOH/Signing.hs | 63 ++++++ exec/BOH/UI.hs | 350 ++++++++++++++++++++++++++++++++++ 6 files changed, 498 insertions(+), 436 deletions(-) create mode 100644 exec/BOH/CLI.hs create mode 100644 exec/BOH/Signing.hs create mode 100644 exec/BOH/UI.hs diff --git a/.gitignore b/.gitignore index 6c392f0..6e36113 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ .stack-work/* +*.dump-hi diff --git a/bag-of-holding.cabal b/bag-of-holding.cabal index ee7dec8..a42d7fd 100644 --- a/bag-of-holding.cabal +++ b/bag-of-holding.cabal @@ -51,6 +51,11 @@ executable boh ghc-options: -threaded -with-rtsopts=-N hs-source-dirs: exec main-is: BOH.hs + other-modules: + BOH.CLI + BOH.Signing + BOH.UI + build-depends: , bag-of-holding , brick >=0.47 && <0.50 diff --git a/exec/BOH.hs b/exec/BOH.hs index d632cc4..a545504 100644 --- a/exec/BOH.hs +++ b/exec/BOH.hs @@ -1,106 +1,24 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} module Main ( main ) where -import Brick -import qualified Brick.AttrMap as A -import Brick.BChan -import Brick.Focus -import Brick.Forms -import qualified Brick.Widgets.Border as B -import qualified Brick.Widgets.Center as C -import qualified Brick.Widgets.Edit as E +import BOH.CLI (Args(..), Env(..), env, pArgs) +import BOH.Signing (signApp) +import BOH.UI +import Brick (customMain) +import Brick.Focus (focusRing) import qualified Brick.Widgets.List as L -import Chainweb.HostAddress (HostAddress, hostAddressToBaseUrl) -import Chainweb.Utils (fromText, textOption, toText) import Chainweb.Version -import Control.Error.Util (hoistMaybe, hush, (!?)) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Aeson hiding (Options) -import Data.Aeson.Types (prependFailure, typeMismatch) -import Data.Bitraversable (bitraverse) -import Data.Generics.Product.Fields (field) -import Data.Generics.Product.Positions (position) -import Data.Generics.Sum.Constructors (_Ctor) -import Data.Generics.Wrapped (_Unwrapped) import qualified Graphics.Vty as V import Holding -import Lens.Micro -import Lens.Micro.Extras (preview) -import Network.HTTP.Client (newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) import qualified Network.Wai.Handler.Warp as W -import Network.Wai.Middleware.Cors import Options.Applicative hiding (command, footer, header, str) -import qualified Pact.Types.Command as P -import qualified Pact.Types.Runtime as P import RIO hiding (Handler, local, on) -import qualified RIO.ByteString.Lazy as BL -import qualified RIO.HashSet as HS -import qualified RIO.List as L import RIO.Partial (fromJust) -import qualified RIO.Seq as Seq -import qualified RIO.Text as T -import qualified RIO.Text.Lazy as TL -import Servant -import Servant.Client -import Text.Pretty.Simple (pShowNoColor) import Text.Printf (printf) --------------------------------------------------------------------------------- --- CLI Handling - --- | CLI arguments. -data Args = Args ChainwebVersion FilePath Account BaseUrl - -pArgs :: Parser Args -pArgs = Args - <$> pVersion - <*> strOption (long "keyfile" <> help "Path to key file") - <*> (Account <$> strOption (long "account" <> help "Account name")) - <*> pUrl - -pVersion :: Parser ChainwebVersion -pVersion = textOption - (long "version" <> metavar "VERSION" <> value defv - <> help ("Chainweb Network Version (default: " <> T.unpack (toText defv) <> ")")) - where - defv :: ChainwebVersion - defv = Mainnet01 - -pUrl :: Parser BaseUrl -pUrl = hostAddressToBaseUrl Https <$> host - where - host :: Parser HostAddress - host = textOption (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") - --- | The immutable runtime environment. -data Env = Env - { verOf :: !ChainwebVersion - , clenvOf :: !ClientEnv - , keysOf :: !Keys - , accOf :: !Account - , chanOf :: !(BChan SignReq) - , respOf :: !(TMVar (Maybe Signed)) } - deriving stock (Generic) - --- | From some CLI `Args`, form the immutable runtime environment. -env :: Args -> IO (Either Text Env) -env (Args v fp acc url) = runExceptT $ do - ks <- keysFromFile fp !? ("Could not decode key file: " <> T.pack fp) - mn <- lift $ newManager tlsManagerSettings - bc <- lift $ newBChan 1 - ts <- newEmptyTMVarIO - pure $ Env v (ClientEnv mn url Nothing) ks acc bc ts +--- main :: IO () main = execParser opts >>= env >>= \case @@ -124,350 +42,3 @@ main = execParser opts >>= env >>= \case opts :: ParserInfo Args opts = info (pArgs <**> helper) (fullDesc <> progDesc "The Bag of Holding: A Chainweb Wallet") - --------------------------------------------------------------------------------- --- Endpoint Calling - -call :: Env -> REPL -> IO TX -call e r@(REPL cid ep td c) = do - m <- meta (accOf e) cid - tx <- transaction (verOf e) td c (keysOf e) m - TX r <$> runClientM (f tx) (clenvOf e) - where - f :: Transaction -> ClientM From - f = case ep of - Local -> fmap T . local (verOf e) cid - Send -> fmap R . send (verOf e) cid - --------------------------------------------------------------------------------- --- Terminal UI - -type Listo = L.GenericList Name Seq TX - -data TX = TX REPL (Either ClientError From) - deriving stock (Generic) - -data Wallet = Wallet - { txsOf :: !Listo - , logOf :: !Text - , focOf :: !(FocusRing Name) - , replOf :: !(Form REPL SignReq Name) - , balsOf :: [(ChainId, Maybe Double)] - , reqOf :: Maybe SignReq } - deriving stock (Generic) - -data From = R Receipt | T TXResult deriving (Generic) - -data Endpoint = Local | Send deriving (Eq) - -data REPL = REPL { rcid :: !ChainId, re :: !Endpoint, dat :: !TxData, rpc :: !PactCode } - deriving stock (Generic) - --- | Resource names. -data Name = TXList | ReplChain | ReplLocal | ReplSend | ReplData | ReplCode - | Help | Balances | Sign - deriving stock (Eq, Ord, Show, Enum, Bounded) - -app :: Env -> App Wallet SignReq Name -app e = App { appDraw = draw e - , appChooseCursor = focusRingCursor focOf - , appHandleEvent = event e - , appStartEvent = pure - , appAttrMap = const $ A.attrMap V.defAttr attrs } - where - attrs :: [(AttrName, V.Attr)] - attrs = [ -- (L.listAttr, V.white `on` V.blue) - (L.listSelectedAttr, V.blue `on` V.white) - , (E.editAttr, V.white `on` V.black) - , (E.editFocusedAttr, V.black `on` V.yellow) - , (invalidFormInputAttr, V.white `on` V.red) - , (focusedFormInputAttr, V.black `on` V.yellow) ] - -draw :: Env -> Wallet -> [Widget Name] -draw e w = dispatch <> [ui] - where - ui :: Widget Name - ui = header <=> (left <+> right) <=> footer (logOf w) - - dispatch :: [Widget Name] - dispatch = case focusGetCurrent $ focOf w of - Just ReplCode -> [repl] - Just Help -> [he1p] - Just Balances -> [balances] - Just Sign -> [signing] - _ -> [] - - repl :: Widget Name - repl = C.centerLayer . vLimit 12 . hLimitPercent 50 - . B.borderWithLabel (txt " Pact Transaction ") - $ renderForm (replOf w) <=> C.hCenter (txt "[Esc] [Enter]") - - -- TODO Look into text wrapping. - he1p :: Widget Name - he1p = C.centerLayer . vLimit 16 . hLimitPercent 50 . B.borderWithLabel (txt " Help ") - $ vBox - [ C.hCenter . padBottom (Pad 1) $ txt "The Bag of Holding - A Chainweb Wallet" - , txt "Author: Colin Woodbury" - , txt "Issues: " <+> hyperlink url (txt url) - , txt $ "Chainweb: " <> toText (verOf e) - , txt $ "Account: " <> (accOf e ^. _Unwrapped) - , padTop (Pad 1) $ txt "A note on endpoints:" - , txt "LOCAL: Transaction is 'free', but results aren't" - , txt " saved to the blockchain. Returns instantly." - , txt "SEND: Transaction is mined into a block." - , txt " Costs gas and takes time for the results." - , padTop (Pad 1) $ C.hCenter (txt "Press any key.") ] - where - url = "github.com/kadena-community/bag-of-holding" - - -- | Display account balances on every chain. - balances :: Widget Name - balances = - C.centerLayer . vLimit 15 . hLimitPercent 50 . B.borderWithLabel (txt " Balances ") - $ vBox (map f $ balsOf w) <=> total <=> padTop (Pad 1) (C.hCenter $ txt "Press any key.") - where - total :: Widget w - total = txt "Total => " <+> str (show . sum . mapMaybe snd $ balsOf w) - - f :: (ChainId, Maybe Double) -> Widget Name - f (cid, md) = hBox - [ txt "Chain ", txt (toText cid), txt " => " - , str $ maybe "Balance check failed." show md ] - - signing :: Widget Name - signing = C.centerLayer . vLimit 12 . hLimitPercent 50 - . B.borderWithLabel (txt " Transaction Signing ") $ vBox $ - maybe [] reqContents (reqOf w) <> - [ C.hCenter . padTop (Pad 1) $ txt "[ESC] [Enter]" ] - where - reqContents :: SignReq -> [Widget Name] - reqContents sr = - [ txt $ _signReq_code sr - , padTop (Pad 1) . txt $ "Chain: " <> fromMaybe "Unknown" (_signReq_chainId sr) - , txt $ "Sender: " <> fromMaybe "Unknown" (_signReq_sender sr) - , txt $ "Gas: " <> maybe "Unknown" tshow (_signReq_gasLimit sr) - , C.hCenter . padTop (Pad 1) $ txt "Sign this Transaction?" ] - - -- TODO Consider `round` border style. - left :: Widget Name - left = hLimitPercent 50 $ B.borderWithLabel (txt " Transaction History ") txs - - txs :: Widget Name - txs | Seq.null (txsOf w ^. L.listElementsL) = txt "No transactions yet!" <+> fill ' ' - | otherwise = L.renderList (const txListItem) True $ txsOf w - - txListItem :: TX -> Widget Name - txListItem (TX (REPL cid ep _ pc) eef) = vLimit 1 $ hBox - [ hLimit 1 $ txt icon - , padLeft (Pad 2) . str $ printf "%02d" (chainIdInt cid :: Int) - , padLeft (Pad 2) $ txt end - , padLeft (Pad 2) . txt $ prettyCode pc - , fill ' ' ] - where - icon = case eef of - Left _ -> "☹" - Right (R _) -> "?" - Right (T t) -> maybe "☹" (const "✓") (t ^? pactValue) - end = case ep of - Local -> "LOCL" - Send -> "SEND" - - right :: Widget Name - right = B.borderWithLabel (txt " Transaction Result ") $ contents <=> fill ' ' - where - contents :: Widget Name - contents = case w ^? from of - Nothing -> txt "Select a Transaction." - Just (TX _ eef) -> case eef of - Left err -> txt . TL.toStrict $ pShowNoColor err - Right (T t) -> txt . tencode $ txr t - Right (R r) -> vBox [ txt $ prettyReceipt r - , padTop (Pad 1) $ txt "Press [Enter] to query the result." ] - -header :: Widget a -header = vLimit 1 . C.center $ txt " The Bag of Holding " - -footer :: Text -> Widget a -footer t = vLimit 1 $ txt (T.take 10 t) <+> C.hCenter legend - where - legend = txt "[T]ransaction - [B]alances - [H]elp - [Q]uit" - -replForm :: Env -> REPL -> Form REPL e Name -replForm e = newForm - [ label "Chain" @@= editField (field @"rcid") ReplChain Nothing - toText goodChain (txt . T.unlines) id - , label "Endpoint" @@= radioField (field @"re") - [(Local, ReplLocal, "Local"), (Send, ReplSend, "Send")] - , label "TX Data" @@= editField (field @"dat") ReplData Nothing - (decodeUtf8Lenient . BL.toStrict . encode) (decodeStrict' . encodeUtf8 . T.unlines) (txt . T.unlines) id - , label "Pact Code" @@= editField (field @"rpc") ReplCode Nothing - prettyCode (code . T.unlines) (txt . T.unlines) id - ] - where - label :: Text -> Widget Name -> Widget Name - label t w = padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ txt t <+> fill ' ') <+> w - - -- | Requires that the specified `ChainId` be a valid member of the Chain - -- Graph of the current `ChainwebVersion`. - goodChain :: [Text] -> Maybe ChainId - goodChain ts = do - cid <- chainIdFromText $ T.unlines ts - bool Nothing (Just cid) . HS.member cid . chainIds $ verOf e - -event :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) -event e w be = case focusGetCurrent $ focOf w of - Nothing -> continue w - Just TXList -> mainEvent e w be - Just Help -> simplePage w be - Just Balances -> simplePage w be - Just Sign -> signEvent e w be - Just _ -> replEvent e w be - -replEvent :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) -replEvent e w ev@(VtyEvent ve) = case ve of - -- Close Popup -- - V.EvKey V.KEsc [] -> continue (w & field @"focOf" %~ focusSetCurrent TXList) - - -- Submission -- - V.EvKey V.KEnter [] - | not (allFieldsValid $ replOf w) -> continue w - | otherwise -> do - t <- liftIO . call e . formState $ replOf w - continue $ w & field @"focOf" %~ focusSetCurrent TXList - & field @"txsOf" %~ (L.listMoveTo 0 . L.listInsert 0 t) - - -- Code Input -- - _ -> handleFormEventL (field @"replOf") w ev >>= continue - -replEvent _ w (AppEvent sr) = continue $ w & field @"reqOf" ?~ sr - & field @"focOf" %~ focusSetCurrent Sign -replEvent _ w _ = continue w - -signEvent :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) -signEvent e w (VtyEvent ve) = case ve of - -- Close Popup -- - V.EvKey V.KEsc [] -> do - liftIO . atomically $ putTMVar (respOf e) Nothing - continue (w & field @"focOf" %~ focusSetCurrent TXList) - - -- Sign the Transaction -- - V.EvKey V.KEnter [] -> do - liftIO $ for_ codeAndChain $ \(c, cid) -> do - m <- meta (accOf e) cid - -- TODO This should return the data that they gave, not `Null`! - tx <- view command <$> transaction (verOf e) (TxData Null) c (keysOf e) m - atomically $ putTMVar (respOf e) (Just . Signed tx $ toText cid) - continue $ w & field @"focOf" %~ focusSetCurrent TXList - & field @"reqOf" .~ Nothing - where - codeAndChain :: Maybe (PactCode, ChainId) - codeAndChain = do - sr <- reqOf w - c <- code $ _signReq_code sr - cid <- _signReq_chainId sr >>= fromText - pure (c, cid) - - _ -> continue w -signEvent _ w _ = continue w - --- | Display some simple page until any key is pressed. -simplePage :: Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) -simplePage w be = case be of - VtyEvent (V.EvKey _ []) -> continue (w & field @"focOf" %~ focusSetCurrent TXList) - AppEvent sr -> continue $ w & field @"reqOf" ?~ sr - & field @"focOf" %~ focusSetCurrent Sign - _ -> continue w - -mainEvent :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) -mainEvent e w (VtyEvent ve) = case ve of - -- Quit -- - V.EvKey (V.KChar 'q') [] -> halt w - - -- Transaction Form -- - V.EvKey (V.KChar 't') [] -> continue (w & field @"focOf" %~ focusSetCurrent ReplCode) - - -- Balance Check -- - V.EvKey (V.KChar 'b') [] -> do - txs <- liftIO $ mapConcurrently (bitraverse pure (traverse (call e))) rs - continue $ w & field @"focOf" %~ focusSetCurrent Balances - & field @"balsOf" .~ map (second ds) txs - where - cs = L.sort . toList . chainIds $ verOf e - cd = balance $ accOf e - rs = map (\cid -> (cid, REPL cid Local (TxData Null) <$> cd)) cs - ds = preview (_Just . position @2 . _Right . _Ctor @"T" . pactDouble) - - -- Help Window -- - V.EvKey (V.KChar 'h') [] -> continue (w & field @"focOf" %~ focusSetCurrent Help) - - -- History Selection -- - V.EvKey V.KEnter [] -> liftIO f >>= continue . fromMaybe w - where - f :: IO (Maybe Wallet) - f = runMaybeT $ do - TX (REPL cid _ _ _) eef <- hoistMaybe (w ^? from) - r <- hoistMaybe (eef ^? _Right . _Ctor @"R") - t <- MaybeT . fmap (join . hush) $ runClientM (listen (verOf e) cid r) (clenvOf e) - pure (w & field @"txsOf" %~ L.listModify (set (position @2) (Right $ T t))) - - -- Keyboard Navigation -- - ev -> do - l' <- L.handleListEventVi L.handleListEvent ev (txsOf w) - continue (w & field @"txsOf" .~ l') -mainEvent _ w (AppEvent sr) = continue $ w & field @"reqOf" ?~ sr - & field @"focOf" %~ focusSetCurrent Sign -mainEvent _ w _ = continue w - -from :: SimpleFold Wallet TX -from = field @"txsOf" . to L.listSelectedElement . _Just . _2 - --- | A missing primitive from `brick`. -handleFormEventL :: Eq n => Lens' s (Form x e n) -> s -> BrickEvent n e -> EventM n s -handleFormEventL l s ev = do - f' <- handleFormEvent ev (s ^. l) - pure (s & l .~ f') - --------------------------------------------------------------------------------- --- Signing Server - -type API = "v1" :> "sign" :> ReqBody '[JSON] SignReq :> Post '[JSON] Signed - -data SignReq = SignReq - { _signReq_code :: Text - , _signReq_data :: Maybe Object - , _signReq_nonce :: Maybe Text - , _signReq_chainId :: Maybe Text - , _signReq_gasLimit :: Maybe P.GasLimit - , _signReq_sender :: Maybe Text } - -instance FromJSON SignReq where - parseJSON (Object v) = SignReq - <$> v .: "code" - <*> v .:? "data" - <*> v .:? "nonce" - <*> v .:? "chainId" - <*> v .:? "gasLimit" - <*> v .:? "sender" - parseJSON invalid = - prependFailure "parsing SignReq failed, " $ typeMismatch "Object" invalid - -data Signed = Signed (P.Command Text) Text - -instance ToJSON Signed where - toJSON (Signed c t) = object [ "body" .= c, "chainId" .= t ] - -server :: BChan SignReq -> TMVar (Maybe Signed) -> Server API -server bc ts = sign - where - sign :: SignReq -> Handler Signed - sign sr = do - liftIO $ writeBChan bc sr - atomically (takeTMVar ts) >>= \case - Nothing -> throwM err401 - Just signed -> pure signed - -signApp :: BChan SignReq -> TMVar (Maybe Signed) -> Application -signApp bc ts = cors laxCors . serve (Proxy @API) $ server bc ts - where - laxCors :: a -> Maybe CorsResourcePolicy - laxCors _ = Just $ simpleCorsResourcePolicy { corsRequestHeaders = simpleHeaders } diff --git a/exec/BOH/CLI.hs b/exec/BOH/CLI.hs new file mode 100644 index 0000000..dfd9189 --- /dev/null +++ b/exec/BOH/CLI.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +module BOH.CLI + ( Env(..), env + , Args(..), pArgs + ) where + +import BOH.Signing (SignReq, Signed) +import Brick.BChan (BChan, newBChan) +import Chainweb.HostAddress (HostAddress, hostAddressToBaseUrl) +import Chainweb.Utils (textOption, toText) +import Chainweb.Version (ChainwebVersion(..)) +import Control.Error.Util ((!?)) +import Control.Monad.Trans.Except (runExceptT) +import Holding +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Options.Applicative hiding (command, footer, header, str) +import RIO +import qualified RIO.Text as T +import Servant.Client + +--- + +-- | CLI arguments. +data Args = Args ChainwebVersion FilePath Account BaseUrl + +pArgs :: Parser Args +pArgs = Args + <$> pVersion + <*> strOption (long "keyfile" <> help "Path to key file") + <*> (Account <$> strOption (long "account" <> help "Account name")) + <*> pUrl + +pVersion :: Parser ChainwebVersion +pVersion = textOption + (long "version" <> metavar "VERSION" <> value defv + <> help ("Chainweb Network Version (default: " <> T.unpack (toText defv) <> ")")) + where + defv :: ChainwebVersion + defv = Mainnet01 + +pUrl :: Parser BaseUrl +pUrl = hostAddressToBaseUrl Https <$> host + where + host :: Parser HostAddress + host = textOption (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") + +-- | The immutable runtime environment. +data Env = Env + { verOf :: !ChainwebVersion + , clenvOf :: !ClientEnv + , keysOf :: !Keys + , accOf :: !Account + , chanOf :: !(BChan SignReq) + , respOf :: !(TMVar (Maybe Signed)) } + deriving stock (Generic) + +-- | From some CLI `Args`, form the immutable runtime environment. +env :: Args -> IO (Either Text Env) +env (Args v fp acc url) = runExceptT $ do + ks <- keysFromFile fp !? ("Could not decode key file: " <> T.pack fp) + mn <- lift $ newManager tlsManagerSettings + bc <- lift $ newBChan 1 + ts <- newEmptyTMVarIO + pure $ Env { verOf = v + , clenvOf = ClientEnv mn url Nothing + , keysOf = ks + , accOf = acc + , chanOf = bc + , respOf = ts } diff --git a/exec/BOH/Signing.hs b/exec/BOH/Signing.hs new file mode 100644 index 0000000..c905654 --- /dev/null +++ b/exec/BOH/Signing.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module BOH.Signing + ( SignReq(..) + , Signed(..) + , signApp + ) where + +import Brick.BChan (BChan, writeBChan) +import Data.Aeson +import Data.Aeson.Types (prependFailure, typeMismatch) +import Network.Wai.Middleware.Cors +import qualified Pact.Types.Command as P +import qualified Pact.Types.Gas as P +import RIO hiding (Handler) +import Servant + +--- + +type API = "v1" :> "sign" :> ReqBody '[JSON] SignReq :> Post '[JSON] Signed + +data SignReq = SignReq + { _signReq_code :: Text + , _signReq_data :: Maybe Object + , _signReq_nonce :: Maybe Text + , _signReq_chainId :: Maybe Text + , _signReq_gasLimit :: Maybe P.GasLimit + , _signReq_sender :: Maybe Text } + +instance FromJSON SignReq where + parseJSON (Object v) = SignReq + <$> v .: "code" + <*> v .:? "data" + <*> v .:? "nonce" + <*> v .:? "chainId" + <*> v .:? "gasLimit" + <*> v .:? "sender" + parseJSON invalid = + prependFailure "parsing SignReq failed, " $ typeMismatch "Object" invalid + +data Signed = Signed (P.Command Text) Text + +instance ToJSON Signed where + toJSON (Signed c t) = object [ "body" .= c, "chainId" .= t ] + +server :: BChan SignReq -> TMVar (Maybe Signed) -> Server API +server bc ts = sign + where + sign :: SignReq -> Handler Signed + sign sr = do + liftIO $ writeBChan bc sr + atomically (takeTMVar ts) >>= \case + Nothing -> throwM err401 + Just signed -> pure signed + +signApp :: BChan SignReq -> TMVar (Maybe Signed) -> Application +signApp bc ts = cors laxCors . serve (Proxy @API) $ server bc ts + where + laxCors :: a -> Maybe CorsResourcePolicy + laxCors _ = Just $ simpleCorsResourcePolicy { corsRequestHeaders = simpleHeaders } diff --git a/exec/BOH/UI.hs b/exec/BOH/UI.hs new file mode 100644 index 0000000..37764e7 --- /dev/null +++ b/exec/BOH/UI.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module BOH.UI + ( Wallet(..) + , app + , Name(..) + , replForm + , REPL(..) + , Endpoint(..) + ) where + +import BOH.CLI (Env(..)) +import BOH.Signing (SignReq(..), Signed(..)) +import Brick +import qualified Brick.AttrMap as A +import Brick.Focus +import Brick.Forms +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Edit as E +import qualified Brick.Widgets.List as L +import Chainweb.Utils (fromText, toText) +import Chainweb.Version +import Control.Error.Util (hoistMaybe, hush) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Aeson (Value(..), decodeStrict', encode) +import Data.Bitraversable (bitraverse) +import Data.Generics.Product.Fields (field) +import Data.Generics.Product.Positions (position) +import Data.Generics.Sum.Constructors (_Ctor) +import Data.Generics.Wrapped (_Unwrapped) +import qualified Graphics.Vty as V +import Holding +import Lens.Micro +import Lens.Micro.Extras (preview) +import RIO hiding (local, on) +import qualified RIO.ByteString.Lazy as BL +import qualified RIO.HashSet as HS +import qualified RIO.List as L +import qualified RIO.Seq as Seq +import qualified RIO.Text as T +import qualified RIO.Text.Lazy as TL +import Servant.Client +import Text.Pretty.Simple (pShowNoColor) +import Text.Printf (printf) + +--- + +type Listo = L.GenericList Name Seq TX + +data TX = TX REPL (Either ClientError From) + deriving stock (Generic) + +data Wallet = Wallet + { txsOf :: !Listo + , logOf :: !Text + , focOf :: !(FocusRing Name) + , replOf :: !(Form REPL SignReq Name) + , balsOf :: [(ChainId, Maybe Double)] + , reqOf :: Maybe SignReq } + deriving stock (Generic) + +data From = R Receipt | T TXResult deriving (Generic) + +data Endpoint = Local | Send deriving (Eq) + +data REPL = REPL { rcid :: !ChainId, re :: !Endpoint, dat :: !TxData, rpc :: !PactCode } + deriving stock (Generic) + +-- | Resource names. +data Name = TXList | ReplChain | ReplLocal | ReplSend | ReplData | ReplCode + | Help | Balances | Sign + deriving stock (Eq, Ord, Show, Enum, Bounded) + +app :: Env -> App Wallet SignReq Name +app e = App { appDraw = draw e + , appChooseCursor = focusRingCursor focOf + , appHandleEvent = event e + , appStartEvent = pure + , appAttrMap = const $ A.attrMap V.defAttr attrs } + where + attrs :: [(AttrName, V.Attr)] + attrs = [ -- (L.listAttr, V.white `on` V.blue) + (L.listSelectedAttr, V.blue `on` V.white) + , (E.editAttr, V.white `on` V.black) + , (E.editFocusedAttr, V.black `on` V.yellow) + , (invalidFormInputAttr, V.white `on` V.red) + , (focusedFormInputAttr, V.black `on` V.yellow) ] + +draw :: Env -> Wallet -> [Widget Name] +draw e w = dispatch <> [ui] + where + ui :: Widget Name + ui = header <=> (left <+> right) <=> footer (logOf w) + + dispatch :: [Widget Name] + dispatch = case focusGetCurrent $ focOf w of + Just ReplCode -> [repl] + Just Help -> [he1p] + Just Balances -> [balances] + Just Sign -> [signing] + _ -> [] + + repl :: Widget Name + repl = C.centerLayer . vLimit 12 . hLimitPercent 50 + . B.borderWithLabel (txt " Pact Transaction ") + $ renderForm (replOf w) <=> C.hCenter (txt "[Esc] [Enter]") + + -- TODO Look into text wrapping. + he1p :: Widget Name + he1p = C.centerLayer . vLimit 16 . hLimitPercent 50 . B.borderWithLabel (txt " Help ") + $ vBox + [ C.hCenter . padBottom (Pad 1) $ txt "The Bag of Holding - A Chainweb Wallet" + , txt "Author: Colin Woodbury" + , txt "Issues: " <+> hyperlink url (txt url) + , txt $ "Chainweb: " <> toText (verOf e) + , txt $ "Account: " <> (accOf e ^. _Unwrapped) + , padTop (Pad 1) $ txt "A note on endpoints:" + , txt "LOCAL: Transaction is 'free', but results aren't" + , txt " saved to the blockchain. Returns instantly." + , txt "SEND: Transaction is mined into a block." + , txt " Costs gas and takes time for the results." + , padTop (Pad 1) $ C.hCenter (txt "Press any key.") ] + where + url = "github.com/kadena-community/bag-of-holding" + + -- | Display account balances on every chain. + balances :: Widget Name + balances = + C.centerLayer . vLimit 15 . hLimitPercent 50 . B.borderWithLabel (txt " Balances ") + $ vBox (map f $ balsOf w) <=> total <=> padTop (Pad 1) (C.hCenter $ txt "Press any key.") + where + total :: Widget w + total = txt "Total => " <+> str (show . sum . mapMaybe snd $ balsOf w) + + f :: (ChainId, Maybe Double) -> Widget Name + f (cid, md) = hBox + [ txt "Chain ", txt (toText cid), txt " => " + , str $ maybe "Balance check failed." show md ] + + signing :: Widget Name + signing = C.centerLayer . vLimit 12 . hLimitPercent 50 + . B.borderWithLabel (txt " Transaction Signing ") $ vBox $ + maybe [] reqContents (reqOf w) <> + [ C.hCenter . padTop (Pad 1) $ txt "[ESC] [Enter]" ] + where + reqContents :: SignReq -> [Widget Name] + reqContents sr = + [ txt $ _signReq_code sr + , padTop (Pad 1) . txt $ "Chain: " <> fromMaybe "Unknown" (_signReq_chainId sr) + , txt $ "Sender: " <> fromMaybe "Unknown" (_signReq_sender sr) + , txt $ "Gas: " <> maybe "Unknown" tshow (_signReq_gasLimit sr) + , C.hCenter . padTop (Pad 1) $ txt "Sign this Transaction?" ] + + -- TODO Consider `round` border style. + left :: Widget Name + left = hLimitPercent 50 $ B.borderWithLabel (txt " Transaction History ") txs + + txs :: Widget Name + txs | Seq.null (txsOf w ^. L.listElementsL) = txt "No transactions yet!" <+> fill ' ' + | otherwise = L.renderList (const txListItem) True $ txsOf w + + txListItem :: TX -> Widget Name + txListItem (TX (REPL cid ep _ pc) eef) = vLimit 1 $ hBox + [ hLimit 1 $ txt icon + , padLeft (Pad 2) . str $ printf "%02d" (chainIdInt cid :: Int) + , padLeft (Pad 2) $ txt end + , padLeft (Pad 2) . txt $ prettyCode pc + , fill ' ' ] + where + icon = case eef of + Left _ -> "☹" + Right (R _) -> "?" + Right (T t) -> maybe "☹" (const "✓") (t ^? pactValue) + end = case ep of + Local -> "LOCL" + Send -> "SEND" + + right :: Widget Name + right = B.borderWithLabel (txt " Transaction Result ") $ contents <=> fill ' ' + where + contents :: Widget Name + contents = case w ^? from of + Nothing -> txt "Select a Transaction." + Just (TX _ eef) -> case eef of + Left err -> txt . TL.toStrict $ pShowNoColor err + Right (T t) -> txt . tencode $ txr t + Right (R r) -> vBox [ txt $ prettyReceipt r + , padTop (Pad 1) $ txt "Press [Enter] to query the result." ] + +header :: Widget a +header = vLimit 1 . C.center $ txt " The Bag of Holding " + +footer :: Text -> Widget a +footer t = vLimit 1 $ txt (T.take 10 t) <+> C.hCenter legend + where + legend = txt "[T]ransaction - [B]alances - [H]elp - [Q]uit" + +replForm :: Env -> REPL -> Form REPL e Name +replForm e = newForm + [ label "Chain" @@= editField (field @"rcid") ReplChain Nothing + toText goodChain (txt . T.unlines) id + , label "Endpoint" @@= radioField (field @"re") + [(Local, ReplLocal, "Local"), (Send, ReplSend, "Send")] + , label "TX Data" @@= editField (field @"dat") ReplData Nothing + (decodeUtf8Lenient . BL.toStrict . encode) (decodeStrict' . encodeUtf8 . T.unlines) (txt . T.unlines) id + , label "Pact Code" @@= editField (field @"rpc") ReplCode Nothing + prettyCode (code . T.unlines) (txt . T.unlines) id + ] + where + label :: Text -> Widget Name -> Widget Name + label t w = padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ txt t <+> fill ' ') <+> w + + -- | Requires that the specified `ChainId` be a valid member of the Chain + -- Graph of the current `ChainwebVersion`. + goodChain :: [Text] -> Maybe ChainId + goodChain ts = do + cid <- chainIdFromText $ T.unlines ts + bool Nothing (Just cid) . HS.member cid . chainIds $ verOf e + +event :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) +event e w be = case focusGetCurrent $ focOf w of + Nothing -> continue w + Just TXList -> mainEvent e w be + Just Help -> simplePage w be + Just Balances -> simplePage w be + Just Sign -> signEvent e w be + Just _ -> replEvent e w be + +replEvent :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) +replEvent e w ev@(VtyEvent ve) = case ve of + -- Close Popup -- + V.EvKey V.KEsc [] -> continue (w & field @"focOf" %~ focusSetCurrent TXList) + + -- Submission -- + V.EvKey V.KEnter [] + | not (allFieldsValid $ replOf w) -> continue w + | otherwise -> do + t <- liftIO . call e . formState $ replOf w + continue $ w & field @"focOf" %~ focusSetCurrent TXList + & field @"txsOf" %~ (L.listMoveTo 0 . L.listInsert 0 t) + + -- Code Input -- + _ -> handleFormEventL (field @"replOf") w ev >>= continue + +replEvent _ w (AppEvent sr) = continue $ w & field @"reqOf" ?~ sr + & field @"focOf" %~ focusSetCurrent Sign +replEvent _ w _ = continue w + +signEvent :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) +signEvent e w (VtyEvent ve) = case ve of + -- Close Popup -- + V.EvKey V.KEsc [] -> do + liftIO . atomically $ putTMVar (respOf e) Nothing + continue (w & field @"focOf" %~ focusSetCurrent TXList) + + -- Sign the Transaction -- + V.EvKey V.KEnter [] -> do + liftIO $ for_ codeAndChain $ \(c, cid) -> do + m <- meta (accOf e) cid + -- TODO This should return the data that they gave, not `Null`! + tx <- view command <$> transaction (verOf e) (TxData Null) c (keysOf e) m + atomically $ putTMVar (respOf e) (Just . Signed tx $ toText cid) + continue $ w & field @"focOf" %~ focusSetCurrent TXList + & field @"reqOf" .~ Nothing + where + codeAndChain :: Maybe (PactCode, ChainId) + codeAndChain = do + sr <- reqOf w + c <- code $ _signReq_code sr + cid <- _signReq_chainId sr >>= fromText + pure (c, cid) + + _ -> continue w +signEvent _ w _ = continue w + +-- | Display some simple page until any key is pressed. +simplePage :: Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) +simplePage w be = case be of + VtyEvent (V.EvKey _ []) -> continue (w & field @"focOf" %~ focusSetCurrent TXList) + AppEvent sr -> continue $ w & field @"reqOf" ?~ sr + & field @"focOf" %~ focusSetCurrent Sign + _ -> continue w + +mainEvent :: Env -> Wallet -> BrickEvent Name SignReq -> EventM Name (Next Wallet) +mainEvent e w (VtyEvent ve) = case ve of + -- Quit -- + V.EvKey (V.KChar 'q') [] -> halt w + + -- Transaction Form -- + V.EvKey (V.KChar 't') [] -> continue (w & field @"focOf" %~ focusSetCurrent ReplCode) + + -- Balance Check -- + V.EvKey (V.KChar 'b') [] -> do + txs <- liftIO $ mapConcurrently (bitraverse pure (traverse (call e))) rs + continue $ w & field @"focOf" %~ focusSetCurrent Balances + & field @"balsOf" .~ map (second ds) txs + where + cs = L.sort . toList . chainIds $ verOf e + cd = balance $ accOf e + rs = map (\cid -> (cid, REPL cid Local (TxData Null) <$> cd)) cs + ds = preview (_Just . position @2 . _Right . _Ctor @"T" . pactDouble) + + -- Help Window -- + V.EvKey (V.KChar 'h') [] -> continue (w & field @"focOf" %~ focusSetCurrent Help) + + -- History Selection -- + V.EvKey V.KEnter [] -> liftIO f >>= continue . fromMaybe w + where + f :: IO (Maybe Wallet) + f = runMaybeT $ do + TX (REPL cid _ _ _) eef <- hoistMaybe (w ^? from) + r <- hoistMaybe (eef ^? _Right . _Ctor @"R") + t <- MaybeT . fmap (join . hush) $ runClientM (listen (verOf e) cid r) (clenvOf e) + pure (w & field @"txsOf" %~ L.listModify (set (position @2) (Right $ T t))) + + -- Keyboard Navigation -- + ev -> do + l' <- L.handleListEventVi L.handleListEvent ev (txsOf w) + continue (w & field @"txsOf" .~ l') +mainEvent _ w (AppEvent sr) = continue $ w & field @"reqOf" ?~ sr + & field @"focOf" %~ focusSetCurrent Sign +mainEvent _ w _ = continue w + +from :: SimpleFold Wallet TX +from = field @"txsOf" . to L.listSelectedElement . _Just . _2 + +-- | A missing primitive from `brick`. +handleFormEventL :: Eq n => Lens' s (Form x e n) -> s -> BrickEvent n e -> EventM n s +handleFormEventL l s ev = do + f' <- handleFormEvent ev (s ^. l) + pure (s & l .~ f') + +-------------------------------------------------------------------------------- +-- Endpoint Calling + +call :: Env -> REPL -> IO TX +call e r@(REPL cid ep td c) = do + m <- meta (accOf e) cid + tx <- transaction (verOf e) td c (keysOf e) m + TX r <$> runClientM (f tx) (clenvOf e) + where + f :: Transaction -> ClientM From + f = case ep of + Local -> fmap T . local (verOf e) cid + Send -> fmap R . send (verOf e) cid From 104d4c64db722ada0e092a8d758f9889ff3f10fa Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Thu, 28 Nov 2019 15:53:11 -0800 Subject: [PATCH 02/10] Preliminary massaging before chainweb rip-out --- exec/BOH.hs | 2 +- exec/BOH/UI.hs | 11 +++++++---- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/exec/BOH.hs b/exec/BOH.hs index a545504..82b3eba 100644 --- a/exec/BOH.hs +++ b/exec/BOH.hs @@ -8,7 +8,7 @@ import BOH.UI import Brick (customMain) import Brick.Focus (focusRing) import qualified Brick.Widgets.List as L -import Chainweb.Version +import Chainweb.Version (unsafeChainId) import Data.Aeson hiding (Options) import qualified Graphics.Vty as V import Holding diff --git a/exec/BOH/UI.hs b/exec/BOH/UI.hs index 37764e7..335af91 100644 --- a/exec/BOH/UI.hs +++ b/exec/BOH/UI.hs @@ -5,12 +5,14 @@ {-# LANGUAGE TypeApplications #-} module BOH.UI - ( Wallet(..) + ( -- * Types + Wallet(..) + , Name(TXList) + , REPL(..) + , Endpoint(Local) + -- * UI , app - , Name(..) , replForm - , REPL(..) - , Endpoint(..) ) where import BOH.CLI (Env(..)) @@ -25,6 +27,7 @@ import qualified Brick.Widgets.Edit as E import qualified Brick.Widgets.List as L import Chainweb.Utils (fromText, toText) import Chainweb.Version + (ChainId, chainIdFromText, chainIdInt, chainIds) import Control.Error.Util (hoistMaybe, hush) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Aeson (Value(..), decodeStrict', encode) From fc8a55ec057ce82e77af41f0f6ef9425557e6b98 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Thu, 28 Nov 2019 16:31:21 -0800 Subject: [PATCH 03/10] First pass at excising Chainweb dep --- bag-of-holding.cabal | 5 ++++- exec/BOH.hs | 4 ++-- exec/BOH/CLI.hs | 15 +++++++++------ exec/BOH/UI.hs | 16 +++++++--------- lib/Holding.hs | 12 +++++------- 5 files changed, 27 insertions(+), 25 deletions(-) diff --git a/bag-of-holding.cabal b/bag-of-holding.cabal index a42d7fd..4b48e1d 100644 --- a/bag-of-holding.cabal +++ b/bag-of-holding.cabal @@ -39,7 +39,10 @@ common commons library import: commons hs-source-dirs: lib - exposed-modules: Holding + exposed-modules: + Holding + Holding.Chainweb + build-depends: , prettyprinter ^>=1.2 , servant ^>=0.16 diff --git a/exec/BOH.hs b/exec/BOH.hs index 82b3eba..aa4d2df 100644 --- a/exec/BOH.hs +++ b/exec/BOH.hs @@ -8,10 +8,10 @@ import BOH.UI import Brick (customMain) import Brick.Focus (focusRing) import qualified Brick.Widgets.List as L -import Chainweb.Version (unsafeChainId) import Data.Aeson hiding (Options) import qualified Graphics.Vty as V import Holding +import Holding.Chainweb import qualified Network.Wai.Handler.Warp as W import Options.Applicative hiding (command, footer, header, str) import RIO hiding (Handler, local, on) @@ -36,7 +36,7 @@ main = execParser opts >>= env >>= \case (L.list TXList mempty 1) "" (focusRing [minBound ..]) - (replForm e . REPL (unsafeChainId 0) Local (TxData Null) . fromJust $ code "(+ 1 1)") [] + (replForm e . REPL (ChainId 0) Local (TxData Null) . fromJust $ code "(+ 1 1)") [] Nothing opts :: ParserInfo Args diff --git a/exec/BOH/CLI.hs b/exec/BOH/CLI.hs index dfd9189..b74c504 100644 --- a/exec/BOH/CLI.hs +++ b/exec/BOH/CLI.hs @@ -9,11 +9,11 @@ module BOH.CLI import BOH.Signing (SignReq, Signed) import Brick.BChan (BChan, newBChan) import Chainweb.HostAddress (HostAddress, hostAddressToBaseUrl) -import Chainweb.Utils (textOption, toText) -import Chainweb.Version (ChainwebVersion(..)) -import Control.Error.Util ((!?)) +import Chainweb.Utils (textOption) +import Control.Error.Util (note, (!?)) import Control.Monad.Trans.Except (runExceptT) import Holding +import Holding.Chainweb import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Options.Applicative hiding (command, footer, header, str) @@ -34,12 +34,15 @@ pArgs = Args <*> pUrl pVersion :: Parser ChainwebVersion -pVersion = textOption +pVersion = option p (long "version" <> metavar "VERSION" <> value defv - <> help ("Chainweb Network Version (default: " <> T.unpack (toText defv) <> ")")) + <> help ("Chainweb Network Version (default: " <> T.unpack (vText defv) <> ")")) where + p :: ReadM ChainwebVersion + p = eitherReader (\v -> note ("Invalid Chainweb Version given: " <> v) $ verP v) + defv :: ChainwebVersion - defv = Mainnet01 + defv = Mainnet pUrl :: Parser BaseUrl pUrl = hostAddressToBaseUrl Https <$> host diff --git a/exec/BOH/UI.hs b/exec/BOH/UI.hs index 335af91..19ab0f0 100644 --- a/exec/BOH/UI.hs +++ b/exec/BOH/UI.hs @@ -25,9 +25,6 @@ import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Edit as E import qualified Brick.Widgets.List as L -import Chainweb.Utils (fromText, toText) -import Chainweb.Version - (ChainId, chainIdFromText, chainIdInt, chainIds) import Control.Error.Util (hoistMaybe, hush) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Aeson (Value(..), decodeStrict', encode) @@ -38,6 +35,7 @@ import Data.Generics.Sum.Constructors (_Ctor) import Data.Generics.Wrapped (_Unwrapped) import qualified Graphics.Vty as V import Holding +import Holding.Chainweb import Lens.Micro import Lens.Micro.Extras (preview) import RIO hiding (local, on) @@ -120,7 +118,7 @@ draw e w = dispatch <> [ui] [ C.hCenter . padBottom (Pad 1) $ txt "The Bag of Holding - A Chainweb Wallet" , txt "Author: Colin Woodbury" , txt "Issues: " <+> hyperlink url (txt url) - , txt $ "Chainweb: " <> toText (verOf e) + , txt $ "Chainweb: " <> vText (verOf e) , txt $ "Account: " <> (accOf e ^. _Unwrapped) , padTop (Pad 1) $ txt "A note on endpoints:" , txt "LOCAL: Transaction is 'free', but results aren't" @@ -142,7 +140,7 @@ draw e w = dispatch <> [ui] f :: (ChainId, Maybe Double) -> Widget Name f (cid, md) = hBox - [ txt "Chain ", txt (toText cid), txt " => " + [ txt "Chain ", txt (chainIdToText cid), txt " => " , str $ maybe "Balance check failed." show md ] signing :: Widget Name @@ -170,7 +168,7 @@ draw e w = dispatch <> [ui] txListItem :: TX -> Widget Name txListItem (TX (REPL cid ep _ pc) eef) = vLimit 1 $ hBox [ hLimit 1 $ txt icon - , padLeft (Pad 2) . str $ printf "%02d" (chainIdInt cid :: Int) + , padLeft (Pad 2) . str . printf "%02d" $ chainIdInt cid , padLeft (Pad 2) $ txt end , padLeft (Pad 2) . txt $ prettyCode pc , fill ' ' ] @@ -206,7 +204,7 @@ footer t = vLimit 1 $ txt (T.take 10 t) <+> C.hCenter legend replForm :: Env -> REPL -> Form REPL e Name replForm e = newForm [ label "Chain" @@= editField (field @"rcid") ReplChain Nothing - toText goodChain (txt . T.unlines) id + chainIdToText goodChain (txt . T.unlines) id , label "Endpoint" @@= radioField (field @"re") [(Local, ReplLocal, "Local"), (Send, ReplSend, "Send")] , label "TX Data" @@= editField (field @"dat") ReplData Nothing @@ -267,7 +265,7 @@ signEvent e w (VtyEvent ve) = case ve of m <- meta (accOf e) cid -- TODO This should return the data that they gave, not `Null`! tx <- view command <$> transaction (verOf e) (TxData Null) c (keysOf e) m - atomically $ putTMVar (respOf e) (Just . Signed tx $ toText cid) + atomically $ putTMVar (respOf e) (Just . Signed tx $ chainIdToText cid) continue $ w & field @"focOf" %~ focusSetCurrent TXList & field @"reqOf" .~ Nothing where @@ -275,7 +273,7 @@ signEvent e w (VtyEvent ve) = case ve of codeAndChain = do sr <- reqOf w c <- code $ _signReq_code sr - cid <- _signReq_chainId sr >>= fromText + cid <- _signReq_chainId sr >>= chainIdFromText pure (c, cid) _ -> continue w diff --git a/lib/Holding.hs b/lib/Holding.hs index 1fdbf2a..bf52ffe 100644 --- a/lib/Holding.hs +++ b/lib/Holding.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -49,18 +49,16 @@ module Holding , cute ) where -import Chainweb.Pact.RestAPI (pactApi) -import Chainweb.Version import Control.Error.Util (hush) import Data.Aeson import Data.Aeson.Types (prependFailure, typeMismatch) import Data.Generics.Sum.Constructors (_Ctor) import Data.Generics.Wrapped (_Unwrapped) -import Data.Singletons import Data.Text.Prettyprint.Doc (defaultLayoutOptions, layoutPretty) import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Yaml.Pretty (defConfig, encodePretty) +import Holding.Chainweb import Lens.Micro (SimpleFold, Traversal', _Right) import qualified Pact.ApiReq as P import qualified Pact.Compile as P @@ -181,7 +179,7 @@ transaction v (TxData td) (PactCode pc) (Keys ks) pm = Transaction <$> P.mkExec (T.unpack pc) td pm [(ks, mempty)] nid Nothing where nid :: Maybe P.NetworkId - nid = Just . P.NetworkId $ chainwebVersionToText v + nid = Just . P.NetworkId $ vText v newtype TxData = TxData Value deriving newtype (ToJSON, FromJSON) @@ -271,8 +269,8 @@ clients :<|> (P.Poll -> ClientM P.PollResponses) :<|> (P.ListenerRequest -> ClientM P.ListenResponse) :<|> (P.Command Text -> ClientM (P.CommandResult P.Hash)) -clients (FromSing (SChainwebVersion :: Sing v)) (FromSing (SChainId :: Sing cid)) = - client (pactApi @v @cid) +clients _ _ = undefined + -- client (pactApi @v @cid) -------------------------------------------------------------------------------- -- Coin Contract Functions From bb6698c23146c69a326fc52a5fbb92ad9d93c823 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Thu, 28 Nov 2019 16:43:16 -0800 Subject: [PATCH 04/10] Chainweb dependency dropped --- bag-of-holding.cabal | 1 - exec/BOH/CLI.hs | 7 +++---- lib/Holding.hs | 2 +- stack.yaml | 20 -------------------- 4 files changed, 4 insertions(+), 26 deletions(-) diff --git a/bag-of-holding.cabal b/bag-of-holding.cabal index 4b48e1d..761087e 100644 --- a/bag-of-holding.cabal +++ b/bag-of-holding.cabal @@ -28,7 +28,6 @@ common commons build-depends: , aeson ^>=1.4 , base >=4.12 && <5 - , chainweb ^>=1.0 , errors ^>=2.3 , generic-lens >=1.1 && <1.3 , microlens ^>=0.4 diff --git a/exec/BOH/CLI.hs b/exec/BOH/CLI.hs index b74c504..9917b9c 100644 --- a/exec/BOH/CLI.hs +++ b/exec/BOH/CLI.hs @@ -8,8 +8,6 @@ module BOH.CLI import BOH.Signing (SignReq, Signed) import Brick.BChan (BChan, newBChan) -import Chainweb.HostAddress (HostAddress, hostAddressToBaseUrl) -import Chainweb.Utils (textOption) import Control.Error.Util (note, (!?)) import Control.Monad.Trans.Except (runExceptT) import Holding @@ -45,10 +43,11 @@ pVersion = option p defv = Mainnet pUrl :: Parser BaseUrl -pUrl = hostAddressToBaseUrl Https <$> host +pUrl = hostAddressToBaseUrl <$> host where host :: Parser HostAddress - host = textOption (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") + host = option (eitherReader (note "Invalid host" . hostAddressP)) + (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") -- | The immutable runtime environment. data Env = Env diff --git a/lib/Holding.hs b/lib/Holding.hs index bf52ffe..02a2f86 100644 --- a/lib/Holding.hs +++ b/lib/Holding.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} diff --git a/stack.yaml b/stack.yaml index 6192cf9..a83fb60 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,26 +10,6 @@ extra-deps: - github: kadena-io/thyme commit: 6ee9fcb026ebdb49b810802a981d166680d867c9 - # --- Transitive Chainweb Dependencies --- # - # Most of this can be removed once a `chainweb-types` repo is created. - - QuickCheck-GenT-0.2.0 - - bloomfilter-2.0.1.0 - - digraph-0.1.0.2 - - fake-0.1.1.2 - - generic-lens-1.2.0.1 - - loglevel-0.1.0.0 - - merkle-log-0.1.0.0 - - mwc-probability-2.0.4 - - paths-0.2.0.0 - - streaming-events-1.0.0 - - strict-tuple-0.1.3 - - tls-1.5.2 - - yet-another-logger-0.3.1 - # --- Custom Pins --- # - - github: kadena-io/chainweb-node - commit: dcc25bad55930385b2c7b25226071ea321288718 - github: kadena-io/pact commit: 084e129bb38010ef0d0d2b84a0708d1877cdd9ed - - github: kadena-io/chainweb-storage - commit: 17a5fb130926582eff081eeb1b94cb6c7097c67a From 4d40ae3186591c4dacdf50bbc36976824ade7162 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Thu, 28 Nov 2019 16:45:38 -0800 Subject: [PATCH 05/10] One step closer --- exec/BOH/CLI.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/exec/BOH/CLI.hs b/exec/BOH/CLI.hs index 9917b9c..55dce61 100644 --- a/exec/BOH/CLI.hs +++ b/exec/BOH/CLI.hs @@ -43,11 +43,11 @@ pVersion = option p defv = Mainnet pUrl :: Parser BaseUrl -pUrl = hostAddressToBaseUrl <$> host +pUrl = option (eitherReader pBaseUrl) + (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") where - host :: Parser HostAddress - host = option (eitherReader (note "Invalid host" . hostAddressP)) - (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") + pBaseUrl :: String -> Either String BaseUrl + pBaseUrl = undefined -- | The immutable runtime environment. data Env = Env From 88986a853f183d11cd0f55efb91c7e4a27707737 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Thu, 28 Nov 2019 16:56:54 -0800 Subject: [PATCH 06/10] BaseUrl parser --- exec/BOH/CLI.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/exec/BOH/CLI.hs b/exec/BOH/CLI.hs index 55dce61..1c81103 100644 --- a/exec/BOH/CLI.hs +++ b/exec/BOH/CLI.hs @@ -16,6 +16,7 @@ import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Options.Applicative hiding (command, footer, header, str) import RIO +import qualified RIO.List as L import qualified RIO.Text as T import Servant.Client @@ -47,7 +48,12 @@ pUrl = option (eitherReader pBaseUrl) (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") where pBaseUrl :: String -> Either String BaseUrl - pBaseUrl = undefined + pBaseUrl s = case L.break (== ':') s of + ([],_) -> Left "Empty input" + (h, ':' : mp) -> case readMaybe mp of + Nothing -> Left "Malformed port" + Just p -> Right $ BaseUrl Https h p "" + _ -> Left "Bad url/port" -- | The immutable runtime environment. data Env = Env From f23548b1585be22d90f24ebc4ec341de8a83932e Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Fri, 29 Nov 2019 09:50:23 -0800 Subject: [PATCH 07/10] Chainweb shim module --- lib/Holding/Chainweb.hs | 61 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 lib/Holding/Chainweb.hs diff --git a/lib/Holding/Chainweb.hs b/lib/Holding/Chainweb.hs new file mode 100644 index 0000000..6c199fd --- /dev/null +++ b/lib/Holding/Chainweb.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module: Holding.Chainweb +-- Copyright: Copyright © 2019 Colin Woodbury +-- License: BSD3 +-- Maintainer: Colin Woodbury +-- Stability: experimental +-- +-- This module is a reimplementation of certain Chainweb types / functionality, +-- to avoid depending on it in its entirety. +-- + +module Holding.Chainweb + ( -- * ChainwebVersion + ChainwebVersion(..) + , vText, verP + -- * ChainId + , ChainId(..) + , chainIdToText, chainIdFromText + , chainIds + ) where + +import RIO +import qualified RIO.HashSet as HS +import qualified RIO.Text as T +import Servant.API + +--- + +data ChainwebVersion = Testnet | Mainnet + +instance ToHttpApiData ChainwebVersion where + toUrlPiece = vText + +chainIds :: ChainwebVersion -> HashSet ChainId +chainIds Testnet = HS.fromList [0 .. 9] +chainIds Mainnet = HS.fromList [0 .. 9] + +vText :: ChainwebVersion -> Text +vText Testnet = "testnet03" +vText Mainnet = "mainnet01" + +verP :: String -> Maybe ChainwebVersion +verP "testnet03" = Just Testnet +verP "mainnet01" = Just Mainnet +verP _ = Nothing + +newtype ChainId = ChainId { chainIdInt :: Word } + deriving stock (Eq, Ord) + deriving newtype (Num, Enum, Hashable) + +instance ToHttpApiData ChainId where + toUrlPiece = chainIdToText + +chainIdToText :: ChainId -> Text +chainIdToText (ChainId n) = T.pack $ show n + +chainIdFromText :: Text -> Maybe ChainId +chainIdFromText = fmap ChainId . readMaybe . T.unpack From 81b1c1aadcb9ceb1e1720740e7db61b9165789e3 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Fri, 29 Nov 2019 09:50:39 -0800 Subject: [PATCH 08/10] Hand write the Pact API --- lib/Holding.hs | 83 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 63 insertions(+), 20 deletions(-) diff --git a/lib/Holding.hs b/lib/Holding.hs index 02a2f86..3360cba 100644 --- a/lib/Holding.hs +++ b/lib/Holding.hs @@ -226,22 +226,71 @@ pactDouble = pactValue . _Ctor @"PLiteral" . _Ctor @"LDecimal" . to realToFrac -------------------------------------------------------------------------------- -- Endpoint Calls +type PactAPI = SendAPI :<|> PollAPI :<|> ListenAPI :<|> LocalAPI + +type SendAPI = "chainweb" + :> "0.0" + :> Capture "version" ChainwebVersion + :> "chain" + :> Capture "chainId" ChainId + :> "pact" + :> "api" + :> "v1" + :> "send" + :> ReqBody '[JSON] P.SubmitBatch + :> Post '[JSON] P.RequestKeys + +type PollAPI = "chainweb" + :> "0.0" + :> Capture "version" ChainwebVersion + :> "chain" + :> Capture "chainId" ChainId + :> "pact" + :> "api" + :> "v1" + :> "poll" + :> ReqBody '[JSON] P.Poll + :> Post '[JSON] P.PollResponses + +type ListenAPI = "chainweb" + :> "0.0" + :> Capture "version" ChainwebVersion + :> "chain" + :> Capture "chainId" ChainId + :> "pact" + :> "api" + :> "v1" + :> "listen" + :> ReqBody '[JSON] P.ListenerRequest + :> Post '[JSON] P.ListenResponse + +type LocalAPI = "chainweb" + :> "0.0" + :> Capture "version" ChainwebVersion + :> "chain" + :> Capture "chainId" ChainId + :> "pact" + :> "api" + :> "v1" + :> "local" + :> ReqBody '[JSON] (P.Command Text) + :> Post '[JSON] (P.CommandResult P.Hash) + -- | Submit a `Transaction` to Chainweb. This will cost gas, and the associated -- `Account` will be charged. send :: ChainwebVersion -> ChainId -> Transaction -> ClientM Receipt -send v cid (Transaction tx) = case clients v cid of - f :<|> _ -> Receipt . NEL.head . P._rkRequestKeys <$> f (P.SubmitBatch $ pure tx) +send v cid (Transaction tx) = + Receipt . NEL.head . P._rkRequestKeys <$> send' v cid (P.SubmitBatch $ pure tx) sends :: ChainwebVersion -> ChainId -> NonEmpty Transaction -> ClientM Receipts -sends v cid txs = case clients v cid of - f :<|> _ -> Receipts . P._rkRequestKeys <$> f (P.SubmitBatch $ NEL.map cmdt txs) +sends v cid txs = + Receipts . P._rkRequestKeys <$> send' v cid (P.SubmitBatch $ NEL.map cmdt txs) -- | A quick peek into the status of a `Transaction`. Unlike `listen`, this is -- non-blocking and so will always return right away, even when the -- `Transaction` has not completed. poll :: ChainwebVersion -> ChainId -> Receipt -> ClientM (Maybe TXResult) -poll v cid (Receipt rk) = case clients v cid of - _ :<|> f :<|> _ -> g <$> f (P.Poll $ pure rk) +poll v cid (Receipt rk) = g <$> poll' v cid (P.Poll $ pure rk) where g :: P.PollResponses -> Maybe TXResult g (P.PollResponses hm) = TXResult <$> HM.lookup rk hm @@ -250,8 +299,7 @@ poll v cid (Receipt rk) = case clients v cid of -- Might time out, in which case `Nothing` is returned. Should return quickly -- for `Transaction`s which have already completed. listen :: ChainwebVersion -> ChainId -> Receipt -> ClientM (Maybe TXResult) -listen v cid (Receipt rk) = case clients v cid of - _ :<|> _ :<|> f :<|> _ -> g <$> f (P.ListenerRequest rk) +listen v cid (Receipt rk) = g <$> listen' v cid (P.ListenerRequest rk) where g :: P.ListenResponse -> Maybe TXResult g (P.ListenTimeout _) = Nothing @@ -259,18 +307,13 @@ listen v cid (Receipt rk) = case clients v cid of -- | A non-blocking `Transaction` that can't write changes and spends no gas. local :: ChainwebVersion -> ChainId -> Transaction -> ClientM TXResult -local v cid (Transaction tx) = case clients v cid of - _ :<|> _ :<|> _ :<|> f -> TXResult <$> f tx - -clients - :: ChainwebVersion - -> ChainId - -> (P.SubmitBatch -> ClientM P.RequestKeys) - :<|> (P.Poll -> ClientM P.PollResponses) - :<|> (P.ListenerRequest -> ClientM P.ListenResponse) - :<|> (P.Command Text -> ClientM (P.CommandResult P.Hash)) -clients _ _ = undefined - -- client (pactApi @v @cid) +local v cid (Transaction tx) = TXResult <$> local' v cid tx + +send' :: ChainwebVersion -> ChainId -> P.SubmitBatch -> ClientM P.RequestKeys +poll' :: ChainwebVersion -> ChainId -> P.Poll -> ClientM P.PollResponses +listen' :: ChainwebVersion -> ChainId -> P.ListenerRequest -> ClientM P.ListenResponse +local' :: ChainwebVersion -> ChainId -> P.Command Text -> ClientM (P.CommandResult P.Hash) +send' :<|> poll' :<|> listen' :<|> local' = client (Proxy @PactAPI) -------------------------------------------------------------------------------- -- Coin Contract Functions From 65009833108913ba2ea45853edb1a8c4c9202feb Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Fri, 29 Nov 2019 09:57:03 -0800 Subject: [PATCH 09/10] Rename chainweb functions to match their originals --- exec/BOH/CLI.hs | 7 +++++-- exec/BOH/UI.hs | 2 +- lib/Holding.hs | 2 +- lib/Holding/Chainweb.hs | 18 +++++++++--------- 4 files changed, 16 insertions(+), 13 deletions(-) diff --git a/exec/BOH/CLI.hs b/exec/BOH/CLI.hs index 1c81103..03cb61f 100644 --- a/exec/BOH/CLI.hs +++ b/exec/BOH/CLI.hs @@ -35,14 +35,17 @@ pArgs = Args pVersion :: Parser ChainwebVersion pVersion = option p (long "version" <> metavar "VERSION" <> value defv - <> help ("Chainweb Network Version (default: " <> T.unpack (vText defv) <> ")")) + <> help ("Chainweb Network Version (default: " <> asT <> ")")) where p :: ReadM ChainwebVersion - p = eitherReader (\v -> note ("Invalid Chainweb Version given: " <> v) $ verP v) + p = eitherReader (\v -> note ("Unknown version given: " <> v) $ chainwebVersionFromText v) defv :: ChainwebVersion defv = Mainnet + asT :: String + asT = T.unpack $ chainwebVersionToText defv + pUrl :: Parser BaseUrl pUrl = option (eitherReader pBaseUrl) (long "node" <> metavar "HOSTNAME:PORT" <> help "Node to send TXs") diff --git a/exec/BOH/UI.hs b/exec/BOH/UI.hs index 19ab0f0..fbd0349 100644 --- a/exec/BOH/UI.hs +++ b/exec/BOH/UI.hs @@ -118,7 +118,7 @@ draw e w = dispatch <> [ui] [ C.hCenter . padBottom (Pad 1) $ txt "The Bag of Holding - A Chainweb Wallet" , txt "Author: Colin Woodbury" , txt "Issues: " <+> hyperlink url (txt url) - , txt $ "Chainweb: " <> vText (verOf e) + , txt $ "Chainweb: " <> chainwebVersionToText (verOf e) , txt $ "Account: " <> (accOf e ^. _Unwrapped) , padTop (Pad 1) $ txt "A note on endpoints:" , txt "LOCAL: Transaction is 'free', but results aren't" diff --git a/lib/Holding.hs b/lib/Holding.hs index 3360cba..a3a0910 100644 --- a/lib/Holding.hs +++ b/lib/Holding.hs @@ -179,7 +179,7 @@ transaction v (TxData td) (PactCode pc) (Keys ks) pm = Transaction <$> P.mkExec (T.unpack pc) td pm [(ks, mempty)] nid Nothing where nid :: Maybe P.NetworkId - nid = Just . P.NetworkId $ vText v + nid = Just . P.NetworkId $ chainwebVersionToText v newtype TxData = TxData Value deriving newtype (ToJSON, FromJSON) diff --git a/lib/Holding/Chainweb.hs b/lib/Holding/Chainweb.hs index 6c199fd..f4cc352 100644 --- a/lib/Holding/Chainweb.hs +++ b/lib/Holding/Chainweb.hs @@ -15,7 +15,7 @@ module Holding.Chainweb ( -- * ChainwebVersion ChainwebVersion(..) - , vText, verP + , chainwebVersionToText, chainwebVersionFromText -- * ChainId , ChainId(..) , chainIdToText, chainIdFromText @@ -32,20 +32,20 @@ import Servant.API data ChainwebVersion = Testnet | Mainnet instance ToHttpApiData ChainwebVersion where - toUrlPiece = vText + toUrlPiece = chainwebVersionToText chainIds :: ChainwebVersion -> HashSet ChainId chainIds Testnet = HS.fromList [0 .. 9] chainIds Mainnet = HS.fromList [0 .. 9] -vText :: ChainwebVersion -> Text -vText Testnet = "testnet03" -vText Mainnet = "mainnet01" +chainwebVersionToText :: ChainwebVersion -> Text +chainwebVersionToText Testnet = "testnet03" +chainwebVersionToText Mainnet = "mainnet01" -verP :: String -> Maybe ChainwebVersion -verP "testnet03" = Just Testnet -verP "mainnet01" = Just Mainnet -verP _ = Nothing +chainwebVersionFromText :: String -> Maybe ChainwebVersion +chainwebVersionFromText "testnet03" = Just Testnet +chainwebVersionFromText "mainnet01" = Just Mainnet +chainwebVersionFromText _ = Nothing newtype ChainId = ChainId { chainIdInt :: Word } deriving stock (Eq, Ord) From 57ad9c5f5001b7e1a236d27fd3ff7ad8a4477ff3 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Fri, 29 Nov 2019 10:01:12 -0800 Subject: [PATCH 10/10] 1.0.1 --- ChangeLog.md | 5 ++++- bag-of-holding.cabal | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 906b22d..a79f40a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,6 @@ # Changelog for bag-of-holding -## Unreleased changes +## 1.0.1 (2019-11-29) + +The dependency on `chainweb` has been dropped, vastly reducing the number of +transitive dependencies required by `boh`. This also reduces binary size. diff --git a/bag-of-holding.cabal b/bag-of-holding.cabal index 761087e..a07dd14 100644 --- a/bag-of-holding.cabal +++ b/bag-of-holding.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: bag-of-holding -version: 1.0.0 +version: 1.0.1 synopsis: A terminal-based wallet for Chainweb. description: A terminal-based wallet for Chainweb. homepage: https://github.com/kadena-community/bag-of-holding