Support backend-specific functionality; JSON support for postgres.

Squashed commit of the following:

commit c3791db7e06edf0c338d082958073945cd274f39
Author: Anton Ekblad <anton@ekblad.cc>
Date:   Wed May 8 03:35:35 2019 +0200

    JSON support.

commit c675b1c7447f108908a4c7795848f91352770e19
Author: Anton Ekblad <anton@ekblad.cc>
Date:   Tue May 7 15:43:48 2019 +0200

    Add unsafe operator function, to define custom SQL operators.

commit 45d71ae1c791f1b93bada94b52e6e40015c8f2eb
Author: Anton Ekblad <anton@ekblad.cc>
Date:   Wed May 1 02:49:35 2019 +0200

    Add unsafe sink function.

commit c3083c016794bf0c26217c75b9570ce49c2aa9d9
Author: Anton Ekblad <anton@ekblad.cc>
Date:   Wed May 1 02:18:35 2019 +0200

    Fix prepared statement type inference with constrained backend.

commit f64c4d069ca3eb574539efdd754939b92b4297a5
Author: Anton Ekblad <anton@ekblad.cc>
Date:   Mon Apr 29 21:31:28 2019 +0200

    Parameterise SeldaT over backend. #80

Makefile

@@ -1,4 +1,4 @@
-PACKAGES=selda selda-sqlite selda-postgresql
+PACKAGES=selda selda-sqlite selda-postgresql selda-json
 .PHONY: help build license deps travischeck haddock check test selda pgtest sqlite postgres repl upload-selda upload
 
 help:
@@ -17,13 +17,7 @@ help:
 	@echo "haddock      - build Haddock docs"
 	@echo "tags         - build tags file for emacs"
 
-build: selda sqlite postgres
-
-selda:
-	cp -f LICENSE ./selda/LICENSE
-	cp -f README.md ./selda/README.md
-	cabal v2-build selda
-	make tags ; true
+build: selda sqlite postgres json
 
 travischeck:
 	echo '{-# LANGUAGE OverloadedStrings #-}' > selda-tests/PGConnectInfo.hs
@@ -58,13 +52,26 @@ pgtest: selda postgres
 	cd ./selda-tests && cabal v2-configure --enable-tests -fpostgres
 	cd ./selda-tests && cabal v2-test
 
+selda:
+	cp -f LICENSE ./selda/LICENSE
+	cp -f README.md ./selda/README.md
+	cabal v2-build selda
+	make tags ; true
+
+json:
+	cp -f LICENSE ./selda/LICENSE
+	cabal v2-build selda-json
+	make tags ; true
+
 sqlite:
 	cp -f LICENSE ./selda-sqlite/LICENSE
 	cabal v2-build selda-sqlite
+	make tags ; true
 
 postgres:
 	cp -f LICENSE ./selda-postgresql/LICENSE
 	cabal v2-build selda-postgresql
+	make tags ; true
 
 repl:
 	cabal v2-repl --ghc-options="-XOverloadedStrings" selda

cabal.project

@@ -3,4 +3,5 @@ packages:
   selda-sqlite/
   selda-postgresql/
   selda-tests/
+  selda-json/
   ./

selda-json/selda-json.cabal

@@ -0,0 +1,29 @@
+cabal-version:       >=1.10
+name:                selda-json
+version:             0.1.0.0
+synopsis:            JSON support for the Selda database library.
+-- description:
+homepage:            https://selda.link
+-- bug-reports:
+license:             MIT
+license-file:        LICENSE
+author:              Anton Ekblad
+maintainer:          anton@ekblad.cc
+-- copyright:
+category:            Database
+build-type:          Simple
+extra-source-files:  CHANGELOG.md
+
+library
+  exposed-modules:
+    Database.Selda.JSON
+  -- other-modules:
+  -- other-extensions:
+  build-depends:
+      aeson      >=1.0  && <1.5
+    , base       >=4.8  && <5
+    , bytestring >=0.10 && <0.11
+    , selda      >=0.4  && <0.5
+    , text       >=1.0   && <1.3
+  hs-source-dirs:      src
+  default-language:    Haskell2010

selda-json/src/Database/Selda/JSON.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE GADTs, OverloadedStrings #-}
+module Database.Selda.JSON (JSONBackend (..)) where
+import Database.Selda (Text, Col, Inner)
+import Database.Selda.Backend
+import Database.Selda.Unsafe (sink, sink2)
+import Data.Aeson (Value (Null), encode, decode')
+import qualified Data.ByteString.Lazy as BSL (ByteString, fromStrict, toStrict)
+import Data.Text.Encoding (encodeUtf8)
+
+class JSONValue a
+instance JSONValue Value
+instance JSONValue a => JSONValue (Maybe a)
+
+-- | Any backend that supports JSON lookups in queries.
+class JSONBackend b where
+  -- | Look up the given key in the given JSON column.
+  (~>) :: JSONValue a => Col b a -> Col b Text -> Col b (Maybe Value)
+  infixl 8 ~>
+
+  -- | Convert the given JSON column to plain text.
+  jsonToText :: Col b Value -> Col b Text
+
+instance JSONBackend b => JSONBackend (Inner b) where
+  (~>) = sink2 (~>)
+  jsonToText = sink jsonToText
+
+decodeError :: Show a => a -> b
+decodeError x = error $ "fromSql: json column with invalid json: " ++ show x
+
+typeError :: Show a => a -> b
+typeError x = error $ "fromSql: json column with non-text value: " ++ show x
+
+textToLazyBS :: Text -> BSL.ByteString
+textToLazyBS = BSL.fromStrict . encodeUtf8
+
+instance SqlType Value where
+  mkLit = LCustom TJSON . LBlob . BSL.toStrict . encode
+  sqlType _ = TJSON
+  defaultValue = mkLit Null
+  fromSql (SqlBlob t)   = maybe (decodeError t) id (decode' $ BSL.fromStrict t)
+  fromSql (SqlString t) = maybe (decodeError t) id (decode' $ textToLazyBS t)
+  fromSql x             = typeError x

selda-postgresql/selda-postgresql.cabal

@@ -28,11 +28,12 @@ library
     OverloadedStrings
     CPP
   build-depends:
-      base              >=4.8 && <5
-    , bytestring        >=0.9 && <0.11
-    , exceptions        >=0.8 && <0.11
-    , selda             >=0.4 && <0.5
-    , text              >=1.0 && <1.3
+      base       >=4.8 && <5
+    , bytestring >=0.9 && <0.11
+    , exceptions >=0.8 && <0.11
+    , selda      >=0.4 && <0.5
+    , selda-json >=0.1 && <0.2
+    , text       >=1.0 && <1.3
   if !flag(haste)
     build-depends:
         postgresql-binary >=0.12 && <0.13

selda-postgresql/src/Database/Selda/PostgreSQL.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings, RecordWildCards, GADTs, CPP #-}
 -- | PostgreSQL backend for Selda.
 module Database.Selda.PostgreSQL
-  ( PGConnectInfo (..)
+  ( PG, PGConnectInfo (..)
   , withPostgreSQL, on, auth
   , pgOpen, pgOpen', seldaClose
   , pgConnString, pgPPConfig
@@ -12,6 +12,8 @@ import Data.Monoid
 import Data.ByteString (ByteString)
 import qualified Data.Text as T
 import Database.Selda.Backend hiding (toText)
+import Database.Selda.JSON
+import Database.Selda.Unsafe (cast, operator)
 import Control.Monad.Catch
 import Control.Monad.IO.Class
 
@@ -26,6 +28,12 @@ import Database.Selda.PostgreSQL.Encoding
 import Database.PostgreSQL.LibPQ hiding (user, pass, db, host)
 #endif
 
+data PG
+
+instance JSONBackend PG where
+  (~>) = operator "->"
+  jsonToText = cast
+
 -- | PostgreSQL connection information.
 data PGConnectInfo = PGConnectInfo
   { -- | Host to connect to.
@@ -96,7 +104,9 @@ pgConnString PGConnectInfo{..} = mconcat
 --   The database connection is guaranteed to be closed when the computation
 --   terminates.
 withPostgreSQL :: (MonadIO m, MonadMask m)
-               => PGConnectInfo -> SeldaT m a -> m a
+               => PGConnectInfo
+               -> SeldaT PG m a
+               -> m a
 #ifdef __HASTE__
 withPostgreSQL _ _ = return $ error "withPostgreSQL called in JS context"
 #else
@@ -106,11 +116,14 @@ withPostgreSQL ci m = bracket (pgOpen ci) seldaClose (runSeldaT m)
 -- | Open a new PostgreSQL connection. The connection will persist across
 --   calls to 'runSeldaT', and must be explicitly closed using 'seldaClose'
 --   when no longer needed.
-pgOpen :: (MonadIO m, MonadMask m) => PGConnectInfo -> m SeldaConnection
+pgOpen :: (MonadIO m, MonadMask m) => PGConnectInfo -> m (SeldaConnection PG)
 pgOpen ci = pgOpen' (pgSchema ci) (pgConnString ci)
 
 pgPPConfig :: PPConfig
-pgOpen' :: (MonadIO m, MonadMask m) => Maybe T.Text -> ByteString -> m SeldaConnection
+pgOpen' :: (MonadIO m, MonadMask m)
+        => Maybe T.Text
+        -> ByteString
+        -> m (SeldaConnection PG)
 #ifdef __HASTE__
 pgOpen' _ _ = return $ error "pgOpen' called in JS context"
 pgPPConfig = error "pgPPConfig evaluated in JS context"
@@ -155,7 +168,6 @@ pgPPConfig = defPPConfig
 
     pgTypeRenameHook _ TDateTime = "timestamp with time zone"
     pgTypeRenameHook _ TTime     = "time with time zone"
-    pgTypeRenameHook _ TUUID     = "uuid"
     pgTypeRenameHook f ty        = f ty
 
     pgColAttrsHook :: SqlTypeRep -> [ColAttr] -> ([ColAttr] -> T.Text) -> T.Text
@@ -172,7 +184,7 @@ pgPPConfig = defPPConfig
 
 -- | Create a `SeldaBackend` for PostgreSQL `Connection`
 pgBackend :: Connection   -- ^ PostgreSQL connection object.
-          -> SeldaBackend
+          -> SeldaBackend PG
 pgBackend c = SeldaBackend
   { runStmt         = \q ps -> right <$> pgQueryRunner c False q ps
   , runStmtWithPK   = \q ps -> left <$> pgQueryRunner c True q ps
@@ -423,6 +435,7 @@ mkTypeRep "boolean"                  = Right TBool
 mkTypeRep "date"                     = Right TDate
 mkTypeRep "time with time zone"      = Right TTime
 mkTypeRep "uuid"                     = Right TUUID
+mkTypeRep "jsonb"                    = Right TJSON
 mkTypeRep typ                        = Left typ
 
 -- | Custom column types for postgres.
@@ -432,6 +445,8 @@ pgColType _ TInt      = "INT8"
 pgColType _ TFloat    = "FLOAT8"
 pgColType _ TDateTime = "TIMESTAMP"
 pgColType _ TBlob     = "BYTEA"
+pgColType _ TUUID     = "UUID"
+pgColType _ TJSON     = "JSONB"
 pgColType cfg t       = ppType cfg t
 
 -- | Custom attribute types for postgres.

selda-postgresql/src/Database/Selda/PostgreSQL/Encoding.hs

@@ -29,7 +29,8 @@ import Data.Int (Int16, Int32, Int64)
 
 -- | OIDs for all types used by Selda.
 blobType, boolType, intType, int32Type, int16Type, textType, doubleType,
-  dateType, timeType, timestampType, nameType, varcharType, uuidType :: Oid
+  dateType, timeType, timestampType, nameType, varcharType, uuidType,
+  jsonbType :: Oid
 boolType      = Oid 16
 intType       = Oid 20
 int32Type     = Oid 23
@@ -43,6 +44,7 @@ timestampType = Oid 1184
 blobType      = Oid 17
 varcharType   = Oid 1043
 uuidType      = Oid 2950
+jsonbType     = Oid 3802
 
 bytes :: Enc.Encoding -> BS.ByteString
 bytes = Enc.encodingBytes
@@ -64,7 +66,10 @@ fromSqlValue (LUUID x)     = Just (uuidType, bytes $ Enc.uuid x, Binary)
 fromSqlValue (LBlob b)     = Just (blobType, bytes $ Enc.bytea_strict b, Binary)
 fromSqlValue (LNull)       = Nothing
 fromSqlValue (LJust x)     = fromSqlValue x
-fromSqlValue (LCustom l)   = fromSqlValue l
+fromSqlValue (LCustom TJSON (LBlob b)) = Just ( jsonbType
+                                              , bytes $ Enc.jsonb_bytes b
+                                              , Binary)
+fromSqlValue (LCustom _ l) = fromSqlValue l
 
 -- | Get the corresponding OID for an SQL type representation.
 fromSqlType :: SqlTypeRep -> Oid
@@ -78,6 +83,7 @@ fromSqlType TTime     = timeType
 fromSqlType TBlob     = blobType
 fromSqlType TRowID    = intType
 fromSqlType TUUID     = uuidType
+fromSqlType TJSON     = jsonbType
 
 -- | Convert the given postgres return value and type to an @SqlValue@.
 toSqlValue :: Oid -> BS.ByteString -> SqlValue
@@ -88,17 +94,18 @@ toSqlValue t val
   | t == int16Type     = SqlInt     $ fromIntegral $ parse (Dec.int :: Value Int16) val
   | t == doubleType    = SqlFloat   $ parse Dec.float8 val
   | t == blobType      = SqlBlob    $ parse Dec.bytea_strict val
-  | t == uuidType      = SqlBlob    $ toBS $ parse Dec.uuid val
+  | t == uuidType      = SqlBlob    $ uuid2bs $ parse Dec.uuid val
   | t == timestampType = SqlUTCTime $ parse parseTimestamp val
   | t == timeType      = SqlTime    $ toTime $ parse parseTime val
   | t == dateType      = SqlDate    $ parse Dec.date val
+  | t == jsonbType     = SqlBlob    $ parse (Dec.jsonb_bytes pure) val
   | t `elem` textish   = SqlString  $ parse Dec.text_strict val
   | otherwise          = error $ "BUG: result with unknown type oid: " ++ show t
   where
     parseTimestamp = Dec.timestamptz_int <|> Dec.timestamptz_float
     parseTime = Dec.timetz_int <|> Dec.timetz_float
     toTime (tod, tz) = snd $ localToUTCTimeOfDay tz tod
-    toBS = LBS.toStrict . UUID.toByteString
+    uuid2bs = LBS.toStrict . UUID.toByteString
     textish = [textType, nameType, varcharType]
 
 parse :: Value a -> BS.ByteString -> a

selda-sqlite/src/Database/Selda/SQLite.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE GADTs, CPP, OverloadedStrings #-}
 -- | SQLite3 backend for Selda.
 module Database.Selda.SQLite
-  ( withSQLite
+  ( SQLite
+  , withSQLite
   , sqliteOpen, seldaClose
   , sqliteBackend
   ) where
@@ -19,10 +20,12 @@ import Database.SQLite3
 import System.Directory (makeAbsolute)
 #endif
 
+data SQLite
+
 -- | Open a new connection to an SQLite database.
 --   The connection is reusable across calls to `runSeldaT`, and must be
 --   explicitly closed using 'seldaClose' when no longer needed.
-sqliteOpen :: (MonadIO m, MonadMask m) => FilePath -> m SeldaConnection
+sqliteOpen :: (MonadIO m, MonadMask m) => FilePath -> m (SeldaConnection SQLite)
 #ifdef __HASTE__
 sqliteOpen _ = error "sqliteOpen called in JS context"
 #else
@@ -41,7 +44,7 @@ sqliteOpen file = do
 
 -- | Perform the given computation over an SQLite database.
 --   The database is guaranteed to be closed when the computation terminates.
-withSQLite :: (MonadIO m, MonadMask m) => FilePath -> SeldaT m a -> m a
+withSQLite :: (MonadIO m, MonadMask m) => FilePath -> SeldaT SQLite m a -> m a
 #ifdef __HASTE__
 withSQLite _ _ = return $ error "withSQLite called in JS context"
 
@@ -58,7 +61,7 @@ withSQLite file m = bracket (sqliteOpen file) seldaClose (runSeldaT m)
 --   any and all safety guarantees made by the Selda API.
 --   Caching functionality in particular WILL break.
 --   Proceed with extreme caution.
-sqliteBackend :: Database -> SeldaBackend
+sqliteBackend :: Database -> SeldaBackend SQLite
 sqliteBackend db = SeldaBackend
   { runStmt         = \q ps -> snd <$> sqliteQueryRunner db q ps
   , runStmtWithPK   = \q ps -> fst <$> sqliteQueryRunner db q ps
@@ -198,7 +201,7 @@ toSqlData (LBool b)     = SQLInteger $ if b then 1 else 0
 toSqlData (LBlob b)     = SQLBlob b
 toSqlData (LNull)       = SQLNull
 toSqlData (LJust x)     = toSqlData x
-toSqlData (LCustom l)   = toSqlData l
+toSqlData (LCustom _ l) = toSqlData l
 toSqlData (LUUID x)     = SQLBlob (toStrict $ toByteString x)
 
 fromSqlData :: SQLData -> SqlValue

selda-tests/selda-tests.cabal

@@ -25,28 +25,32 @@ test-suite selda-testsuite
   other-modules:
     Tables
     Utils
+    Tests.JSON
     Tests.MultiConn
     Tests.Mutable
     Tests.NonDB
     Tests.Query
     Tests.Validation
   build-depends:
-      base       >=4.8  && <5
+      aeson
+    , base       >=4.8  && <5
     , bytestring >=0.10 && <0.11
     , directory  >=1.2  && <1.4
     , exceptions >=0.8  && <0.11
     , HUnit      >=1.4  && <1.7
     , selda
+    , selda-json
     , text       >=1.1  && <1.3
     , time       >=1.4  && <1.10
     , random     >=1.1  && <1.2
     , uuid-types >=1.0  && <1.1
   if flag(postgres)
     other-modules: PGConnectInfo
     build-depends: selda-postgresql
-    cpp-options:   -DPOSTGRES
+    cpp-options:   -DPOSTGRES -DTEST_JSON -DBACKEND=PG
   else
     build-depends: selda-sqlite
+    cpp-options: -DSQLITE -DBACKEND=SQLite
   hs-source-dirs:
     test, .
   default-language: