@@ -1,87 +0,0 @@
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