aelve/guide

{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Utilities for working with Postgres.
module Guide.Database.Utils
(
  -- * Generic queries
  -- ** Simple query functions
  queryRowMaybe,
  queryRows,
  execute,
  -- ** General query function
  makeStatement,
  -- ** Typeclasses for encoders and decoders
  ToPostgres (..),
  FromPostgres (..),
  -- ** Row conversion
  ToPostgresParam (..),
  FromPostgresColumn (..),
  ToPostgresParams (..),
  FromPostgresRow (..),
  -- ** One-element row newtypes
  SingleParam (..),
  SingleColumn (..),
)
where

import Imports
import Hasql.Statement
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Contravariant.Divisible (divided, lost, chosen)
import Generics.Eot (toEot, HasEot(..))
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH (stringE)

import qualified Data.Set as Set
import qualified Hasql.Encoders as HE
import qualified Hasql.Decoders as HD

import Guide.Uid

----------------------------------------------------------------------------
-- Query functions
----------------------------------------------------------------------------

-- | A wrapper around 'Statement' using named parameters.
makeStatement
  :: "prepared" :! Bool  -- ^ Whether the query should be prepared (see
                         -- <https://www.postgresql.org/docs/current/sql-prepare.html>).
                         -- Use prepared queries if you perform the same
                         -- query many times per 'Session', e.g. in a loop.
  -> "params" :! HE.Params a  -- ^ How to encode the parameters
  -> "result" :! HD.Result b  -- ^ How to decode the result
  -> ByteString  -- ^ Query
  -> Statement a b
makeStatement
  (arg #prepared -> prepared)
  (arg #params -> params)
  (arg #result -> result)
  sql
  =
  Statement sql params result prepared

-- | Create a 'Statement' fetching a single row from the database:
--
-- @
-- statement :: Statement (Uid Trait, Bool) (Maybe (Uid Trait, Text))
-- statement =
--   [queryRowMaybe|
--     SELECT uid, content
--     FROM traits
--     WHERE uid = $1
--       AND deleted = $2
--   |]
-- @
--
-- The resulting 'Statement' can be executed using 'Hasql.Session.statement'
-- from "Hasql.Session" or 'Hasql.Transaction.statement' from
-- "Hasql.Transaction". If the query contains @$1, $2, ...@ placeholders,
-- you will have to fill them:
--
-- @
-- fetchItem :: Session (Maybe (Uid Trait, Text))
-- fetchItem itemId = Hasql.Session.statement (itemId, False) statement
-- @
--
-- 'queryRowMaybe' uses @'ToPostgresParams' a@ for encoding and
-- @'FromPostgresRow' b@ for decoding. To pass no parameters, use @()@. To
-- pass several parameters or get several columns from the query, either use
-- tuples, or write your own row type and derive instances for it. To pass
-- only one parameter, use 'SingleParam', and to get back only one column,
-- use 'SingleColumn'. The following example demonstrates both:
--
-- @
-- statement :: Statement (Uid Item) (Maybe (Uid Category))
-- statement = dimap SingleParam (fmap fromSingleColumn) $
--   [queryRowMaybe|
--     SELECT category_uid
--     FROM items
--     WHERE uid = $1
--   |]
-- @
--
-- See 'Data.Profunctor.lmap', 'Data.Profunctor.rmap',
-- 'Data.Profunctor.dimap' from "Data.Profunctor".
queryRowMaybe :: QuasiQuoter
queryRowMaybe = QuasiQuoter
  { quoteExp = \sql ->
      [|makeStatement
          (#prepared False)
          (#params toPostgresParams)
          (#result (HD.rowMaybe fromPostgresRow))
          (fromString $(stringE sql))|]
  , quotePat = error "queryRowMaybe: can not be used in patterns"
  , quoteType = error "queryRowMaybe: can not be used in types"
  , quoteDec = error "queryRowMaybe: can not be used in declarations"
  }

-- | Create a 'Statement' fetching many rows from the database.
--
-- Like 'queryRowMaybe', but returns @Statement a [b]@ instead of @Statement
-- a (Maybe b)@.
queryRows :: QuasiQuoter
queryRows = QuasiQuoter
  { quoteExp = \sql ->
      [|makeStatement
          (#prepared False)
          (#params toPostgresParams)
          (#result (HD.rowList fromPostgresRow))
          (fromString $(stringE sql))|]
  , quotePat = error "queryRows: can not be used in patterns"
  , quoteType = error "queryRows: can not be used in types"
  , quoteDec = error "queryRows: can not be used in declarations"
  }

-- | Create a 'Statement' that executes a query without returning anything.
--
-- Like 'queryRowMaybe', but returns @Statement a ()@ instead of @Statement
-- a (Maybe b)@.
-- NOTE: 'execute' consumes only one query at time.
execute :: QuasiQuoter
execute = QuasiQuoter
  { quoteExp = \sql ->
      [|makeStatement
          (#prepared False)
          (#params toPostgresParams)
          (#result HD.noResult)
          (fromString $(stringE sql))|]
  , quotePat = error "execute: can not be used in patterns"
  , quoteType = error "execute: can not be used in types"
  , quoteDec = error "execute: can not be used in declarations"
  }

----------------------------------------------------------------------------
-- ToPostgres and FromPostgres
----------------------------------------------------------------------------

class ToPostgres a where
  -- | Encode a single value to the Postgres format.
  --
  -- If you have a newtype over an existing type supported by 'ToPostgres',
  -- you can write an instance like this:
  --
  -- @
  -- instance ToPostgres Foo where
  --   toPostgres = unFoo '>$<' toPostgres
  -- @
  toPostgres :: HE.Value a

class FromPostgres a where
  -- | Decode a single value from the Postgres format.
  --
  -- If you have a newtype over an existing type supported by
  -- 'FromPostgres', you can write an instance like this:
  --
  -- @
  -- instance FromPostgres Foo where
  --   fromPostgres = Foo '<$>' fromPostgres
  -- @
  fromPostgres :: HD.Value a

instance ToPostgres Bool where
  toPostgres = HE.bool

instance FromPostgres Bool where
  fromPostgres = HD.bool

instance ToPostgres Int32 where
  toPostgres = HE.int4

instance FromPostgres Int32 where
  fromPostgres = HD.int4

instance ToPostgres Text where
  toPostgres = HE.text

instance FromPostgres Text where
  fromPostgres = HD.text

instance ToPostgres UTCTime where
  toPostgres = HE.timestamptz

instance FromPostgres UTCTime where
  fromPostgres = HD.timestamptz

instance ToPostgres (Uid a) where
  toPostgres = uidToText >$< HE.text

instance FromPostgres (Uid a) where
  fromPostgres = Uid <$> HD.text

----------------------------------------------------------------------------
-- ToPostgresParam
----------------------------------------------------------------------------

class ToPostgresParam a where
  -- | Convert a single value to a parameter that can be passed to a query.
  --
  -- Unlike 'toPostgres', this function can deal with nullable parameters
  -- and array parameters, which are not representable as 'HE.Value'.
  toPostgresParam :: HE.Params a

-- | Non-nullable parameters.
instance {-# OVERLAPPABLE #-} ToPostgres a => ToPostgresParam a where
  toPostgresParam = HE.param (HE.nonNullable toPostgres)

-- | Nullable parameters.
instance ToPostgres a => ToPostgresParam (Maybe a) where
  toPostgresParam = HE.param (HE.nullable toPostgres)

-- | Arrays of non-nullable values.
instance ToPostgres a => ToPostgresParam [a] where
  toPostgresParam =
    HE.param (HE.nonNullable (HE.foldableArray (HE.nonNullable toPostgres)))

-- | Arrays of nullable values.
instance ToPostgres a => ToPostgresParam [Maybe a] where
  toPostgresParam =
    HE.param (HE.nonNullable (HE.foldableArray (HE.nullable toPostgres)))

-- | Sets of non-nullable values, represented as arrays.
instance ToPostgres a => ToPostgresParam (Set a) where
  toPostgresParam =
    HE.param (HE.nonNullable (HE.foldableArray (HE.nonNullable toPostgres)))

-- | Sets of nullable values, represented as arrays.
instance ToPostgres a => ToPostgresParam (Set (Maybe a)) where
  toPostgresParam =
    HE.param (HE.nonNullable (HE.foldableArray (HE.nullable toPostgres)))

----------------------------------------------------------------------------
-- FromPostgresColumn
----------------------------------------------------------------------------

class FromPostgresColumn a where
  -- | Fetch a single column from a row.
  --
  -- Unlike 'fromPostgres', this function can deal with nullable columns and
  -- array columns, which are not representable as 'HD.Value'.
  fromPostgresColumn :: HD.Row a

-- | Non-nullable columns.
instance {-# OVERLAPPABLE #-} FromPostgres a => FromPostgresColumn a where
  fromPostgresColumn = HD.column (HD.nonNullable fromPostgres)

-- | Nullable columns.
instance FromPostgres a => FromPostgresColumn (Maybe a) where
  fromPostgresColumn = HD.column (HD.nullable fromPostgres)

-- | Arrays of non-nullable values.
instance FromPostgres a => FromPostgresColumn [a] where
  fromPostgresColumn =
    HD.column (HD.nonNullable (HD.listArray (HD.nonNullable fromPostgres)))

-- | Arrays of nullable values.
instance FromPostgres a => FromPostgresColumn [Maybe a] where
  fromPostgresColumn =
    HD.column (HD.nonNullable (HD.listArray (HD.nullable fromPostgres)))

-- | Sets of non-nullable values, represented as arrays.
instance (Ord a, FromPostgres a) => FromPostgresColumn (Set a) where
  fromPostgresColumn =
    Set.fromList <$>
    HD.column (HD.nonNullable (HD.listArray (HD.nonNullable fromPostgres)))

-- | Sets of nullable values, represented as arrays.
instance (Ord a, FromPostgres a) => FromPostgresColumn (Set (Maybe a)) where
  fromPostgresColumn =
    Set.fromList <$>
    HD.column (HD.nonNullable (HD.listArray (HD.nullable fromPostgres)))

----------------------------------------------------------------------------
-- ToPostgresParams
----------------------------------------------------------------------------

class ToPostgresParams a where
  -- | Pass a row of parameters to a query.
  toPostgresParams :: HE.Params a

  -- | A default implementation for anything that implements 'Generic'.
  default toPostgresParams :: (HasEot a, GToPostgresParams (Eot a)) => HE.Params a
  toPostgresParams = toEot >$< genericToPostgresParams

class GToPostgresParams a where
  -- | A generic method to encode data types with one constructor as Hasql
  -- rows. See
  -- <https://generics-eot.readthedocs.io/en/stable/tutorial.html#eot-isomorphic-representations>
  -- to understand its implementation.
  genericToPostgresParams :: HE.Params a

-- An instance for zero fields.
instance GToPostgresParams () where
  genericToPostgresParams = HE.noParams

-- If we can encode N fields, we can encode N+1 fields.
instance (ToPostgresParam a, GToPostgresParams b) => GToPostgresParams (a, b) where
  genericToPostgresParams = divided toPostgresParam genericToPostgresParams

-- One-constructor types are represented as @Either a Void@, where @a@ is a
-- tuple that we already know how to encode thanks to the instances above.
-- We do not support types with more than one constructor.
instance GToPostgresParams a => GToPostgresParams (Either a Void) where
  genericToPostgresParams = chosen genericToPostgresParams lost

----------------------------------------------------------------------------
-- FromPostgresRow
----------------------------------------------------------------------------

class FromPostgresRow a where
  -- | Fetch a row of results from a query.
  fromPostgresRow :: HD.Row a

  -- | A default implementation for anything that implements 'Generic'.
  default fromPostgresRow :: (HasEot a, GFromPostgresRow (Eot a)) => HD.Row a
  fromPostgresRow = fromEot <$> genericFromPostgresRow

class GFromPostgresRow a where
  -- | A generic method to decode data types with one constructor as Hasql
  -- rows. See
  -- <https://generics-eot.readthedocs.io/en/stable/tutorial.html#eot-isomorphic-representations>
  -- to understand its implementation.
  genericFromPostgresRow :: HD.Row a

-- An instance for zero fields.
instance GFromPostgresRow () where
  genericFromPostgresRow = pure ()

-- If we can encode N fields, we can encode N+1 fields.
instance (FromPostgresColumn a, GFromPostgresRow b) => GFromPostgresRow (a, b) where
  genericFromPostgresRow = (,) <$> fromPostgresColumn <*> genericFromPostgresRow

-- One-constructor types are represented as @Either a Void@, where @a@ is a
-- tuple that we already know how to encode thanks to the instances above.
-- We do not support types with more than one constructor.
instance GFromPostgresRow a => GFromPostgresRow (Either a Void) where
  genericFromPostgresRow = Left <$> genericFromPostgresRow

----------------------------------------------------------------------------
-- SingleParam and SingleColumn
----------------------------------------------------------------------------

newtype SingleParam a = SingleParam { fromSingleParam :: a }
  deriving (Eq, Ord, Show, Generic)

instance ToPostgresParam a => ToPostgresParams (SingleParam a)

newtype SingleColumn a = SingleColumn { fromSingleColumn :: a }
  deriving (Eq, Ord, Show, Generic)

instance FromPostgresColumn a => FromPostgresRow (SingleColumn a)

----------------------------------------------------------------------------
-- Tuples
----------------------------------------------------------------------------

-- Note: 'Generic' provides instances for tuples only until 7-tuples

instance ToPostgresParams ()
instance (ToPostgresParam a, ToPostgresParam b) => ToPostgresParams (a, b)
instance (ToPostgresParam a, ToPostgresParam b, ToPostgresParam c) => ToPostgresParams (a, b, c)
instance (ToPostgresParam a, ToPostgresParam b, ToPostgresParam c, ToPostgresParam d) => ToPostgresParams (a, b, c, d)
instance (ToPostgresParam a, ToPostgresParam b, ToPostgresParam c, ToPostgresParam d, ToPostgresParam e) => ToPostgresParams (a, b, c, d, e)
instance (ToPostgresParam a, ToPostgresParam b, ToPostgresParam c, ToPostgresParam d, ToPostgresParam e, ToPostgresParam f) => ToPostgresParams (a, b, c, d, e, f)
instance (ToPostgresParam a, ToPostgresParam b, ToPostgresParam c, ToPostgresParam d, ToPostgresParam e, ToPostgresParam f, ToPostgresParam g) => ToPostgresParams (a, b, c, d, e, f, g)

instance FromPostgresRow ()
instance (FromPostgresColumn a, FromPostgresColumn b) => FromPostgresRow (a, b)
instance (FromPostgresColumn a, FromPostgresColumn b, FromPostgresColumn c) => FromPostgresRow (a, b, c)
instance (FromPostgresColumn a, FromPostgresColumn b, FromPostgresColumn c, FromPostgresColumn d) => FromPostgresRow (a, b, c, d)
instance (FromPostgresColumn a, FromPostgresColumn b, FromPostgresColumn c, FromPostgresColumn d, FromPostgresColumn e) => FromPostgresRow (a, b, c, d, e)
instance (FromPostgresColumn a, FromPostgresColumn b, FromPostgresColumn c, FromPostgresColumn d, FromPostgresColumn e, FromPostgresColumn f) => FromPostgresRow (a, b, c, d, e, f)
instance (FromPostgresColumn a, FromPostgresColumn b, FromPostgresColumn c, FromPostgresColumn d, FromPostgresColumn e, FromPostgresColumn f, FromPostgresColumn g) => FromPostgresRow (a, b, c, d, e, f, g)