Add a few negative test cases to ApiTypes specs for JSON instances that aren't fully generic

cardano-wallet.cabal

@@ -99,6 +99,7 @@ test-suite unit
       -Werror
   build-depends:
       aeson
+    , aeson-qq
     , base
     , async
     , base58-bytestring

src/Cardano/Wallet/Api/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -38,6 +39,8 @@ module Cardano.Wallet.Api.Types
     -- * Limits
     , passphraseMinLength
     , passphraseMaxLength
+    , walletNameMinLength
+    , walletNameMaxLength
 
     -- * Polymorphic Types
     , ApiT (..)
@@ -69,7 +72,6 @@ import Cardano.Wallet.Primitive.Types
     , WalletName (..)
     , WalletPassphraseInfo (..)
     , WalletState (..)
-    , mkWalletName
     )
 import Control.Applicative
     ( (<|>) )
@@ -86,7 +88,6 @@ import Data.Aeson
     , genericToJSON
     , omitNothingFields
     , sumEncoding
-    , tagSingleConstructors
     )
 import Data.ByteString.Base58
     ( bitcoinAlphabet, decodeBase58, encodeBase58 )
@@ -233,16 +234,15 @@ instance FromJSON (ApiT (Passphrase "encryption")) where
                 <> show passphraseMaxLength <> " chars"
         t ->
             return $ ApiT $ Passphrase $ BA.convert $ T.encodeUtf8 t
+instance ToJSON (ApiT (Passphrase "encryption")) where
+    toJSON (ApiT (Passphrase bytes)) = toJSON $ T.decodeUtf8 $ BA.convert bytes
 
 passphraseMinLength :: Int
 passphraseMinLength = 10
 
 passphraseMaxLength :: Int
 passphraseMaxLength = 255
 
-instance ToJSON (ApiT (Passphrase "encryption")) where
-    toJSON (ApiT (Passphrase bytes)) = toJSON $ T.decodeUtf8 $ BA.convert bytes
-
 instance {-# OVERLAPS #-}
     ( n ~ EntropySize mw
     , csz ~ CheckSumBits n
@@ -273,7 +273,7 @@ instance
         return $ ApiMnemonicT (pwd, xs)
 
 instance ToJSON (ApiMnemonicT sizes purpose) where
-    toJSON (ApiMnemonicT (_, xs)) = toJSON xs
+    toJSON (ApiMnemonicT (!_, xs)) = toJSON xs
 
 instance FromJSON (ApiT WalletId) where
     parseJSON = fmap ApiT . genericParseJSON defaultRecordTypeOptions
@@ -298,10 +298,24 @@ instance ToJSON (ApiT (WalletDelegation (ApiT PoolId))) where
     toJSON = genericToJSON walletDelegationOptions . getApiT
 
 instance FromJSON (ApiT WalletName) where
-    parseJSON x = fmap ApiT . eitherToParser . mkWalletName =<< parseJSON x
+    parseJSON = parseJSON >=> \case
+        t | T.length t < walletNameMinLength ->
+            fail $ "name is too short: expected at least "
+                <> show walletNameMinLength <> " chars"
+        t | T.length t > walletNameMaxLength ->
+            fail $ "name is too long: expected at most "
+                <> show walletNameMaxLength <> " chars"
+        t ->
+            return $ ApiT $ WalletName t
 instance ToJSON (ApiT WalletName) where
     toJSON = toJSON . getWalletName . getApiT
 
+walletNameMinLength :: Int
+walletNameMinLength = 1
+
+walletNameMaxLength :: Int
+walletNameMaxLength = 255
+
 instance FromJSON (ApiT WalletPassphraseInfo) where
     parseJSON = fmap ApiT . genericParseJSON defaultRecordTypeOptions
 instance ToJSON (ApiT WalletPassphraseInfo) where
@@ -358,7 +372,6 @@ data TaggedObjectOptions = TaggedObjectOptions
 defaultSumTypeOptions :: Aeson.Options
 defaultSumTypeOptions = Aeson.defaultOptions
     { constructorTagModifier = camelTo2 '_'
-    , tagSingleConstructors = True
     }
 
 defaultRecordTypeOptions :: Aeson.Options

src/Cardano/Wallet/Network.hs

@@ -83,11 +83,18 @@ listen network action = do
     getNextBlocks :: SlotId -> IO (TickResult [Block], SlotId)
     getNextBlocks current = do
         res <- runExceptT $ nextBlocks network current
+        -- NOTE
+        -- In order to avoid having to perform some slotting arithmetic, we only
+        -- process blocks if we receive more than one, such that we can use the
+        -- last block as the starting point for the next batch.
+        -- The trade-off is is that we'll be fetching this last block twice,
+        -- which is fair price to pay in order NOT to have to do any slotting
+        -- arithmetic nor track how many blocks are present per epochs.
         case res of
             Left err ->
                 die $ fmt $ "Chain producer error: "+||err||+""
-            Right [] ->
+            Right bs | length bs < 2 ->
                 pure (Sleep, current)
             Right blocks ->
-                let next = succ . slotId . header . last $ blocks
-                in pure (GotChunk blocks, next)
+                let next = slotId . header . last $ blocks
+                in pure (GotChunk (init blocks), next)

src/Cardano/Wallet/Network/HttpBridge.hs

@@ -26,13 +26,7 @@ import Cardano.Wallet.Network
 import Cardano.Wallet.Network.HttpBridge.Api
     ( ApiT (..), EpochIndex (..), NetworkName (..), api )
 import Cardano.Wallet.Primitive.Types
-    ( Block (..)
-    , BlockHeader (..)
-    , Hash (..)
-    , SlotId (..)
-    , invariant
-    , isValidSlotId
-    )
+    ( Block (..), BlockHeader (..), Hash (..), SlotId (..) )
 import Control.Exception
     ( Exception (..) )
 import Control.Monad.Trans.Class
@@ -86,21 +80,16 @@ rbNextBlocks
     => HttpBridge m e -- ^ http-bridge API
     -> SlotId -- ^ Starting point
     -> ExceptT e m [Block]
-rbNextBlocks net sl = do
-    -- NOTE
-    -- Adding an invariant here. If an invalid slot was given, the algorithm
-    -- below will start fetching all blocks from the start down to the first
-    -- genesis block, causing the system to hang for quite a while.
-    let start = invariant "given starting slot is a valid slot" sl isValidSlotId
-    (tipHash, tip) <- fmap slotId <$> getNetworkTip net
-    epochBlocks <- lift $ nextStableEpoch start
+rbNextBlocks network start = do
+    (tipHash, tip) <- fmap slotId <$> getNetworkTip network
+    epochBlocks <- lift nextStableEpoch
     lastBlocks <- if null epochBlocks
-        then unstableBlocks net start tipHash tip
+        then unstableBlocks tipHash tip
         else pure []
     pure (epochBlocks ++ lastBlocks)
   where
-    nextStableEpoch start = do
-        epochBlocks <- runExceptT (getEpoch net (epochIndex start)) >>= \case
+    nextStableEpoch = do
+        epochBlocks <- runExceptT (getEpoch network (epochIndex start)) >>= \case
             Left _ -> pure []
             Right r -> return r
         pure $ filter (blockIsSameOrAfter start) epochBlocks
@@ -112,7 +101,7 @@ rbNextBlocks net sl = do
 
     -- Grab the remaining blocks which aren't packed in epoch files,
     -- starting from the tip.
-    unstableBlocks network start tipHash tip
+    unstableBlocks tipHash tip
         | start <= tip = fetchBlocksFromTip network start tipHash
         | otherwise    = pure []
 

src/Cardano/Wallet/Primitive/Types.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -56,19 +55,11 @@ module Cardano.Wallet.Primitive.Types
 
     -- * Slotting
     , SlotId (..)
-    , isValidSlotId
-    , slotsPerEpoch
-    , slotDiff
-    , slotIncr
 
     -- * Wallet Metadata
     , WalletMetadata(..)
     , WalletId(..)
     , WalletName(..)
-    , mkWalletName
-    , walletNameMinLength
-    , walletNameMaxLength
-    , WalletNameError(..)
     , WalletState(..)
     , WalletDelegation (..)
     , WalletPassphraseInfo(..)
@@ -127,7 +118,6 @@ import Numeric.Natural
 
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 
 
@@ -151,23 +141,6 @@ data WalletMetadata = WalletMetadata
 newtype WalletName = WalletName { getWalletName ::  Text }
     deriving (Eq, Show)
 
-data WalletNameError
-    = WalletNameTooShortError
-    | WalletNameTooLongError
-    deriving Show
-
-mkWalletName :: Text -> Either WalletNameError WalletName
-mkWalletName n
-    | T.length n < walletNameMinLength = Left WalletNameTooShortError
-    | T.length n > walletNameMaxLength = Left WalletNameTooLongError
-    | otherwise = Right $ WalletName n
-
-walletNameMinLength :: Int
-walletNameMinLength = 1
-
-walletNameMaxLength :: Int
-walletNameMaxLength = 255
-
 newtype WalletId = WalletId UUID
     deriving (Generic, Eq, Ord, Show)
 
@@ -461,10 +434,6 @@ restrictedTo (UTxO utxo) outs =
   If slotting arithmetic has to be introduced, it will require proper thoughts.
 -------------------------------------------------------------------------------}
 
--- | Hard-coded for the time being
-slotsPerEpoch :: Word64
-slotsPerEpoch = 21600
-
 -- | A slot identifier is the combination of an epoch and slot.
 data SlotId = SlotId
   { epochIndex :: !Word64
@@ -476,35 +445,6 @@ instance NFData SlotId
 instance Buildable SlotId where
     build (SlotId e s) = build e <> "." <> build s
 
-instance Enum SlotId where
-    toEnum i
-        | i < 0 = error "SlotId.toEnum: bad argument"
-        | otherwise = slotIncr (fromIntegral i) (SlotId 0 0)
-    fromEnum (SlotId e s)
-        | n > fromIntegral (maxBound @Int) =
-            error "SlotId.fromEnum: arithmetic overflow"
-        | otherwise = fromIntegral n
-      where
-        n :: Word64
-        n = fromIntegral e * fromIntegral slotsPerEpoch + fromIntegral s
-
--- | Add a number of slots to an (Epoch, LocalSlotIndex) pair, where the number
--- of slots can be greater than one epoch.
-slotIncr :: Word64 -> SlotId -> SlotId
-slotIncr n slot = SlotId e s
-  where
-    e = fromIntegral (fromIntegral n' `div` slotsPerEpoch)
-    s = fromIntegral (fromIntegral n' `mod` slotsPerEpoch)
-    n' = n + fromIntegral (fromEnum slot)
-
--- | @slotDiff a b@ is the number of slots by which @a@ is greater than @b@.
-slotDiff :: SlotId -> SlotId -> Integer
-slotDiff s1 s2 = fromIntegral (fromEnum s1 - fromEnum s2)
-
--- | Whether the epoch index and slot number are in range.
-isValidSlotId :: SlotId -> Bool
-isValidSlotId (SlotId e s) =
-    e >= 0 && s >= 0 && s < fromIntegral slotsPerEpoch
 
 {-------------------------------------------------------------------------------
                                Polymorphic Types

test/integration/Cardano/Wallet/Network/HttpBridgeSpec.hs

@@ -19,22 +19,12 @@ import Control.Concurrent
     ( threadDelay )
 import Control.Concurrent.Async
     ( async, cancel )
-import Control.Exception.Base
-    ( ErrorCall )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
     ( runExceptT )
 import Test.Hspec
-    ( Spec
-    , afterAll
-    , beforeAll
-    , describe
-    , it
-    , shouldReturn
-    , shouldSatisfy
-    , shouldThrow
-    )
+    ( Spec, afterAll, beforeAll, describe, it, shouldReturn, shouldSatisfy )
 
 import qualified Cardano.Wallet.Network.HttpBridge as HttpBridge
 
@@ -65,22 +55,21 @@ spec = do
 
         it "get unstable blocks for the unstable epoch" $ \(_, network) -> do
             let action = runExceptT $ do
-                    tip <- (slotId . snd) <$> networkTip network
-                    blocks <- nextBlocks network (pred $ pred $ pred tip)
-                    lift $ blocks `shouldSatisfy`
-                        (\bs -> length bs >= 4 && length bs <= 5)
+                    (SlotId ep sl) <- (slotId . snd) <$> networkTip network
+                    let sl' = if sl > 2 then sl - 2 else 0
+                    blocks <- nextBlocks network (SlotId ep sl')
+                    lift $ blocks `shouldSatisfy` (\bs
+                        -> length bs >= fromIntegral (sl - sl')
+                        && length bs <= fromIntegral (sl - sl' + 1)
+                        )
             action `shouldReturn` pure ()
 
         it "produce no blocks if start is after tip" $ \(_, network) -> do
             let action = runExceptT $ do
-                    tip <- (slotId . snd) <$> networkTip network
-                    length <$> nextBlocks network (succ $ succ tip)
+                    SlotId ep sl <- (slotId . snd) <$> networkTip network
+                    length <$> nextBlocks network (SlotId (ep + 1) sl)
             action `shouldReturn` pure 0
 
-        it "fails when given an invalid slot" $ \(_, network) -> do
-            let action = runExceptT $ nextBlocks network (SlotId 14 22000)
-            action `shouldThrow` (\(_ :: ErrorCall) -> True)
-
     describe "Error paths" $ beforeAll newNetworkLayer $ do
         it "gets a 'NodeUnavailable' if bridge isn't up" $ \network -> do
             let msg x = "Expected a 'NodeAvailable' failure but got " <> show x

test/integration/Main.hs

@@ -83,25 +83,26 @@ dummySetup action = do
 respCodesSpec :: Scenarios Context
 respCodesSpec = do
     scenario "GET; Response code 200" $ do
-        response <- request' ("GET", "/get") Nothing
-        verify
-            (response :: Either RequestException (Request, Response ByteString))
-            [ expectResponseCode status200 ]
+        response <- request' ("GET", "/get?my=arg") Nothing Nothing
+        verify (response :: Either RequestException (Request, Response ByteString))
+            [ expectResponseCode status200
+            ]
 
     scenario "GET; Response code 404" $ do
-        response <- request' ("GET", "/get/nothing") Nothing
-        verify
-            (response :: Either RequestException (Request, Response ByteString))
-            [ expectResponseCode status404 ]
+        response <- request' ("GET", "/get/nothing") Nothing Nothing
+        verify (response :: Either RequestException (Request, Response ByteString))
+            [ expectResponseCode status404
+            ]
 
     scenario "POST; Response code 200" $ do
-        response <- request' ("POST", "/post") Nothing
-        verify
-            (response :: Either RequestException (Request, Response ByteString))
-            [ expectResponseCode status200 ]
+        let header = [("dummy", "header")]
+        response <- request' ("POST", "/post") (Just header) Nothing
+        verify (response :: Either RequestException (Request, Response ByteString))
+            [ expectResponseCode status200
+            ]
 
     scenario "POST; Response code 405" $ do
-        response <- request' ("POST", "/get") Nothing
-        verify
-            (response :: Either RequestException (Request, Response ByteString))
-            [ expectResponseCode status405 ]
+        response <- request' ("POST", "/get") Nothing Nothing
+        verify (response :: Either RequestException (Request, Response ByteString))
+            [ expectResponseCode status405
+            ]

test/integration/Test/Integration/Framework/DSL.hs

@@ -122,7 +122,6 @@ pendingWith = liftIO . H.pendingWith
 verify :: (Monad m) => a -> [a -> m ()] -> m ()
 verify a = mapM_ (a &)
 
-
 -- | Expect an errored response, without any further assumptions
 expectError
     :: (MonadIO m, MonadFail m, Show a)