Merge branch 'master' into connect_to_staging

app/Cardano/CLI.hs

@@ -1,5 +1,9 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeApplications #-}
+
 
 -- |
 -- Copyright: © 2018-2019 IOHK
@@ -15,65 +19,93 @@ module Cardano.CLI
     , decode
     ) where
 
+import Prelude
+
+import Cardano.Wallet.Mnemonic
+    ( Mnemonic, mkMnemonic )
+import Control.Monad
+    ( when )
+import Data.Bifunctor
+    ( first )
 import GHC.TypeLits
     ( Symbol )
-import Prelude
 import System.Console.Docopt
-    ( Arguments, Docopt, Option, exitWithUsage, getArgOrExitWith )
+    ( Arguments, Docopt, Option, exitWithUsage, getAllArgs, getArgOrExitWith )
 import Text.Read
     ( readMaybe )
 
+import qualified Data.Text as T
+
+
 -- | Port number with a tag for describing what it is used for
 newtype Port (tag :: Symbol) = Port Int
 
 data Network = Mainnet | Testnet | Staging
     deriving (Show, Enum)
 
-getArg
-    :: Arguments
-    -> Docopt
-    -> Option
-    -> (String -> Either String a)
-    -> IO a
-getArg args cli opt decod = do
-    str <- getArgOrExitWith cli args opt
-    case decod str of
-        Right a -> return a
-        Left err -> do
-            putStrLn $ "Invalid " <> show opt <> ". " <> err
-            putStrLn ""
-            exitWithUsage cli
+
+class GetArg from where
+    getArg
+        :: Arguments
+        -> Docopt
+        -> Option
+        -> (from -> Either String to)
+        -> IO to
+
+instance GetArg String where
+    getArg args cli opt decod = do
+        str <- getArgOrExitWith cli args opt
+        case decod str of
+            Right a -> return a
+            Left err -> do
+                putStrLn $ "Invalid " <> show opt <> ". " <> err
+                putStrLn ""
+                exitWithUsage cli
+
+instance GetArg [String] where
+    getArg args cli opt decod = do
+        let str = getAllArgs args opt
+        when (null str) $ exitWithUsage cli
+        case decod str of
+            Right a -> return a
+            Left err -> do
+                putStrLn $ "Invalid " <> show opt <> ". " <> err
+                putStrLn ""
+                exitWithUsage cli
 
 -- | Encoding things into command line arguments
-class Encodable a where
-    encode :: a -> String
+class Encodable from to where
+    encode :: from -> to
 
 -- | Decoding command line arguments
-class Decodable a where
-    decode :: String -> Either String a
+class Decodable from to where
+    decode :: from -> Either String to
 
-instance Encodable Int where
+instance Encodable Int String where
     encode = show
 
-instance Decodable Int where
+instance Decodable String Int where
     decode str =
         maybe (Left err) Right (readMaybe str)
       where
         err = "Not an integer: " ++ show str ++ "."
 
-instance Encodable (Port (tag :: Symbol)) where
+instance Encodable (Port tag) String where
     encode (Port p) = encode p
 
-instance Decodable (Port (tag :: Symbol))where
+instance Decodable String (Port tag) where
     decode str = Port <$> decode str
 
-instance Encodable Network where
+instance Encodable Network String where
     encode Mainnet = "mainnet"
     encode Testnet = "testnet"
     encode Staging = "staging"
 
-instance Decodable Network where
+instance Decodable String Network where
     decode "mainnet" = Right Mainnet
     decode "testnet" = Right Testnet
     decode "staging" = Right Staging
     decode s = Left $ show s ++ " is neither \"mainnet\", \"testnet\" nor \"staging\"."
+
+instance Decodable [String] (Mnemonic 15) where
+    decode ws = first show $ mkMnemonic @15 (T.pack <$> ws)

app/launcher/Main.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Main where
 
@@ -58,9 +59,9 @@ main = do
     args <- parseArgsOrExit cli =<< getArgs
     when (args `isPresent` (longOption "help")) $ exitWithUsage cli
 
-    bridgePort <- getArg args cli (longOption "http-bridge-port") decode
-    walletPort <- getArg args cli (longOption "wallet-server-port") decode
-    network <- getArg args cli (longOption "network") decode
+    bridgePort <- getArg @String args cli (longOption "http-bridge-port") decode
+    walletPort <- getArg @String args cli (longOption "wallet-server-port") decode
+    network <- getArg @String args cli (longOption "network") decode
 
     sayErr "Starting..."
     installSignalHandlers

app/server/Main.hs

@@ -14,26 +14,31 @@ module Main where
 import Prelude
 
 import Cardano.CLI
-    ( Network, Port, decode, encode, getArg )
-import Cardano.NetworkLayer
-    ( listen )
-import Cardano.Wallet.Primitive
-    ( Block )
+    ( Network, decode, encode, getArg )
+import Cardano.Wallet
+    ( WalletName (..) )
+import Cardano.Wallet.Mnemonic
+    ( Mnemonic )
+import Cardano.WalletLayer
+    ( NewWallet (..), WalletLayer (..), mkWalletLayer )
 import Control.Monad
     ( when )
-import Fmt
-    ( build, fmt )
-import Say
-    ( say )
 import System.Console.Docopt
-    ( Docopt, docopt, exitWithUsage, isPresent, longOption, parseArgsOrExit )
+    ( Docopt
+    , argument
+    , docopt
+    , exitWithUsage
+    , isPresent
+    , longOption
+    , parseArgsOrExit
+    )
 import System.Environment
     ( getArgs )
 
+import qualified Cardano.DBLayer.MVar as MVar
 import qualified Cardano.NetworkLayer.HttpBridge as HttpBridge
 import qualified Data.Text as T
 
-
 -- | Command-Line Interface specification. See http://docopt.org/
 cli :: Docopt
 cli = [docopt|
@@ -42,7 +47,7 @@ cardano-wallet-server
 Start the cardano wallet server.
 
 Usage:
-  cardano-wallet-server [options]
+  cardano-wallet-server [options] <mnemonic>...
   cardano-wallet-server --help
 
 Options:
@@ -55,13 +60,21 @@ main :: IO ()
 main = do
     args <- parseArgsOrExit cli =<< getArgs
     when (args `isPresent` (longOption "help")) $ exitWithUsage cli
-
-    networkName <- getArg args cli (longOption "network") (decode @Network)
-    bridgePort <- getArg args cli (longOption "http-bridge-port") decode
-    _ <- getArg args cli (longOption "wallet-server-port") (decode @(Port "wallet"))
+    networkName <-
+        getArg @String args cli (longOption "network") (decode @_ @Network)
+    bridgePort <-
+        getArg @String args cli (longOption "http-bridge-port") (decode @_ @Int)
+    mnemonicSentence <-
+        getArg @[String] args cli (argument "mnemonic") (decode @_ @(Mnemonic 15))
 
     network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) bridgePort
-    listen network logBlock
-  where
-    logBlock :: Block -> IO ()
-    logBlock = say . fmt . build
+    db <- MVar.newDBLayer
+    let wallet = mkWalletLayer db network
+    wid <- createWallet wallet NewWallet
+        { mnemonic = mnemonicSentence
+        , mnemonic2ndFactor = mempty
+        , name = WalletName "My Wallet"
+        , passphrase = mempty
+        , gap = minBound
+        }
+    watchWallet wallet wid

cardano-wallet.cabal

@@ -50,6 +50,7 @@ library
     , http-media
     , memory
     , mtl
+    , say
     , servant
     , servant-client
     , servant-client-core
@@ -60,6 +61,7 @@ library
       src
   exposed-modules:
       Cardano.DBLayer
+      Cardano.DBLayer.MVar
       Cardano.NetworkLayer
       Cardano.NetworkLayer.HttpBridge
       Cardano.NetworkLayer.HttpBridge.Api
@@ -137,7 +139,6 @@ test-suite unit
     build-depends: unix, say
     other-modules: Cardano.Launcher.POSIX
 
-
 executable cardano-wallet-server
   default-language:
       Haskell2010
@@ -153,8 +154,6 @@ executable cardano-wallet-server
       base
     , cardano-wallet
     , docopt
-    , fmt
-    , say
     , text
   hs-source-dirs:
       app
@@ -177,6 +176,7 @@ executable cardano-wallet-launcher
       -O2
   build-depends:
       async
+    , cardano-wallet
     , base
     , docopt
     , fmt
@@ -199,7 +199,6 @@ executable cardano-wallet-launcher
   main-is:
      Main.hs
 
-
 executable cardano-generate-mnemonic
   default-language:
       Haskell2010

src/Cardano/DBLayer.hs

@@ -1,39 +1,40 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE RankNTypes #-}
+-- |
+-- Copyright: © 2018-2019 IOHK
+-- License: MIT
+--
+-- Database / Pesistence layer for the wallet backend. This is where we define
+-- the interface allowing us to store and fetch various data on our wallets.
 
 module Cardano.DBLayer
     ( DBLayer(..)
+    , PrimaryKey(..)
     ) where
 
+import Prelude
+
 import Cardano.Wallet
-    ( Wallet )
-import Control.Monad.Except
-    ( ExceptT )
-import Data.Word
-    ( Word64 )
-import GHC.TypeLits
-    ( Symbol )
+    ( Wallet, WalletId )
+import Data.List.NonEmpty
+    ( NonEmpty )
 
 
 -- | A Database interface for storing various things in a DB. In practice,
 -- we'll need some extra contraints on the wallet state that allows us to
 -- serialize and unserialize it (e.g. @forall s. (Serialize s) => ...@)
-data DBLayer m = forall s. DBLayer
+data DBLayer m s = DBLayer
     -- Wallet checkpoints, checkpoints are handled as a bounded FIFO, where we
     -- eventually store @k@ values (e.g. k=2160) at the same time.
-    { enqueueCheckpoint -- Add a checkpoint on top of the queue
-        :: PrimaryKey "wallet"
-        -> Wallet s
-        -> ExceptT ErrEnqueueCheckpoint m ()
-    , dequeueCheckpoints -- Discard a number of checkpoints from the end
-        :: PrimaryKey "wallet"
-        -> Word64
-        -> ExceptT ErrDequeueCheckpoints m ()
-    , checkpoints --
-        :: PrimaryKey "wallet"
-        -> ExceptT ErrCheckpoints m [Wallet s]
+    { putCheckpoints
+        :: PrimaryKey WalletId
+        -> NonEmpty (Wallet s)
+        -> m ()
+
+    , readCheckpoints
+        :: PrimaryKey WalletId
+        -> m (Maybe (NonEmpty (Wallet s)))
+
+    , readWallets
+        :: m [PrimaryKey WalletId]
     }
 
 -- | A primary key which can take many forms depending on the value. This may
@@ -44,8 +45,5 @@ data DBLayer m = forall s. DBLayer
 -- functions like 'enqueueCheckpoint' needs to be associated to a corresponding
 -- wallet. Some other may not because they are information valid for all wallets
 -- (like for instance, the last known network tip).
-data PrimaryKey (resource :: Symbol)
-
-data ErrEnqueueCheckpoint
-data ErrDequeueCheckpoints
-data ErrCheckpoints
+newtype PrimaryKey key = PrimaryKey key
+    deriving (Eq, Ord)

src/Cardano/DBLayer/MVar.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- |
+-- Copyright: © 2018-2019 IOHK
+-- License: MIT
+--
+-- Dummy implementation of the database-layer, using MVar. This may be good for
+-- state-machine testing in order to compare it with an implementation on a real
+-- data store.
+
+module Cardano.DBLayer.MVar
+    ( newDBLayer
+    ) where
+
+import Prelude
+
+import Cardano.DBLayer
+    ( DBLayer (..) )
+import Control.Concurrent.MVar
+    ( modifyMVar_, newMVar, readMVar )
+
+import qualified Data.Map.Strict as Map
+
+
+-- | Instantiate a new in-memory "database" layer that simply stores data in
+-- a local MVar. Data vanishes if the software is shut down.
+newDBLayer :: forall s. IO (DBLayer IO s)
+newDBLayer = do
+    wallets <- newMVar mempty
+    return $ DBLayer
+        { putCheckpoints = \key cps ->
+            modifyMVar_ wallets (return . Map.insert key cps)
+        , readCheckpoints = \key ->
+            Map.lookup key <$> readMVar wallets
+        , readWallets =
+            Map.keys <$> readMVar wallets
+        }