{-# LANGUAGE OverloadedStrings #-}

module TmpProc.Example2.Database
  ( -- * Contact Database access
    create
  , fetch
  , remove
  , migrateDB

    -- * Database location
  , 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

{-| Specifies the database to connect to .-}
type Locator = ConnectionString


{-| A default for local development .-}
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)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend 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)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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 ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend 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 :: forall a. 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' :: forall a.
(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 :: forall a. a -> LogLevel -> Bool
defaultFilter a
_ LogLevel
level = LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
> LogLevel
LevelDebug