{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
module Opaleye.Internal.RunQuery where
import Control.Applicative
(Applicative, pure, (<$>), (*>), (<*>), liftA2)
import qualified Database.PostgreSQL.Simple as PGS
import qualified Database.PostgreSQL.Simple.Cursor as PGSC (Cursor)
import Database.PostgreSQL.Simple.Internal (RowParser)
import qualified Database.PostgreSQL.Simple.FromField as PGS
import Database.PostgreSQL.Simple.FromField
(FieldParser, fromField, pgArrayFieldParser)
import Database.PostgreSQL.Simple.FromRow (fromRow, fieldWith)
import Database.PostgreSQL.Simple.Types (fromPGArray, Only(..))
import Opaleye.Column (Column)
import Opaleye.Internal.Column (Nullable)
import qualified Opaleye.Internal.PackMap as PackMap
import qualified Opaleye.Internal.QueryArr as Q
import qualified Opaleye.Column as C
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.PGTypesExternal as T
import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)
import qualified Opaleye.Select as S
import qualified Opaleye.Sql as S
import qualified Data.Profunctor as P
import Data.Profunctor (dimap)
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D
import qualified Data.Aeson as Ae
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as ST
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Time as Time
import qualified Data.Scientific as Sci
import qualified Data.String as String
import Data.UUID (UUID)
import GHC.Int (Int32, Int64)
import Database.PostgreSQL.Simple.FromField
(ResultError(UnexpectedNull, Incompatible), typeInfo, returnError)
import qualified Database.PostgreSQL.Simple.TypeInfo as TI
import qualified Database.PostgreSQL.Simple.Range as PGSR
import Data.Typeable (Typeable)
data FromField pgType haskellType =
QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType)
instance Functor (FromField u) where
fmap f ~(QueryRunnerColumn u fp) = QueryRunnerColumn u ((fmap . fmap . fmap) f fp)
type QueryRunnerColumn = FromField
data FromFields columns haskells =
QueryRunner (U.Unpackspec columns ())
(columns -> RowParser haskells)
(columns -> Int)
type QueryRunner = FromFields
fieldQueryRunnerColumn :: PGS.FromField haskell => FromField pgType haskell
fieldQueryRunnerColumn = fromPGSFromField
fromPGSFromField :: PGS.FromField haskell => FromField pgType haskell
fromPGSFromField = fieldParserQueryRunnerColumn fromField
fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn = fromPGSFieldParser
fromPGSFieldParser :: FieldParser haskell -> FromField pgType haskell
fromPGSFieldParser = QueryRunnerColumn (P.rmap (const ()) U.unpackspecField)
queryRunner :: FromField a b -> FromFields (Column a) b
queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const 1)
where QueryRunnerColumn u fp = qrc
queryRunnerColumnNullable :: FromField a b
-> FromField (Nullable a) (Maybe b)
queryRunnerColumnNullable qr =
QueryRunnerColumn (P.lmap C.unsafeCoerceColumn u) (fromField' fp)
where QueryRunnerColumn u fp = qr
fromField' :: FieldParser a -> FieldParser (Maybe a)
fromField' _ _ Nothing = pure Nothing
fromField' fp' f bs = fmap Just (fp' f bs)
unsafeFromFieldRaw :: FromField a (PGS.Field, Maybe SBS.ByteString)
unsafeFromFieldRaw = fieldParserQueryRunnerColumn (\f mdata -> pure (f, mdata))
instance DefaultFromField a b =>
DefaultFromField (Nullable a) (Maybe b) where
defaultFromField = queryRunnerColumnNullable defaultFromField
instance DefaultFromField a b =>
D.Default FromFields (Column a) b where
def = queryRunner defaultFromField
{-# DEPRECATED queryRunnerColumnDefault "Use defaultFromField instead. It will be removed in 0.8" #-}
class DefaultFromField sqlType haskellType where
queryRunnerColumnDefault :: FromField sqlType haskellType
queryRunnerColumnDefault = defaultFromField
defaultFromField :: FromField sqlType haskellType
defaultFromField = queryRunnerColumnDefault
{-# MINIMAL queryRunnerColumnDefault | defaultFromField #-}
type QueryRunnerColumnDefault = DefaultFromField
instance DefaultFromField sqlType haskellType
=> D.Default FromField sqlType haskellType where
def = defaultFromField
instance DefaultFromField T.SqlNumeric Sci.Scientific where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlInt4 Int where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlInt4 Int32 where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlInt8 Int64 where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlText String where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlFloat8 Double where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlBool Bool where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlUuid UUID where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlBytea SBS.ByteString where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlBytea LBS.ByteString where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlText ST.Text where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlText LT.Text where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlDate Time.Day where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlTimestamptz Time.UTCTime where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlTimestamp Time.LocalTime where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlTimestamptz Time.ZonedTime where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlTime Time.TimeOfDay where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlCitext (CI.CI ST.Text) where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlCitext (CI.CI LT.Text) where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlJson String where
defaultFromField = fieldParserQueryRunnerColumn jsonFieldParser
instance DefaultFromField T.SqlJson Ae.Value where
defaultFromField = fromPGSFromField
instance DefaultFromField T.SqlJsonb String where
defaultFromField = fieldParserQueryRunnerColumn jsonbFieldParser
instance DefaultFromField T.SqlJsonb Ae.Value where
defaultFromField = fromPGSFromField
arrayColumn :: Column (T.SqlArray a) -> Column a
arrayColumn = C.unsafeCoerceColumn
instance (Typeable b, DefaultFromField a b) =>
DefaultFromField (T.SqlArray a) [b] where
defaultFromField = fromFieldArray defaultFromField
fromFieldArray :: Typeable h => FromField f h -> FromField (T.SqlArray f) [h]
fromFieldArray q =
QueryRunnerColumn (P.lmap arrayColumn c)
((fmap . fmap . fmap) fromPGArray (pgArrayFieldParser f))
where QueryRunnerColumn c f = q
instance (Typeable b, DefaultFromField a b) =>
DefaultFromField (T.PGRange a) (PGSR.PGRange b) where
defaultFromField = fromFieldRange defaultFromField
fromFieldRange :: Typeable b
=> FromField a b
-> FromField (T.PGRange a) (PGSR.PGRange b)
fromFieldRange off =
QueryRunnerColumn (P.lmap C.unsafeCoerceColumn c) (PGSR.fromFieldRange pff)
where QueryRunnerColumn c pff = off
instance Functor (FromFields c) where
fmap f (QueryRunner u r b) = QueryRunner u ((fmap . fmap) f r) b
instance Applicative (FromFields c) where
pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const 0)
. pure
. pure
QueryRunner uf rf bf <*> QueryRunner ux rx bx =
QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (+) bf bx)
instance P.Profunctor FromFields where
dimap f g (QueryRunner u r b) =
QueryRunner (P.lmap f u) (P.dimap f (fmap g) r) (P.lmap f b)
instance PP.ProductProfunctor FromFields where
purePP = pure
(****) = (<*>)
instance PP.SumProfunctor FromFields where
f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu))
(PackMap.eitherFunction fr gr)
(either fb gb)
where QueryRunner fu fr fb = f
QueryRunner gu gr gb = g
jsonFieldParser, jsonbFieldParser :: FieldParser String
jsonFieldParser = jsonFieldTypeParser (String.fromString "json")
jsonbFieldParser = jsonFieldTypeParser (String.fromString "jsonb")
jsonFieldTypeParser :: SBS.ByteString -> FieldParser String
jsonFieldTypeParser jsonTypeName field mData = do
ti <- typeInfo field
if TI.typname ti == jsonTypeName
then convert
else returnError Incompatible field "types incompatible"
where
convert = case mData of
Just bs -> pure $ IPT.strictDecodeUtf8 bs
_ -> returnError UnexpectedNull field ""
prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells
prepareRowParser (QueryRunner _ rowParser numColumns) cols =
if numColumns cols > 0
then rowParser cols
else (fromRow :: RowParser (Only Int)) *> rowParser cols
data Cursor haskells = EmptyCursor | Cursor (RowParser haskells) PGSC.Cursor
prepareQuery :: FromFields fields haskells -> S.Select fields -> (Maybe PGS.Query, RowParser haskells)
prepareQuery qr@(QueryRunner u _ _) q = (sql, parser)
where sql :: Maybe PGS.Query
sql = fmap String.fromString (S.showSqlExplicit u q)
(b, _, _) = Q.runSimpleQueryArrStart q ()
parser = prepareRowParser qr b