diff --git a/spago.lock b/spago.lock index 2aa7e2a..2813027 100644 --- a/spago.lock +++ b/spago.lock @@ -24,6 +24,7 @@ workspace: - nullable - precise-datetime - prelude + - profunctor - record - simple-json - transformers diff --git a/spago.yaml b/spago.yaml index 6283a84..6d9965c 100644 --- a/spago.yaml +++ b/spago.yaml @@ -1,6 +1,8 @@ package: name: pg build: + censorProjectWarnings: + - 'ImplicitQualifiedImportReExport' strict: true pedanticPackages: true dependencies: @@ -25,6 +27,7 @@ package: - nullable - precise-datetime - prelude + - profunctor - record - simple-json - transformers diff --git a/src/Control.Monad.Postgres.purs b/src/Control.Monad.Postgres.purs new file mode 100644 index 0000000..ee9bf64 --- /dev/null +++ b/src/Control.Monad.Postgres.purs @@ -0,0 +1 @@ +module Control.Monad.Postgres where diff --git a/src/Data.Postgres.Query.purs b/src/Data.Postgres.Query.purs index 19259a8..a1003fb 100644 --- a/src/Data.Postgres.Query.purs +++ b/src/Data.Postgres.Query.purs @@ -11,9 +11,6 @@ import Effect (Effect) import Record (insert, modify) import Type.Prelude (Proxy(..)) --- | FFI Query type -type QueryRaw = { text :: String, values :: Array Raw, name :: Nullable String, rowMode :: String } - -- | SQL Query -- | -- | * `text` - the query string @@ -22,27 +19,18 @@ type QueryRaw = { text :: String, values :: Array Raw, name :: Nullable String, newtype Query = Query { text :: String, values :: Array Raw, name :: Maybe String } derive instance Newtype Query _ -derive newtype instance Eq Query derive newtype instance Show Query -- | An empty query emptyQuery :: Query emptyQuery = Query { text: "", values: [], name: Nothing } -queryToRaw :: Query -> QueryRaw -queryToRaw (Query r) = - let - name = Proxy @"name" - rowMode = Proxy @"rowMode" - in - insert rowMode "array" $ modify name toNullable $ r - -- | Values that can be rendered as a SQL query class AsQuery a where asQuery :: a -> Effect Query instance AsQuery a => AsQuery (Effect a) where - asQuery = flip bind asQuery + asQuery a = asQuery =<< a instance AsQuery Query where asQuery = pure @@ -52,3 +40,16 @@ instance AsQuery String where instance AsQuery (String /\ Array Raw) where asQuery (text /\ values) = pure $ Query { text, values, name: Nothing } + +-- | FFI +type QueryRaw = { text :: String, values :: Array Raw, name :: Nullable String, rowMode :: String } + +-- | FFI +__queryToRaw :: Query -> QueryRaw +__queryToRaw (Query r) = + let + name = Proxy @"name" + rowMode = Proxy @"rowMode" + in + insert rowMode "array" $ modify name toNullable $ r + diff --git a/src/Data.Postgres.Range.js b/src/Data.Postgres.Range.js index 31140be..fa0900b 100644 --- a/src/Data.Postgres.Range.js +++ b/src/Data.Postgres.Range.js @@ -6,7 +6,7 @@ import * as Range from 'postgres-range' */ /** @type {(_: Range.Range) => RangeRawRecord} */ -export const rangeRawToRecord = r => { +export const __rangeRawToRecord = r => { if (r.hasMask(Range.RANGE_EMPTY)) { return { upper: undefined, @@ -27,7 +27,7 @@ export const rangeRawToRecord = r => { } /** @type {(_: RangeRawRecord) => Range.Range} */ -export const rangeRawFromRecord = r => { +export const __rangeRawFromRecord = r => { const upper = r.upper === undefined ? null : r.upper const lower = r.lower === undefined ? null : r.lower if (upper === null && lower === null) { @@ -52,17 +52,17 @@ export const rangeRawFromRecord = r => { } /** @type {(r: Range.Range) => () => string} */ -export const rangeRawSerialize = r => () => { +export const __rangeRawSerialize = r => () => { return Range.serialize(r) } /** @type {(r: string) => (f: (s: string) => () => T) => () => Range.Range} */ -export const rangeRawParse = r => f => () => { +export const __rangeRawParse = r => f => () => { return Range.parse(r, s => f(s)()) } /** @type {(r: unknown) => () => Range.Range} */ -export const readRangeRaw = r => () => { +export const __rangeRawFromRaw = r => () => { if (r instanceof Range.Range) { return r } else { diff --git a/src/Data.Postgres.Range.purs b/src/Data.Postgres.Range.purs index 64d5c93..883937f 100644 --- a/src/Data.Postgres.Range.purs +++ b/src/Data.Postgres.Range.purs @@ -14,53 +14,12 @@ import Data.Show.Generic (genericShow) import Effect (Effect) import Foreign (unsafeToForeign) -type RangeRawRecord = { upper :: Raw, lower :: Raw, lowerIncl :: Boolean, upperIncl :: Boolean } - -foreign import data RangeRaw :: Type -foreign import readRangeRaw :: Raw -> Effect RangeRaw -foreign import rangeRawToRecord :: RangeRaw -> RangeRawRecord -foreign import rangeRawFromRecord :: RangeRawRecord -> RangeRaw -foreign import rangeRawParse :: String -> (String -> Effect Raw) -> Effect RangeRaw -foreign import rangeRawSerialize :: RangeRaw -> Effect String - -rangeFromRaw :: forall a. Deserialize a => RangeRawRecord -> RepT (Range a) -rangeFromRaw raw = do - upper' :: Maybe a <- deserialize raw.upper - lower' :: Maybe a <- deserialize raw.lower - pure $ Range { upper: makeBound raw.upperIncl <$> upper', lower: makeBound raw.lowerIncl <$> lower' } - -rangeToRaw :: forall a. Serialize a => Range a -> RepT RangeRawRecord -rangeToRaw r = do - upper' <- serialize $ boundValue <$> upper r - lower' <- serialize $ boundValue <$> lower r - pure $ { upper: upper', lower: lower', upperIncl: fromMaybe false $ boundIsInclusive <$> upper r, lowerIncl: fromMaybe false $ boundIsInclusive <$> lower r } - -data Bound a = BoundIncl a | BoundExcl a - -derive instance Generic (Bound a) _ -derive instance Eq a => Eq (Bound a) -instance Show a => Show (Bound a) where - show = genericShow - -boundValue :: forall a. Bound a -> a -boundValue (BoundIncl a) = a -boundValue (BoundExcl a) = a - -boundIsInclusive :: forall a. Bound a -> Boolean -boundIsInclusive (BoundIncl _) = true -boundIsInclusive (BoundExcl _) = false - -upper :: forall a. Range a -> Maybe (Bound a) -upper = _.upper <<< unwrap - -lower :: forall a. Range a -> Maybe (Bound a) -lower = _.lower <<< unwrap - -makeBound :: forall a. Boolean -> a -> Bound a -makeBound i a - | i = BoundIncl a - | otherwise = BoundExcl a - +-- | A range of values with optional upper & lower bounds. +-- | +-- | * `mempty -> '(,)'` +-- | * `gte 1 -> '[1,)'` +-- | * `lt 2 -> '(,2]'` +-- | * `gte 1 <> lt 2 -> '[1,2)'` newtype Range a = Range { upper :: Maybe (Bound a), lower :: Maybe (Bound a) } derive instance Generic (Range a) _ @@ -70,14 +29,10 @@ instance Show a => Show (Range a) where show = genericShow instance (Ord a, Rep a) => Serialize (Range a) where - serialize a = do - raw <- rangeToRaw a - pure $ Raw.unsafeFromForeign $ unsafeToForeign $ rangeRawFromRecord raw + serialize = map (Raw.unsafeFromForeign <<< unsafeToForeign <<< __rangeRawFromRecord) <<< __rangeToRecord instance (Ord a, Rep a) => Deserialize (Range a) where - deserialize raw = do - range :: RangeRaw <- lift $ readRangeRaw raw - rangeFromRaw $ rangeRawToRecord range + deserialize = __rangeFromRecord <=< map __rangeRawToRecord <<< lift <<< __rangeRawFromRaw instance Monoid (Range a) where mempty = Range { upper: Nothing, lower: Nothing } @@ -85,16 +40,52 @@ instance Monoid (Range a) where instance Semigroup (Range a) where append (Range { upper: au, lower: al }) (Range { upper: bu, lower: bl }) = Range ({ upper: bu <|> au, lower: bl <|> al }) +-- | An upper or lower range bound +data Bound a = BoundIncl a | BoundExcl a + +derive instance Generic (Bound a) _ +derive instance Eq a => Eq (Bound a) +instance Show a => Show (Bound a) where + show = genericShow + +-- | Get the value of the bound +boundValue :: forall a. Bound a -> a +boundValue (BoundIncl a) = a +boundValue (BoundExcl a) = a + +-- | Whether this bound includes the value `a` +boundIsInclusive :: forall a. Bound a -> Boolean +boundIsInclusive (BoundIncl _) = true +boundIsInclusive (BoundExcl _) = false + +-- | The upper bound of a range +upper :: forall a. Range a -> Maybe (Bound a) +upper = _.upper <<< unwrap + +-- | The lower bound of a range +lower :: forall a. Range a -> Maybe (Bound a) +lower = _.lower <<< unwrap + +-- | Creates a bound from a bool indicating if the bound is inclusive +-- | and a value `a` +makeBound :: forall a. Boolean -> a -> Bound a +makeBound i a + | i = BoundIncl a + | otherwise = BoundExcl a + +-- | Attempt to parse a SQL string of a range as `Range a` parseSQL :: forall a. Rep a => (String -> RepT a) -> String -> RepT (Range a) parseSQL fromString sql = do - range <- lift $ rangeRawParse sql $ smash <<< (serialize <=< fromString) - rangeFromRaw $ rangeRawToRecord range + range <- lift $ __rangeRawParse sql $ smash <<< (serialize <=< fromString) + __rangeFromRecord $ __rangeRawToRecord range +-- | Serialize a `Range` as a SQL string printSQL :: forall a. Rep a => Range a -> RepT String printSQL range = do - record <- rangeToRaw range - lift $ rangeRawSerialize $ rangeRawFromRecord record + record <- __rangeToRecord range + lift $ __rangeRawSerialize $ __rangeRawFromRecord record +-- | Returns whether the range contains value `a` contains :: forall a. Ord a => a -> Range a -> Boolean contains a r = let @@ -109,14 +100,49 @@ contains a r = in upperOk && lowerOk +-- | Creates a range with no upper bound and inclusive lower bound `a`; `[a,)` gte :: forall a. Ord a => a -> Range a -gte a = Range { upper: Just $ BoundIncl a, lower: Nothing } +gte a = Range { lower: Just $ BoundIncl a, upper: Nothing } +-- | Creates a range with no upper bound and exclusive lower bound `a`; `(a,)` gt :: forall a. Ord a => a -> Range a -gt a = Range { upper: Just $ BoundExcl a, lower: Nothing } +gt a = Range { lower: Just $ BoundExcl a, upper: Nothing } +-- | Creates a range with no lower bound and inclusive upper bound `a`; `(,a]` lt :: forall a. Ord a => a -> Range a -lt a = Range { upper: Nothing, lower: Just $ BoundExcl a } +lt a = Range { lower: Nothing, upper: Just $ BoundExcl a } +-- | Creates a range with no lower bound and exclusive upper bound `a`; `(,a)` lte :: forall a. Ord a => a -> Range a -lte a = Range { upper: Nothing, lower: Just $ BoundIncl a } +lte a = Range { lower: Nothing, upper: Just $ BoundIncl a } + +-- | FFI +type RangeRecord = { upper :: Raw, lower :: Raw, lowerIncl :: Boolean, upperIncl :: Boolean } + +-- | FFI +foreign import data RangeRaw :: Type +-- | FFI +foreign import __rangeRawFromRaw :: Raw -> Effect RangeRaw +-- | FFI +foreign import __rangeRawToRecord :: RangeRaw -> RangeRecord +-- | FFI +foreign import __rangeRawFromRecord :: RangeRecord -> RangeRaw +-- | FFI +foreign import __rangeRawParse :: String -> (String -> Effect Raw) -> Effect RangeRaw +-- | FFI +foreign import __rangeRawSerialize :: RangeRaw -> Effect String + +-- | FFI +__rangeFromRecord :: forall a. Deserialize a => RangeRecord -> RepT (Range a) +__rangeFromRecord raw = do + upper' :: Maybe a <- deserialize raw.upper + lower' :: Maybe a <- deserialize raw.lower + pure $ Range { upper: makeBound raw.upperIncl <$> upper', lower: makeBound raw.lowerIncl <$> lower' } + +-- | FFI +__rangeToRecord :: forall a. Serialize a => Range a -> RepT RangeRecord +__rangeToRecord r = do + upper' <- serialize $ boundValue <$> upper r + lower' <- serialize $ boundValue <$> lower r + pure $ { upper: upper', lower: lower', upperIncl: fromMaybe false $ boundIsInclusive <$> upper r, lowerIncl: fromMaybe false $ boundIsInclusive <$> lower r } + diff --git a/src/Data.Postgres.Raw.js b/src/Data.Postgres.Raw.js index 7acd4fe..b4a4e64 100644 --- a/src/Data.Postgres.Raw.js +++ b/src/Data.Postgres.Raw.js @@ -1,5 +1,5 @@ /** @type {(raw: unknown) => string} */ -export const rawToString = raw => +export const rawToDebugString = raw => typeof raw === 'undefined' ? 'undefined' : typeof raw === 'string' @@ -15,7 +15,7 @@ export const rawToString = raw => : 'unknown' /** @type {(a: unknown) => (b: unknown) => boolean} */ -export const rawEq = a => b => +export const rawDebugEq = a => b => typeof a === 'undefined' && typeof b === 'undefined' ? true : typeof a === typeof b && @@ -25,6 +25,6 @@ export const rawEq = a => b => ? a === null && b === null ? true : a instanceof Array && b instanceof Array - ? a.every((a_, ix) => rawEq(a_)(b[ix])) + ? a.every((a_, ix) => rawDebugEq(a_)(b[ix])) : false : false diff --git a/src/Data.Postgres.Raw.purs b/src/Data.Postgres.Raw.purs index 990649a..d661a98 100644 --- a/src/Data.Postgres.Raw.purs +++ b/src/Data.Postgres.Raw.purs @@ -3,20 +3,43 @@ module Data.Postgres.Raw where import Prelude import Foreign (Foreign) +import Prim.TypeError (class Warn, Text) import Unsafe.Coerce (unsafeCoerce) +-- | A raw JS value converted from SQL +-- | +-- | In practice, this is an alias for `Foreign` with +-- | type system guarantees that purescript types are +-- | correctly represented in JS to be represented in SQL. foreign import data Raw :: Type -foreign import rawToString :: Raw -> String -foreign import rawEq :: Raw -> Raw -> Boolean + +-- | Stringifies a `Raw` value if a JS primitive, +-- | else returns a debug representation. +-- | +-- | * `{foo: 'bar'} -> "[Object]"` +-- | * `[1, 2, 3] -> "[Array]"` +-- | * `'foo' -> "foo"` +-- | * `123 -> "123"` +foreign import rawToDebugString :: Raw -> String + +-- | Performs JS referential equality `===` for primitives +-- | or arrays of primitives, else returns `false`. +foreign import rawDebugEq :: Raw -> Raw -> Boolean instance Show Raw where - show = rawToString + show = rawToDebugString -instance Eq Raw where - eq = rawEq +instance (Warn (Text "`Eq Raw` only checks equality for JS primitives, and is always `false` for objects.")) => Eq Raw where + eq = rawDebugEq +-- | Coerce a `Foreign` value to `Raw`. +-- | +-- | This is only safe if the `Foreign` value +-- | is guaranteed to be serializable to a SQL +-- | value via `pg-types`. unsafeFromForeign :: Foreign -> Raw unsafeFromForeign = unsafeCoerce -unsafeToForeign :: Raw -> Foreign -unsafeToForeign = unsafeCoerce +-- | Coerce a `Raw` value to `Foreign`. +asForeign :: Raw -> Foreign +asForeign = unsafeCoerce diff --git a/src/Data.Postgres.Result.js b/src/Data.Postgres.Result.js index 2ded8fe..3340a3e 100644 --- a/src/Data.Postgres.Result.js +++ b/src/Data.Postgres.Result.js @@ -2,4 +2,4 @@ export const rows = r => r.rows /** @type {(_: import('pg').QueryResult) => number | null} */ -export const rowsAffectedImpl = r => r.rowCount +export const __rowsAffected = r => r.rowCount diff --git a/src/Data.Postgres.Result.purs b/src/Data.Postgres.Result.purs index 7212ae3..f84c22e 100644 --- a/src/Data.Postgres.Result.purs +++ b/src/Data.Postgres.Result.purs @@ -15,38 +15,83 @@ import Data.Tuple.Nested (type (/\), (/\)) import Foreign (ForeignError(..)) import Type.Prelude (Proxy(..)) +-- | A raw query result +-- | +-- | foreign import data Result :: Type -foreign import rowsAffectedImpl :: Result -> Nullable Number -foreign import rows :: Result -> Array (Array Raw) - +-- | Returns the number of rows affected by the query +-- | +-- | rowsAffected :: Result -> Maybe Int -rowsAffected = Int.fromNumber <=< Nullable.toMaybe <<< rowsAffectedImpl +rowsAffected = Int.fromNumber <=< Nullable.toMaybe <<< __rowsAffected -class FromResult (a :: Type) where - expectedRowLength :: forall g. g a -> Int +-- | Can be unmarshalled from a queried row +-- | +-- | Implementations are provided for: +-- | * tuples of any length containing types that are `Rep` +-- | * tuples of any length with the last member of `Array Raw` +-- | * a single value of a type that is `Rep` +-- | * `Array Raw` +-- | * `Unit` (always succeeds) +-- | +-- | ``` +-- | -- CREATE TABLE foo +-- | -- ( id INT NOT NULL PRIMARY KEY +-- | -- , fruit TEXT NOT NULL +-- | -- , created TIMESTAMPTZ NOT NULL DEFAULT NOW() +-- | -- ); +-- | do +-- | let q = query "select id, fruit, created from foo" client +-- | +-- | -- pick all 3 columns explicitly +-- | _ :: Array (Int /\ String /\ DateTime) <- q +-- | +-- | -- pick first 2 columns, discarding any others +-- | _ :: Array (Int /\ String) <- q +-- | +-- | -- pick first 2 columns, if any more keep as `Array Raw` +-- | _ :: Array (Int /\ String /\ Array Raw) <- q +-- | +-- | -- pick just the ID, discarding all other columns +-- | id :: Array Int <- q +-- | +-- | pure unit +-- | ``` +class FromRow (a :: Type) where + -- | Minimum length of row for type `a` + minColumnCount :: forall g. g a -> Int + -- | Performs the conversion fromRow :: Array Raw -> RepT a -instance (Rep a, FromResult b) => FromResult (a /\ b) where - expectedRowLength _ = expectedRowLength (Proxy @b) + 1 +instance (Rep a, FromRow b) => FromRow (a /\ b) where + minColumnCount _ = minColumnCount (Proxy @b) + 1 fromRow r = let - expLen = expectedRowLength (Proxy @(Tuple a b)) - lengthMismatch = pure $ TypeMismatch ("Expected row of length " <> show expLen) ("Found row of length " <> show (Array.length r)) + minLen = minColumnCount (Proxy @(Tuple a b)) + lengthMismatch = pure $ TypeMismatch ("Expected row to have at least " <> show minLen <> " columns") ("Found row of length " <> show (Array.length r)) in do - when (Array.length r /= expLen) (throwError lengthMismatch) + when (Array.length r < minLen) (throwError lengthMismatch) a <- deserialize =<< liftMaybe lengthMismatch (Array.head r) b <- fromRow =<< liftMaybe lengthMismatch (Array.tail r) pure $ a /\ b -else instance FromResult Unit where - expectedRowLength _ = 0 +else instance FromRow (Array Raw) where + minColumnCount _ = 0 + fromRow = pure +else instance FromRow Unit where + minColumnCount _ = 0 fromRow _ = pure unit -else instance Rep a => FromResult a where - expectedRowLength _ = 1 - fromRow = +else instance Rep a => FromRow a where + minColumnCount _ = 1 + fromRow r = let - get [ a ] = pure a - get o = throwError $ pure $ TypeMismatch "Expected row of length 1" $ show o + err = pure $ TypeMismatch "Expected row of length >= 1" "Empty row" in - deserialize <=< get + deserialize =<< liftMaybe err (Array.head r) + +-- | FFI binding for `Result#rowCount` +foreign import __rowsAffected :: Result -> Nullable Number + +-- | FFI binding for `Result#rows` +foreign import rows :: Result -> Array (Array Raw) diff --git a/src/Data.Postgres.purs b/src/Data.Postgres.purs index a0f5e33..11f9dc4 100644 --- a/src/Data.Postgres.purs +++ b/src/Data.Postgres.purs @@ -13,7 +13,7 @@ import Data.List.NonEmpty (NonEmptyList) import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype, unwrap, wrap) import Data.Postgres.Raw (Raw) -import Data.Postgres.Raw (unsafeFromForeign, unsafeToForeign) as Raw +import Data.Postgres.Raw (unsafeFromForeign, asForeign) as Raw import Data.RFC3339String as DateTime.ISO import Data.Show.Generic (genericShow) import Data.Traversable (traverse) @@ -141,7 +141,7 @@ instance Deserialize Unit where -- | `NULL` (fails if non-null) instance Deserialize Null where - deserialize = map (const Null) <<< F.readNullOrUndefined <<< Raw.unsafeToForeign + deserialize = map (const Null) <<< F.readNullOrUndefined <<< Raw.asForeign -- | `json`, `jsonb` instance ReadForeign a => Deserialize (JSON a) where @@ -149,11 +149,11 @@ instance ReadForeign a => Deserialize (JSON a) where -- | `bytea` instance Deserialize Buffer where - deserialize = (F.unsafeReadTagged "Buffer") <<< Raw.unsafeToForeign + deserialize = (F.unsafeReadTagged "Buffer") <<< Raw.asForeign -- | `int2`, `int4` instance Deserialize Int where - deserialize = F.readInt <<< Raw.unsafeToForeign + deserialize = F.readInt <<< Raw.asForeign -- | `int8` instance Deserialize BigInt where @@ -166,15 +166,15 @@ instance Deserialize BigInt where -- | `bool` instance Deserialize Boolean where - deserialize = F.readBoolean <<< Raw.unsafeToForeign + deserialize = F.readBoolean <<< Raw.asForeign -- | `text`, `inet`, `tsquery`, `tsvector`, `uuid`, `xml`, `cidr`, `time`, `timetz` instance Deserialize String where - deserialize = F.readString <<< Raw.unsafeToForeign + deserialize = F.readString <<< Raw.asForeign -- | `float4`, `float8` instance Deserialize Number where - deserialize = F.readNumber <<< Raw.unsafeToForeign + deserialize = F.readNumber <<< Raw.asForeign -- | `timestamp`, `timestamptz` instance Deserialize DateTime where @@ -185,7 +185,7 @@ instance Deserialize DateTime where -- | postgres `array` instance Deserialize a => Deserialize (Array a) where - deserialize = traverse (deserialize <<< Raw.unsafeFromForeign) <=< F.readArray <<< Raw.unsafeToForeign + deserialize = traverse (deserialize <<< Raw.unsafeFromForeign) <=< F.readArray <<< Raw.asForeign -- | non-NULL -> `Just`, NULL -> `Nothing` instance Deserialize a => Deserialize (Maybe a) where diff --git a/src/Effect.Aff.Postgres.Client.js b/src/Effect.Aff.Postgres.Client.js index 6ce2384..45bf35c 100644 --- a/src/Effect.Aff.Postgres.Client.js +++ b/src/Effect.Aff.Postgres.Client.js @@ -1,8 +1,8 @@ /** @type {(c: import('pg').Client) => () => Promise} */ -export const connectImpl = c => () => c.connect() +export const __connect = c => () => c.connect() /** @type {(c: import('pg').Client) => () => Promise} */ -export const endImpl = c => () => c.end() +export const __end = c => () => c.end() /** @type {(q: import('pg').QueryConfig) => (c: import('pg').Client) => () => Promise} */ -export const queryImpl = q => c => () => c.query(q) +export const __query = q => c => () => c.query(q) diff --git a/src/Effect.Aff.Postgres.Client.purs b/src/Effect.Aff.Postgres.Client.purs index b8b3d97..9fc0270 100644 --- a/src/Effect.Aff.Postgres.Client.purs +++ b/src/Effect.Aff.Postgres.Client.purs @@ -1,43 +1,69 @@ -module Effect.Aff.Postgres.Client where +module Effect.Aff.Postgres.Client (connected, connect, end, exec, query, queryRaw, __connect, __end, __query, module X) where import Prelude import Control.Promise (Promise) import Control.Promise as Promise +import Data.Functor (voidRight) import Data.Maybe (fromMaybe) import Data.Postgres (smash) -import Data.Postgres.Query (class AsQuery, QueryRaw, asQuery, queryToRaw) -import Data.Postgres.Result (class FromResult, Result, fromRow, rows, rowsAffected) +import Data.Postgres.Query (class AsQuery, QueryRaw, asQuery, __queryToRaw) +import Data.Postgres.Result (class FromRow, Result, fromRow, rows, rowsAffected) import Data.Traversable (traverse) import Effect (Effect) import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Postgres.Client (Client, Config, make) +import Effect.Postgres.Client as X import Prim.Row (class Union) -foreign import connectImpl :: Client -> Effect (Promise Unit) -foreign import endImpl :: Client -> Effect (Promise Unit) -foreign import queryImpl :: QueryRaw -> Client -> Effect (Promise Result) - +-- | Create a client and immediately connect it to the database +-- | +-- | The config parameter `r` is `Config` with all keys optional. +-- | +-- | This is a shorthand for `(voidRight <*> connect) =<< liftEffect (make cfg)` connected :: forall r trash. Union r trash (Config ()) => Record r -> Aff Client -connected c = do - client <- liftEffect $ make c - connect client - pure client +connected cfg = (voidRight <*> connect) =<< liftEffect (make cfg) +-- | Connects the client to the database +-- | +-- | connect :: Client -> Aff Unit -connect = Promise.toAffE <<< connectImpl +connect = Promise.toAffE <<< __connect +-- | Disconnects the client from the database +-- | +-- | end :: Client -> Aff Unit -end = Promise.toAffE <<< endImpl +end = Promise.toAffE <<< __end +-- | Performs a query, returning the raw `Result` object +-- | +-- | queryRaw :: forall q. AsQuery q => q -> Client -> Aff Result queryRaw q c = do - q' <- queryToRaw <$> liftEffect (asQuery q) - Promise.toAffE $ queryImpl q' c + q' <- __queryToRaw <$> liftEffect (asQuery q) + Promise.toAffE $ __query q' c +-- | Performs a query that we expect to not yield any rows, +-- | returning the number of rows affected by the statement. +-- | +-- | exec :: forall q. AsQuery q => q -> Client -> Aff Int exec q = map (fromMaybe 0 <<< rowsAffected) <<< queryRaw q -query :: forall q r. AsQuery q => FromResult r => q -> Client -> Aff (Array r) +-- | Performs a query that we expect to yield rows, +-- | returning them unmarshalled into destination type `r`. +-- | +-- | +query :: forall q r. AsQuery q => FromRow r => q -> Client -> Aff (Array r) query q = traverse (liftEffect <<< smash <<< fromRow) <=< map rows <<< queryRaw q + +-- | FFI binding to `Client#connect` +foreign import __connect :: Client -> Effect (Promise Unit) + +-- | FFI binding to `Client#end` +foreign import __end :: Client -> Effect (Promise Unit) + +-- | FFI binding to `Client#query` +foreign import __query :: QueryRaw -> Client -> Effect (Promise Result) diff --git a/src/Effect.Aff.Postgres.Pool.js b/src/Effect.Aff.Postgres.Pool.js new file mode 100644 index 0000000..f75a2eb --- /dev/null +++ b/src/Effect.Aff.Postgres.Pool.js @@ -0,0 +1,7 @@ +import Pg from 'pg' + +/** @type {(pool: Pg.Pool) => () => Promise} */ +export const __end = pool => () => pool.end() + +/** @type {(pool: Pg.Pool) => () => Promise} */ +export const __connect = pool => () => pool.connect() diff --git a/src/Effect.Aff.Postgres.Pool.purs b/src/Effect.Aff.Postgres.Pool.purs new file mode 100644 index 0000000..31ab428 --- /dev/null +++ b/src/Effect.Aff.Postgres.Pool.purs @@ -0,0 +1,37 @@ +module Effect.Aff.Postgres.Pool (connect, end, __end, __connect, module X) where + +import Prelude + +import Control.Promise (Promise) +import Control.Promise as Promise +import Effect (Effect) +import Effect.Aff (Aff) +import Effect.Postgres.Client (Client) +import Effect.Postgres.Pool (Pool) +import Effect.Postgres.Pool as X + +-- | Acquires a client from the pool. +-- | +-- | * If there are idle clients in the pool one will be returned to the callback on process.nextTick. +-- | * If the pool is not full but all current clients are checked out a new client will be created & returned to this callback. +-- | * If the pool is 'full' and all clients are currently checked out will wait in a FIFO queue until a client becomes available by it being released back to the pool. +-- | +-- | +connect :: Pool -> Aff Client +connect = Promise.toAffE <<< __connect + +-- | Drain the pool of all active clients, disconnect them, +-- | and shut down any internal timers in the pool. +-- | +-- | It is common to call this at the end of a script using the pool or when +-- | your process is attempting to shut down cleanly. +-- | +-- | +end :: Pool -> Aff Unit +end = Promise.toAffE <<< __end + +-- | FFI binding to `Pool#end` +foreign import __end :: Pool -> Effect (Promise Unit) + +-- | FFI binding to `Pool#connect` +foreign import __connect :: Pool -> Effect (Promise Client) diff --git a/src/Effect.Postgres.Client.js b/src/Effect.Postgres.Client.js index e0df28b..fec64f4 100644 --- a/src/Effect.Postgres.Client.js +++ b/src/Effect.Postgres.Client.js @@ -2,11 +2,10 @@ import Pg from 'pg' /** @typedef {{statementTimeout: unknown, queryTimeout: unknown, idleInTransactionTimeout: unknown, connectionTimeout: unknown, applicationName: string}} ClientConfigExtra */ -/** @type {(_: {unwrapMillis: (_m: unknown) => number}) => (cfg: Pg.ClientConfig & ClientConfigExtra) => () => Pg.Client} */ -export const makeImpl = +/** @type {(_o: {unwrapMillis: (ms: unknown) => number}) => (cfg: Pg.ClientConfig & ClientConfigExtra) => Pg.ClientConfig} */ +export const __uncfg = ({ unwrapMillis }) => - cfg => - () => { + cfg => { if ('statementTimeout' in cfg) { cfg.statement_timeout = unwrapMillis(cfg.statementTimeout) } @@ -24,5 +23,8 @@ export const makeImpl = if ('applicationName' in cfg) { cfg.application_name = cfg.applicationName } - return new Pg.Client(cfg) + return cfg } + +/** @type {(cfg: Pg.ClientConfig) => () => Pg.Client} */ +export const __make = cfg => () => new Pg.Client(cfg) diff --git a/src/Effect.Postgres.Client.purs b/src/Effect.Postgres.Client.purs index 1ece197..62fd1e1 100644 --- a/src/Effect.Postgres.Client.purs +++ b/src/Effect.Postgres.Client.purs @@ -7,6 +7,7 @@ import Data.Newtype (unwrap) import Data.Nullable (Nullable) import Data.Nullable as Nullable import Data.Postgres (modifyPgTypes) +import Data.Profunctor (lcmap) import Data.Time.Duration (Milliseconds) import Effect (Effect) import Effect.Exception (Error) @@ -18,21 +19,17 @@ import Prim.Row (class Union) import Record (modify) import Type.Prelude (Proxy(..)) +-- | Database connection foreign import data Client :: Type -foreign import makeImpl :: { unwrapMillis :: Milliseconds -> Number } -> Foreign -> Effect Client +-- | A notification raised by `NOTIFY` type Notification = { processId :: Number , channel :: String , payload :: Maybe String } -type NotificationRaw = - { processId :: Number - , channel :: String - , payload :: Nullable String - } - +-- | Client connection config type Config r = ( user :: String , password :: String @@ -48,23 +45,49 @@ type Config r = | r ) +-- | Creates a new client, not yet connected to the database. +-- | +-- | The config parameter `r` is `Config` with all keys optional. +-- | +-- | make :: forall r trash. Union r trash (Config ()) => Record r -> Effect Client make r = do modifyPgTypes - makeImpl { unwrapMillis: unwrap } $ unsafeToForeign r + __make $ __uncfg { unwrapMillis: unwrap } $ unsafeToForeign r -error :: EventHandle1 Client Error -error = EventHandle "end" mkEffectFn1 +-- | +errorE :: EventHandle1 Client Error +errorE = EventHandle "error" mkEffectFn1 -notice :: EventHandle1 Client Error -notice = EventHandle "notice" mkEffectFn1 +-- | +noticeE :: EventHandle1 Client Error +noticeE = EventHandle "notice" mkEffectFn1 -end :: EventHandle0 Client -end = EventHandle "end" identity +-- | +endE :: EventHandle0 Client +endE = EventHandle "end" identity -notification :: EventHandle Client (Notification -> Effect Unit) (EffectFn1 NotificationRaw Unit) -notification = +-- | +notificationE :: EventHandle Client (Notification -> Effect Unit) (EffectFn1 NotificationRaw Unit) +notificationE = let payload = Proxy @"payload" + payloadToMaybe = modify payload Nullable.toMaybe in - EventHandle "notification" (\f -> mkEffectFn1 $ f <<< modify payload Nullable.toMaybe) + EventHandle "notification" (mkEffectFn1 <<< lcmap payloadToMaybe) + +-- | FFI +foreign import data ClientConfigRaw :: Type + +-- | FFI +foreign import __make :: ClientConfigRaw -> Effect Client + +-- | FFI +foreign import __uncfg :: { unwrapMillis :: Milliseconds -> Number } -> Foreign -> ClientConfigRaw + +-- | FFI +type NotificationRaw = + { processId :: Number + , channel :: String + , payload :: Nullable String + } diff --git a/src/Effect.Postgres.Pool.js b/src/Effect.Postgres.Pool.js new file mode 100644 index 0000000..8b128f6 --- /dev/null +++ b/src/Effect.Postgres.Pool.js @@ -0,0 +1,34 @@ +import Pg from 'pg' + +import { __uncfg as uncfgClient } from './Effect.Postgres.Client.js' + +/** @typedef {{idleTimeout: unknown}} PoolConfigExtra */ + +/** @type {(o: {unwrapMillis: (_: unknown) => number}) => (cfg: Pg.PoolConfig & PoolConfigExtra & import('./Effect.Postgres.Client.js').ClientConfigExtra) => Pg.PoolConfig} */ +export const __uncfg = + ({ unwrapMillis }) => + cfg => { + uncfgClient({ unwrapMillis })(cfg) + + if ('idleTimeout' in cfg) { + cfg.idleTimeoutMillis = unwrapMillis(cfg.idleTimeout) + } + + return cfg + } + +/** @type {(cfg: Pg.PoolConfig) => () => Pg.Pool} */ +export const __make = cfg => () => new Pg.Pool(cfg) + +/** @type {(pool: Pg.Pool) => number} */ +export const clientCount = pool => pool.totalCount + +/** @type {(pool: Pg.Pool) => number} */ +export const clientIdleCount = pool => pool.idleCount + +/** @type {(pool: Pg.Pool) => number} */ +export const clientWaitingCount = pool => pool.waitingCount + +/** @type {(pool: Pg.Pool) => (client: Pg.Client | Pg.PoolClient) => (destroy: boolean) => () => void} */ +export const __release = _pool => client => destroy => () => + 'release' in client ? client.release(destroy) : undefined diff --git a/src/Effect.Postgres.Pool.purs b/src/Effect.Postgres.Pool.purs new file mode 100644 index 0000000..877f97a --- /dev/null +++ b/src/Effect.Postgres.Pool.purs @@ -0,0 +1,92 @@ +module Effect.Postgres.Pool where + +import Prelude + +import Data.Maybe (Maybe) +import Data.Newtype (unwrap) +import Data.Nullable (Nullable) +import Data.Nullable as Nullable +import Data.Postgres (modifyPgTypes) +import Data.Profunctor (lcmap) +import Data.Time.Duration (Milliseconds) +import Effect (Effect) +import Effect.Exception (Error) +import Effect.Postgres.Client (Client) +import Effect.Postgres.Client as Client +import Effect.Uncurried (EffectFn2, mkEffectFn1, mkEffectFn2) +import Foreign (Foreign, unsafeToForeign) +import Node.EventEmitter (EventHandle(..)) +import Node.EventEmitter.UtilTypes (EventHandle1, EventHandle2) +import Prim.Row (class Union) +import Type.Row (type (+)) + +-- | Database connection pool +foreign import data Pool :: Type + +-- | Pool construction config +-- | +-- | Includes all Client config options +type Config r = Client.Config + (idleTimeout :: Milliseconds, max :: Int, allowExitOnIdle :: Boolean | r) + +-- | The total number of clients existing within the pool. +foreign import clientCount :: Pool -> Int + +-- | The number of clients which are not checked out but are currently idle in the pool. +foreign import clientIdleCount :: Pool -> Int + +-- | The number of queued requests waiting on a client when all clients are checked out. +-- | It can be helpful to monitor this number to see if you need to adjust the size of the pool. +foreign import clientWaitingCount :: Pool -> Int + +-- | Creates a new pool +-- | +-- | The config parameter `r` is `Config` with all keys optional. +-- | +-- | +make :: forall r omitted. Union r omitted (Config ()) => Record r -> Effect Pool +make r = do + modifyPgTypes + __make $ __uncfg { unwrapMillis: unwrap } $ unsafeToForeign r + +-- | +releaseClient :: Pool -> Client -> Effect Unit +releaseClient p c = __release p c false + +-- | +destroyClient :: Pool -> Client -> Effect Unit +destroyClient p c = __release p c true + +-- | +connectE :: EventHandle1 Pool Client +connectE = EventHandle "connect" mkEffectFn1 + +-- | +errorE :: EventHandle2 Pool Error Client +errorE = EventHandle "error" mkEffectFn2 + +-- | +acquireE :: EventHandle1 Pool Client +acquireE = EventHandle "acquire" mkEffectFn1 + +-- | +removeE :: EventHandle1 Pool Client +removeE = EventHandle "remove" mkEffectFn1 + +-- | +releaseE :: EventHandle Pool (Maybe Error -> Client -> Effect Unit) (EffectFn2 (Nullable Error) Client Unit) +releaseE = EventHandle "release" (mkEffectFn2 <<< lcmap Nullable.toMaybe) + +-- | FFI type for `import('pg').PoolConfig` +foreign import data PoolConfigRaw :: Type + +-- | FFI binding to `new Pool()` +foreign import __make :: PoolConfigRaw -> Effect Pool + +-- | FFI binding to `Client#release` for clients created from pools +-- | +-- | Accepts a `Pool` as a type-level hint that the `Client` should have +-- | come from a `Pool` +foreign import __release :: Pool -> Client -> Boolean -> Effect Unit + +-- | partial `Config` to `import('pg').PoolConfig` +foreign import __uncfg :: { unwrapMillis :: Milliseconds -> Number } -> Foreign -> PoolConfigRaw diff --git a/src/Effect.Postgres.purs b/src/Effect.Postgres.purs deleted file mode 100644 index ab90000..0000000 --- a/src/Effect.Postgres.purs +++ /dev/null @@ -1,3 +0,0 @@ -module Effect.Postgres where - -foreign import data Pool :: Type diff --git a/test/Test.Data.Postgres.purs b/test/Test.Data.Postgres.purs index 00495d3..92bb21a 100644 --- a/test/Test.Data.Postgres.purs +++ b/test/Test.Data.Postgres.purs @@ -18,7 +18,7 @@ import Data.Postgres (class Rep, jsNull) import Data.Postgres.Query.Builder as Q import Data.Postgres.Raw (Raw) import Data.Postgres.Raw as Raw -import Data.Postgres.Result (class FromResult) +import Data.Postgres.Result (class FromRow) import Data.RFC3339String as DateTime.ISO import Data.String as String import Data.Time (Time(..)) @@ -48,11 +48,13 @@ foreign import readBigInt64BE :: Buffer -> Effect BigInt foreign import dbg :: forall a. a -> Effect Unit newtype GenSmallInt = GenSmallInt Int + derive instance Newtype GenSmallInt _ instance Arbitrary GenSmallInt where arbitrary = wrap <$> chooseInt (-32768) 32767 newtype GenDateTime = GenDateTime DateTime + derive instance Newtype GenDateTime _ instance Arbitrary GenDateTime where arbitrary = do @@ -69,6 +71,7 @@ instance Arbitrary GenDateTime where pure $ wrap $ DateTime date time newtype GenString = GenString String + derive instance Newtype GenString _ instance Arbitrary GenString where arbitrary = do @@ -78,6 +81,7 @@ instance Arbitrary GenString where pure $ wrap $ fold chars' newtype GenSmallFloat = GenSmallFloat Number + derive instance Newtype GenSmallFloat _ instance Arbitrary GenSmallFloat where arbitrary = do @@ -132,8 +136,8 @@ asRaw = Raw.unsafeFromForeign <<< unsafeToForeign spec :: Spec Unit spec = let - check :: forall @a @x. Show a => Arbitrary x => Rep a => FromResult a => String -> String -> (x -> a) -> (a -> Raw) -> (a -> a -> Boolean) -> SpecT Aff Client Identity Unit - check purs sql xa asRaw_ isEq = + check :: forall @a @x. Show a => Arbitrary x => Rep a => FromRow a => String -> String -> (x -> a) -> (a -> a -> Boolean) -> SpecT Aff Client Identity Unit + check purs sql xa isEq = it (purs <> " <> " <> sql) \c -> do let tab = String.replace (wrap " ") (wrap "_") $ String.replace (wrap "[") (wrap "") $ String.replace (wrap "]") (wrap "") $ sql <> "_is_" <> String.toLower purs @@ -157,27 +161,24 @@ spec = act = unsafePartial fromJust $ Array.head res when (not $ isEq exp act) $ fail $ "expected " <> show exp <> " to equal " <> show act - check_ :: forall @a. Eq a => Show a => Arbitrary a => FromResult a => Rep a => String -> String -> SpecT Aff Client Identity Unit - check_ purs sql = check @a @a purs sql identity asRaw eq - - dateTimeFromArbitrary :: Int -> DateTime - dateTimeFromArbitrary = Instant.toDateTime <<< unsafePartial fromJust <<< Instant.instant <<< wrap <<< Int.toNumber + check_ :: forall @a. Eq a => Show a => Arbitrary a => FromRow a => Rep a => String -> String -> SpecT Aff Client Identity Unit + check_ purs sql = check @a @a purs sql identity eq in around withClient $ describe "Data.Postgres" $ do - check @Int @GenSmallInt "Int" "int2" unwrap asRaw eq + check @Int @GenSmallInt "Int" "int2" unwrap eq check_ @Int "Int" "int4" - check @String @GenString "String" "text" unwrap asRaw eq + check @String @GenString "String" "text" unwrap eq check_ @Boolean "Boolean" "bool" - check @Number @GenSmallFloat "Number" "float4" unwrap asRaw (\a b -> Number.abs (a - b) <= 0.0001) + check @Number @GenSmallFloat "Number" "float4" unwrap (\a b -> Number.abs (a - b) <= 0.0001) check_ @Number "Number" "float8" - check @BigInt @GenBigInt "BigInt" "int8" unwrap (asRaw <<< BigInt.toString) eq - check @(Maybe String) @(Maybe GenString) "Maybe String" "text" (map unwrap) (maybe jsNull asRaw) eq - check @(Array String) @(Array GenString) "Array String" "text[]" (map unwrap) asRaw eq - check @DateTime @GenDateTime "DateTime" "timestamptz" unwrap (asRaw <<< DateTime.ISO.fromDateTime) eq - check @String @GenJSON "JSON" "json" (writeJSON <<< unwrap) asRaw eq + check @BigInt @GenBigInt "BigInt" "int8" unwrap eq + check @(Maybe String) @(Maybe GenString) "Maybe String" "text" (map unwrap) eq + check @(Array String) @(Array GenString) "Array String" "text[]" (map unwrap) eq + check @DateTime @GenDateTime "DateTime" "timestamptz" unwrap eq + check @String @GenJSON "JSON" "json" (writeJSON <<< unwrap) eq