|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE DerivingStrategies #-} |
| 3 | +{-# LANGUAGE FlexibleInstances #-} |
| 4 | +{-# LANGUAGE GADTs #-} |
| 5 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 6 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 7 | +{-# LANGUAGE OverloadedStrings #-} |
| 8 | +{-# LANGUAGE QuasiQuotes #-} |
| 9 | +{-# LANGUAGE StandaloneDeriving #-} |
| 10 | +{-# LANGUAGE TemplateHaskell #-} |
| 11 | +{-# LANGUAGE TypeFamilies #-} |
| 12 | +{-# LANGUAGE UndecidableInstances #-} |
| 13 | + |
| 14 | +module Main (main) where |
| 15 | + |
| 16 | +import Control.Exception (bracket_) |
| 17 | +import Control.Monad.IO.Class (liftIO) |
| 18 | +import Control.Monad.Logger (runNoLoggingT) |
| 19 | +import Control.Monad.Trans.Reader (runReaderT) |
| 20 | +import Data.Text (Text) |
| 21 | +import Database.Persist |
| 22 | +import Database.Persist.Postgresql |
| 23 | +import Database.Persist.TH |
| 24 | +import Test.Hspec |
| 25 | + |
| 26 | +share |
| 27 | + [mkPersist sqlSettings, mkMigrate "migrateAll"] |
| 28 | + [persistLowerCase| |
| 29 | +PersistentThing sql=haskell_persistent |
| 30 | + value Text |
| 31 | + deriving Eq Show |
| 32 | +|] |
| 33 | + |
| 34 | +connectionString :: ConnectionString |
| 35 | +connectionString = "host=127.0.0.1 port=6432 user=pgdog password=pgdog dbname=pgdog sslmode=disable" |
| 36 | + |
| 37 | +adminConnectionString :: ConnectionString |
| 38 | +adminConnectionString = "host=127.0.0.1 port=6432 user=admin password=pgdog dbname=admin sslmode=disable" |
| 39 | + |
| 40 | +main :: IO () |
| 41 | +main = |
| 42 | + bracket_ |
| 43 | + (runAdminCommand "SET read_write_strategy TO 'conservative'") |
| 44 | + (runAdminCommand "RELOAD") |
| 45 | + runTests |
| 46 | + |
| 47 | +runAdminCommand :: Text -> IO () |
| 48 | +runAdminCommand command = runNoLoggingT $ |
| 49 | + withPostgresqlConn adminConnectionString $ |
| 50 | + runReaderT (rawExecute command []) |
| 51 | + |
| 52 | +runTests :: IO () |
| 53 | +runTests = runNoLoggingT $ |
| 54 | + withPostgresqlPool connectionString 2 $ \pool -> |
| 55 | + liftIO $ do |
| 56 | + runSqlPool (runMigration migrateAll) pool |
| 57 | + hspec $ |
| 58 | + before_ (runSqlPool clearTestRows pool) $ |
| 59 | + describe "Persistent through PgDog" $ do |
| 60 | + it "connects and runs a typed query" $ do |
| 61 | + result <- runSqlPool selectOne pool |
| 62 | + result `shouldBe` [Single 1] |
| 63 | + |
| 64 | + it "creates, reads, updates, and deletes a row" $ |
| 65 | + runSqlPool basicCrud pool |
| 66 | + |
| 67 | +clearTestRows :: SqlPersistT IO () |
| 68 | +clearTestRows = deleteWhere ([] :: [Filter PersistentThing]) |
| 69 | + |
| 70 | +selectOne :: SqlPersistT IO [Single Int] |
| 71 | +selectOne = rawSql "SELECT 1" [] |
| 72 | + |
| 73 | +basicCrud :: SqlPersistT IO () |
| 74 | +basicCrud = do |
| 75 | + key <- insert (PersistentThing "created") |
| 76 | + |
| 77 | + created <- get key |
| 78 | + liftIO $ created `shouldBe` Just (PersistentThing "created") |
| 79 | + |
| 80 | + update key [PersistentThingValue =. "updated"] |
| 81 | + updated <- get key |
| 82 | + liftIO $ updated `shouldBe` Just (PersistentThing "updated") |
| 83 | + |
| 84 | + delete key |
| 85 | + deleted <- get key |
| 86 | + liftIO $ deleted `shouldBe` Nothing |
0 commit comments