{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Ribbit.PostgreSQL (
HasPsqlType(..),
PsqlType(..),
query,
execute,
createTable,
createTableStatement,
HasFields,
HasPsqlTypes,
HasIsNullable,
IsSubset,
FromRow,
ToRow,
) where
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Int (Int64)
import Data.Proxy (Proxy(Proxy))
import Data.String (fromString, IsString)
import Data.Text (Text)
import Data.Time (Day)
import Data.Tuple.Only (Only(Only))
import Data.Type.Bool (If)
import Database.PostgreSQL.Simple (Connection)
import Database.PostgreSQL.Simple.FromField (FromField)
import Database.PostgreSQL.Simple.ToField (Action, ToField)
import Database.Ribbit (Render, render, ArgsType, ResultType, (:>)((:>)),
Name, Field, DBSchema, ValidField)
import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage((:<>:),
ShowType))
import qualified Data.Text as T
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.FromRow as PGF
import qualified Database.PostgreSQL.Simple.ToRow as PGT
import qualified GHC.TypeLits as Lit
query :: (
MonadIO m,
Render query,
ToRow (ArgsType query),
FromRow (ResultType query)
)
=> Connection
-> Proxy query
-> ArgsType query
-> m [ResultType query]
query conn theQuery args =
liftIO . (fmap . fmap) unWrap $
PG.query
conn
((fromString . T.unpack . render) theQuery)
(Wrap args)
execute :: (
MonadIO m,
ToRow (ArgsType query),
Render query
)
=> Connection
-> Proxy query
-> ArgsType query
-> m Int64
execute conn theQuery args =
liftIO $
PG.execute
conn
((fromString . T.unpack . render) theQuery)
(Wrap args)
createTable :: forall proxy1 proxy2 key table m. (
KnownSymbol (Name table),
HasPsqlTypes (DBSchema table),
HasFields (DBSchema table),
HasFields key,
IsSubset key (DBSchema table) ~ 'True,
MonadIO m
)
=> Connection
-> proxy1 key
-> proxy2 table
-> m ()
createTable conn key table =
let
stmt :: Text
stmt = createTableStatement key table
in
liftIO . void $
PG.execute_
conn
(fromString . T.unpack $ stmt)
createTableStatement :: forall proxy1 proxy2 table key. (
KnownSymbol (Name table),
HasPsqlTypes (DBSchema table),
HasFields (DBSchema table),
HasFields key,
IsSubset key (DBSchema table) ~ 'True
)
=> proxy1 key
-> proxy2 table
-> Text
createTableStatement key _table =
"create table " <> symbolVal tableName
<> " (" <> T.intercalate ", " [
field
<> " "
<> typ
| (field, typ) <- zip (fields schema) (psqlTypes schema)
]
<> (
case fields key of
[] -> ""
fs -> ", primary key (" <> T.intercalate ", " fs <> ")"
)
<> ");"
where
schema :: Proxy (DBSchema table)
schema = Proxy
tableName :: Proxy (Name table)
tableName = Proxy
class HasFields a where
fields :: proxy a -> [Text]
instance (KnownSymbol name) => HasFields (Field name typ) where
fields _proxy = [symbolVal (Proxy @name)]
instance (KnownSymbol name, HasFields more) =>
HasFields (Field name typ :> more)
where
fields _proxy = symbolVal (Proxy @name) : fields (Proxy @more)
instance HasFields '[] where
fields _proxy = []
instance (KnownSymbol name, HasFields more) => HasFields (name:more) where
fields _proxy = symbolVal (Proxy @name) : fields (Proxy @more)
class HasPsqlTypes a where
psqlTypes :: proxy a -> [Text]
instance (HasIsNullable typ, HasPsqlType typ) => HasPsqlTypes (Field name typ) where
psqlTypes _proxy =
[
unPsqlType (psqlType (Proxy @typ))
<> if isNullable (Proxy @typ) then "" else " not null"
]
instance (HasIsNullable typ, HasPsqlType typ, HasPsqlTypes more) =>
HasPsqlTypes (Field name typ :> more)
where
psqlTypes _proxy =
psqlTypes (Proxy @(Field name typ)) ++ psqlTypes (Proxy @more)
class HasPsqlType a where
psqlType :: proxy a -> PsqlType
instance (HasPsqlType a) => HasPsqlType (Maybe a) where
psqlType _proxy = psqlType (Proxy @a)
instance HasPsqlType Text where
psqlType _proxy = "text"
instance HasPsqlType Int where
psqlType _proxy = "integer"
instance HasPsqlType Day where
psqlType _proxy = "date"
class HasIsNullable a where
isNullable :: proxy a -> Bool
instance HasIsNullable (Maybe a) where
isNullable _proxy = True
instance {-# OVERLAPPABLE #-} HasIsNullable a where
isNullable _proxy = False
newtype PsqlType = PsqlType {
unPsqlType :: Text
}
deriving newtype (IsString)
class FromRow a where
fromRow :: PGF.RowParser a
instance (FromRow a, FromRow b) => FromRow (a :> b) where
fromRow =
(:>)
<$> fromRow
<*> fromRow
instance (FromField a) => FromRow (Only a) where
fromRow = Only <$> PGF.field
class ToRow a where
toRow :: a -> [Action]
instance (ToRow a, ToRow b) => ToRow (a :> b) where
toRow (a :> b) = toRow a ++ toRow b
instance (ToField a) => ToRow (Only a) where
toRow = PGT.toRow
instance ToRow () where
toRow = PGT.toRow
newtype Wrap a = Wrap {
unWrap :: a
}
instance (FromRow a) => PGF.FromRow (Wrap a) where
fromRow = Wrap <$> fromRow
instance (ToRow a) => PGT.ToRow (Wrap a) where
toRow = toRow . unWrap
symbolVal :: (KnownSymbol n, IsString a) => proxy n -> a
symbolVal = fromString . Lit.symbolVal
type family IsSubset fields schema where
IsSubset '[] schema = 'True
IsSubset (field:more) schema =
If
(ValidField field schema)
(IsSubset more schema)
(
TypeError (
'Lit.Text "field "
':<>: 'ShowType field
':<>: 'Lit.Text " is not part of the schema, so it cannot be\
\ used as a component of the primary key."
)
)