diff --git a/cabal.project b/cabal.project index e3977ca3248..eea6c2c9bc4 100644 --- a/cabal.project +++ b/cabal.project @@ -86,6 +86,7 @@ packages: lib/temporary-extra/ lib/test-utils/ lib/text-class/ + lib/ui/ lib/unit/ lib/wai-middleware-logging/ lib/wallet-benchmarks/ diff --git a/lib/api/cardano-wallet-api.cabal b/lib/api/cardano-wallet-api.cabal index 1b99f38a124..5c96186c90a 100644 --- a/lib/api/cardano-wallet-api.cabal +++ b/lib/api/cardano-wallet-api.cabal @@ -105,6 +105,7 @@ library Cardano.Wallet.Api.Http.Server.Error.AssignReedemers Cardano.Wallet.Api.Http.Server.Error.IsServerError Cardano.Wallet.Api.Http.Server.Handlers.MintBurn + Cardano.Wallet.Api.Http.Server.Handlers.NetworkInformation Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR Cardano.Wallet.Api.Http.Shelley.Server Cardano.Wallet.Api.Lib.ApiAsArray diff --git a/lib/api/src/Cardano/Wallet/Api/Http/Server/Handlers/NetworkInformation.hs b/lib/api/src/Cardano/Wallet/Api/Http/Server/Handlers/NetworkInformation.hs new file mode 100644 index 00000000000..e017b12822c --- /dev/null +++ b/lib/api/src/Cardano/Wallet/Api/Http/Server/Handlers/NetworkInformation.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} + +module Cardano.Wallet.Api.Http.Server.Handlers.NetworkInformation + ( getNetworkInformation + , makeApiBlockReferenceFromHeader + , makeApiSlotReference + , makeApiBlockReference + ) +where + +import Prelude + +import Cardano.Api + ( NetworkId + , toNetworkMagic + , unNetworkMagic + ) +import Cardano.Wallet.Api.Types + ( ApiBlockInfo (..) + , ApiBlockReference (..) + , ApiNetworkInformation + , ApiSlotId (..) + , ApiSlotReference (..) + , ApiT (..) + , ApiWalletMode (..) + ) +import Cardano.Wallet.Network + ( NetworkLayer (..) + , timeInterpreter + ) +import Cardano.Wallet.Pools + ( EpochInfo (..) + ) +import Cardano.Wallet.Primitive.Slotting + ( RelativeTime + , TimeInterpreter + , currentRelativeTime + , hoistTimeInterpreter + , interpretQuery + , neverFails + , ongoingSlotAt + , slotToUTCTime + , timeOfEpoch + , toSlotId + ) +import Cardano.Wallet.Primitive.Types + ( BlockHeader (..) + , SlotId + , SlotNo (..) + ) +import Control.Monad.IO.Class + ( liftIO + ) +import Control.Monad.Trans.Maybe + ( MaybeT (..) + , exceptToMaybeT + ) +import Data.Generics.Internal.VL.Lens + ( (^.) + ) +import Data.Generics.Labels + () +import Data.Quantity + ( Quantity (..) + ) +import Data.Word + ( Word32 + ) +import GHC.Stack + ( HasCallStack + ) +import Numeric.Natural + ( Natural + ) +import Servant.Server + ( Handler (..) + ) + +import qualified Cardano.Api as Cardano +import qualified Cardano.Wallet.Api.Types as Api +import qualified Cardano.Wallet.Api.Types.Era as ApiEra +import qualified Cardano.Wallet.Read as Read + +getNetworkInformation + :: HasCallStack + => NetworkId + -> NetworkLayer IO block + -> ApiWalletMode + -> Handler ApiNetworkInformation +getNetworkInformation + nid + NetworkLayer + { syncProgress + , currentNodeTip + , currentNodeEra + , timeInterpreter + } + mode = liftIO $ do + now <- currentRelativeTime ti + nodeTip <- currentNodeTip + nodeEra <- currentNodeEra + apiNodeTip <- + makeApiBlockReferenceFromTip + (neverFails "node tip is within safe-zone" timeInterpreter) + nodeTip + nowInfo <- runMaybeT $ networkTipInfo now + let pseudoSlot Read.GenesisTip = SlotNo 0 + pseudoSlot Read.BlockTip{slotNo} = + SlotNo $ fromIntegral $ Read.unSlotNo slotNo + progress <- syncProgress $ pseudoSlot nodeTip + pure + Api.ApiNetworkInformation + { Api.syncProgress = ApiT progress + , Api.nextEpoch = snd <$> nowInfo + , Api.nodeTip = apiNodeTip + , Api.networkTip = fst <$> nowInfo + , Api.nodeEra = ApiEra.fromAnyCardanoEra nodeEra + , Api.networkInfo = + Api.ApiNetworkInfo + ( case nid of + Cardano.Mainnet -> "mainnet" + Cardano.Testnet _ -> "testnet" + ) + (fromIntegral $ unNetworkMagic $ toNetworkMagic nid) + , Api.walletMode = mode + } + where + ti :: TimeInterpreter (MaybeT IO) + ti = hoistTimeInterpreter exceptToMaybeT timeInterpreter + + -- (network tip, next epoch) + -- May be unavailable if the node is still syncing. + networkTipInfo :: RelativeTime -> MaybeT IO (ApiSlotReference, EpochInfo) + networkTipInfo now = do + networkTipSlot <- interpretQuery ti $ ongoingSlotAt now + tip <- makeApiSlotReference ti networkTipSlot + let curEpoch = tip ^. #slotId . #epochNumber . #getApiT + (_, nextEpochStart) <- interpretQuery ti $ timeOfEpoch curEpoch + let nextEpoch = EpochInfo (succ curEpoch) nextEpochStart + return (tip, nextEpoch) + +makeApiBlockReferenceFromHeader + :: Monad m + => TimeInterpreter m + -> BlockHeader + -> m ApiBlockReference +makeApiBlockReferenceFromHeader ti tip = + makeApiBlockReference ti (tip ^. #slotNo) (natural $ tip ^. #blockHeight) + +natural :: Quantity q Word32 -> Quantity q Natural +natural = Quantity . fromIntegral . getQuantity + +makeApiSlotReference + :: Monad m + => TimeInterpreter m + -> SlotNo + -> m ApiSlotReference +makeApiSlotReference ti sl = + ApiSlotReference (ApiT sl) + <$> fmap apiSlotId (interpretQuery ti $ toSlotId sl) + <*> interpretQuery ti (slotToUTCTime sl) + +apiSlotId :: SlotId -> ApiSlotId +apiSlotId slotId = + ApiSlotId + (ApiT $ slotId ^. #epochNumber) + (ApiT $ slotId ^. #slotNumber) + +makeApiBlockReference + :: Monad m + => TimeInterpreter m + -> SlotNo + -> Quantity "block" Natural + -> m ApiBlockReference +makeApiBlockReference ti sl height = do + slotId <- interpretQuery ti (toSlotId sl) + slotTime <- interpretQuery ti (slotToUTCTime sl) + pure + ApiBlockReference + { absoluteSlotNumber = ApiT sl + , slotId = apiSlotId slotId + , time = slotTime + , block = ApiBlockInfo{height} + } + +makeApiBlockReferenceFromTip + :: Monad m + => TimeInterpreter m + -> Read.ChainTip + -> m ApiBlockReference +makeApiBlockReferenceFromTip ti Read.GenesisTip = + makeApiBlockReference ti 0 (Quantity 0) +makeApiBlockReferenceFromTip ti Read.BlockTip{slotNo,blockNo} = + makeApiBlockReference + ti + (fromIntegral $ Read.unSlotNo slotNo) + (Quantity $ fromIntegral $ Read.unBlockNo blockNo) diff --git a/lib/api/src/Cardano/Wallet/Api/Http/Shelley/Server.hs b/lib/api/src/Cardano/Wallet/Api/Http/Shelley/Server.hs index 7992ca7caaf..aeb96fd08c6 100644 --- a/lib/api/src/Cardano/Wallet/Api/Http/Shelley/Server.hs +++ b/lib/api/src/Cardano/Wallet/Api/Http/Shelley/Server.hs @@ -122,6 +122,7 @@ module Cardano.Wallet.Api.Http.Shelley.Server , withWorkerCtx , getCurrentEpoch + , MkApiWallet -- * Workers , manageRewardBalance , idleWorker @@ -150,10 +151,7 @@ import Cardano.Address.Script , validateScriptOfTemplate ) import Cardano.Api - ( NetworkId - , SerialiseAsCBOR (..) - , toNetworkMagic - , unNetworkMagic + ( SerialiseAsCBOR (..) ) import Cardano.Api.Shelley ( StakeAddress (..) @@ -319,6 +317,12 @@ import Cardano.Wallet.Api.Http.Server.Handlers.MintBurn ( convertApiAssetMintBurn , getTxApiAssetMintBurn ) +-- import Cardano.Wallet.Api.Http.Server.Handlers.NetworkInformation +-- ( getNetworkInformation +-- , makeApiBlockReference +-- , makeApiBlockReferenceFromHeader +-- , makeApiSlotReference +-- ) import Cardano.Wallet.Api.Http.Server.Handlers.TxCBOR ( ParsedTxCBOR (..) , parseTxCBOR @@ -336,7 +340,6 @@ import Cardano.Wallet.Api.Types , ApiAsset (..) , ApiAssetMintBurn (..) , ApiBalanceTransactionPostData (..) - , ApiBlockInfo (..) , ApiBlockReference (..) , ApiBurnData (..) , ApiByronWallet (..) @@ -365,7 +368,6 @@ import Cardano.Wallet.Api.Types , ApiMnemonicT (..) , ApiMultiDelegationAction (..) , ApiNetworkClock (..) - , ApiNetworkInformation , ApiNetworkParameters (..) , ApiNullStakeKey (..) , ApiOurStakeKey (..) @@ -391,8 +393,6 @@ import Cardano.Wallet.Api.Types , ApiSharedWalletPostDataFromAccountPubX (..) , ApiSharedWalletPostDataFromMnemonics (..) , ApiSignTransactionPostData (..) - , ApiSlotId (..) - , ApiSlotReference (..) , ApiStakeKeyIndex (..) , ApiStakeKeys (..) , ApiT (..) @@ -417,7 +417,6 @@ import Cardano.Wallet.Api.Types , ApiWalletMigrationPlan (..) , ApiWalletMigrationPlanPostData (..) , ApiWalletMigrationPostData (..) - , ApiWalletMode (..) , ApiWalletOutput (..) , ApiWalletPassphrase (..) , ApiWalletPassphraseInfo (..) @@ -520,8 +519,7 @@ import Cardano.Wallet.Network.RestorationMode , getRestorationPoint ) import Cardano.Wallet.Pools - ( EpochInfo (..) - , toEpochInfo + ( toEpochInfo ) import Cardano.Wallet.Primitive.Delegation.UTxO ( stakeKeyCoinDistr @@ -551,18 +549,11 @@ import Cardano.Wallet.Primitive.Passphrase ) import Cardano.Wallet.Primitive.Slotting ( PastHorizonException - , RelativeTime , TimeInterpreter , currentEpoch - , currentRelativeTime , expectAndThrowFailures - , hoistTimeInterpreter , interpretQuery , neverFails - , ongoingSlotAt - , slotToUTCTime - , timeOfEpoch - , toSlotId , unsafeExtendSafeZone ) import Cardano.Wallet.Primitive.SyncProgress @@ -570,11 +561,9 @@ import Cardano.Wallet.Primitive.SyncProgress ) import Cardano.Wallet.Primitive.Types ( Block - , BlockHeader (..) , NetworkParameters (..) , PoolLifeCycleStatus , Signature (..) - , SlotId , SlotNo (..) , SortOrder (..) , WalletDelegation @@ -713,10 +702,6 @@ import Control.Monad.Trans.Except , throwE , withExceptT ) -import Control.Monad.Trans.Maybe - ( MaybeT (..) - , exceptToMaybeT - ) import Control.Tracer ( Tracer , contramap @@ -814,9 +799,6 @@ import Fmt import GHC.Generics ( Generic ) -import GHC.Stack - ( HasCallStack - ) import Internal.Cardano.Write.Tx ( AnyRecentEra (..) ) @@ -871,11 +853,9 @@ import qualified Cardano.Wallet.Address.Derivation.Byron as Byron import qualified Cardano.Wallet.Address.Derivation.Icarus as Icarus import qualified Cardano.Wallet.Address.Discovery.Sequential as Seq import qualified Cardano.Wallet.Address.Discovery.Shared as Shared +import Cardano.Wallet.Api.Http.Server.Handlers.NetworkInformation import qualified Cardano.Wallet.Api.Types as Api import qualified Cardano.Wallet.Api.Types.Amount as ApiAmount -import qualified Cardano.Wallet.Api.Types.Era as ApiEra - ( fromAnyCardanoEra - ) import qualified Cardano.Wallet.Api.Types.WalletAssets as ApiWalletAssets import qualified Cardano.Wallet.DB as W import qualified Cardano.Wallet.Delegation as WD @@ -4277,61 +4257,6 @@ getCurrentEpoch ctx = liftIO (runExceptT (currentEpoch ti)) >>= \case ti :: TimeInterpreter (ExceptT PastHorizonException IO) ti = timeInterpreter (ctx ^. networkLayer) -getNetworkInformation - :: HasCallStack - => NetworkId - -> NetworkLayer IO block - -> ApiWalletMode - -> Handler ApiNetworkInformation -getNetworkInformation nid - NetworkLayer - { syncProgress - , currentNodeTip - , currentNodeEra - , timeInterpreter - } - mode = liftIO $ do - now <- currentRelativeTime ti - nodeTip <- currentNodeTip - nodeEra <- currentNodeEra - apiNodeTip <- makeApiBlockReferenceFromTip - (neverFails "node tip is within safe-zone" timeInterpreter) - nodeTip - nowInfo <- runMaybeT $ networkTipInfo now - let pseudoSlot Read.GenesisTip = SlotNo 0 - pseudoSlot Read.BlockTip{slotNo} = - SlotNo $ fromIntegral $ Read.unSlotNo slotNo - progress <- syncProgress $ pseudoSlot nodeTip - pure Api.ApiNetworkInformation - { Api.syncProgress = ApiT progress - , Api.nextEpoch = snd <$> nowInfo - , Api.nodeTip = apiNodeTip - , Api.networkTip = fst <$> nowInfo - , Api.nodeEra = ApiEra.fromAnyCardanoEra nodeEra - , Api.networkInfo = - Api.ApiNetworkInfo - ( case nid of - Cardano.Mainnet -> "mainnet" - Cardano.Testnet _ -> "testnet" - ) - (fromIntegral $ unNetworkMagic $ toNetworkMagic nid) - , Api.walletMode = mode - } - where - ti :: TimeInterpreter (MaybeT IO) - ti = hoistTimeInterpreter exceptToMaybeT timeInterpreter - - -- (network tip, next epoch) - -- May be unavailable if the node is still syncing. - networkTipInfo :: RelativeTime -> MaybeT IO (ApiSlotReference, EpochInfo) - networkTipInfo now = do - networkTipSlot <- interpretQuery ti $ ongoingSlotAt now - tip <- makeApiSlotReference ti networkTipSlot - let curEpoch = tip ^. #slotId . #epochNumber . #getApiT - (_, nextEpochStart) <- interpretQuery ti $ timeOfEpoch curEpoch - let nextEpoch = EpochInfo (succ curEpoch) nextEpochStart - return (tip, nextEpoch) - getNetworkParameters :: (Block, NetworkParameters) -> NetworkLayer IO block @@ -4923,58 +4848,6 @@ addressAmountToTxOut (AddressAmount (ApiAddress addr) c assets) = natural :: Quantity q Word32 -> Quantity q Natural natural = Quantity . fromIntegral . getQuantity -apiSlotId :: SlotId -> ApiSlotId -apiSlotId slotId = ApiSlotId - (ApiT $ slotId ^. #epochNumber) - (ApiT $ slotId ^. #slotNumber) - -makeApiBlockReference - :: Monad m - => TimeInterpreter m - -> SlotNo - -> Quantity "block" Natural - -> m ApiBlockReference -makeApiBlockReference ti sl height = do - slotId <- interpretQuery ti (toSlotId sl) - slotTime <- interpretQuery ti (slotToUTCTime sl) - pure ApiBlockReference - { absoluteSlotNumber = ApiT sl - , slotId = apiSlotId slotId - , time = slotTime - , block = ApiBlockInfo { height } - } - -makeApiBlockReferenceFromHeader - :: Monad m - => TimeInterpreter m - -> BlockHeader - -> m ApiBlockReference -makeApiBlockReferenceFromHeader ti tip = - makeApiBlockReference ti (tip ^. #slotNo) (natural $ tip ^. #blockHeight) - -makeApiBlockReferenceFromTip - :: Monad m - => TimeInterpreter m - -> Read.ChainTip - -> m ApiBlockReference -makeApiBlockReferenceFromTip ti Read.GenesisTip = - makeApiBlockReference ti 0 (Quantity 0) -makeApiBlockReferenceFromTip ti Read.BlockTip{slotNo,blockNo} = - makeApiBlockReference - ti - (fromIntegral $ Read.unSlotNo slotNo) - (Quantity $ fromIntegral $ Read.unBlockNo blockNo) - -makeApiSlotReference - :: Monad m - => TimeInterpreter m - -> SlotNo - -> m ApiSlotReference -makeApiSlotReference ti sl = - ApiSlotReference (ApiT sl) - <$> fmap apiSlotId (interpretQuery ti $ toSlotId sl) - <*> interpretQuery ti (slotToUTCTime sl) - getWalletTip :: Monad m => TimeInterpreter m diff --git a/lib/api/src/Cardano/Wallet/Api/Types.hs b/lib/api/src/Cardano/Wallet/Api/Types.hs index e8ba0049df0..ba5ad9e94dc 100644 --- a/lib/api/src/Cardano/Wallet/Api/Types.hs +++ b/lib/api/src/Cardano/Wallet/Api/Types.hs @@ -81,6 +81,7 @@ module Cardano.Wallet.Api.Types , ApiCoinSelectionWithdrawal (..) , ApiEncryptMetadata (..) , ApiEncryptMetadataMethod (..) + , ApiEra (..) , ApiConstructTransaction (..) , ApiConstructTransactionData (..) , ApiCosignerIndex (..) @@ -2869,7 +2870,7 @@ instance FromJSON ApiScriptTemplateEntry where parseJSON = withObject "ApiScriptTemplateEntry" $ \o -> do template' <- parseJSON <$> o .: "template" cosigners' <- parseCosignerPairs <$> o .: "cosigners" - ApiScriptTemplateEntry <$> (Map.fromList <$> cosigners') <*> template' + (ApiScriptTemplateEntry . Map.fromList <$> cosigners') <*> template' where parseCosignerPairs = withObject "Cosigner pairs" $ \o -> case Aeson.toList o of @@ -2909,8 +2910,7 @@ instance FromJSON ApiScriptTemplate where parseJSON = withObject "ApiScriptTemplate" $ \o -> do template' <- parseJSON <$> o .: "template" cosigners' <- parseCosignerPairs <$> o .: "cosigners" - scriptTemplate <- CA.ScriptTemplate - <$> (Map.fromList <$> cosigners') + scriptTemplate <- (CA.ScriptTemplate . Map.fromList <$> cosigners') <*> template' pure $ ApiScriptTemplate scriptTemplate where diff --git a/lib/api/src/Cardano/Wallet/Api/Types/WalletAssets.hs b/lib/api/src/Cardano/Wallet/Api/Types/WalletAssets.hs index 51f7022063c..c546d362df3 100644 --- a/lib/api/src/Cardano/Wallet/Api/Types/WalletAssets.hs +++ b/lib/api/src/Cardano/Wallet/Api/Types/WalletAssets.hs @@ -12,13 +12,12 @@ -- License: Apache-2.0 -- -- Representation of the API specification `walletAssets` type. --- module Cardano.Wallet.Api.Types.WalletAssets ( ApiWalletAssets (..) , fromTokenMap , toTokenMap ) - where +where import Prelude @@ -62,10 +61,12 @@ import qualified Cardano.Wallet.Primitive.Types.TokenQuantity as W ( TokenQuantity (TokenQuantity) ) -newtype ApiWalletAssets = ApiWalletAssets [ApiWalletAsset] +newtype ApiWalletAssets = ApiWalletAssets + { getApiWalletAssets :: [ApiWalletAsset] + } deriving (Data, Eq, Generic, Ord, Show, Typeable) deriving newtype (Hashable, IsList, Semigroup, Monoid, FromJSON, ToJSON) - deriving anyclass NFData + deriving anyclass (NFData) fromTokenMap :: W.TokenMap -> ApiWalletAssets fromTokenMap = fromList . fmap f . W.TokenMap.toFlatList diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs index 64a1f2e4c3d..ad8eed95ec1 100644 --- a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs @@ -1224,7 +1224,7 @@ splitSignedValue :: Value -> (W.TokenBundle, W.TokenBundle) splitSignedValue v = (bNegative, bPositive) where bNegative = Convert.toWallet . filterPositive $ invert v - bPositive = Convert.toWallet . filterPositive $ v + bPositive = Convert.toWallet . filterPositive $ v filterPositive :: Value -> Value filterPositive (MaryValue (Coin a) (MultiAsset m)) = diff --git a/lib/exe/cardano-wallet-exe.cabal b/lib/exe/cardano-wallet-exe.cabal index 2aafa3a9b18..a76d66eed32 100644 --- a/lib/exe/cardano-wallet-exe.cabal +++ b/lib/exe/cardano-wallet-exe.cabal @@ -86,6 +86,7 @@ library , cardano-wallet-primitive , cardano-wallet-read , cardano-wallet-secrets + , cardano-wallet-ui , contra-tracer , data-default , directory diff --git a/lib/exe/lib/Cardano/Wallet/Application.hs b/lib/exe/lib/Cardano/Wallet/Application.hs index 9a70e72df18..b2a25ff54cb 100644 --- a/lib/exe/lib/Cardano/Wallet/Application.hs +++ b/lib/exe/lib/Cardano/Wallet/Application.hs @@ -167,6 +167,16 @@ import Cardano.Wallet.TokenMetadata import Cardano.Wallet.Transaction ( TransactionLayer ) +import Cardano.Wallet.UI.Html.Pages.Page + ( PageConfig (..) + ) +import Cardano.Wallet.UI.Html.Pages.Template.Head + ( HeadConfig (..) + ) +import Cardano.Wallet.UI.Layer + ( UILayer + , sourceOfNewTip + ) import Control.Exception.Extra ( handle ) @@ -182,7 +192,7 @@ import Control.Monad.Trans.Except ( ExceptT (ExceptT) ) import Control.Tracer - ( Tracer + ( Tracer (..) , traceWith ) import Data.Function @@ -235,6 +245,10 @@ import UnliftIO import qualified Cardano.Pool.DB.Layer as Pool import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server import qualified Cardano.Wallet.DB.Layer as Sqlite +import qualified Cardano.Wallet.UI.API as Ui + +import qualified Cardano.Wallet.UI.Layer as Ui +import qualified Cardano.Wallet.UI.Server as Ui import qualified Network.Wai.Handler.Warp as Warp import qualified Servant.Server as Servant @@ -343,8 +357,22 @@ serveWallet case ms of Nothing -> pure () Just (_port, socket) -> do + ui <- Ui.withUILayer 1 + sourceOfNewTip netLayer ui + let uiService = + startUiServer + ui + sNetwork + socket + randomApi + icarusApi + shelleyApi + multisigApi + stakePoolLayer + ntpClient + blockchainSource ContT $ \k -> - withAsync (startUiServer socket) $ \_ -> k () + withAsync uiService $ \_ -> k () pure ExitSuccess eApiSocket <- bindApiSocket @@ -409,9 +437,53 @@ serveWallet (newTransactionLayer SharedKeyS netId) netLayer Server.idleWorker - - startUiServer :: Socket -> IO () - startUiServer _socket = pure () -- TODO + startUiServer + :: forall n + . ( HasSNetworkId n + ) + => UILayer + -> SNetworkId n + -> Socket + -> ApiLayer (RndState n) + -> ApiLayer (SeqState n IcarusKey) + -> ApiLayer (SeqState n ShelleyKey) + -> ApiLayer (SharedState n SharedKey) + -> StakePoolLayer + -> NtpClient + -> BlockchainSource + -> IO () + startUiServer + ui + _proxy + socket + randomApi + icarusApi + shelleyApi + multisigApi + spl + ntp + bs = do + let serverSettings = Warp.defaultSettings + api = Proxy @Ui.UI + application = + Server.serve api + $ Ui.serveUI + ui + (PageConfig "" $ HeadConfig "Shelley Cardano Wallet") + _proxy + randomApi + icarusApi + shelleyApi + multisigApi + spl + ntp + bs + start + serverSettings + apiServerTracer + tlsConfig + socket + application startApiServer :: forall n @@ -427,29 +499,37 @@ serveWallet -> StakePoolLayer -> NtpClient -> IO () - startApiServer _proxy socket byron icarus shelley multisig spl ntp = do - serverUrl <- getServerUrl tlsConfig socket - let serverSettings = - Warp.defaultSettings - & setBeforeMainLoop (beforeMainLoop serverUrl) - api = Proxy @(ApiV2 n) - application = - Server.serve api - $ Servant.hoistServer api handleWalletExceptions - $ server - byron - icarus - shelley - multisig - spl - ntp - blockchainSource - start - serverSettings - apiServerTracer - tlsConfig - socket - application + startApiServer + _proxy + socket + byron + icarus + shelley + multisig + spl + ntp = do + serverUrl <- getServerUrl tlsConfig socket + let serverSettings = + Warp.defaultSettings + & setBeforeMainLoop (beforeMainLoop serverUrl) + api = Proxy @(ApiV2 n) + application = + Server.serve api + $ Servant.hoistServer api handleWalletExceptions + $ server + byron + icarus + shelley + multisig + spl + ntp + blockchainSource + start + serverSettings + apiServerTracer + tlsConfig + socket + application apiLayer :: forall s k diff --git a/lib/ui/CHANGELOG.md b/lib/ui/CHANGELOG.md new file mode 100644 index 00000000000..65a9f940873 --- /dev/null +++ b/lib/ui/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for cardano-wallet-ui + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/lib/ui/LICENSE b/lib/ui/LICENSE new file mode 100644 index 00000000000..d6456956733 --- /dev/null +++ b/lib/ui/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal new file mode 100644 index 00000000000..6c8cad6ac60 --- /dev/null +++ b/lib/ui/cardano-wallet-ui.cabal @@ -0,0 +1,99 @@ +cabal-version: 3.6 +name: cardano-wallet-ui +version: 0.2024.7.27 +synopsis: web ui for the cardano-wallet +license: Apache-2.0 +license-file: LICENSE +author: hal team +maintainer: hal@cardanofoundation.org +category: Web +build-type: Simple +extra-doc-files: CHANGELOG.md +data-files: + data/images/*.png + data/english.txt + +common language + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +common opts-lib + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wunused-packages + + if flag(release) + ghc-options: -O2 -Werror + +flag release + description: Enable optimization and `-Werror` + default: False + manual: True + +library + import: language, opts-lib + exposed-modules: + Cardano.Wallet.UI.API + Cardano.Wallet.UI.Cookies + Cardano.Wallet.UI.Handlers.Addresses + Cardano.Wallet.UI.Handlers.Lib + Cardano.Wallet.UI.Handlers.Settings + Cardano.Wallet.UI.Handlers.SSE + Cardano.Wallet.UI.Handlers.State + Cardano.Wallet.UI.Handlers.Wallet + Cardano.Wallet.UI.Handlers.Wallets + Cardano.Wallet.UI.Html.Html + Cardano.Wallet.UI.Html.Htmx + Cardano.Wallet.UI.Html.Lib + Cardano.Wallet.UI.Html.Pages.About + Cardano.Wallet.UI.Html.Pages.Addresses + Cardano.Wallet.UI.Html.Pages.Lib + Cardano.Wallet.UI.Html.Pages.Network + Cardano.Wallet.UI.Html.Pages.Page + Cardano.Wallet.UI.Html.Pages.Settings + Cardano.Wallet.UI.Html.Pages.Template.Footer + Cardano.Wallet.UI.Html.Pages.Template.Head + Cardano.Wallet.UI.Html.Pages.Template.Navigation + Cardano.Wallet.UI.Html.Pages.Wallet + Cardano.Wallet.UI.Html.Pages.Wallets + Cardano.Wallet.UI.Html.Pages.Wallets.NewWallet + Cardano.Wallet.UI.Layer + Cardano.Wallet.UI.Lib.ListOf + Cardano.Wallet.UI.Server + Cardano.Wallet.UI.Signal + other-modules: + Paths_cardano_wallet_ui + build-depends: + , address-derivation-discovery + , aeson + , aeson-pretty + , base + , bytestring + , cardano-addresses + , cardano-slotting + , cardano-wallet + , cardano-wallet-api + , cardano-wallet-network-layer + , cardano-wallet-primitive + , containers + , contra-tracer + , cookie + , exceptions + , generic-lens + , http-media + , lens + , lucid + , mtl + , ntp-client + , operational + , random + , servant + , servant-server + , string-interpolate + , text + , text-class + , time + , unliftio + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/lib/ui/data/english.txt b/lib/ui/data/english.txt new file mode 100644 index 00000000000..942040ed50f --- /dev/null +++ b/lib/ui/data/english.txt @@ -0,0 +1,2048 @@ +abandon +ability +able +about +above +absent +absorb +abstract +absurd +abuse +access +accident +account +accuse +achieve +acid +acoustic +acquire +across +act +action +actor +actress +actual +adapt +add +addict +address +adjust +admit +adult +advance +advice +aerobic +affair +afford +afraid +again +age +agent +agree +ahead +aim +air +airport +aisle +alarm +album +alcohol +alert +alien +all +alley +allow +almost +alone +alpha +already +also +alter +always +amateur +amazing +among +amount +amused +analyst +anchor +ancient +anger +angle +angry +animal +ankle +announce +annual +another +answer +antenna +antique +anxiety +any +apart +apology +appear +apple +approve +april +arch +arctic +area +arena +argue +arm +armed +armor +army +around +arrange +arrest +arrive +arrow +art +artefact +artist +artwork +ask +aspect +assault +asset +assist +assume +asthma +athlete +atom +attack +attend +attitude +attract +auction +audit +august +aunt +author +auto +autumn +average +avocado +avoid +awake +aware +away +awesome +awful +awkward +axis +baby +bachelor +bacon +badge +bag +balance +balcony +ball +bamboo +banana +banner +bar +barely +bargain +barrel +base +basic +basket +battle +beach +bean +beauty +because +become +beef +before +begin +behave +behind +believe +below +belt +bench +benefit +best +betray +better +between +beyond +bicycle +bid +bike +bind +biology +bird +birth +bitter +black +blade +blame +blanket +blast +bleak +bless +blind +blood +blossom +blouse +blue +blur +blush +board +boat +body +boil +bomb +bone +bonus +book +boost +border +boring +borrow +boss +bottom +bounce +box +boy +bracket +brain +brand +brass +brave +bread +breeze +brick +bridge +brief +bright +bring +brisk +broccoli +broken +bronze +broom +brother +brown +brush +bubble +buddy +budget +buffalo +build +bulb +bulk +bullet +bundle +bunker +burden +burger +burst +bus +business +busy +butter +buyer +buzz +cabbage +cabin +cable +cactus +cage +cake +call +calm +camera +camp +can +canal +cancel +candy +cannon +canoe +canvas +canyon +capable +capital +captain +car +carbon +card +cargo +carpet +carry +cart +case +cash +casino +castle +casual +cat +catalog +catch +category +cattle +caught +cause +caution +cave +ceiling +celery +cement +census +century +cereal +certain +chair +chalk +champion +change +chaos +chapter +charge +chase +chat +cheap +check +cheese +chef +cherry +chest +chicken +chief +child +chimney +choice +choose +chronic +chuckle +chunk +churn +cigar +cinnamon +circle +citizen +city +civil +claim +clap +clarify +claw +clay +clean +clerk +clever +click +client +cliff +climb +clinic +clip +clock +clog +close +cloth +cloud +clown +club +clump +cluster +clutch +coach +coast +coconut +code +coffee +coil +coin +collect +color +column +combine +come +comfort +comic +common +company +concert +conduct +confirm +congress +connect +consider +control +convince +cook +cool +copper +copy +coral +core +corn +correct +cost +cotton +couch +country +couple +course +cousin +cover +coyote +crack +cradle +craft +cram +crane +crash +crater +crawl +crazy +cream +credit +creek +crew +cricket +crime +crisp +critic +crop +cross +crouch +crowd +crucial +cruel +cruise +crumble +crunch +crush +cry +crystal +cube +culture +cup +cupboard +curious +current +curtain +curve +cushion +custom +cute +cycle +dad +damage +damp +dance +danger +daring +dash +daughter +dawn +day +deal +debate +debris +decade +december +decide +decline +decorate +decrease +deer +defense +define +defy +degree +delay +deliver +demand +demise +denial +dentist +deny +depart +depend +deposit +depth +deputy +derive +describe +desert +design +desk +despair +destroy +detail +detect +develop +device +devote +diagram +dial +diamond +diary +dice +diesel +diet +differ +digital +dignity +dilemma +dinner +dinosaur +direct +dirt +disagree +discover +disease +dish +dismiss +disorder +display +distance +divert +divide +divorce +dizzy +doctor +document +dog +doll +dolphin +domain +donate +donkey +donor +door +dose +double +dove +draft +dragon +drama +drastic +draw +dream +dress +drift +drill +drink +drip +drive +drop +drum +dry +duck +dumb +dune +during +dust +dutch +duty +dwarf +dynamic +eager +eagle +early +earn +earth +easily +east +easy +echo +ecology +economy +edge +edit +educate +effort +egg +eight +either +elbow +elder +electric +elegant +element +elephant +elevator +elite +else +embark +embody +embrace +emerge +emotion +employ +empower +empty +enable +enact +end +endless +endorse +enemy +energy +enforce +engage +engine +enhance +enjoy +enlist +enough +enrich +enroll +ensure +enter +entire +entry +envelope +episode +equal +equip +era +erase +erode +erosion +error +erupt +escape +essay +essence +estate +eternal +ethics +evidence +evil +evoke +evolve +exact +example +excess +exchange +excite +exclude +excuse +execute +exercise +exhaust +exhibit +exile +exist +exit +exotic +expand +expect +expire +explain +expose +express +extend +extra +eye +eyebrow +fabric +face +faculty +fade +faint +faith +fall +false +fame +family +famous +fan +fancy +fantasy +farm +fashion +fat +fatal +father +fatigue +fault +favorite +feature +february +federal +fee +feed +feel +female +fence +festival +fetch +fever +few +fiber +fiction +field +figure +file +film +filter +final +find +fine +finger +finish +fire +firm +first +fiscal +fish +fit +fitness +fix +flag +flame +flash +flat +flavor +flee +flight +flip +float +flock +floor +flower +fluid +flush +fly +foam +focus +fog +foil +fold +follow +food +foot +force +forest +forget +fork +fortune +forum +forward +fossil +foster +found +fox +fragile +frame +frequent +fresh +friend +fringe +frog +front +frost +frown +frozen +fruit +fuel +fun +funny +furnace +fury +future +gadget +gain +galaxy +gallery +game +gap +garage +garbage +garden +garlic +garment +gas +gasp +gate +gather +gauge +gaze +general +genius +genre +gentle +genuine +gesture +ghost +giant +gift +giggle +ginger +giraffe +girl +give +glad +glance +glare +glass +glide +glimpse +globe +gloom +glory +glove +glow +glue +goat +goddess +gold +good +goose +gorilla +gospel +gossip +govern +gown +grab +grace +grain +grant +grape +grass +gravity +great +green +grid +grief +grit +grocery +group +grow +grunt +guard +guess +guide +guilt +guitar +gun +gym +habit +hair +half +hammer +hamster +hand +happy +harbor +hard +harsh +harvest +hat +have +hawk +hazard +head +health +heart +heavy +hedgehog +height +hello +helmet +help +hen +hero +hidden +high +hill +hint +hip +hire +history +hobby +hockey +hold +hole +holiday +hollow +home +honey +hood +hope +horn +horror +horse +hospital +host +hotel +hour +hover +hub +huge +human +humble +humor +hundred +hungry +hunt +hurdle +hurry +hurt +husband +hybrid +ice +icon +idea +identify +idle +ignore +ill +illegal +illness +image +imitate +immense +immune +impact +impose +improve +impulse +inch +include +income +increase +index +indicate +indoor +industry +infant +inflict +inform +inhale +inherit +initial +inject +injury +inmate +inner +innocent +input +inquiry +insane +insect +inside +inspire +install +intact +interest +into +invest +invite +involve +iron +island +isolate +issue +item +ivory +jacket +jaguar +jar +jazz +jealous +jeans +jelly +jewel +job +join +joke +journey +joy +judge +juice +jump +jungle +junior +junk +just +kangaroo +keen +keep +ketchup +key +kick +kid +kidney +kind +kingdom +kiss +kit +kitchen +kite +kitten +kiwi +knee +knife +knock +know +lab +label +labor +ladder +lady +lake +lamp +language +laptop +large +later +latin +laugh +laundry +lava +law +lawn +lawsuit +layer +lazy +leader +leaf +learn +leave +lecture +left +leg +legal +legend +leisure +lemon +lend +length +lens +leopard +lesson +letter +level +liar +liberty +library +license +life +lift +light +like +limb +limit +link +lion +liquid +list +little +live +lizard +load +loan +lobster +local +lock +logic +lonely +long +loop +lottery +loud +lounge +love +loyal +lucky +luggage +lumber +lunar +lunch +luxury +lyrics +machine +mad +magic +magnet +maid +mail +main +major +make +mammal +man +manage +mandate +mango +mansion +manual +maple +marble +march +margin +marine +market +marriage +mask +mass +master +match +material +math +matrix +matter +maximum +maze +meadow +mean +measure +meat +mechanic +medal +media +melody +melt +member +memory +mention +menu +mercy +merge +merit +merry +mesh +message +metal +method +middle +midnight +milk +million +mimic +mind +minimum +minor +minute +miracle +mirror +misery +miss +mistake +mix +mixed +mixture +mobile +model +modify +mom +moment +monitor +monkey +monster +month +moon +moral +more +morning +mosquito +mother +motion +motor +mountain +mouse +move +movie +much +muffin +mule +multiply +muscle +museum +mushroom +music +must +mutual +myself +mystery +myth +naive +name +napkin +narrow +nasty +nation +nature +near +neck +need +negative +neglect +neither +nephew +nerve +nest +net +network +neutral +never +news +next +nice +night +noble +noise +nominee +noodle +normal +north +nose +notable +note +nothing +notice +novel +now +nuclear +number +nurse +nut +oak +obey +object +oblige +obscure +observe +obtain +obvious +occur +ocean +october +odor +off +offer +office +often +oil +okay +old +olive +olympic +omit +once +one +onion +online +only +open +opera +opinion +oppose +option +orange +orbit +orchard +order +ordinary +organ +orient +original +orphan +ostrich +other +outdoor +outer +output +outside +oval +oven +over +own +owner +oxygen +oyster +ozone +pact +paddle +page +pair +palace +palm +panda +panel +panic +panther +paper +parade +parent +park +parrot +party +pass +patch +path +patient +patrol +pattern +pause +pave +payment +peace +peanut +pear +peasant +pelican +pen +penalty +pencil +people +pepper +perfect +permit +person +pet +phone +photo +phrase +physical +piano +picnic +picture +piece +pig +pigeon +pill +pilot +pink +pioneer +pipe +pistol +pitch +pizza +place +planet +plastic +plate +play +please +pledge +pluck +plug +plunge +poem +poet +point +polar +pole +police +pond +pony +pool +popular +portion +position +possible +post +potato +pottery +poverty +powder +power +practice +praise +predict +prefer +prepare +present +pretty +prevent +price +pride +primary +print +priority +prison +private +prize +problem +process +produce +profit +program +project +promote +proof +property +prosper +protect +proud +provide +public +pudding +pull +pulp +pulse +pumpkin +punch +pupil +puppy +purchase +purity +purpose +purse +push +put +puzzle +pyramid +quality +quantum +quarter +question +quick +quit +quiz +quote +rabbit +raccoon +race +rack +radar +radio +rail +rain +raise +rally +ramp +ranch +random +range +rapid +rare +rate +rather +raven +raw +razor +ready +real +reason +rebel +rebuild +recall +receive +recipe +record +recycle +reduce +reflect +reform +refuse +region +regret +regular +reject +relax +release +relief +rely +remain +remember +remind +remove +render +renew +rent +reopen +repair +repeat +replace +report +require +rescue +resemble +resist +resource +response +result +retire +retreat +return +reunion +reveal +review +reward +rhythm +rib +ribbon +rice +rich +ride +ridge +rifle +right +rigid +ring +riot +ripple +risk +ritual +rival +river +road +roast +robot +robust +rocket +romance +roof +rookie +room +rose +rotate +rough +round +route +royal +rubber +rude +rug +rule +run +runway +rural +sad +saddle +sadness +safe +sail +salad +salmon +salon +salt +salute +same +sample +sand +satisfy +satoshi +sauce +sausage +save +say +scale +scan +scare +scatter +scene +scheme +school +science +scissors +scorpion +scout +scrap +screen +script +scrub +sea +search +season +seat +second +secret +section +security +seed +seek +segment +select +sell +seminar +senior +sense +sentence +series +service +session +settle +setup +seven +shadow +shaft +shallow +share +shed +shell +sheriff +shield +shift +shine +ship +shiver +shock +shoe +shoot +shop +short +shoulder +shove +shrimp +shrug +shuffle +shy +sibling +sick +side +siege +sight +sign +silent +silk +silly +silver +similar +simple +since +sing +siren +sister +situate +six +size +skate +sketch +ski +skill +skin +skirt +skull +slab +slam +sleep +slender +slice +slide +slight +slim +slogan +slot +slow +slush +small +smart +smile +smoke +smooth +snack +snake +snap +sniff +snow +soap +soccer +social +sock +soda +soft +solar +soldier +solid +solution +solve +someone +song +soon +sorry +sort +soul +sound +soup +source +south +space +spare +spatial +spawn +speak +special +speed +spell +spend +sphere +spice +spider +spike +spin +spirit +split +spoil +sponsor +spoon +sport +spot +spray +spread +spring +spy +square +squeeze +squirrel +stable +stadium +staff +stage +stairs +stamp +stand +start +state +stay +steak +steel +stem +step +stereo +stick +still +sting +stock +stomach +stone +stool +story +stove +strategy +street +strike +strong +struggle +student +stuff +stumble +style +subject +submit +subway +success +such +sudden +suffer +sugar +suggest +suit +summer +sun +sunny +sunset +super +supply +supreme +sure +surface +surge +surprise +surround +survey +suspect +sustain +swallow +swamp +swap +swarm +swear +sweet +swift +swim +swing +switch +sword +symbol +symptom +syrup +system +table +tackle +tag +tail +talent +talk +tank +tape +target +task +taste +tattoo +taxi +teach +team +tell +ten +tenant +tennis +tent +term +test +text +thank +that +theme +then +theory +there +they +thing +this +thought +three +thrive +throw +thumb +thunder +ticket +tide +tiger +tilt +timber +time +tiny +tip +tired +tissue +title +toast +tobacco +today +toddler +toe +together +toilet +token +tomato +tomorrow +tone +tongue +tonight +tool +tooth +top +topic +topple +torch +tornado +tortoise +toss +total +tourist +toward +tower +town +toy +track +trade +traffic +tragic +train +transfer +trap +trash +travel +tray +treat +tree +trend +trial +tribe +trick +trigger +trim +trip +trophy +trouble +truck +true +truly +trumpet +trust +truth +try +tube +tuition +tumble +tuna +tunnel +turkey +turn +turtle +twelve +twenty +twice +twin +twist +two +type +typical +ugly +umbrella +unable +unaware +uncle +uncover +under +undo +unfair +unfold +unhappy +uniform +unique +unit +universe +unknown +unlock +until +unusual +unveil +update +upgrade +uphold +upon +upper +upset +urban +urge +usage +use +used +useful +useless +usual +utility +vacant +vacuum +vague +valid +valley +valve +van +vanish +vapor +various +vast +vault +vehicle +velvet +vendor +venture +venue +verb +verify +version +very +vessel +veteran +viable +vibrant +vicious +victory +video +view +village +vintage +violin +virtual +virus +visa +visit +visual +vital +vivid +vocal +voice +void +volcano +volume +vote +voyage +wage +wagon +wait +walk +wall +walnut +want +warfare +warm +warrior +wash +wasp +waste +water +wave +way +wealth +weapon +wear +weasel +weather +web +wedding +weekend +weird +welcome +west +wet +whale +what +wheat +wheel +when +where +whip +whisper +wide +width +wife +wild +will +win +window +wine +wing +wink +winner +winter +wire +wisdom +wise +wish +witness +wolf +woman +wonder +wood +wool +word +work +world +worry +worth +wrap +wreck +wrestle +wrist +write +wrong +yard +year +yellow +you +young +youth +zebra +zero +zone +zoo diff --git a/lib/ui/data/images/icon.png b/lib/ui/data/images/icon.png new file mode 100644 index 00000000000..65350077f0d Binary files /dev/null and b/lib/ui/data/images/icon.png differ diff --git a/lib/ui/src/Cardano/Wallet/UI/API.hs b/lib/ui/src/Cardano/Wallet/UI/API.hs new file mode 100644 index 00000000000..c54268b5aea --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/API.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Wallet.UI.API where + +import Prelude + +import Cardano.Wallet.Primitive.Types + ( WalletId (..) + ) +import Cardano.Wallet.UI.Cookies + ( CookieRequest + , Cookied + ) +import Cardano.Wallet.UI.Handlers.SSE + ( SSE + ) +import Cardano.Wallet.UI.Html.Html + ( HTML + , RawHtml (..) + ) +import Data.Aeson + ( Value + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( ToText (..) + ) +import Network.HTTP.Media + ( (//) + ) +import Servant + ( Accept (..) + , Capture + , FromHttpApiData (..) + , Get + , JSON + , Link + , MimeRender (..) + , Post + , Proxy (..) + , QueryParam + , ReqBody + , ToHttpApiData (..) + , allLinks + , linkURI + , (:<|>) (..) + , (:>) + ) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + +data Visible = Visible | Hidden + +instance FromHttpApiData Visible where + parseQueryParam "visible" = Right Visible + parseQueryParam "hidden" = Right Hidden + parseQueryParam _ = Left "Invalid value for visibility" + +instance ToHttpApiData Visible where + toQueryParam Visible = "visible" + toQueryParam Hidden = "hidden" + +instance ToHttpApiData WalletId where + toQueryParam = toText + +type SessionedHtml b = Cookied (b '[HTML]) RawHtml + +infixr 5 |> + +-- | Prepend a path segment to every path +type family f |> xs where + q |> (f :<|> g) = (q :> f) :<|> q |> g + q |> f = q :> f + +infixr 4 |>> + +-- | Append a paths +type family xs |>> ys where + (x :<|> xs) |>> ys = x :<|> xs |>> ys + x |>> ys = x :<|> ys + +-- | Pages endpoints +type Pages = + "about" :> SessionedHtml Get + :<|> "network" :> SessionedHtml Get + :<|> "wallet" :> SessionedHtml Get + :<|> "wallets" :> SessionedHtml Get + :<|> "addresses" :> SessionedHtml Get + :<|> "settings" :> SessionedHtml Get + +-- | Image mime type +data Image + +instance Accept Image where + contentType _ = "image" // "png" + +instance MimeRender Image BL.ByteString where + mimeRender _ = id + +-- | Data endpoints +type Data = + "network" :> "info" :> SessionedHtml Get + :<|> "wallet" :> ReqBody '[JSON] Value :> SessionedHtml Post + :<|> "wallet" + :> "mnemonic" + :> QueryParam "clean" Bool + :> SessionedHtml Get + :<|> "wallet" + :> "post" + :> "form" + :> QueryParam "visible" Visible + :> SessionedHtml Get + :<|> "wallets" :> "list" :> SessionedHtml Get + :<|> "wallet" :> SessionedHtml Get + :<|> "wallet" :> "addresses" :> SessionedHtml Get + :<|> "wallet" :> "delete" :> SessionedHtml Post + :<|> "settings" :> SessionedHtml Get + :<|> "settings" :> "sse" :> "toggle" :> SessionedHtml Post + :<|> "wallets" + :> "select" + :> Capture "id" WalletId + :> SessionedHtml Post + :<|> "sse" :> (CookieRequest :> SSE) + :<|> "favicon.ico" :> Get '[Image] BL.ByteString + +type Home = SessionedHtml Get + +-- | UI endpoints +type UI = + Home + :<|> "page" + |> Pages + |>> "data" + |> Data + +homePageLink :: Link +aboutPageLink :: Link +networkPageLink :: Link +walletPageLink :: Link +walletsPageLink :: Link +addressesPageLink :: Link +settingsPageLink :: Link +networkInfoLink :: Link +walletPostLink :: Link +walletMnemonicLink :: Maybe Bool -> Link +walletPostFormLink :: Maybe Visible -> Link +walletsListLink :: Link +walletLink :: Link +walletAddressesLink :: Link +walletDeleteLink :: Link +settingsGetLink :: Link +settingsSseToggleLink :: Link +settingsWalletSelectLink :: WalletId -> Link +sseLink :: Link +faviconLink :: Link + +homePageLink + :<|> aboutPageLink + :<|> networkPageLink + :<|> walletPageLink + :<|> walletsPageLink + :<|> addressesPageLink + :<|> settingsPageLink + :<|> networkInfoLink + :<|> walletPostLink + :<|> walletMnemonicLink + :<|> walletPostFormLink + :<|> walletsListLink + :<|> walletLink + :<|> walletAddressesLink + :<|> walletDeleteLink + :<|> settingsGetLink + :<|> settingsSseToggleLink + :<|> settingsWalletSelectLink + :<|> sseLink + :<|> faviconLink = + allLinks (Proxy @UI) + +linkText :: Link -> Text +linkText = T.pack . ('/' :) . show . linkURI diff --git a/lib/ui/src/Cardano/Wallet/UI/Cookies.hs b/lib/ui/src/Cardano/Wallet/UI/Cookies.hs new file mode 100644 index 00000000000..8f8181e17b7 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Cookies.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Cardano.Wallet.UI.Cookies + ( CookieRequest + , CookieResponse + , Cookied + , RequestCookies (..) + , SessionKey (..) + , cookieName + , sessioning + , withSession + , withSessionRead + ) +where + +import Prelude + +import Control.Monad + ( replicateM + ) +import Control.Monad.IO.Class + ( liftIO + ) +import Data.ByteString + ( ByteString + ) +import Servant + ( FromHttpApiData (parseHeader, parseQueryParam) + , Handler + , Header + , Headers + , addHeader + , type (:>) + ) +import System.Random + ( randomRIO + ) +import Web.Cookie + ( Cookies + , SetCookie (..) + , defaultSetCookie + , parseCookies + ) + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Text.Encoding as T + +-- | A type representing a request that may contain cookies. +type CookieRequest = Header "Cookie" RequestCookies + +-- | A type representing a response that may contain cookies. +type CookieResponse a = Headers '[Header "Set-Cookie" SetCookie] a + +-- | A type representing a request and response that may contain cookies. +type Cookied b a = CookieRequest :> b (CookieResponse a) + +-- | Cookies in a request. +newtype RequestCookies = RequestCookies Cookies + +instance FromHttpApiData RequestCookies where + parseHeader = return . RequestCookies . parseCookies + parseQueryParam = return . RequestCookies . parseCookies . T.encodeUtf8 + +-- | The name of the cookie used to store the session key. +cookieName :: ByteString +cookieName = "wallet-UI" + +-- | A 'SetCookie' value for a given session key. +setCookie :: SessionKey -> SetCookie +setCookie (SessionKey v) = + defaultSetCookie + { setCookieName = cookieName + , setCookieValue = v + } + +newtype SessionKey = SessionKey ByteString + deriving (Eq, Ord, Show) + +sessioning + :: Handler a + -> Maybe RequestCookies + -> Handler (CookieResponse a) +sessioning action = withSession (const action) + +withSession + :: (SessionKey -> Handler a) + -> Maybe RequestCookies + -> Handler (CookieResponse a) +withSession action mc = do + c <- case mc of + Nothing -> createCookie + Just (RequestCookies cs) -> + maybe createCookie (pure . SessionKey) (lookup cookieName cs) + addHeader (setCookie c) <$> action c + +withSessionRead + :: (SessionKey -> Handler a) + -> Maybe RequestCookies + -> Handler a +withSessionRead action mc = do + c <- case mc of + Nothing -> createCookie + Just (RequestCookies cs) -> + maybe createCookie (pure . SessionKey) (lookup cookieName cs) + action c + +-- | Create a new session key. +createCookie :: Handler SessionKey +createCookie = + liftIO + $ fmap (SessionKey . B8.pack) + $ replicateM 16 + $ randomRIO ('a', 'z') diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/Addresses.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/Addresses.hs new file mode 100644 index 00000000000..d3df889de76 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/Addresses.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Handlers.Addresses + ( listAddresses + ) +where + +import Prelude hiding + ( lookup + ) + +import Cardano.Wallet + ( normalizeDelegationAddress + ) +import Cardano.Wallet.Address.Derivation.Shelley + ( ShelleyKey (..) + ) +import Cardano.Wallet.Address.Discovery.Sequential + ( SeqState + ) +import Cardano.Wallet.Api + ( ApiLayer + ) +import Cardano.Wallet.Api.Types + ( ApiAddressWithPath + , ApiT (..) + ) +import Cardano.Wallet.Primitive.NetworkId + ( HasSNetworkId (..) + ) +import Cardano.Wallet.UI.Handlers.Lib + ( alertOnServerError + , catching + ) +import Cardano.Wallet.UI.Html.Html + ( RawHtml (..) + ) +import Cardano.Wallet.UI.Layer + ( SessionLayer (..) + , walletId + ) +import Control.Lens + ( view + ) +import Control.Monad.Trans + ( MonadIO (..) + ) +import Servant + ( Handler + , runHandler + ) + +import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server +import qualified Data.ByteString.Lazy.Char8 as BL + +listAddresses + :: forall n + . HasSNetworkId n + => SessionLayer + -> ApiLayer (SeqState n ShelleyKey) + -> (BL.ByteString -> RawHtml) + -> ([ApiAddressWithPath n] -> RawHtml) + -> Handler RawHtml +listAddresses SessionLayer{..} ctx alert render = catching alert $ do + liftIO $ do + mwid <- view walletId <$> state + case mwid of + Nothing -> pure $ alert "No wallet selected" + Just wid -> do + result <- + runHandler + $ Server.listAddresses + ctx + (normalizeDelegationAddress @_ @ShelleyKey @n) + (ApiT wid) + Nothing + pure $ alertOnServerError alert render result diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/Lib.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/Lib.hs new file mode 100644 index 00000000000..f405e71520d --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/Lib.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Handlers.Lib + ( handleParseRequestError + , alertOnServerError + , catching + , withWallet + , evenWithNoWallet + ) +where + +import Prelude + +import Cardano.Wallet.Primitive.Types + ( WalletId + ) +import Cardano.Wallet.UI.Layer + ( SessionLayer (..) + , walletId + ) +import Control.Lens + ( view + ) +import Control.Monad.Catch + ( MonadCatch (..) + , SomeException (..) + ) +import Data.Aeson + ( Value + , decode + ) +import Servant + ( Handler + , ServerError (..) + , err400 + , throwError + ) +import Servant.Server + ( runHandler + ) + +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.ByteString.Lazy.Char8 as BL + +-- | Handle a parsing error by returning a 400 error with the error message. +handleParseRequestError :: Either String a -> Handler a +handleParseRequestError = \case + Left e -> throwError $ err400{errBody = BL.pack e} + Right a -> pure a + +-- +alertOnServerError + :: (BL.ByteString -> html) + -> (b -> html) + -> Either ServerError b + -> html +alertOnServerError alert render = \case + Left ServerError{..} -> + case decode errBody of + Nothing -> alert errBody + Just je -> alert $ Aeson.encodePretty @Value je + Right ws -> render ws + +catching :: MonadCatch m => (BL.ByteString -> html) -> m html -> m html +catching alert f = catch f + $ \(SomeException e) -> pure . alert . BL.pack . show $ e + +-- | Run a handler with the current wallet, if any, or return an error message. +withWallet + :: SessionLayer + -> (BL.ByteString -> html) + -- ^ Alert renderer + -> (a -> html) + -- ^ Result renderer + -> (WalletId -> Handler a) + -- ^ Action to run with the wallet + -> IO html +withWallet SessionLayer{..} alert render action = catching alert $ do + mwid <- view walletId <$> state + case mwid of + Nothing -> do + pure $ alert "No wallet selected" + Just wid -> do + result <- runHandler $ action wid + pure $ alertOnServerError alert render result + +evenWithNoWallet + :: (BL.ByteString -> html) + -> (a -> html) + -> (Handler a) + -> IO html +evenWithNoWallet alert render action = + catching alert $ do + result <- runHandler action + pure $ alertOnServerError alert render result diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/SSE.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/SSE.hs new file mode 100644 index 00000000000..ea5cdc6e931 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/SSE.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Wallet.UI.Handlers.SSE + ( Message (..) + , SSE + , sse + ) +where + +import Prelude + +import Control.Monad.Fix + ( fix + ) +import Data.Typeable + ( Typeable + ) +import Servant + ( Accept (contentType) + , MimeRender (..) + , NoFraming + , Server + , SourceIO + , StreamGet + ) +import Servant.Types.SourceT + ( StepT (..) + , fromStepT + ) +import UnliftIO + ( TChan + , dupTChan + , readTChan + ) +import UnliftIO.STM + ( atomically + ) + +import Lucid + ( Html + , renderBS + ) + +import qualified Data.ByteString.Lazy as BL +import qualified Network.HTTP.Media as M + +-- imitate the Servant JSON and OctetStream implementations +data EventStream deriving (Typeable) + +instance Accept EventStream where + contentType _ = "text" M.// "event-stream" + +data Message = Message + { event :: BL.ByteString + , data_ :: Html () + } + deriving (Show) + +instance MimeRender EventStream Message where + mimeRender _ Message{..} = + "event: " + <> event + <> "\ndata: " + <> renderBS data_ + <> "\n\n" + +type SSE = StreamGet NoFraming EventStream (SourceIO Message) + +sse :: TChan Message -> Server SSE +sse sseConfigSource = do + duplicate <- atomically $ dupTChan sseConfigSource + pure $ fromStepT $ fix $ \s -> Effect $ do + x <- atomically $ readTChan duplicate + pure $ Yield x s diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/Settings.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/Settings.hs new file mode 100644 index 00000000000..dde50a15157 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/Settings.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Wallet.UI.Handlers.Settings + ( toggleSSE + ) where + +import Prelude + +import Cardano.Wallet.UI.Layer + ( Push (..) + , SessionLayer (..) + , sseEnabled + ) +import Control.Lens + ( over + ) +import Control.Monad.Trans + ( MonadIO (..) + ) +import Servant + ( Handler + ) + +toggleSSE :: SessionLayer -> Handler () +toggleSSE SessionLayer{..} = liftIO $ do + update $ over sseEnabled not + sendSSE $ Push "settings" diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/State.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/State.hs new file mode 100644 index 00000000000..1fe4a3a8416 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/State.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Wallet.UI.Handlers.State + ( getState + ) where + +import Prelude + +import Cardano.Wallet.UI.Html.Html + ( RawHtml (..) + ) +import Cardano.Wallet.UI.Layer + ( SessionLayer (..) + , State + ) +import Control.Monad.Trans + ( MonadIO (..) + ) +import Servant + ( Handler + ) + +getState + :: SessionLayer + -> (State -> RawHtml) + -> Handler RawHtml +getState uiLayer render = fmap render . liftIO $ state uiLayer diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/Wallet.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/Wallet.hs new file mode 100644 index 00000000000..6b4fd4d911e --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/Wallet.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Handlers.Wallet where + +import Prelude hiding + ( lookup + ) + +import Cardano.Mnemonic + ( MkSomeMnemonic (mkSomeMnemonic) + ) +import Cardano.Wallet.Address.Derivation.Shelley + ( ShelleyKey (..) + ) +import Cardano.Wallet.Address.Discovery.Sequential + ( SeqState + ) +import Cardano.Wallet.Api + ( ApiLayer + , PostData + ) +import Cardano.Wallet.Api.Types + ( AllowedMnemonics + , ApiMnemonicT (..) + , ApiT (..) + , ApiWallet + , WalletOrAccountPostData (WalletOrAccountPostData) + , WalletPostData (..) + , WalletStyle (..) + ) +import Cardano.Wallet.Primitive.NetworkId + ( HasSNetworkId (..) + ) +import Cardano.Wallet.Primitive.Types + ( WalletId + ) +import Cardano.Wallet.UI.Handlers.Lib + ( evenWithNoWallet + , handleParseRequestError + , withWallet + ) +import Cardano.Wallet.UI.Layer + ( Push (..) + , SessionLayer (..) + , walletId + ) +import Control.Lens + ( set + , (^.) + ) +import Control.Monad + ( replicateM + ) +import Control.Monad.Trans + ( MonadIO (..) + ) +import Data.Aeson + ( Value + , withObject + ) +import Data.Aeson.Types + ( parseEither + , (.:) + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( FromText (..) + ) +import Paths_cardano_wallet_ui + ( getDataFileName + ) +import Servant + ( Handler + , NoContent + ) +import System.Random.Stateful + ( randomRIO + ) + +import qualified Cardano.Wallet.Address.Derivation.Shelley as Shelley +import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text as T + +newWallet :: Text -> Text -> Text -> PostData ApiWallet +newWallet xs name' passphrase' = + WalletOrAccountPostData + $ Left + $ WalletPostData + Nothing + ( ApiMnemonicT + $ fromRight + $ mkSomeMnemonic @(AllowedMnemonics 'Shelley) + $ T.words xs + ) + Nothing + (ApiT $ fromRight $ fromText name') + (ApiT $ fromRight $ fromText passphrase') + Nothing + Nothing + +postWallet + :: HasSNetworkId n + => SessionLayer + -> ApiLayer (SeqState n ShelleyKey) + -> (BL.ByteString -> html) -- problem report + -> (ApiWallet -> html) -- success report + -> Value + -> Handler html +postWallet SessionLayer{..} ctx alert render v = do + (mnemonic, name', password) <- + handleParseRequestError + $ parsePostWalletRequest v + liftIO $ do + evenWithNoWallet alert render $ do + r <- Server.postWallet ctx Shelley.generateKeyFromSeed ShelleyKey + $ newWallet mnemonic name' password + liftIO $ do + sendSSE $ Push "wallets" + update $ set walletId $ Just $ r ^. #id . #getApiT + pure r + +parsePostWalletRequest :: Value -> Either String (Text, Text, Text) +parsePostWalletRequest = parseEither + . withObject "create wallet request" + $ \o -> do + mnemonic <- o .: "mnemonicSentence" + name' <- o .: "name" + password <- o .: "passphrase" + pure (mnemonic, name', password) + +fromRight :: Show a => Either a b -> b +fromRight (Right a) = a +fromRight (Left a) = error $ show a + +pickMnemonic :: Int -> Maybe Bool -> IO (Maybe [Text]) +pickMnemonic _n (Just True) = pure Nothing +pickMnemonic n _ = do + wordsFile <- getDataFileName "data/english.txt" + dict <- fmap T.pack . words <$> readFile wordsFile + + let loop = do + xs <- replicateM n $ do + i <- randomRIO (0, length dict - 1) + pure $ dict !! i + case mkSomeMnemonic @(AllowedMnemonics 'Shelley) xs of + Left _ -> loop + Right _ -> pure xs + Just <$> loop + +data UIWallet = UIWallet {id :: WalletId, name :: Text} + +getWallet + :: HasSNetworkId n + => SessionLayer -- session provider + -> ApiLayer (SeqState n ShelleyKey) -- api provider + -> (BL.ByteString -> html) -- problem report + -> (ApiWallet -> html) -- success report + -> Handler html +getWallet layer ctx alert render = liftIO $ do + withWallet layer alert render $ \wid -> + fmap fst $ Server.getWallet ctx Server.mkShelleyWallet $ ApiT wid + +deleteWallet + :: SessionLayer + -> ApiLayer (SeqState n ShelleyKey) + -> (BL.ByteString -> html) + -> (NoContent -> html) + -> Handler html +deleteWallet layer ctx alert render = liftIO $ do + withWallet layer alert render $ \wid -> do + r <- Server.deleteWallet ctx $ ApiT wid + liftIO $ do + update layer $ set walletId Nothing + sendSSE layer $ Push "wallets" + sendSSE layer $ Push "wallet" + pure r + +selectWallet :: SessionLayer -> WalletId -> Handler () +selectWallet SessionLayer{..} wid = liftIO $ do + update $ set walletId $ Just wid + sendSSE $ Push "wallet" + sendSSE $ Push "wallets" + sendSSE $ Push "settings" diff --git a/lib/ui/src/Cardano/Wallet/UI/Handlers/Wallets.hs b/lib/ui/src/Cardano/Wallet/UI/Handlers/Wallets.hs new file mode 100644 index 00000000000..2b46d279b7f --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Handlers/Wallets.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Handlers.Wallets where + +import Prelude + +import Cardano.Wallet.Address.Derivation.Shelley + ( ShelleyKey (..) + ) +import Cardano.Wallet.Address.Discovery.Sequential + ( SeqState + ) +import Cardano.Wallet.Api + ( ApiLayer + ) +import Cardano.Wallet.Primitive.NetworkId + ( HasSNetworkId (..) + ) +import Cardano.Wallet.UI.Html.Html + ( RawHtml (..) + ) +import Control.Monad.Catch + ( MonadCatch (..) + , SomeException (..) + ) +import Control.Monad.Trans + ( MonadIO (..) + ) +import Data.Aeson + ( Value + , decode + ) +import Servant + ( Handler + , ServerError (..) + , runHandler + ) + +import Cardano.Wallet.Api.Types + ( ApiWallet + ) +import Cardano.Wallet.Primitive.Types + ( WalletId + ) +import Cardano.Wallet.UI.Layer + ( SessionLayer (..) + , walletId + ) +import Control.Lens + ( view + ) +import Data.Time + ( UTCTime + ) + +import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.ByteString.Lazy.Char8 as BL + +listWallets + :: HasSNetworkId n + => SessionLayer + -> ApiLayer (SeqState n ShelleyKey) + -> (Maybe WalletId -> [(ApiWallet, UTCTime)] -> RawHtml) + -> Handler RawHtml +listWallets SessionLayer{..} ctx render = do + catch + do + ex <- + liftIO + $ runHandler + $ Server.listWallets ctx Server.mkShelleyWallet + case ex of + Left ServerError{..} -> + case decode errBody of + Nothing -> pure . RawHtml $ errBody + Just je -> pure . RawHtml . Aeson.encodePretty @Value $ je + Right ls -> do + wid <- liftIO $ view walletId <$> state + pure $ render wid ls + do \(SomeException e) -> pure . RawHtml . BL.pack . show $ e diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Html.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Html.hs new file mode 100644 index 00000000000..d59a74ed6d8 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Html.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Cardano.Wallet.UI.Html.Html where + +import Prelude + +import Lucid + ( Html + , renderBS + ) +import Network.HTTP.Media + ( (//) + , (/:) + ) +import Servant + ( Accept (contentType) + , MimeRender (..) + ) + +import qualified Data.ByteString.Lazy as BL + +data HTML = HTML + +newtype RawHtml = RawHtml {unRaw :: BL.ByteString} + +instance Accept HTML where + contentType _ = "text" // "html" /: ("charset", "utf-8") + +instance MimeRender HTML RawHtml where + mimeRender _ = unRaw + +renderHtml :: Html () -> RawHtml +renderHtml = RawHtml . renderBS diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Htmx.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Htmx.hs new file mode 100644 index 00000000000..5a91315afab --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Htmx.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Wallet.UI.Html.Htmx + ( hxBoost_ + , hxConfirm_ + , hxEncoding_ + , hxExt_ + , hxDelete_ + , hxDisable_ + , hxGet_ + , hxHeaders_ + , hxHistoryElt_ + , hxInclude_ + , hxIndicator_ + , hxParams_ + , hxPatch_ + , hxPost_ + , hxPreserve_ + , hxPrompt_ + , hxPushUrl_ + , hxPut_ + , hxRequest_ + , hxSelect_ + , hxSse_ + , hxSwapOob_ + , hxSwap_ + , hxTarget_ + , hxTrigger_ + , hxVals_ + , hxWs_ + , useHtmx + , useHtmxExtension + , useHtmxVersion + , useHtmxVersionExtension + , hxSseSwap_ + ) +where + +import Prelude + +import Data.Text + ( Text + , pack + ) +import Lucid + ( Html + , HtmlT + , script_ + , src_ + ) +import Lucid.Base + ( Attribute + , makeAttribute + ) + +-- | +hxBoost_ :: Text -> Attribute +hxBoost_ = makeAttribute "data-hx-boost" + +-- | +hxConfirm_ :: Text -> Attribute +hxConfirm_ = makeAttribute "data-hx-confirm" + +-- | +hxDelete_ :: Text -> Attribute +hxDelete_ = makeAttribute "data-hx-delete" + +-- | +hxDisable_ :: Attribute +hxDisable_ = makeAttribute "data-hx-disable" mempty + +-- | +hxEncoding_ :: Text -> Attribute +hxEncoding_ = makeAttribute "data-hx-encoding" + +-- | +hxExt_ :: Text -> Attribute +hxExt_ = makeAttribute "data-hx-ext" + +-- | +hxGet_ :: Text -> Attribute +hxGet_ = makeAttribute "data-hx-get" + +-- | +hxHeaders_ :: Text -> Attribute +hxHeaders_ = makeAttribute "data-hx-headers" + +-- | +hxHistoryElt_ :: Attribute +hxHistoryElt_ = makeAttribute "data-hx-history-elt" mempty + +-- | +hxInclude_ :: Text -> Attribute +hxInclude_ = makeAttribute "data-hx-include" + +-- | +hxIndicator_ :: Text -> Attribute +hxIndicator_ = makeAttribute "data-hx-indicator" + +-- | +hxParams_ :: Text -> Attribute +hxParams_ = makeAttribute "data-hx-params" + +-- | +hxPatch_ :: Text -> Attribute +hxPatch_ = makeAttribute "data-hx-patch" + +-- | +hxPost_ :: Text -> Attribute +hxPost_ = makeAttribute "data-hx-post" + +-- | +hxPreserve_ :: Text -> Attribute +hxPreserve_ = makeAttribute "data-hx-preserve" + +-- | +hxPrompt_ :: Text -> Attribute +hxPrompt_ = makeAttribute "data-hx-prompt" + +-- | +hxPushUrl_ :: Text -> Attribute +hxPushUrl_ = makeAttribute "data-hx-push-url" + +-- | +hxPut_ :: Text -> Attribute +hxPut_ = makeAttribute "data-hx-put" + +-- | +hxRequest_ :: Text -> Attribute +hxRequest_ = makeAttribute "data-hx-request" + +-- | +hxSelect_ :: Text -> Attribute +hxSelect_ = makeAttribute "data-hx-select" + +-- | +hxSse_ :: Text -> Attribute +hxSse_ = makeAttribute "data-hx-sse" + +hxSseSwap_ :: Text -> Attribute +hxSseSwap_ = makeAttribute "sse-swap" + +-- | +hxSwapOob_ :: Text -> Attribute +hxSwapOob_ = makeAttribute "data-hx-swap-oob" + +-- | +hxSwap_ :: Text -> Attribute +hxSwap_ = makeAttribute "data-hx-swap" + +-- | +hxTarget_ :: Text -> Attribute +hxTarget_ = makeAttribute "data-hx-target" + +-- | +hxTrigger_ :: Text -> Attribute +hxTrigger_ = makeAttribute "data-hx-trigger" + +-- | +hxVals_ :: Text -> Attribute +hxVals_ = makeAttribute "data-hx-vals" + +-- | +hxWs_ :: Text -> Attribute +hxWs_ = makeAttribute "data-hx-ws" + +-- | Place in your @head_@ tag to use htmx attributes in your lucid template +useHtmx :: Monad m => HtmlT m () +useHtmx = script_ [src_ htmxSrc] ("" :: Html ()) + +-- | Place in your template after @useHtmx@, but before where the extension is used via @hxExt_@ +useHtmxExtension :: Monad m => Text -> HtmlT m () +useHtmxExtension ext = + script_ + [src_ $ htmxSrc <> extensionPath ext] + ("" :: Html ()) + +-- | Choose the version of htmx to use using a 3-tuple representing semantic versioning +useHtmxVersion + :: Monad m + => (Int, Int, Int) + -> HtmlT m () +useHtmxVersion semVer = + script_ + [src_ $ htmxSrcWithSemVer semVer] + ("" :: Html ()) + +-- | Choose the version of a htmx extension you want to use. +-- Should only be used when using @useHtmxVersion@ and the semantic version should be the same +useHtmxVersionExtension + :: Monad m + => (Int, Int, Int) + -> Text + -> HtmlT m () +useHtmxVersionExtension semVer ext = + script_ + [src_ $ htmxSrcWithSemVer semVer <> extensionPath ext] + ("" :: Html ()) + +htmxSrc :: Text +htmxSrc = "https://unpkg.com/htmx.org" + +showT :: Show a => a -> Text +showT = pack . show + +htmxSrcWithSemVer :: (Int, Int, Int) -> Text +htmxSrcWithSemVer (major, minor, patch) = + htmxSrc + <> "@" + <> showT major + <> "." + <> showT minor + <> "." + <> showT patch + +extensionPath :: Text -> Text +extensionPath ext = "/dist/ext/" <> ext <> ".js" diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Lib.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Lib.hs new file mode 100644 index 00000000000..1642123dc75 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Lib.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Wallet.UI.Html.Lib + ( showPercentage + , showLocalTime + , ShowTime + , justifyRight + + ) +where + +import Prelude + +import Data.Generics.Product + () +import Data.Time + ( UTCTime + , defaultTimeLocale + , formatTime + , getCurrentTimeZone + , utcToLocalTime + ) +import Lucid + ( Html + , ToHtml (..) + , class_ + , div_ + ) + +showPercentage :: Rational -> String +showPercentage p = + show @Double + ( fromIntegral + (round (p * 100_000_000) :: Int) + / 1_000_000 + ) + <> "%" + +type ShowTime = UTCTime -> String + +showLocalTime :: IO ShowTime +showLocalTime = do + zone <- getCurrentTimeZone + pure + $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" . utcToLocalTime zone + +justifyRight :: ToHtml b => b -> Html () +justifyRight = div_ [class_ "d-flex justify-content-end"] . toHtml diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/About.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/About.hs new file mode 100644 index 00000000000..d05a47fb4d8 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/About.hs @@ -0,0 +1,11 @@ +module Cardano.Wallet.UI.Html.Pages.About where + +import Lucid + ( Html + , p_ + ) + +aboutH :: Html () +aboutH = do + p_ + "This is the new builtin Cardano Wallet web UI, pre-alpha version" diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Addresses.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Addresses.hs new file mode 100644 index 00000000000..1c8837e1d7a --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Addresses.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Html.Pages.Addresses + ( addressesPageH + , addressesH + ) +where + +import Prelude hiding + ( id + ) + +import Cardano.Wallet.Address.Encoding + ( encodeAddress + ) +import Cardano.Wallet.Api.Types + ( ApiAddressWithPath (..) + , ApiT (..) + , apiAddress + ) +import Cardano.Wallet.Primitive.NetworkId + ( HasSNetworkId (..) + ) +import Cardano.Wallet.Primitive.Types.Address + ( Address + ) +import Cardano.Wallet.UI.API + ( sseLink + , walletAddressesLink + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( copyButton + , fieldHtml + , record + , simpleField + , sseH + ) +import Control.Monad + ( forM_ + ) +import Data.Proxy + ( Proxy (..) + ) +import Data.Text.Class + ( ToText (..) + ) +import Lucid + ( Html + , ToHtml (toHtml) + , class_ + , div_ + , id_ + , li_ + , ul_ + ) + +addressesPageH :: Html () +addressesPageH = + sseH sseLink walletAddressesLink "addresses" ["wallet"] + +addressesH :: forall n. HasSNetworkId n => [ApiAddressWithPath n] -> Html () +addressesH addresses = record $ do + forM_ (zip [0 :: Int ..] addresses) $ \(j, ApiAddressWithPath{..}) -> do + fieldHtml [] "id" $ do + let identifier = "address-" <> toText j + div_ [class_ "row"] $ do + div_ [class_ "text-break col-sm-10", id_ identifier] + $ addressH (Proxy @n) + $ apiAddress id + div_ [class_ "col-sm-2"] $ copyButton identifier + simpleField "state" $ toText $ getApiT state + fieldHtml [] "derivation path" + $ ul_ [class_ "list-inline"] + $ forM_ derivationPath + $ li_ [class_ "list-inline-item"] + . toHtml + . toText + . getApiT + +addressH :: forall n. HasSNetworkId n => Proxy n -> Address -> Html () +addressH _ a = toHtml $ encodeAddress (sNetworkId @n) a diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Lib.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Lib.hs new file mode 100644 index 00000000000..0a3715df82a --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Lib.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Html.Pages.Lib + ( PrintHtml + , alertH + , rogerH + , AssocRow (..) + , assocRowH + , record + , field + , simpleField + , fieldHtml + , fieldShow + , sseH + , sseInH + , adaOfLovelace + , showAda + , showAdaOfLoveLace + , showThousandDots + , copyButton + ) +where + +import Prelude + +import Cardano.Wallet.UI.API + ( linkText + ) +import Cardano.Wallet.UI.Html.Htmx + ( hxExt_ + , hxGet_ + , hxSse_ + , hxSwap_ + , hxTarget_ + , hxTrigger_ + ) +import Cardano.Wallet.UI.Lib.ListOf + ( Cons (..) + , ListOf + , listOf + ) +import Control.Monad.Operational + ( singleton + ) +import Data.ByteString.Lazy.Char8 + ( ByteString + ) +import Data.String.Interpolate + ( i + ) +import Data.Text + ( Text + ) +import Lucid + ( Attribute + , Html + , ToHtml (..) + , b_ + , button_ + , class_ + , div_ + , id_ + , role_ + , scope_ + , script_ + , table_ + , td_ + , tr_ + ) +import Lucid.Base + ( makeAttribute + ) +import Numeric.Natural + ( Natural + ) +import Servant + ( Link + ) + +import qualified Data.Text as T + +type PrintHtml = forall a. ToHtml a => a -> ByteString + +alertH :: ToHtml a => a -> Html () +alertH = + div_ + [ id_ "result" + , class_ "alert alert-primary" + , role_ "alert" + ] + . toHtml + +rogerH :: ToHtml a => a -> Html () +rogerH = + div_ + [ id_ "result" + , class_ "alert alert-success" + , role_ "alert" + ] + . toHtml + +data AssocRow = forall b k . + (ToHtml b, ToHtml k) => + AssocRow + { rowAttributes :: [Attribute] + , key :: k + , val :: b + } + +assocRowH :: AssocRow -> Html () +assocRowH AssocRow{..} = tr_ ([scope_ "row"] <> rowAttributes) $ do + td_ [scope_ "col"] $ b_ $ toHtml key + td_ [scope_ "col"] $ toHtml val + +record :: ListOf AssocRow -> Html () +record xs = + table_ [class_ "table table-hover table-striped"] + $ mapM_ assocRowH + $ listOf xs + +field :: (ToHtml b, ToHtml k) => [Attribute] -> k -> b -> ListOf AssocRow +field attrs key val = singleton $ Elem $ AssocRow attrs key val + +simpleField :: ToHtml b => Text -> b -> ListOf AssocRow +simpleField = field [] + +fieldHtml :: [Attribute] -> Text -> Html () -> ListOf AssocRow +fieldHtml = field @(Html ()) + +fieldShow :: Show a => [Attribute] -> Text -> a -> ListOf AssocRow +fieldShow attrs key val = field attrs key (show val) + +sseConnectFromLink :: Link -> Text +sseConnectFromLink sse = "connect:" <> linkText sse + +sseH + :: Link + -- ^ SSE link + -> Link + -- ^ Link to fetch data from + -> Text + -- ^ Target element + -> [Text] + -- ^ Events to trigger onto + -> Html () +sseH sseLink link target events = do + div_ [hxSse_ $ sseConnectFromLink sseLink] $ do + div_ + [ hxTrigger_ triggered + , hxGet_ $ linkText link + , hxTarget_ $ "#" <> target + , hxSwap_ "innerHTML" + ] + $ div_ + [ id_ target + , hxGet_ $ linkText link + , hxTrigger_ "load" + ] + "" + where + triggered = T.intercalate "," $ ("sse:" <>) <$> events + +sseInH :: Link -> Text -> [Text] -> Html () +sseInH sseLink target events = + div_ + [ hxSse_ $ sseConnectFromLink sseLink + , hxExt_ "sse" + ] + + $ div_ + [ hxTarget_ $ "#" <> target + , hxSwap_ "innerHTML" + , makeAttribute "sse-swap" triggered + ] + $ div_ [id_ target] "hello" + where + triggered = T.intercalate "," events + +adaOfLovelace :: Natural -> (Natural, Natural) +adaOfLovelace x = + let + (ada, lovelace) = properFraction @Double $ fromIntegral x / 1_000_000 + in + (ada, floor $ lovelace * 1_000_000) + +showAda :: (Natural, Natural) -> Text +showAda (ada, lovelace) = T.pack $ showThousandDots ada <> ", " <> pad 6 (show lovelace) <> " ADA" + where + pad n s = replicate (n - length s) '0' <> s + +showAdaOfLoveLace :: Natural -> Text +showAdaOfLoveLace = showAda . adaOfLovelace + +showThousandDots :: Show a => a -> String +showThousandDots = reverse . showThousandDots' . reverse . show + where + showThousandDots' :: String -> String + showThousandDots' [] = [] + showThousandDots' xs = + let + (a, b) = splitAt 3 xs + in + a <> if null b then [] else "." <> showThousandDots' b + +copyButton :: Text -> Html () +copyButton field' = do + script_ + [i| + document.getElementById('#{button}').addEventListener('click', function() { + var mnemonic = document.getElementById('#{field'}').innerText; + navigator.clipboard.writeText(mnemonic); + }); + |] + button_ [class_ "btn btn-outline-secondary", id_ button] "Copy" + where + button = field' <> "-copy-button" diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Network.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Network.hs new file mode 100644 index 00000000000..445049af996 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Network.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Wallet.UI.Html.Pages.Network where + +import Prelude + +import Cardano.Slotting.Slot + ( SlotNo (..) + ) +import Cardano.Wallet.Api.Types + ( ApiBlockInfo (..) + , ApiBlockReference (..) + , ApiEra (..) + , ApiNetworkInfo (..) + , ApiNetworkInformation (..) + , ApiSlotReference (..) + , ApiT (..) + ) +import Cardano.Wallet.Pools + ( EpochInfo (..) + ) +import Cardano.Wallet.Primitive.SyncProgress + ( SyncProgress (..) + ) +import Cardano.Wallet.Primitive.Types.EpochNo + ( EpochNo (..) + ) +import Cardano.Wallet.UI.API + ( networkInfoLink + , sseLink + ) +import Cardano.Wallet.UI.Html.Lib + ( ShowTime + , showPercentage + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( fieldShow + , record + , showThousandDots + , simpleField + , sseH + ) +import Data.Quantity + ( Quantity (..) + ) +import Lucid + ( Html + , ToHtml (..) + , p_ + ) + +import qualified Data.Percentage as Percentage + +networkH :: Html () +networkH = sseH sseLink networkInfoLink "content" ["tip"] + +networkInfoH :: ShowTime -> ApiNetworkInformation -> Html () +networkInfoH showTime ApiNetworkInformation{..} = record $ do + simpleField "Sync progress" $ syncProgressH progress + simpleField "Next epoch" $ nextEpochH nextEpoch + simpleField "Node tip" $ blockReferenceH showTime nodeTip + simpleField "Node era" $ nodeEraH nodeEra + simpleField "Network tip" $ networkTipH showTime networkTip + simpleField "Network info" $ networkInfoH' networkInfo + where + ApiT progress = syncProgress + +nextEpochH :: Maybe EpochInfo -> Html () +nextEpochH Nothing = p_ "Unknown" +nextEpochH (Just EpochInfo{..}) = do + record $ do + simpleField "Epoch start" $ show epochStartTime + simpleField "Epoch number" $ showThousandDots epochNumber' + where + EpochNo epochNumber' = epochNumber + +syncProgressH :: SyncProgress -> Html () +syncProgressH Ready = "Ready" +syncProgressH (Syncing (Quantity percentage)) = + "Syncing " <> toHtml (showPercentage $ Percentage.toRational percentage) +syncProgressH (NotResponding) = "Not Responding" + +blockReferenceH :: ShowTime -> ApiBlockReference -> Html () +blockReferenceH showTime ApiBlockReference{..} = + record $ do + simpleField "Slot" $ showThousandDots slot + simpleField "Time" $ showTime time + simpleField "Block" $ blockInfoH block + where + ApiT (SlotNo slot) = absoluteSlotNumber + +blockInfoH :: ApiBlockInfo -> Html () +blockInfoH (ApiBlockInfo (Quantity height)) = toHtml (showThousandDots height) + +networkTipH :: ShowTime -> Maybe ApiSlotReference -> Html () +networkTipH _ Nothing = "Unknown" +networkTipH showTime (Just ApiSlotReference{..}) = do + record $ do + simpleField "Slot" $ showThousandDots slot + simpleField "Time" $ showTime time + where + ApiT (SlotNo slot) = absoluteSlotNumber + +nodeEraH :: ApiEra -> Html () +nodeEraH ApiByron = "Byron" +nodeEraH ApiShelley = "Shelley" +nodeEraH ApiAllegra = "Allegra" +nodeEraH ApiMary = "Mary" +nodeEraH ApiAlonzo = "Alonzo" +nodeEraH ApiBabbage = "Babbage" +nodeEraH ApiConway = "Conway" + +networkInfoH' :: ApiNetworkInfo -> Html () +networkInfoH' ApiNetworkInfo{..} = do + record $ do + simpleField "Network ID" networkId + fieldShow [] "Protocol Magic" protocolMagic diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Page.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Page.hs new file mode 100644 index 00000000000..57dbaedfe58 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Page.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Cardano.Wallet.UI.Html.Pages.Page + ( Page (..) + , page + , PageConfig (..) + ) +where + +import Prelude + +import Cardano.Wallet.UI.API + ( aboutPageLink + , addressesPageLink + , networkPageLink + , settingsPageLink + , walletPageLink + , walletsPageLink + ) +import Cardano.Wallet.UI.Html.Html + ( RawHtml (..) + ) +import Cardano.Wallet.UI.Html.Pages.About + ( aboutH + ) +import Cardano.Wallet.UI.Html.Pages.Addresses + ( addressesPageH + ) +import Cardano.Wallet.UI.Html.Pages.Network + ( networkH + ) +import Cardano.Wallet.UI.Html.Pages.Settings + ( settingsPageH + ) +import Cardano.Wallet.UI.Html.Pages.Template.Footer + ( footerH + ) +import Cardano.Wallet.UI.Html.Pages.Template.Head + ( HeadConfig + , pageFromBodyH + ) +import Cardano.Wallet.UI.Html.Pages.Template.Navigation + ( navigationH + ) +import Cardano.Wallet.UI.Html.Pages.Wallet + ( WalletPresent + , walletH + ) +import Cardano.Wallet.UI.Html.Pages.Wallets + ( walletsH + ) +import Control.Lens.Extras + ( is + ) +import Control.Lens.TH + ( makePrisms + ) +import Data.Text + ( Text + ) +import Lucid + ( Html + , class_ + , div_ + , renderBS + ) + +data Page + = About + | Network + | Wallets + | Wallet + | Settings + | Addresses + +makePrisms ''Page + +data PageConfig = PageConfig + { prefix :: Text + -- ^ Prefix to prepend to all links + , headConfig :: HeadConfig + -- ^ Head configuration + } + +page + :: PageConfig + -- ^ Page configuration + -> Page + -- ^ Page to render + -> WalletPresent + -- ^ If a wallet was selected + -> RawHtml +page PageConfig{..} p wp = RawHtml + $ renderBS + $ pageFromBodyH headConfig + $ bodyH prefix p + $ case p of + About -> aboutH + Network -> networkH + Wallets -> walletsH + Wallet -> walletH wp + Addresses -> addressesPageH + Settings -> settingsPageH + +bodyH + :: Text + -- ^ Prefix + -> Page + -- ^ Current page + -> Html () + -- ^ Body content + -> Html () +bodyH prefix p body = do + headerH prefix p + div_ [class_ "container-fluid"] $ do + div_ [class_ "main"] body + div_ + [class_ "footer"] + footerH + +headerH :: Text -> Page -> Html () +headerH prefix p = + navigationH + prefix + [ (is _About p, aboutPageLink, "About") + , (is _Network p, networkPageLink, "Network") + , (is _Wallets p, walletsPageLink, "List") + , (is _Wallet p, walletPageLink, "Wallet") + , (is _Addresses p, addressesPageLink, "Addresses") + , (is _Settings p, settingsPageLink, "Settings") + ] diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Settings.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Settings.hs new file mode 100644 index 00000000000..d70b9105d95 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Settings.hs @@ -0,0 +1,53 @@ +module Cardano.Wallet.UI.Html.Pages.Settings where + +import Prelude hiding + ( id + ) + +import Cardano.Wallet.UI.Html.Htmx + ( hxPost_ + , hxSwap_ + , hxTrigger_ + ) +import Lucid + ( Html + , checked_ + , class_ + , input_ + , type_ + ) + +import Cardano.Wallet.UI.API + ( linkText + , settingsGetLink + , settingsSseToggleLink + , sseLink + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( record + , simpleField + , sseH + ) +import Cardano.Wallet.UI.Layer + ( State + , sseEnabled + ) +import Control.Lens + ( view + ) + +settingsPageH :: Html () +settingsPageH = sseH sseLink settingsGetLink "content" ["settings"] + +settingsStateH :: State -> Html () +settingsStateH state = + record $ do + simpleField "Enable SSE" $ do + input_ + $ [ hxTrigger_ "click" + , type_ "checkbox" + , class_ "form-check-input" + , hxPost_ (linkText settingsSseToggleLink) + , hxSwap_ "none" + ] + <> [checked_ | view sseEnabled state] diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Footer.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Footer.hs new file mode 100644 index 00000000000..f4a055ce48a --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Footer.hs @@ -0,0 +1,47 @@ +module Cardano.Wallet.UI.Html.Pages.Template.Footer + ( footerH + ) +where + +import Prelude + +import Lucid + ( Html + , a_ + , class_ + , div_ + , href_ + , li_ + , span_ + , term + , ul_ + ) + +githubLinkH :: Html () +githubLinkH = + a_ + [href_ "https://github.com/cardano-foundation/cardano-wallet"] + "GitHub" + +footerH :: Html () +footerH = + term + "footer_" + [ class_ + "text-center text-muted bg-secondary" + ] + $ do + div_ [class_ "row d-md-flex align-items-center"] + $ do + ul_ [class_ "nav flex-column"] $ do + li_ + [class_ "nav-item mb-2"] + "© 2024 Cardano Foundation, HAL team" + li_ [class_ "nav-item mb-2"] $ do + span_ "Source code on " + githubLinkH + + div_ [class_ "row d-md-flex align-items-center"] + $ div_ + [class_ "mb-3 mb-md-0 text-body-secondary"] + "Powered by Haskell, Htmx, Servant, Lucid, Bootstrap" diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Head.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Head.hs new file mode 100644 index 00000000000..14765bdde24 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Head.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE RecordWildCards #-} +module Cardano.Wallet.UI.Html.Pages.Template.Head + ( pageFromBodyH + , HeadConfig (..) + ) +where + +import Prelude + +import Cardano.Wallet.UI.API + ( faviconLink + , linkText + ) +import Cardano.Wallet.UI.Html.Htmx + ( useHtmxVersion + ) +import qualified Data.Text as T +import Lucid + ( Html + , ToHtml (..) + , body_ + , charset_ + , content_ + , crossorigin_ + , head_ + , href_ + , html_ + , integrity_ + , link_ + , meta_ + , name_ + , rel_ + , src_ + , term + , title_ + ) +import Servant + ( Link + ) + +bootstrapLink :: Html () +bootstrapLink = + link_ + [ rel_ "stylesheet" + , href_ "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css" + , integrity_ + "sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM" + , crossorigin_ "anonymous" + ] + +bootstrapScript :: Html () +bootstrapScript = + term + "script" + [ src_ + "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js" + , integrity_ + "sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz" + , crossorigin_ "anonymous" + ] + $ pure () + +bootstrapIcons :: Html () +bootstrapIcons = + link_ + [ rel_ "stylesheet" + , href_ "https://cdn.jsdelivr.net/npm/bootstrap-icons@1.11.3/font/bootstrap-icons.min.css" + , integrity_ + "sha384-XI+Zz5ooq0QtjZVWisDbzKhZHpDvojmuW5fxM3Z1NY3VHU2hlI7c1o4TmYH72yK" + , crossorigin_ "anonymous" + ] + +popperScript :: Html () +popperScript = + term + "script" + [ src_ + "https://cdn.jsdelivr.net/npm/@popperjs/core@2.9.2/dist/umd/popper.min.js" + , integrity_ + "sha384-UOdGjl+2WYrdV0fJ9xJJ4TLEkH4WcJs1SXmeaZ7uwy/ZPwmYupt0VyrKjqqhd8q8" + , crossorigin_ "anonymous" + ] + $ pure () + +favicon :: Link -> Html () +favicon path = + link_ + [ rel_ "icon" + , href_ $ linkText path + ] + +newtype HeadConfig = HeadConfig + { title :: T.Text + } + +pageFromBodyH :: HeadConfig -> Html () -> Html () +pageFromBodyH HeadConfig{..} body = html_ [term "data-bs-theme" "dark"] + $ do + head_ $ do + title_ $ toHtml title + meta_ [charset_ "utf-8"] + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] + bootstrapLink + bootstrapScript + bootstrapIcons + popperScript + favicon faviconLink + useHtmxVersion (1,9,12) + body_ body diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Navigation.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Navigation.hs new file mode 100644 index 00000000000..ba7c10d49e2 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Template/Navigation.hs @@ -0,0 +1,49 @@ +module Cardano.Wallet.UI.Html.Pages.Template.Navigation + ( navigationH + ) +where + +import Prelude + +import Cardano.Wallet.UI.API + ( linkText + ) +import Control.Monad + ( forM_ + ) +import Data.Text + ( Text + ) +import Lucid + ( Attribute + , Html + , a_ + , class_ + , header_ + , href_ + , li_ + , term + , ul_ + ) +import Servant + ( Link + ) + +activePageH :: Bool -> [Attribute] -> [Attribute] +activePageH c = + if c + then (<> [class_ "nav-link active", term "aria-current" "page"]) + else (<> [class_ "nav-link"]) + +tabOf :: Text -> Bool -> Link -> Html () -> Html () +tabOf prefix c p t = + li_ [class_ "nav-item"] + $ a_ (activePageH c [href_ $ prefix <> linkText p]) t + +type PageLinks = [(Bool, Link, Html ())] + +navigationH :: Text -> PageLinks -> Html () +navigationH prefix pages = do + header_ [class_ "d-flex justify-content-center py-3"] $ do + ul_ [class_ "nav nav-pills"] $ do + forM_ pages $ \(c, p, t) -> tabOf prefix c p t diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallet.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallet.hs new file mode 100644 index 00000000000..9aa5b329590 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallet.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Wallet.UI.Html.Pages.Wallet where + +import Prelude hiding + ( id + ) + +import Cardano.Wallet.Address.Discovery.Sequential + ( AddressPoolGap (..) + ) +import Cardano.Wallet.Api.Types + ( ApiT (..) + , ApiWallet (..) + , ApiWalletAssetsBalance (..) + , ApiWalletBalance (..) + , ApiWalletDelegation (..) + , ApiWalletDelegationNext (..) + , ApiWalletDelegationStatus (..) + , ApiWalletPassphraseInfo (..) + ) +import Cardano.Wallet.Api.Types.Amount + ( toNatural + ) +import Cardano.Wallet.Api.Types.WalletAsset + ( ApiWalletAsset (..) + ) +import Cardano.Wallet.Api.Types.WalletAssets + ( ApiWalletAssets (..) + ) +import Cardano.Wallet.Primitive.SyncProgress + ( SyncProgress (..) + ) +import Cardano.Wallet.UI.API + ( linkText + , sseLink + , walletDeleteLink + , walletLink + ) +import Cardano.Wallet.UI.Html.Htmx + ( hxPost_ + , hxTarget_ + ) +import Cardano.Wallet.UI.Html.Lib + ( ShowTime + , showPercentage + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( fieldHtml + , record + , showThousandDots + , simpleField + , sseH + ) +import Cardano.Wallet.UI.Html.Pages.Network + ( blockReferenceH + ) +import Control.Monad + ( forM_ + ) +import Data.Quantity + ( Quantity (..) + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( ToText (..) + ) +import Lucid + ( Html + , ToHtml (toHtml) + , button_ + , class_ + , div_ + , id_ + , li_ + , ul_ + ) + +import qualified Data.Percentage as Percentage + +data WalletPresent = WalletPresent | WalletAbsent + +walletH :: WalletPresent -> Html () +walletH wp = do + sseH sseLink walletLink "wallet" ["wallet"] + case wp of + WalletPresent -> walletActionsH + WalletAbsent -> mempty + +walletActionsH :: Html () +walletActionsH = do + div_ [class_ "mt-3"] $ do + button_ + [ class_ "btn btn-danger" + , hxPost_ (linkText walletDeleteLink) + , hxTarget_ "#actions" + ] + "Forget this wallet" + div_ + [ id_ "actions" + ] + mempty + mempty + +walletElementH :: ShowTime -> ApiWallet -> Html () +walletElementH showTime ApiWallet{..} = do + record $ do + simpleField "name" $ toText $ getApiT name + simpleField "id" $ toText $ getApiT id + simpleField "state" $ renderState state + simpleField "tip" $ blockReferenceH showTime tip + simpleField "pool gap" $ renderPoolGap addressPoolGap + simpleField "balance" $ renderBalance balance + simpleField "assets" $ renderAssets assets + simpleField "delegation" $ renderDelegation delegation + simpleField "passphrase" $ renderPassphrase showTime passphrase + +renderPassphrase :: ShowTime -> Maybe ApiWalletPassphraseInfo -> Html () +renderPassphrase _ Nothing = "" +renderPassphrase showTime (Just ApiWalletPassphraseInfo{..}) = + toHtml $ showTime lastUpdatedAt + +renderPoolGap :: ApiT AddressPoolGap -> Html () +renderPoolGap = toHtml . show . getAddressPoolGap . getApiT + +renderDelegation :: ApiWalletDelegation -> Html () +renderDelegation ApiWalletDelegation{..} = record + $ do + simpleField "active" $ renderActive active + fieldHtml [] "next" $ ul_ $ forM_ next $ li_ . renderActive + +renderActive :: ApiWalletDelegationNext -> Html () +renderActive (ApiWalletDelegationNext status target voting _changesAt) = + record $ do + case status of + NotDelegating -> simpleField "not delegating" (mempty :: Text) + Delegating -> simpleField "delegating to" $ foldMap (show . getApiT) target + Voting -> simpleField "voting through" $ foldMap (show . getApiT) voting + VotingAndDelegating -> do + simpleField "delegating to" $ foldMap (show . getApiT) target + simpleField "voting through" $ foldMap (show . getApiT) voting + +renderAsset :: ApiWalletAsset -> Html () +renderAsset ApiWalletAsset{..} = record $ do + simpleField "policy id" $ toText $ getApiT policyId + simpleField "asset name" $ toText $ getApiT assetName + simpleField "quantity" $ toHtml $ showThousandDots quantity + +renderAssets :: ApiWalletAssetsBalance -> Html () +renderAssets ApiWalletAssetsBalance{..} = + record $ do + fieldHtml [] "available" + $ ul_ + $ forM_ (getApiWalletAssets available) + $ li_ + . renderAsset + fieldHtml [] "total" + $ ul_ + $ forM_ (getApiWalletAssets total) + $ li_ . renderAsset + +renderBalance :: ApiWalletBalance -> Html () +renderBalance ApiWalletBalance{..} = + record $ do + simpleField "available" $ toHtml $ showAmount available + simpleField "total" $ toHtml $ showAmount total + simpleField "reward" $ toHtml $ showAmount reward + where + showAmount = toHtml . show . toNatural + +renderState :: ApiT SyncProgress -> String +renderState (ApiT (Syncing (Quantity p))) = + showPercentage + $ Percentage.toRational p +renderState (ApiT Ready) = "Ready" +renderState (ApiT NotResponding) = "NotResponding" diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallets.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallets.hs new file mode 100644 index 00000000000..50a01a73601 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallets.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Wallet.UI.Html.Pages.Wallets where + +import Prelude hiding + ( id + ) + +import Cardano.Wallet.Api.Types + ( ApiT (..) + , ApiWallet (..) + , ApiWalletBalance (..) + ) +import Cardano.Wallet.Primitive.Types + ( WalletId + ) +import Cardano.Wallet.UI.API + ( linkText + , settingsWalletSelectLink + , sseLink + , walletsListLink + ) +import Cardano.Wallet.UI.Html.Htmx + ( hxPost_ + , hxSwap_ + , hxTrigger_ + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( AssocRow + , field + , record + , simpleField + , sseH + ) +import Cardano.Wallet.UI.Html.Pages.Wallet + ( renderState + ) +import Cardano.Wallet.UI.Html.Pages.Wallets.NewWallet + ( newWalletH + ) +import Cardano.Wallet.UI.Lib.ListOf + ( ListOf + ) +import Control.Monad + ( forM_ + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( ToText (..) + ) +import Data.Time + ( UTCTime + ) +import Lucid + ( Attribute + , Html + , ToHtml (..) + , class_ + , i_ + , scope_ + ) + +data Selected = Selected | NotSelected + +walletsH :: Html () +walletsH = do + sseH sseLink walletsListLink "content" ["wallets"] + newWalletH + +walletListH :: Maybe WalletId -> [(ApiWallet, UTCTime)] -> Html () +walletListH mwid wallets = record + $ forM_ wallets + $ \(w, _) -> do + let wid' = getApiT $ id w + walletElementH + (mkSelected $ mwid == Just wid') + w + [ scope_ "col" + , hxTrigger_ "click" + , hxPost_ $ linkText $ settingsWalletSelectLink wid' + , hxSwap_ "none" + ] + +selectedName :: Selected -> Text -> Html () +selectedName Selected name = toHtml name >> checked +selectedName NotSelected name = toHtml name + +checked :: Html () +checked = + i_ + [ class_ "bi bi-check2 ml-1 h-4 test-checked" + ] + $ pure () + +mkSelected :: Bool -> Selected +mkSelected True = Selected +mkSelected False = NotSelected + +walletElementH :: Selected -> ApiWallet -> [Attribute] -> ListOf AssocRow +walletElementH selected ApiWallet{..} attrs = + field attrs (selectedName selected $ toText $ getApiT name) $ do + record $ do + simpleField "id" $ toText $ getApiT id + simpleField "state" $ renderState state + simpleField "balance" $ renderBalance balance + +renderBalance :: ApiWalletBalance -> Html () +renderBalance ApiWalletBalance{..} = toHtml $ toText available diff --git a/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallets/NewWallet.hs b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallets/NewWallet.hs new file mode 100644 index 00000000000..1dd5e108973 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Html/Pages/Wallets/NewWallet.hs @@ -0,0 +1,118 @@ +module Cardano.Wallet.UI.Html.Pages.Wallets.NewWallet where + +import Prelude hiding + ( id + ) + +import Cardano.Wallet.UI.Html.Htmx + ( hxExt_ + , hxGet_ + , hxPost_ + , hxTarget_ + , useHtmxExtension + ) +import Lucid + ( Html + , ToHtml (..) + , autocomplete_ + , button_ + , class_ + , div_ + , form_ + , id_ + , input_ + , name_ + , placeholder_ + , role_ + , type_ + ) + +import Cardano.Wallet.UI.API + ( Visible (..) + , linkText + , walletLink + , walletMnemonicLink + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( copyButton + ) +import Data.Text + ( Text + ) + +import qualified Data.Text as T + +mnemonicH :: Maybe [Text] -> Html () +mnemonicH Nothing = "" +mnemonicH (Just mnemonic) = do + div_ [class_ "card"] $ do + div_ + [ class_ "card-body text-muted small" + , id_ "copy-mnemonic" + ] + $ toHtml + $ T.intercalate " " mnemonic + copyButton "copy-mnemonic" + +newWalletH :: Html () +newWalletH = do + useHtmxExtension "json-enc" + div_ [class_ "btn-group mb-3", role_ "group"] $ do + button_ + [ class_ "btn btn-outline-secondary" + , hxGet_ $ linkText $ walletMnemonicLink Nothing + , hxTarget_ "#menmonic" + ] + "Hint a mnemonic" + button_ + [ class_ "btn btn-outline-secondary" + , hxGet_ $ linkText $ walletMnemonicLink $ Just True + , hxTarget_ "#menmonic" + ] + "Clean hinted mnemonic" + + div_ [id_ "menmonic", class_ "mb-3"] "" + + postWalletForm Nothing + + div_ + [ id_ "new_wallet" + ] + mempty + +postWalletForm :: Maybe Visible -> Html () +postWalletForm mv = form_ + [ hxPost_ $ linkText walletLink + , hxExt_ "json-enc" + , hxTarget_ "#new_wallet" + , autocomplete_ "off" + ] + $ do + input_ + [ class_ "form-control form-control-lg mb-3" + , visibility + , name_ "mnemonicSentence" + , placeholder_ "Mnemonic Sentence" + ] + input_ + [ class_ "form-control form-control-lg mb-3" + , type_ "text" + , name_ "name" + , placeholder_ "Wallet Name" + ] + input_ + [ class_ "form-control form-control-lg mb-3" + , visibility + , name_ "passphrase" + , placeholder_ "Passphrase" + ] + button_ + [ class_ "btn btn-primary btn-block mb-3" + , type_ "submit" + ] + "Restore wallet" + where + visibility = type_ $ case mv of + Just Visible -> "text" + Just Hidden -> "password" + Nothing -> "password" diff --git a/lib/ui/src/Cardano/Wallet/UI/Layer.hs b/lib/ui/src/Cardano/Wallet/UI/Layer.hs new file mode 100644 index 00000000000..540508769a2 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Layer.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Wallet.UI.Layer + ( UILayer (..) + , withUILayer + , SessionLayer (..) + , Push (..) + , State (..) + , walletId + , sseEnabled + , sourceOfNewTip + ) +where + +import Prelude + +import Cardano.Wallet.Primitive.Types + ( WalletId + ) +import Cardano.Wallet.UI.Cookies + ( SessionKey + ) +import Cardano.Wallet.UI.Handlers.SSE + ( Message (..) + ) +import Cardano.Wallet.UI.Signal + ( Signal (..) + ) +import Control.Lens + ( Lens' + , lens + , view + ) +import Control.Monad + ( forM_ + , forever + , void + , when + ) +import Control.Tracer + ( Tracer (..) + , traceWith + ) +import UnliftIO + ( MonadIO (..) + , newEmptyTMVarIO + , putTMVar + , readTMVar + , withAsync + , writeTChan + ) +import UnliftIO.STM + ( TChan + , TVar + , atomically + , modifyTVar + , newBroadcastTChan + , newTVar + , newTVarIO + , orElse + , readTVarIO + ) + +import Cardano.Wallet.Network + ( NetworkLayer (..) + ) +import Control.Monad.Cont + ( ContT (..) + ) +import Data.Functor + ( ($>) + ) +import UnliftIO.Concurrent + ( threadDelay + ) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map + +-- | The state of the UI. +data State = State + { _walletId :: Maybe WalletId + -- ^ The selected wallet id, if any. + , _sseEnabled :: Bool + -- ^ Whether server-sent events are enabled. + } + deriving (Eq, Show) + +bootState :: State +bootState = State Nothing True + +walletId :: Lens' State (Maybe WalletId) +walletId = lens _walletId (\s a -> s{_walletId = a}) + +sseEnabled :: Lens' State Bool +sseEnabled = lens _sseEnabled (\s a -> s{_sseEnabled = a}) + +-- | A push message. +newtype Push = Push BL.ByteString + +-- | The UI layer. +data UILayer = UILayer + { sessions :: SessionKey -> IO SessionLayer + -- ^ Get the session layer for a given session key. Always succeed + , signals :: Tracer IO Signal + -- ^ A tracer for signals. + } + +-- | The session layer. +data SessionLayer = SessionLayer + { state :: IO State + -- ^ Get the state. + , update :: (State -> State) -> IO () + -- ^ Update the state. + , sendSSE :: Push -> IO () + -- ^ Send a server-sent event. + , sseConfig :: TChan Message + -- ^ The server-sent events configuration. + } + +-- | Create a session layer giver the state and the server-sent events channel. +mkSession :: TVar State -> TChan Message -> SessionLayer +mkSession var sseChan = + SessionLayer + { state = readTVarIO var + , update = atomically . modifyTVar var + , sendSSE = \x -> do + s <- readTVarIO var + case (view sseEnabled s, x) of + (True, Push m) -> write $ Message m mempty + _ -> pure () + , sseConfig = sseChan + } + where + write :: Message -> IO () + write = atomically . writeTChan sseChan + +type Throttling = IO () -> IO () + +throttler :: Int -> ContT r IO Throttling +throttler freq = do + t <- liftIO newEmptyTMVarIO + _ <- ContT $ withAsync $ forever $ do + atomically $ putTMVar t () + threadDelay $ 1_000_000 `div` freq + pure $ \action -> do + run <- atomically $ (readTMVar t $> True) `orElse` pure False + when run action + +-- | Create a UI layer given the sessions map. +mkUILayer :: Throttling -> TVar (Map.Map SessionKey SessionLayer) -> UILayer +mkUILayer throttling sessions' = UILayer{..} + where + sessions sid = do + sids <- readTVarIO sessions' + case Map.lookup sid sids of + Just session -> pure session + Nothing -> atomically $ do + sseChan <- newBroadcastTChan + var <- newTVar bootState + let session = mkSession var sseChan + modifyTVar sessions' $ Map.insert sid session + pure session + + signals = Tracer $ \case + NewTip -> throttling $ do + sessions'' <- readTVarIO sessions' + forM_ (Map.elems sessions'') $ \s -> do + sendSSE s $ Push "tip" + sendSSE s $ Push "wallets" + sendSSE s $ Push "wallet" + +-- | Run an action with a UI layer. +withUILayer :: Int -> ContT r IO UILayer +withUILayer freq = do + sessions' <- liftIO $ newTVarIO mempty + throttled <- throttler freq + pure $ mkUILayer throttled sessions' + +-- | Collect NewTip signals +sourceOfNewTip :: NetworkLayer IO block -> UILayer -> ContT r IO () +sourceOfNewTip netLayer ui = do + void + $ ContT + $ withAsync + $ watchNodeTip netLayer + $ \_ -> traceWith (signals ui) NewTip diff --git a/lib/ui/src/Cardano/Wallet/UI/Lib/ListOf.hs b/lib/ui/src/Cardano/Wallet/UI/Lib/ListOf.hs new file mode 100644 index 00000000000..dbf157a1fda --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Lib/ListOf.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Wallet.UI.Lib.ListOf where + +import Prelude + +import Control.Monad.Operational + ( Program + , ProgramView + , ProgramViewT (Return, (:>>=)) + , view + ) + +data Cons e a where + Elem :: e -> Cons e () + +type ListOf e = Program (Cons e) () + +listOf :: ListOf a -> [a] +listOf = reverse . ($ []) . interpret + +interpret :: forall e. ListOf e -> [e] -> [e] +interpret = eval . view + where + eval :: ProgramView (Cons e) () -> [e] -> [e] + eval (Elem x :>>= is) stack = interpret (is ()) (x : stack) + eval (Return _a) stack = stack diff --git a/lib/ui/src/Cardano/Wallet/UI/Server.hs b/lib/ui/src/Cardano/Wallet/UI/Server.hs new file mode 100644 index 00000000000..9b827de8789 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Server.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Wallet.UI.Server where + +import Prelude + +import Cardano.Wallet.Address.Derivation.Icarus + ( IcarusKey + ) +import Cardano.Wallet.Address.Derivation.Shared + ( SharedKey + ) +import Cardano.Wallet.Address.Derivation.Shelley + ( ShelleyKey (..) + ) +import Cardano.Wallet.Address.Discovery.Random + ( RndState + ) +import Cardano.Wallet.Address.Discovery.Sequential + ( SeqState + ) +import Cardano.Wallet.Address.Discovery.Shared + ( SharedState + ) +import Cardano.Wallet.Api + ( ApiLayer + , netLayer + ) +import Cardano.Wallet.Api.Http.Server.Handlers.NetworkInformation + ( getNetworkInformation + ) +import Cardano.Wallet.Api.Types + ( ApiWalletMode (..) + ) +import Cardano.Wallet.Pools + ( StakePoolLayer + ) +import Cardano.Wallet.Primitive.NetworkId + ( HasSNetworkId (..) + , SNetworkId + , networkIdVal + ) +import Cardano.Wallet.Shelley.BlockchainSource + ( BlockchainSource (..) + ) +import Cardano.Wallet.UI.API + ( UI + ) +import Cardano.Wallet.UI.Cookies + ( CookieResponse + , RequestCookies + , sessioning + , withSession + , withSessionRead + ) +import Cardano.Wallet.UI.Handlers.Addresses + ( listAddresses + ) +import Cardano.Wallet.UI.Handlers.Settings + ( toggleSSE + ) +import Cardano.Wallet.UI.Handlers.SSE + ( sse + ) +import Cardano.Wallet.UI.Handlers.State + ( getState + ) +import Cardano.Wallet.UI.Handlers.Wallet + ( deleteWallet + , getWallet + , pickMnemonic + , postWallet + , selectWallet + ) +import Cardano.Wallet.UI.Handlers.Wallets + ( listWallets + ) +import Cardano.Wallet.UI.Html.Html + ( RawHtml (..) + , renderHtml + ) +import Cardano.Wallet.UI.Html.Pages.Addresses + ( addressesH + ) +import Cardano.Wallet.UI.Html.Pages.Lib + ( alertH + , rogerH + ) +import Cardano.Wallet.UI.Html.Pages.Network + ( networkInfoH + ) +import Cardano.Wallet.UI.Html.Pages.Page + ( Page (..) + , PageConfig + , page + ) +import Cardano.Wallet.UI.Html.Pages.Settings + ( settingsStateH + ) +import Cardano.Wallet.UI.Html.Pages.Wallet + ( WalletPresent (..) + , walletElementH + ) +import Cardano.Wallet.UI.Html.Pages.Wallets + ( walletListH + ) +import Cardano.Wallet.UI.Html.Pages.Wallets.NewWallet + ( mnemonicH + , postWalletForm + ) +import Cardano.Wallet.UI.Layer + ( SessionLayer (..) + , UILayer (..) + , walletId + ) +import Control.Lens + ( view + ) +import Control.Monad.Trans + ( MonadIO (..) + ) +import Data.Functor + ( ($>) + ) +import Data.Text + ( Text + ) +import Data.Time + ( UTCTime + , defaultTimeLocale + , formatTime + ) +import Network.NTP.Client + ( NtpClient + ) +import Paths_cardano_wallet_ui + ( getDataFileName + ) +import Servant + ( Handler + , Server + , (:<|>) (..) + ) + +import qualified Data.ByteString.Lazy as BL + +pageHandler + :: UILayer + -> PageConfig + -> Page + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +pageHandler uiLayer config x = + withSessionLayer uiLayer $ \session -> do + state' <- liftIO $ state session + let walletPresent = case view walletId state' of + Just _ -> WalletPresent + Nothing -> WalletAbsent + pure $ page config x walletPresent + +showTime :: UTCTime -> String +showTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" + +serveUI + :: forall n + . HasSNetworkId n + => UILayer + -> PageConfig + -> SNetworkId n + -> ApiLayer (RndState n) + -> ApiLayer (SeqState n IcarusKey) + -> ApiLayer (SeqState n ShelleyKey) + -> ApiLayer (SharedState n SharedKey) + -> StakePoolLayer + -> NtpClient + -> BlockchainSource + -> Server UI +serveUI ul config _ alByron _alIcarus alShelley _alShared _spl _ntp bs = + ph Wallets + :<|> ph About + :<|> ph Network + :<|> ph Wallet + :<|> ph Wallets + :<|> ph Addresses + :<|> ph Settings + :<|> sessioning (renderHtml . networkInfoH showTime <$> getNetworkInformation nid nl mode) + :<|> (\v -> wsl (\l -> postWallet l alShelley alert ok v)) + :<|> (\c -> sessioning $ renderHtml . mnemonicH <$> liftIO (pickMnemonic 15 c)) + :<|> sessioning . pure . renderHtml . postWalletForm + :<|> wsl (\l -> listWallets l alShelley (fmap renderHtml . walletListH)) + :<|> wsl (\l -> getWallet l alShelley alert (renderHtml . walletElementH showTime)) + :<|> wsl (\l -> listAddresses l alShelley alert (renderHtml . addressesH)) + :<|> wsl (\l -> deleteWallet l alShelley alert ok) + :<|> wsl (\l -> getState l (renderHtml . settingsStateH)) + :<|> wsl (\l -> toggleSSE l $> RawHtml "") + :<|> (\w -> wsl (\l -> selectWallet l w $> RawHtml "")) + :<|> withSessionLayerRead (sse . sseConfig) + :<|> serveFavicon + where + ph = pageHandler ul config + ok _ = renderHtml . rogerH @Text $ "ok" + alert = renderHtml . alertH + nl = netLayer alByron + nid = networkIdVal (sNetworkId @n) + mode = case bs of + NodeSource{} -> Node + _ = networkInfoH + wsl = withSessionLayer ul + withSessionLayerRead :: (SessionLayer -> Handler a) -> Maybe RequestCookies -> Handler a + withSessionLayerRead f = withSessionRead $ \k -> do + s <- liftIO $ sessions ul k + f s + +withSessionLayer :: UILayer -> (SessionLayer -> Handler a) -> Maybe RequestCookies -> Handler (CookieResponse a) +withSessionLayer ulayer f = withSession $ \k -> do + s <- liftIO $ sessions ulayer k + f s + +serveFavicon :: Handler BL.ByteString +serveFavicon = do + file <- liftIO $ getDataFileName "data/images/icon.png" + liftIO $ BL.readFile file diff --git a/lib/ui/src/Cardano/Wallet/UI/Signal.hs b/lib/ui/src/Cardano/Wallet/UI/Signal.hs new file mode 100644 index 00000000000..96490261562 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Signal.hs @@ -0,0 +1,11 @@ +module Cardano.Wallet.UI.Signal + ( Signal (..) + ) +where + +import Prelude + +-- | Signals that can be collected from the wallet. +data Signal + = NewTip + deriving (Show) diff --git a/lib/ui/test/Main.hs b/lib/ui/test/Main.hs new file mode 100644 index 00000000000..3e2059e31f5 --- /dev/null +++ b/lib/ui/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/run/common/docker/docker-compose.yml b/run/common/docker/docker-compose.yml index 4db48a66709..f4302867270 100644 --- a/run/common/docker/docker-compose.yml +++ b/run/common/docker/docker-compose.yml @@ -30,6 +30,7 @@ services: - ${NODE_SOCKET_DIR}:/ipc ports: - ${WALLET_PORT}:8090 + - ${WALLET_UI_PORT}:8091 entrypoint: [] command: > cardano-wallet serve diff --git a/run/common/docker/run.sh b/run/common/docker/run.sh index 587a83b193b..6b446b2c567 100755 --- a/run/common/docker/run.sh +++ b/run/common/docker/run.sh @@ -34,6 +34,11 @@ export NODE_TAG # Generate a random port for the wallet service and export it RANDOM_PORT=$(shuf -i 2000-65000 -n 1) WALLET_PORT=${WALLET_PORT:=$RANDOM_PORT} +RANDOM_PORT=$(shuf -i 2000-65000 -n 1) +WALLET_UI_PORT=${WALLET_UI_PORT:=$RANDOM_PORT} + +export WALLET_UI_PORT + export WALLET_PORT # Define a local db if WALLET_DB is not set diff --git a/run/common/nix/run.sh b/run/common/nix/run.sh index 181213b2a15..256e3f4a361 100755 --- a/run/common/nix/run.sh +++ b/run/common/nix/run.sh @@ -1,6 +1,7 @@ #! /usr/bin/env -S nix shell '.#cardano-wallet' '.#cardano-node' '.#cardano-cli' --command bash # shellcheck shell=bash +# set -euox pipefail set -euo pipefail usage() { @@ -21,6 +22,9 @@ source .env RANDOM_PORT=$(shuf -i 2000-65000 -n 1) WALLET_PORT=${WALLET_PORT:=$RANDOM_PORT} +RANDOM_PORT=$(shuf -i 2000-65000 -n 1) +WALLET_UI_PORT=${WALLET_UI_PORT:=$RANDOM_PORT} + mkdir -p ./databases # Define a local db if WALLET_DB is not set @@ -67,6 +71,19 @@ NODE_CONFIGS=${NODE_CONFIGS:=$LOCAL_NODE_CONFIGS} LOCAL_NODE_LOGS_FILE=./node.log NODE_LOGS_FILE="${NODE_LOGS_FILE:=$LOCAL_NODE_LOGS_FILE}" +cleanup() { + # shellcheck disable=SC2317 + echo "Cleaning up..." + # shellcheck disable=SC2317 + kill "${NODE_ID}" || echo "Failed to kill node" + # shellcheck disable=SC2317 + kill "${WALLET_ID}" || echo "Failed to kill wallet" +} + +# Trap the cleanup function on exit +trap cleanup ERR INT EXIT + + # Start the node with logs redirected to a file if NODE_LOGS_FILE is set # shellcheck disable=SC2086 cardano-node run \ @@ -77,9 +94,40 @@ cardano-node run \ +RTS -N -A16m -qg -qb -RTS 1>$NODE_LOGS_FILE 2>$NODE_LOGS_FILE & NODE_ID=$! -sleep 3 +sleep 5 + +##### Wait until the node is ready ##### + +# Capture the start time +start_time=$(date +%s) + +# Define the timeout duration in seconds +timeout_duration=3600 + +# Repeat the command until it succeeds or 10 seconds elapse +while true; do + # Execute the command + failure_status=0 + cardano-cli ping -u "${NODE_SOCKET_PATH}" 2>/dev/null || failure_status=1 + # Check if the command succeeded + # shellcheck disable=SC2181 + if [[ "$failure_status" -eq 0 ]]; then + break + fi + + # Calculate the elapsed time + current_time=$(date +%s) + elapsed_time=$((current_time - start_time)) + + # Check if the timeout duration has been reached + if [[ $elapsed_time -ge $timeout_duration ]]; then + echo "Cannot ping the node after $timeout_duration seconds" + exit 1 + fi -cardano-cli ping -u "${NODE_SOCKET_PATH}" + # Sleep for a short interval before retrying + sleep 1 +done echo "Node id: $NODE_ID" @@ -91,6 +139,7 @@ if [[ "${NETWORK}" == "mainnet" ]]; then # shellcheck disable=SC2086 cardano-wallet serve \ --port "${WALLET_PORT}" \ + --ui-port "${WALLET_UI_PORT}" \ --database "${WALLET_DB}" \ --node-socket "${NODE_SOCKET_PATH}" \ --mainnet \ @@ -100,6 +149,7 @@ else # shellcheck disable=SC2086 cardano-wallet serve \ --port "${WALLET_PORT}" \ + --ui-port "${WALLET_UI_PORT}" \ --database "${WALLET_DB}" \ --node-socket "${NODE_SOCKET_PATH}" \ --testnet "${NODE_CONFIGS}"/byron-genesis.json \ @@ -164,10 +214,10 @@ case "$1" in ;; start) echo "Wallet service port: $WALLET_PORT" + echo "Wallet UI port: $WALLET_UI_PORT" echo "Node socket path: $NODE_SOCKET_PATH" - echo "Wallet pid: $WALLET_ID" - echo "Node pid: $NODE_ID" - trap - ERR INT EXIT + echo "Ctrl-C to stop" + sleep infinity ;; *) echo "Error: Invalid option $1"