{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Imm.Database where
import Imm.Logger
import Imm.Prelude
import Imm.Pretty
import Data.Map (Map)
class (Ord (Key t), Show (Key t), Show (Entry t), Typeable t, Show t, Pretty t, Pretty (Key t))
=> Table t where
type Key t :: *
type Entry t :: *
class MonadThrow m => MonadDatabase t m where
_describeDatabase :: t -> m (Doc a)
_fetchList :: t -> [Key t] -> m (Map (Key t) (Entry t))
_fetchAll :: t -> m (Map (Key t) (Entry t))
_update :: t -> Key t -> (Entry t -> Entry t) -> m ()
_insertList :: t -> [(Key t, Entry t)] -> m ()
_deleteList :: t -> [Key t] -> m ()
_purge :: t -> m ()
_commit :: t -> m ()
data DatabaseException t
= NotCommitted t
| NotDeleted t [Key t]
| NotFound t [Key t]
| NotInserted t [(Key t, Entry t)]
| NotPurged t
| NotUpdated t (Key t)
| UnableFetchAll t
deriving instance (Eq t, Eq (Key t), Eq (Entry t)) => Eq (DatabaseException t)
deriving instance (Show t, Show (Key t), Show (Entry t)) => Show (DatabaseException t)
instance (Table t, Show (Key t), Show (Entry t), Pretty (Key t), Typeable t) => Exception (DatabaseException t) where
displayException = show . pretty
instance (Pretty t, Pretty (Key t)) => Pretty (DatabaseException t) where
pretty (NotCommitted _) = "Unable to commit database changes."
pretty (NotDeleted _ x) = "Unable to delete the following entries in database:" <++> indent 2 (vsep $ map pretty x)
pretty (NotFound _ x) = "Unable to find the following entries in database:" <++> indent 2 (vsep $ map pretty x)
pretty (NotInserted _ x) = "Unable to insert the following entries in database:" <++> indent 2 (vsep $ map (pretty . fst) x)
pretty (NotPurged t) = "Unable to purge database" <+> pretty t
pretty (NotUpdated _ x) = "Unable to update the following entry in database:" <++> indent 2 (pretty x)
pretty (UnableFetchAll _) = "Unable to fetch all entries from database."
fetch :: (MonadDatabase t m, Table t, MonadThrow m) => t -> Key t -> m (Entry t)
fetch t k = do
results <- _fetchList t [k]
maybe (throwM $ NotFound t [k]) return $ lookup k results
fetchList :: (MonadDatabase t m, MonadThrow m) => t -> [Key t] -> m (Map (Key t) (Entry t))
fetchList = _fetchList
fetchAll :: (MonadThrow m, MonadDatabase t m) => t -> m (Map (Key t) (Entry t))
fetchAll = _fetchAll
update :: (MonadDatabase t m, MonadThrow m) => t -> Key t -> (Entry t -> Entry t) -> m ()
update = _update
insert :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> Key t -> Entry t -> m ()
insert t k v = insertList t [(k, v)]
insertList :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> [(Key t, Entry t)] -> m ()
insertList t i = do
logInfo $ "Inserting " <> yellow (pretty $ length i) <> " entries..."
_insertList t i
delete :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> Key t -> m ()
delete t k = deleteList t [k]
deleteList :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> [Key t] -> m ()
deleteList t k = do
logInfo $ "Deleting " <> yellow (pretty $ length k) <> " entries..."
_deleteList t k
purge :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> m ()
purge t = do
logInfo "Purging database..."
_purge t
commit :: (MonadThrow m, MonadDatabase t m, MonadLog m) => t -> m ()
commit t = do
logDebug "Committing database transaction..."
_commit t
logDebug "Database transaction committed"