{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
module Opaleye.Internal.RunQuery where
import Control.Applicative (Applicative, pure, (*>), (<*>), liftA2)
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.Column as C
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.PGTypes as T
import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)
import qualified Data.Profunctor as P
import Data.Profunctor (dimap)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product (empty, (***!))
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 Control.Applicative ((<$>))
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 QueryRunnerColumn 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 FromField = QueryRunnerColumn
data QueryRunner columns haskells =
QueryRunner (U.Unpackspec columns ())
(columns -> RowParser haskells)
(columns -> Bool)
type FromFields = QueryRunner
fieldQueryRunnerColumn :: PGS.FromField haskell => FromField pgType haskell
fieldQueryRunnerColumn = fieldParserQueryRunnerColumn fromField
fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell
fieldParserQueryRunnerColumn = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn)
queryRunner :: FromField a b -> FromFields (Column a) b
queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const True)
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)
instance QueryRunnerColumnDefault a b =>
QueryRunnerColumnDefault (Nullable a) (Maybe b) where
queryRunnerColumnDefault = queryRunnerColumnNullable queryRunnerColumnDefault
instance QueryRunnerColumnDefault a b =>
D.Default QueryRunner (Column a) b where
def = queryRunner queryRunnerColumnDefault
class QueryRunnerColumnDefault pgType haskellType where
queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType
instance QueryRunnerColumnDefault sqlType haskellType
=> D.Default FromField sqlType haskellType where
def = queryRunnerColumnDefault
instance QueryRunnerColumnDefault T.PGNumeric Sci.Scientific where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGInt4 Int where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGInt4 Int32 where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGInt8 Int64 where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGText String where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGFloat8 Double where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGBool Bool where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGUuid UUID where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGBytea SBS.ByteString where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGBytea LBS.ByteString where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGText ST.Text where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGText LT.Text where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGDate Time.Day where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGTimestamptz Time.UTCTime where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGTimestamp Time.LocalTime where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGTimestamptz Time.ZonedTime where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGTime Time.TimeOfDay where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGCitext (CI.CI ST.Text) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGCitext (CI.CI LT.Text) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGJson String where
queryRunnerColumnDefault = fieldParserQueryRunnerColumn jsonFieldParser
instance QueryRunnerColumnDefault T.PGJson Ae.Value where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault T.PGJsonb String where
queryRunnerColumnDefault = fieldParserQueryRunnerColumn jsonbFieldParser
instance QueryRunnerColumnDefault T.PGJsonb Ae.Value where
queryRunnerColumnDefault = fieldQueryRunnerColumn
arrayColumn :: Column (T.PGArray a) -> Column a
arrayColumn = C.unsafeCoerceColumn
instance (Typeable b, QueryRunnerColumnDefault a b) =>
QueryRunnerColumnDefault (T.PGArray a) [b] where
queryRunnerColumnDefault = QueryRunnerColumn (P.lmap arrayColumn c) ((fmap . fmap . fmap) fromPGArray (pgArrayFieldParser f))
where QueryRunnerColumn c f = queryRunnerColumnDefault
instance (Typeable b, PGS.FromField b, QueryRunnerColumnDefault a b) =>
QueryRunnerColumnDefault (T.PGRange a) (PGSR.PGRange b) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
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 False)
. 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
empty = PP.defaultEmpty
(***!) = PP.defaultProfunctorProduct
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 nonZeroColumns) cols =
if nonZeroColumns cols
then rowParser cols
else (fromRow :: RowParser (Only Int)) *> rowParser cols
data Cursor haskells = EmptyCursor | Cursor (RowParser haskells) PGSC.Cursor