Database.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
-- | Database module abstracts over a key-value database that supports CRUD operations.
module Imm.Database where

-- {{{ Imports
import           Imm.Logger
import           Imm.Prelude
import           Imm.Pretty

import           Data.Map    (Map)
-- }}}

-- * Types

-- | Generic database table
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 :: *

-- | Monad capable of interacting with a key-value store.
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."


-- * Primitives

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"