{-# LANGUAGE OverloadedStrings #-}
module TmpProc.Example2.Database
(
create
, fetch
, remove
, migrateDB
, Locator
, defaultLoc
)
where
import Control.Monad.Logger (LogLevel (..), LoggingT,
filterLogger, runStdoutLoggingT, LogSource)
import Control.Monad.Reader (runReaderT)
import Database.Persist
import Database.Persist.Postgresql (ConnectionString, SqlPersistT,
fromSqlKey, runMigration,
toSqlKey, withPostgresqlConn)
import TmpProc.Example2.Schema
type Locator = ConnectionString
defaultLoc :: Locator
defaultLoc :: Locator
defaultLoc = Locator
"host=127.0.0.1 port=5432 contact=postgres dbname=postgres password=postgres"
migrateDB :: Locator -> IO ()
migrateDB :: Locator -> IO ()
migrateDB Locator
loc = Locator -> SqlPersistT (LoggingT IO) () -> IO ()
forall a. Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb Locator
loc (SqlPersistT (LoggingT IO) () -> IO ())
-> SqlPersistT (LoggingT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ Migration -> SqlPersistT (LoggingT IO) ()
forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
runMigration Migration
migrateAll
fetch :: Locator -> ContactID -> IO (Maybe Contact)
fetch :: Locator -> ContactID -> IO (Maybe Contact)
fetch Locator
loc ContactID
cid = Locator
-> SqlPersistT (LoggingT IO) (Maybe Contact) -> IO (Maybe Contact)
forall a. Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb Locator
loc (SqlPersistT (LoggingT IO) (Maybe Contact) -> IO (Maybe Contact))
-> SqlPersistT (LoggingT IO) (Maybe Contact) -> IO (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ Key Contact -> SqlPersistT (LoggingT IO) (Maybe Contact)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get (Key Contact -> SqlPersistT (LoggingT IO) (Maybe Contact))
-> Key Contact -> SqlPersistT (LoggingT IO) (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ ContactID -> Key Contact
forall record.
ToBackendKey SqlBackend record =>
ContactID -> Key record
toSqlKey ContactID
cid
create :: Locator -> Contact -> IO ContactID
create :: Locator -> Contact -> IO ContactID
create Locator
loc Contact
contact = Key Contact -> ContactID
forall record.
ToBackendKey SqlBackend record =>
Key record -> ContactID
fromSqlKey (Key Contact -> ContactID) -> IO (Key Contact) -> IO ContactID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locator
-> SqlPersistT (LoggingT IO) (Key Contact) -> IO (Key Contact)
forall a. Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb Locator
loc (Contact -> SqlPersistT (LoggingT IO) (Key Contact)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert Contact
contact)
remove :: Locator -> ContactID -> IO ()
remove :: Locator -> ContactID -> IO ()
remove Locator
loc ContactID
cid = Locator -> SqlPersistT (LoggingT IO) () -> IO ()
forall a. Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb Locator
loc (SqlPersistT (LoggingT IO) () -> IO ())
-> SqlPersistT (LoggingT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ Key Contact -> SqlPersistT (LoggingT IO) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key Contact
contactKey
where
contactKey :: Key Contact
contactKey :: Key Contact
contactKey = ContactID -> Key Contact
forall record.
ToBackendKey SqlBackend record =>
ContactID -> Key record
toSqlKey ContactID
cid
doDb :: Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb :: Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb = (LogSource -> LogLevel -> Bool)
-> Locator -> SqlPersistT (LoggingT IO) a -> IO a
forall a.
(LogSource -> LogLevel -> Bool)
-> Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb' LogSource -> LogLevel -> Bool
forall a. a -> LogLevel -> Bool
defaultFilter
doDb' :: (LogSource -> LogLevel -> Bool) -> Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb' :: (LogSource -> LogLevel -> Bool)
-> Locator -> SqlPersistT (LoggingT IO) a -> IO a
doDb' LogSource -> LogLevel -> Bool
logFilter Locator
loc SqlPersistT (LoggingT IO) a
action =
LoggingT IO a -> IO a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT IO a -> IO a) -> LoggingT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (LogSource -> LogLevel -> Bool) -> LoggingT IO a -> LoggingT IO a
forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger LogSource -> LogLevel -> Bool
logFilter (LoggingT IO a -> LoggingT IO a) -> LoggingT IO a -> LoggingT IO a
forall a b. (a -> b) -> a -> b
$ Locator -> (SqlBackend -> LoggingT IO a) -> LoggingT IO a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Locator -> (SqlBackend -> m a) -> m a
withPostgresqlConn Locator
loc ((SqlBackend -> LoggingT IO a) -> LoggingT IO a)
-> (SqlBackend -> LoggingT IO a) -> LoggingT IO a
forall a b. (a -> b) -> a -> b
$ \SqlBackend
backend ->
SqlPersistT (LoggingT IO) a -> SqlBackend -> LoggingT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT SqlPersistT (LoggingT IO) a
action SqlBackend
backend
defaultFilter :: a -> LogLevel -> Bool
defaultFilter :: a -> LogLevel -> Bool
defaultFilter a
_ LogLevel
level = LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
> LogLevel
LevelDebug