f895f1b...master · typeable/bucks

bucks.cabal+31

since splitsnapshots

unifiedsplit

@@ -10,11 +10,20 @@ maintainer: nick@typeable.io

10category: Data

11build-type: Simple

12

13+source-repository head

14+ type: git

15+ location: https://github.com/typeable/bucks.git

16+

13flag aeson

17flag aeson

14 description: Enable Aeson instances

18 description: Enable Aeson instances

15 default: False

19 default: False

16 manual: True

20 manual: True

17

21

22+flag openapi

23+ description: Enable OpenAPI instances

24+ default: False

25+ manual: True

26+

18flag rel8

27flag rel8

19 description: Enable Rel8 support

28 description: Enable Rel8 support

20 default: False

29 default: False

@@ -33,9 +42,31 @@ library

33 if flag(aeson)

42 if flag(aeson)

34 other-modules: Data.Money.JSON

43 other-modules: Data.Money.JSON

35 build-depends: aeson >= 2.0 && < 3.0

44 build-depends: aeson >= 2.0 && < 3.0

45+ cpp-options: -DUSE_AESON

46+ if flag(openapi)

47+ other-modules: Data.Money.OpenApi

48+ build-depends: openapi3

49+ cpp-options: -DUSE_OPENAPI

36 if flag(rel8)

50 if flag(rel8)

37 other-modules: Data.Money.Rel8

51 other-modules: Data.Money.Rel8

38 build-depends: rel8 >= 1.4,

52 build-depends: rel8 >= 1.4,

39 scientific

53 scientific

54+ cpp-options: -DUSE_REL8

40 hs-source-dirs: src

55 hs-source-dirs: src

41 default-language: Haskell2010

56 default-language: Haskell2010

57+

58+test-suite rel8-test

59+ import: warnings

60+ type: exitcode-stdio-1.0

61+ hs-source-dirs: test

62+ main-is: Rel8Spec.hs

63+ build-depends: base >= 4.14 && < 5.0,

64+ bucks,

65+ hasql,

66+ hspec,

67+ rel8

68+ default-language: Haskell2010

69+ if flag(rel8)

70+ buildable: True

71+ else

72+ buildable: False

src/Data/Money.hs+6−2

@@ -1,11 +1,15 @@

1{-# LANGUAGE CPP #-}

2module Data.Money (module Export) where

3

4+import Data.Money.Currencies as Export

4import Data.Money.Internal as Export

5import Data.Money.Internal as Export

5

6

6−#ifdef flag_AESON

7+#ifdef USE_AESON

7import Data.Money.JSON as Export ()

8import Data.Money.JSON as Export ()

8#endif

9#endif

9−#ifdef flag_REL8

10+#ifdef USE_OPENAPI

11+import Data.Money.OpenApi as Export ()

12+#endif

13+#ifdef USE_REL8

10import Data.Money.Rel8 as Export ()

14import Data.Money.Rel8 as Export ()

11#endif

15#endif

src/Data/Money/Currencies.hs+6

@@ -11,3 +11,9 @@ type GBP = Currency "GBP" -- Good Boy Points lmao xDDDDD

11type RUB = Currency "RUB"

12type CNY = Currency "CNY"

13type XBT = Currency "XBT"

14+type DKK = Currency "DKK"

15+type NOK = Currency "NOK"

16+type PLN = Currency "PLN"

17+type SEK = Currency "SEK"

18+type AUD = Currency "AUD"

19+type NZD = Currency "NZD"

src/Data/Money/Internal.hs+15−2

@@ -1,5 +1,6 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

@@ -7,23 +8,27 @@

7module Data.Money.Internal ( Money(..)

8module Data.Money.Internal ( Money(..)

8 , Currency

9 , Currency

9 , KnownCurrency(..)

10 , KnownCurrency(..)

11+ , (*%)

12+ , (/%)

10 ) where

13 ) where

11

14

15+import Data.Data

12import Data.Fixed (Centi)

16import Data.Fixed (Centi)

13import Data.Group

17import Data.Group

14−import Data.Proxy

15import GHC.Generics

18import GHC.Generics

16import GHC.TypeLits

19import GHC.TypeLits

20+import GHC.Stack (HasCallStack)

17

21

18-- | Money type. This is actually 'Centi' from 'Data.Fixed' in disguise.

22-- | Money type. This is actually 'Centi' from 'Data.Fixed' in disguise.

19-- The type parameter is phantom, you probably want to use 'Currency' there.

23-- The type parameter is phantom, you probably want to use 'Currency' there.

20-- See also 'Data.Money.Currencies' for currency types.

24-- See also 'Data.Money.Currencies' for currency types.

21newtype Money curr = Money { getAmount :: Centi }

25newtype Money curr = Money { getAmount :: Centi }

22− deriving (Eq, Ord, Generic)

26+ deriving (Eq, Ord, Generic, Data)

23

27

24-- | Empty type, used only to carry its type parameter with a currency code around. E.g. 'Currency "USD"', 'Currency "GBP"', et cetera.

28-- | Empty type, used only to carry its type parameter with a currency code around. E.g. 'Currency "USD"', 'Currency "GBP"', et cetera.

25-- See Data.Money.Currencies for pre-defined currency types.

29-- See Data.Money.Currencies for pre-defined currency types.

26data Currency (name :: Symbol)

30data Currency (name :: Symbol)

31+ deriving (Generic, Data)

27

32

28-- | Statically known currency type class.

33-- | Statically known currency type class.

29class KnownCurrency c where

34class KnownCurrency c where

@@ -55,3 +60,11 @@ instance KnownCurrency c => Read (Money c) where

55 | otherwise = []

60 | otherwise = []

56 where expCurr = currencyCode @c <> " "

61 where expCurr = currencyCode @c <> " "

57 l = length expCurr

62 l = length expCurr

63+

64+(*%) :: Money curr -> Centi -> Money curr

65+(Money m) *% pct = Money (m * pct)

66+

67+(/%) :: HasCallStack => Money curr -> Centi -> Money curr

68+_ /% 0 = error "Called /% with 0 divisor"

69+(Money m) /% pct = Money (fromRational r)

70+ where r = toRational m / toRational pct

src/Data/Money/OpenApi.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE MonoLocalBinds #-}

4+{-# LANGUAGE OverloadedLists #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+module Data.Money.OpenApi where

7+

8+import Data.Fixed

9+import Data.Money.Internal

10+import Data.OpenApi

11+import Data.Typeable

12+

13+instance (KnownCurrency c, Typeable (Money c)) => ToSchema (Money c) where

14+ declareNamedSchema _ = do

15+ centiSchema <- declareSchemaRef (Proxy :: Proxy Centi)

16+ strSchema <- declareSchemaRef (Proxy :: Proxy String)

17+ return $ NamedSchema (Just "Money") $

18+ mempty { _schemaType = Just OpenApiObject

19+ , _schemaProperties = [ ("currency", strSchema)

20+ , ("amount", centiSchema) ]

21+ , _schemaRequired = [ "currency", "amount" ]

22+ }

src/Data/Money/Rel8.hs+3−1

@@ -7,11 +7,13 @@ import Data.Money.Internal

7import Data.Scientific

8import Rel8

9

10+import Debug.Trace

11+

10instance DBType (Money curr) where

12instance DBType (Money curr) where

11 typeInformation =

13 typeInformation =

12 let sci = typeInformation @Scientific

14 let sci = typeInformation @Scientific

13 in TypeInformation { encode = encode sci . realToFrac . getAmount

15 in TypeInformation { encode = encode sci . realToFrac . getAmount

14 , decode = fmap (Money . realToFrac) (decode sci)

16 , decode = fmap (Money . realToFrac) (decode sci)

15− , typeName = "money"

17+ , typeName = "decimal"

16 }

18 }

17

19

stack.yaml+1

@@ -6,6 +6,7 @@ packages:

6flags:

7 bucks:

8 aeson: true

9+ openapi: true

9 rel8: true

10 rel8: true

10

11

11nix:

12nix:

test/Rel8Spec.hsnew file+87

@@ -0,0 +1,87 @@

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DuplicateRecordFields #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE ImportQualifiedPost #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# OPTIONS_GHC -Wno-orphans #-}

8+module Main where

9+

10+import Control.Exception

11+import Data.Money

12+import GHC.Generics

13+import Hasql.Connection (Connection, ConnectionError)

14+import Hasql.Connection qualified as Hasql

15+import Hasql.Session qualified as Hasql

16+import Rel8

17+import Test.Hspec

18+

19+instance Exception ConnectionError

20+

21+data Exc = Exc String

22+ deriving (Show)

23+

24+instance Exception Exc

25+

26+data Bucks f = Bucks { amount :: f (Money USD)

27+ } deriving (Generic, Rel8able)

28+

29+bucksSchema :: TableSchema (Bucks Name)

30+bucksSchema = TableSchema { schema = Nothing

31+ , name = "bucks"

32+ , columns = Bucks { amount = "amount" }

33+ }

34+

35+dbsets :: Hasql.Settings

36+dbsets = Hasql.settings "10.233.1.2" 5432 "bucks" "password" "bucks"

37+

38+throwLeft :: (Exception e, Applicative f) => Either e a -> f a

39+throwLeft (Left e) = throw e

40+throwLeft (Right a) = pure a

41+

42+onLeft :: Applicative f => Either a b -> (a -> f b) -> f b

43+onLeft (Left a) f = f a

44+onLeft (Right b) _ = pure b

45+

46+createConnection :: IO Connection

47+createConnection = throwLeft =<< Hasql.acquire dbsets

48+

49+createTable :: Connection -> IO ()

50+createTable conn = throwLeft =<< Hasql.run sql conn

51+ where sql = Hasql.sql "CREATE TABLE bucks (amount decimal not null);"

52+

53+dropTable :: Connection -> IO ()

54+dropTable conn = throwLeft =<< Hasql.run sql conn

55+ where sql = Hasql.sql "DROP TABLE IF EXISTS bucks;"

56+

57+truncateTable :: Connection -> IO ()

58+truncateTable conn = throwLeft =<< Hasql.run sql conn

59+ where sql = Hasql.sql "TRUNCATE bucks;"

60+

61+insertMoney :: Connection -> Money USD -> IO ()

62+insertMoney conn m = throwLeft =<< Hasql.run (Hasql.statement () (insert ins)) conn

63+ where ins = Insert { into = bucksSchema

64+ , rows = values [ Bucks (lit m) ]

65+ , onConflict = Abort

66+ , returning = pure ()

67+ }

68+

69+fetchMoney :: Connection -> IO (Money USD)

70+fetchMoney conn = f =<< throwLeft =<< Hasql.run (Hasql.statement () st) conn

71+ where st = select $ do b <- each bucksSchema

72+ return (amount b)

73+ f [] = throw (Exc "Zero entries returned")

74+ f [x] = pure x

75+ f _ = throw (Exc "Multiple entries returned")

76+

77+main :: IO ()

78+main = do conn <- createConnection

79+ dropTable conn

80+ createTable conn

81+ hspec $ before_ (truncateTable conn) $ do

82+

83+ describe "Database tests" $ do

84+ it "insert == select" $ do

85+ let m = Money 12.23

86+ insertMoney conn m

87+ fetchMoney conn `shouldReturn` m