mirror of
https://github.com/typeable/bucks.git
synced 2024-08-17 02:50:36 +03:00
Add rel8 test spec.
This commit is contained in:
parent
5c2439e442
commit
cac01c80e2
16
bucks.cabal
16
bucks.cabal
@ -54,3 +54,19 @@ library
|
||||
cpp-options: -DUSE_REL8
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite rel8-test
|
||||
import: warnings
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Rel8Spec.hs
|
||||
build-depends: base >= 4.14 && < 5.0,
|
||||
bucks,
|
||||
hasql,
|
||||
hspec,
|
||||
rel8
|
||||
default-language: Haskell2010
|
||||
if flag(rel8)
|
||||
buildable: True
|
||||
else
|
||||
buildable: False
|
87
test/Rel8Spec.hs
Normal file
87
test/Rel8Spec.hs
Normal file
@ -0,0 +1,87 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Main where
|
||||
|
||||
import Control.Exception
|
||||
import Data.Money
|
||||
import GHC.Generics
|
||||
import Hasql.Connection (Connection, ConnectionError)
|
||||
import Hasql.Connection qualified as Hasql
|
||||
import Hasql.Session qualified as Hasql
|
||||
import Rel8
|
||||
import Test.Hspec
|
||||
|
||||
instance Exception ConnectionError
|
||||
|
||||
data Exc = Exc String
|
||||
deriving (Show)
|
||||
|
||||
instance Exception Exc
|
||||
|
||||
data Bucks f = Bucks { amount :: f (Money USD)
|
||||
} deriving (Generic, Rel8able)
|
||||
|
||||
bucksSchema :: TableSchema (Bucks Name)
|
||||
bucksSchema = TableSchema { schema = Nothing
|
||||
, name = "bucks"
|
||||
, columns = Bucks { amount = "amount" }
|
||||
}
|
||||
|
||||
dbsets :: Hasql.Settings
|
||||
dbsets = Hasql.settings "10.233.1.2" 5432 "bucks" "password" "bucks"
|
||||
|
||||
throwLeft :: (Exception e, Applicative f) => Either e a -> f a
|
||||
throwLeft (Left e) = throw e
|
||||
throwLeft (Right a) = pure a
|
||||
|
||||
onLeft :: Applicative f => Either a b -> (a -> f b) -> f b
|
||||
onLeft (Left a) f = f a
|
||||
onLeft (Right b) _ = pure b
|
||||
|
||||
createConnection :: IO Connection
|
||||
createConnection = throwLeft =<< Hasql.acquire dbsets
|
||||
|
||||
createTable :: Connection -> IO ()
|
||||
createTable conn = throwLeft =<< Hasql.run sql conn
|
||||
where sql = Hasql.sql "CREATE TABLE bucks (amount money not null);"
|
||||
|
||||
dropTable :: Connection -> IO ()
|
||||
dropTable conn = throwLeft =<< Hasql.run sql conn
|
||||
where sql = Hasql.sql "DROP TABLE IF EXISTS bucks;"
|
||||
|
||||
truncateTable :: Connection -> IO ()
|
||||
truncateTable conn = throwLeft =<< Hasql.run sql conn
|
||||
where sql = Hasql.sql "TRUNCATE bucks;"
|
||||
|
||||
insertMoney :: Connection -> Money USD -> IO ()
|
||||
insertMoney conn m = throwLeft =<< Hasql.run (Hasql.statement () (insert ins)) conn
|
||||
where ins = Insert { into = bucksSchema
|
||||
, rows = values [ Bucks (lit m) ]
|
||||
, onConflict = Abort
|
||||
, returning = pure ()
|
||||
}
|
||||
|
||||
fetchMoney :: Connection -> IO (Money USD)
|
||||
fetchMoney conn = f =<< throwLeft =<< Hasql.run (Hasql.statement () st) conn
|
||||
where st = select $ do b <- each bucksSchema
|
||||
return (amount b)
|
||||
f [] = throw (Exc "Zero entries returned")
|
||||
f [x] = pure x
|
||||
f _ = throw (Exc "Multiple entries returned")
|
||||
|
||||
main :: IO ()
|
||||
main = do conn <- createConnection
|
||||
dropTable conn
|
||||
createTable conn
|
||||
hspec $ before_ (truncateTable conn) $ do
|
||||
|
||||
describe "Database tests" $ do
|
||||
it "insert == select" $ do
|
||||
let m = Money 12.23
|
||||
insertMoney conn m
|
||||
fetchMoney conn `shouldReturn` m
|
Loading…
Reference in New Issue
Block a user