diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016-2018, Renzo Carbonara + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Renzo Carbonara nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +This library exports `Serialise` instances (from the `serialise` +library) for many of the types exported by the `safe-money` library. + +Note: The code in this library used to be part of the `safe-money` +library itself, so these instances are intended to be backwards +compatible with older versions of `safe-money`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env nix-shell +#! nix-shell ./shell.nix -i runghc +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +# Version 0.1 + +* This first release of @safe-money-serialise@ includes the same + @serialise@ support and tests that were present in @safe-money-0.6@. diff --git a/safe-money-serialise.cabal b/safe-money-serialise.cabal new file mode 100644 --- /dev/null +++ b/safe-money-serialise.cabal @@ -0,0 +1,54 @@ +name: safe-money-serialise +version: 0.1 +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) Renzo Carbonara 2016-2018 +author: Renzo Carbonara +maintainer: renĪ»ren!zone +stability: Experimental +tested-with: GHC==8.4.1 +homepage: https://github.com/k0001/safe-money +bug-reports: https://github.com/k0001/safe-money/issues +category: Money +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md changelog.md +synopsis: Instances from the serialise library for the safe-money library. +description: + This library exports @Serialise@ instances (from the @serialise@ + library) for many of the types exported by the @safe-money@ library. + . + Note: The code in this library used to be part of the @safe-money@ + library itself, so these instances are intended to be backwards + compatible with older versions of @safe-money@. + +source-repository head + type: git + location: https://github.com/k0001/safe-money + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -O2 + build-depends: + base (>=4.8 && <5.0), + bytestring, + safe-money, + serialise + exposed-modules: + Money.Serialise + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + bytestring, + safe-money, + safe-money-serialise, + serialise, + tasty, + tasty-hunit, + tasty-quickcheck diff --git a/src/Money/Serialise.hs b/src/Money/Serialise.hs new file mode 100644 --- /dev/null +++ b/src/Money/Serialise.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module only exports orphan 'Ser.Serialise' instances. Import as: +-- +-- @ +-- import "Money.Serialise" () +-- @ +module Money.Serialise () where + +import qualified Codec.Serialise as Ser +import Control.Monad (when) +import Data.Ratio ((%), numerator, denominator) +import GHC.TypeLits (KnownSymbol) +import qualified Money +import qualified Money.Internal as MoneyI + +-------------------------------------------------------------------------------- +-- | Compatible with 'Money.SomeDense'. +instance (KnownSymbol currency) => Ser.Serialise (Money.Dense currency) where + encode = Ser.encode . Money.toSomeDense + decode = maybe (fail "Dense") pure =<< fmap Money.fromSomeDense Ser.decode + +-- | Compatible with 'Money.SomeDiscrete'. +instance + ( KnownSymbol currency, Money.GoodScale scale + ) => Ser.Serialise (Money.Discrete' currency scale) where + encode = Ser.encode . Money.toSomeDiscrete + decode = maybe (fail "Discrete'") pure + =<< fmap Money.fromSomeDiscrete Ser.decode + +-- | Compatible with 'Money.SomeExchangeRate'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Ser.Serialise (Money.ExchangeRate src dst) where + encode = Ser.encode . Money.toSomeExchangeRate + decode = maybe (fail "ExchangeRate") pure + =<< fmap Money.fromSomeExchangeRate Ser.decode + +-- | Compatible with 'Money.Dense'. +instance Ser.Serialise Money.SomeDense where + encode = \sd -> + let r = Money.someDenseAmount sd + in Ser.encode (MoneyI.someDenseCurrency' sd) <> + Ser.encode (numerator r) <> + Ser.encode (denominator r) + decode = maybe (fail "SomeDense") pure =<< do + c :: String <- Ser.decode + n :: Integer <- Ser.decode + d :: Integer <- Ser.decode + when (d == 0) (fail "denominator is zero") + pure (MoneyI.mkSomeDense' c (n % d)) + +-- | Compatible with 'Money.Discrete'. +instance Ser.Serialise Money.SomeDiscrete where + encode = \sd -> + let r = Money.someDiscreteScale sd + in Ser.encode (MoneyI.someDiscreteCurrency' sd) <> + Ser.encode (numerator r) <> + Ser.encode (denominator r) <> + Ser.encode (Money.someDiscreteAmount sd) + decode = maybe (fail "SomeDiscrete") pure =<< do + c :: String <- Ser.decode + n :: Integer <- Ser.decode + d :: Integer <- Ser.decode + when (d == 0) (fail "denominator is zero") + a :: Integer <- Ser.decode + pure (MoneyI.mkSomeDiscrete' c (n % d) a) + +-- | Compatible with 'Money.ExchangeRate'. +instance Ser.Serialise Money.SomeExchangeRate where + encode = \ser -> + let r = Money.someExchangeRateRate ser + in Ser.encode (MoneyI.someExchangeRateSrcCurrency' ser) <> + Ser.encode (MoneyI.someExchangeRateDstCurrency' ser) <> + Ser.encode (numerator r) <> + Ser.encode (denominator r) + decode = maybe (fail "SomeExchangeRate") pure =<< do + src :: String <- Ser.decode + dst :: String <- Ser.decode + n :: Integer <- Ser.decode + d :: Integer <- Ser.decode + when (d == 0) (fail "denominator is zero") + pure (MoneyI.mkSomeExchangeRate' src dst (n % d)) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import qualified Codec.Serialise as Ser +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Proxy (Proxy(Proxy)) +import Data.Ratio ((%), numerator, denominator) +import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) +import qualified Money +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ((@?=), (@=?)) +import qualified Test.Tasty.HUnit as HU +import qualified Test.Tasty.Runners as Tasty +import Test.Tasty.QuickCheck ((===), (==>), (.&&.)) +import qualified Test.Tasty.QuickCheck as QC + +import Money.Serialise() + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] (Tasty.localOption (QC.QuickCheckTests 100) tests) + +tests :: Tasty.TestTree +tests = + Tasty.testGroup "root" + [ testCurrencies + , testCurrencyUnits + , testExchange + , testRawSerializations + ] + +testCurrencies :: Tasty.TestTree +testCurrencies = + Tasty.testGroup "Currency" + [ testDense (Proxy :: Proxy "BTC") -- A cryptocurrency. + , testDense (Proxy :: Proxy "USD") -- A fiat currency with decimal fractions. + , testDense (Proxy :: Proxy "VUV") -- A fiat currency with non-decimal fractions. + , testDense (Proxy :: Proxy "XAU") -- A precious metal. + ] + +testCurrencyUnits :: Tasty.TestTree +testCurrencyUnits = + Tasty.testGroup "Currency units" + [ testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "BTC") + , testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "satoshi") + , testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "bitcoin") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "USD") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "cent") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "dollar") + , testDiscrete (Proxy :: Proxy "VUV") (Proxy :: Proxy "vatu") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "gram") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "grain") + ] + +testDense + :: forall currency + . KnownSymbol currency + => Proxy currency + -> Tasty.TestTree +testDense pc = + Tasty.testGroup ("Dense " ++ show (symbolVal pc)) + [ QC.testProperty "Serialise encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise x)) + , QC.testProperty "Serialise encoding roundtrip (SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.toSomeDense x + in Just x' === hush (Ser.deserialiseOrFail (Ser.serialise x')) + , QC.testProperty "Serialise encoding roundtrip (Dense through SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise (Money.toSomeDense x))) + , QC.testProperty "Serialise encoding roundtrip (SomeDense through Dense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just (Money.toSomeDense x) === hush (Ser.deserialiseOrFail (Ser.serialise x)) + ] + +testExchange :: Tasty.TestTree +testExchange = + Tasty.testGroup "Exchange" + [ testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "XAU") + ] + + +testDiscrete + :: forall (currency :: Symbol) (unit :: Symbol) + . ( Money.GoodScale (Money.Scale currency unit) + , KnownSymbol currency + , KnownSymbol unit ) + => Proxy currency + -> Proxy unit + -> Tasty.TestTree +testDiscrete pc pu = + Tasty.testGroup ("Discrete " ++ show (symbolVal pc) ++ " " + ++ show (symbolVal pu)) + [ QC.testProperty "Serialise encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise x)) + , QC.testProperty "Serialise encoding roundtrip (SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.toSomeDiscrete x + in Just x' === hush (Ser.deserialiseOrFail (Ser.serialise x')) + , QC.testProperty "Serialise encoding roundtrip (Discrete through SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise (Money.toSomeDiscrete x))) + , QC.testProperty "Serialise encoding roundtrip (SomeDiscrete through Discrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just (Money.toSomeDiscrete x) === hush (Ser.deserialiseOrFail (Ser.serialise x)) + ] + +testExchangeRate + :: forall (src :: Symbol) (dst :: Symbol) + . (KnownSymbol src, KnownSymbol dst) + => Proxy src + -> Proxy dst + -> Tasty.TestTree +testExchangeRate ps pd = + Tasty.testGroup ("ExchangeRate " ++ show (symbolVal ps) ++ " " + ++ show (symbolVal pd)) + [ QC.testProperty "Serialise encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise x)) + , QC.testProperty "Serialise encoding roundtrip (SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.toSomeExchangeRate x + in Just x' === hush (Ser.deserialiseOrFail (Ser.serialise x')) + , QC.testProperty "Serialise encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise (Money.toSomeExchangeRate x))) + , QC.testProperty "Serialise encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just (Money.toSomeExchangeRate x) === hush (Ser.deserialiseOrFail (Ser.serialise x)) + ] + +-------------------------------------------------------------------------------- +-- Raw parsing "golden tests" + +testRawSerializations :: Tasty.TestTree +testRawSerializations = + Tasty.testGroup "Raw serializations" + [ Tasty.testGroup "serialise" + [ Tasty.testGroup "decode" + [ HU.testCase "Dense" $ do + Just rawDns0 @=? hush (Ser.deserialiseOrFail rawDns0_serialise) + , HU.testCase "Discrete" $ do + Just rawDis0 @=? hush (Ser.deserialiseOrFail rawDis0_serialise) + , HU.testCase "ExchangeRate" $ do + Just rawXr0 @=? hush (Ser.deserialiseOrFail rawXr0_serialise) + ] + , Tasty.testGroup "encode" + [ HU.testCase "Dense" $ rawDns0_serialise @=? Ser.serialise rawDns0 + , HU.testCase "Discrete" $ rawDis0_serialise @=? Ser.serialise rawDis0 + , HU.testCase "ExchangeRate" $ rawXr0_serialise @=? Ser.serialise rawXr0 + ] + ] + ] + +rawDns0 :: Money.Dense "USD" +rawDns0 = Money.dense' (26%1) + +rawDis0 :: Money.Discrete "USD" "cent" +rawDis0 = Money.discrete 4 + +rawXr0 :: Money.ExchangeRate "USD" "BTC" +Just rawXr0 = Money.exchangeRate (3%2) + +rawDns0_serialise :: BL.ByteString +rawDns0_serialise = "cUSD\CAN\SUB\SOH" +rawDis0_serialise :: BL.ByteString +rawDis0_serialise = "cUSD\CANd\SOH\EOT" +rawXr0_serialise :: BL.ByteString +rawXr0_serialise = "cUSDcBTC\ETX\STX" + +-------------------------------------------------------------------------------- +-- Misc + +hush :: Either a b -> Maybe b +hush (Left _ ) = Nothing +hush (Right b) = Just b +