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