Hasql abstractions

hasql-extra.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HasqlExtra where

import Data.UUID (UUID)
import qualified Hasql.Decoders as D
import Hasql.DynamicStatements.Snippet (Snippet, param, sql)
import Hasql.DynamicStatements.Statement (dynamicallyParameterized)
import Hasql.Implicits.Encoders (DefaultParamEncoder)
import Hasql.Statement (Statement)
import RIO
import qualified RIO.List as L

-- TOOLS
-- -----------------------------------------------------------------------------

type Query r = Statement () r

newtype TableName a = TableName {unTableName :: ByteString} deriving (Show, Eq)

newtype Selector a = Selector {unSelector :: Snippet}

newtype Restrictor = Restrictor {unRestrictor :: Snippet}

newtype Stmt a = Stmt {unStmt :: Snippet}

data family Record a

class Table a where
  decode :: D.Row (Record a)
  defaultSelector :: Selector a
  tableName :: TableName a

-- snippet constructors

fromTable_ :: TableName a -> Snippet
fromTable_ t = " FROM " <> sql (unTableName t)

select_ :: Selector a -> Snippet
select_ s = " SELECT " <> unSelector s

restrict :: [Restrictor] -> Snippet
restrict rs = " WHERE " <> condition
  where
    condition = mconcat $ L.intersperse (sql " AND ") (unRestrictor <$> rs)

-- runner

exec :: D.Result result -> Snippet -> Query result
exec decoder snippet = dynamicallyParameterized snippet decoder True

-- public api

select :: TableName a -> Selector a -> [Restrictor] -> Stmt a
select t selector restrictions =
  Stmt $
    mconcat
      [ select_ selector,
        fromTable_ t,
        restrict restrictions
      ]

eq :: (DefaultParamEncoder a) => Snippet -> a -> Restrictor
eq s p = Restrictor $ s <> sql " = " <> param p

singleRow :: (Table r) => Stmt r -> Query (Record r)
singleRow s = exec (D.singleRow decode) (unStmt s)

maybeRow :: (Table r) => Stmt r -> Query (Maybe (Record r))
maybeRow s = exec (D.rowMaybe decode) (unStmt s)

-- DOMAIN
-- -----------------------------------------------------------------------------

required :: D.Value a -> D.Row a
required = D.column . D.nonNullable

nullable :: D.Value a -> D.Row (Maybe a)
nullable = D.column . D.nullable

data family Id a

data Club

data instance Id Club = ClubId UUID deriving (Show, Eq)

data instance Record Club = ClubRow
  { clubId :: Id Club,
    clubName :: Text
  }
  deriving (Show, Eq)

instance Table Club where
  tableName = TableName "my_schema.club"
  defaultSelector = Selector "id, name"
  decode = ClubRow <$> (ClubId <$> required D.uuid) <*> required D.text

clubById :: Id Club -> Query (Maybe (Record Club))
clubById (ClubId cid) =
  maybeRow $
    select tableName defaultSelector [eq "id" cid]

data Car

data instance Id Car = CarId Text deriving (Show, Eq)

data instance Record Car = CarRow
  { carId :: Id Car,
    carModel :: Maybe Text
  }
  deriving (Show, Eq)

instance Table Car where
  tableName = TableName "my_schema.car"
  defaultSelector = Selector "id, name"
  decode = CarRow <$> (CarId <$> required D.text) <*> nullable D.text

carById :: Id Car -> Query (Record Car)
carById (CarId cid) =
  singleRow $
    select tableName defaultSelector [eq "id" cid]