safe-money-cereal (empty) → 0.1

raw patch · 7 files changed

+397/−0 lines, 7 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, safe-money, safe-money-cereal, tasty, tasty-hunit, tasty-quickcheck

Files

LICENSE +30/−0
README.md +6/−0
Setup.hs +4/−0
changelog.md +4/−0
safe-money-cereal.cabal +54/−0
src/Money/Cereal.hs +94/−0
test/Main.hs +205/−0

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,6 @@+This library exports `Serialize` instances (from the `cereal` 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`.

+ Setup.hs view

@@ -0,0 +1,4 @@+#! /usr/bin/env nix-shell+#! nix-shell ./shell.nix -i runghc+import Distribution.Simple+main = defaultMain

+ changelog.md view

@@ -0,0 +1,4 @@+# Version 0.1++* This first release of @safe-money-cereal@ includes the same @cereal@ support+  and tests that were present in @safe-money-0.6@.

+ safe-money-cereal.cabal view

@@ -0,0 +1,54 @@+name: safe-money-cereal+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 cereal library for the safe-money library.+description:+  This library exports @Serialize@ instances (from the @cereal@ 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),+    cereal,+    safe-money+  exposed-modules:+    Money.Cereal++test-suite test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base,+    bytestring,+    cereal,+    safe-money,+    safe-money-cereal,+    tasty,+    tasty-hunit,+    tasty-quickcheck+

+ src/Money/Cereal.hs view

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module only exports orphan 'Cereal.Serialize' instances. Import as:+--+-- @+-- import "Money.Cereal" ()+-- @+module Money.Cereal () where++import Control.Applicative (empty)+import Control.Monad (when)+import Data.Ratio ((%), numerator, denominator)+import qualified Data.Serialize as Cereal+import GHC.TypeLits (KnownSymbol)+import qualified Money+import qualified Money.Internal as MoneyI++--------------------------------------------------------------------------------++-- | Compatible with 'Money.SomeDense'.+instance (KnownSymbol currency) => Cereal.Serialize (Money.Dense currency) where+  put = Cereal.put . Money.toSomeDense+  get = maybe empty pure =<< fmap Money.fromSomeDense Cereal.get++-- | Compatible with 'Money.SomeDiscrete'.+instance+  ( KnownSymbol currency, Money.GoodScale scale+  ) => Cereal.Serialize (Money.Discrete' currency scale) where+  put = Cereal.put . Money.toSomeDiscrete+  get = maybe empty pure =<< fmap Money.fromSomeDiscrete Cereal.get++-- | Compatible with 'Money.SomeExchangeRate'.+instance+  ( KnownSymbol src, KnownSymbol dst+  ) => Cereal.Serialize (Money.ExchangeRate src dst) where+  put = Cereal.put . Money.toSomeExchangeRate+  get = maybe empty pure =<< fmap Money.fromSomeExchangeRate Cereal.get++-- | Compatible with 'Money.Dense'.+instance Cereal.Serialize Money.SomeDense where+  put = \sd -> do+    Cereal.put (MoneyI.someDenseCurrency' sd)+    let r = Money.someDenseAmount sd+    Cereal.put (numerator r)+    Cereal.put (denominator r)+  get = maybe empty pure =<< do+    c :: String <- Cereal.get+    n :: Integer <- Cereal.get+    d :: Integer <- Cereal.get+    when (d == 0) (fail "denominator is zero")+    pure (MoneyI.mkSomeDense' c (n % d))++-- | Compatible with 'Money.Discrete'.+instance Cereal.Serialize Money.SomeDiscrete where+  put = \sd -> do+    -- We go through String for backwards compatibility.+    Cereal.put (MoneyI.someDiscreteCurrency' sd)+    let r = Money.someDiscreteScale sd+    Cereal.put (numerator r)+    Cereal.put (denominator r)+    Cereal.put (Money.someDiscreteAmount sd)+  get = maybe empty pure =<< do+    -- We go through String for backwards compatibility.+    c :: String <- Cereal.get+    n :: Integer <- Cereal.get+    d :: Integer <- Cereal.get+    when (d == 0) (fail "denominator is zero")+    a :: Integer <- Cereal.get+    pure (MoneyI.mkSomeDiscrete' c (n % d) a)++-- | Compatible with 'Money.ExchangeRate'.+instance Cereal.Serialize Money.SomeExchangeRate where+  put = \ser -> do+    -- We go through String for backwards compatibility.+    Cereal.put (MoneyI.someExchangeRateSrcCurrency' ser)+    Cereal.put (MoneyI.someExchangeRateDstCurrency' ser)+    let r = Money.someExchangeRateRate ser+    Cereal.put (numerator r)+    Cereal.put (denominator r)+  get = maybe empty pure =<< do+    -- We go through String for backwards compatibility.+    src :: String <- Cereal.get+    dst :: String <- Cereal.get+    n :: Integer <- Cereal.get+    d :: Integer <- Cereal.get+    when (d == 0) (fail "denominator is zero")+    pure (MoneyI.mkSomeExchangeRate' src dst (n % d))+

+ test/Main.hs view

@@ -0,0 +1,205 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Proxy (Proxy(Proxy))+import Data.Ratio ((%), numerator, denominator)+import qualified Data.Serialize as Cereal+import Data.Word (Word8)+import GHC.Exts (fromList)+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.Cereal ()++--------------------------------------------------------------------------------++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 "Cereal encoding roundtrip" $+      QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+         Right x === Cereal.decode (Cereal.encode x)+  , QC.testProperty "Cereal encoding roundtrip (SomeDense)" $+      QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+         let x' = Money.toSomeDense x+         in Right x' === Cereal.decode (Cereal.encode x')+  , QC.testProperty "Cereal encoding roundtrip (Dense through SomeDense)" $+      QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+         Right x === Cereal.decode (Cereal.encode (Money.toSomeDense x))+  , QC.testProperty "Cereal encoding roundtrip (SomeDense through Dense)" $+      QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+         Right (Money.toSomeDense x) === Cereal.decode (Cereal.encode 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 "Cereal encoding roundtrip" $+      QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+         Right x === Cereal.decode (Cereal.encode x)+  , QC.testProperty "Cereal encoding roundtrip (SomeDiscrete)" $+      QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+         let x' = Money.toSomeDiscrete x+         in Right x' === Cereal.decode (Cereal.encode x')+  , QC.testProperty "Cereal encoding roundtrip (Discrete through SomeDiscrete)" $+      QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+         Right x === Cereal.decode (Cereal.encode (Money.toSomeDiscrete x))+  , QC.testProperty "Cereal encoding roundtrip (SomeDiscrete through Discrete)" $+      QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+         Right (Money.toSomeDiscrete x) === Cereal.decode (Cereal.encode 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 "Cereal encoding roundtrip" $+      QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+         Right x === Cereal.decode (Cereal.encode x)+  , QC.testProperty "Cereal encoding roundtrip (SomeExchangeRate)" $+      QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+         let x' = Money.toSomeExchangeRate x+         in Right x' === Cereal.decode (Cereal.encode x')+  , QC.testProperty "Cereal encoding roundtrip (ExchangeRate through SomeExchangeRate)" $+      QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+         Right x === Cereal.decode (Cereal.encode (Money.toSomeExchangeRate x))+  , QC.testProperty "Cereal encoding roundtrip (SomeExchangeRate through ExchangeRate)" $+      QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+         Right (Money.toSomeExchangeRate x) === Cereal.decode (Cereal.encode x)+  ]++--------------------------------------------------------------------------------+-- Raw parsing "golden tests"++testRawSerializations :: Tasty.TestTree+testRawSerializations =+  Tasty.testGroup "Raw serializations"+  [ Tasty.testGroup "cereal"+    [ Tasty.testGroup "decode"+      [ HU.testCase "Dense" $ do+          Right rawDns0 @=? Cereal.decode rawDns0_cereal+      , HU.testCase "Discrete" $ do+          Right rawDis0 @=? Cereal.decode rawDis0_cereal+      , HU.testCase "ExchangeRate" $ do+          Right rawXr0 @=? Cereal.decode rawXr0_cereal+      ]+    , Tasty.testGroup "encode"+      [ HU.testCase "Dense" $ rawDns0_cereal @=? Cereal.encode rawDns0+      , HU.testCase "Discrete" $ rawDis0_cereal @=? Cereal.encode rawDis0+      , HU.testCase "ExchangeRate" $ rawXr0_cereal @=? Cereal.encode 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)++-- Such a waste of space these many bytes! Can we shrink this and maintain+-- backwards compatibility?+rawDns0_cereal :: B.ByteString+rawDns0_cereal = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETXUSD\NUL\NUL\NUL\NUL\SUB\NUL\NUL\NUL\NUL\SOH"+rawDis0_cereal :: B.ByteString+rawDis0_cereal = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETXUSD\NUL\NUL\NUL\NULd\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\NUL\EOT"+rawXr0_cereal :: B.ByteString+rawXr0_cereal = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETXUSD\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETXBTC\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\STX"