From 340cee4745645e293ff6b94042f41f4a40f9e38e Mon Sep 17 00:00:00 2001 From: Orion Kindel Date: Fri, 29 Mar 2024 14:52:05 -0500 Subject: [PATCH] fix: some ergonomics, tests use postgres --- spago.lock | 495 +++++++++++++++++++++++++- spago.yaml | 5 +- src/Data.Postgres.Query.Builder.purs | 107 ++++++ src/Data.Postgres.Query.purs | 54 +++ src/Data.Postgres.js | 3 +- src/Data.Postgres.purs | 63 +++- src/Effect.Aff.Postgres.Client.purs | 38 +- test/Test.Common.purs | 26 ++ test/Test.Data.Postgres.js | 4 + test/Test.Data.Postgres.purs | 216 +++++++---- test/Test.Effect.Postgres.Client.purs | 31 +- 11 files changed, 898 insertions(+), 144 deletions(-) create mode 100644 src/Data.Postgres.Query.Builder.purs create mode 100644 src/Data.Postgres.Query.purs create mode 100644 test/Test.Common.purs create mode 100644 test/Test.Data.Postgres.js diff --git a/spago.lock b/spago.lock index 0f7e969..2aa7e2a 100644 --- a/spago.lock +++ b/spago.lock @@ -14,6 +14,7 @@ workspace: - foldable-traversable - foreign - integers + - js-bigints - lists - maybe - mmorph @@ -72,6 +73,7 @@ workspace: - identity - integers - invariant + - js-bigints - js-date - lazy - lcg @@ -120,6 +122,487 @@ workspace: - unicode - unsafe-coerce - variant + package_set: + address: + registry: 50.5.0 + compiler: ">=0.15.15 <0.16.0" + content: + abc-parser: 2.0.1 + ace: 9.1.0 + aff: 7.1.0 + aff-bus: 6.0.0 + aff-coroutines: 9.0.0 + aff-promise: 4.0.0 + aff-retry: 2.0.0 + affjax: 13.0.0 + affjax-node: 1.0.0 + affjax-web: 1.0.0 + ansi: 7.0.0 + applicative-phases: 1.0.0 + argonaut: 9.0.0 + argonaut-aeson-generic: 0.4.1 + argonaut-codecs: 9.1.0 + argonaut-core: 7.0.0 + argonaut-generic: 8.0.0 + argonaut-traversals: 10.0.0 + argparse-basic: 2.0.0 + array-builder: 0.1.2 + array-search: 0.5.6 + arraybuffer: 13.2.0 + arraybuffer-builder: 3.1.0 + arraybuffer-types: 3.0.2 + arrays: 7.3.0 + arrays-extra: 0.6.1 + arrays-zipper: 2.0.1 + ask: 1.0.0 + assert: 6.0.0 + assert-multiple: 0.3.4 + avar: 5.0.0 + b64: 0.0.8 + barbies: 1.0.1 + barlow-lens: 0.9.0 + bifunctors: 6.0.0 + bigints: 7.0.1 + bolson: 0.3.9 + bookhound: 0.1.7 + bower-json: 3.0.0 + call-by-name: 4.0.1 + canvas: 6.0.0 + canvas-action: 9.0.0 + cartesian: 1.0.6 + catenable-lists: 7.0.0 + chameleon: 1.0.0 + chameleon-halogen: 1.0.3 + chameleon-react-basic: 1.1.0 + chameleon-styled: 2.5.0 + chameleon-transformers: 1.0.0 + channel: 1.0.0 + checked-exceptions: 3.1.1 + choku: 1.0.1 + classless: 0.1.1 + classless-arbitrary: 0.1.1 + classless-decode-json: 0.1.1 + classless-encode-json: 0.1.3 + classnames: 2.0.0 + codec: 6.1.0 + codec-argonaut: 10.0.0 + codec-json: 1.1.0 + colors: 7.0.1 + concur-core: 0.5.0 + concur-react: 0.5.0 + concurrent-queues: 3.0.0 + console: 6.1.0 + const: 6.0.0 + contravariant: 6.0.0 + control: 6.0.0 + convertable-options: 1.0.0 + coroutines: 7.0.0 + css: 6.0.0 + css-frameworks: 1.0.1 + data-mvc: 0.0.2 + datetime: 6.1.0 + datetime-parsing: 0.2.0 + debug: 6.0.2 + decimals: 7.1.0 + default-values: 1.0.1 + deku: 0.9.23 + deno: 0.0.5 + dissect: 1.0.0 + distributive: 6.0.0 + dom-filereader: 7.0.0 + dom-indexed: 12.0.0 + dotenv: 4.0.3 + droplet: 0.6.0 + dts: 1.0.0 + dual-numbers: 1.0.2 + dynamic-buffer: 3.0.1 + echarts-simple: 0.0.1 + effect: 4.0.0 + either: 6.1.0 + elmish: 0.11.3 + elmish-enzyme: 0.1.1 + elmish-hooks: 0.10.0 + elmish-html: 0.8.2 + elmish-testing-library: 0.3.2 + email-validate: 7.0.0 + encoding: 0.0.9 + enums: 6.0.1 + env-names: 0.3.4 + error: 2.0.0 + eta-conversion: 0.3.2 + exceptions: 6.0.0 + exists: 6.0.0 + exitcodes: 4.0.0 + expect-inferred: 3.0.0 + fahrtwind: 2.0.0 + fallback: 0.1.0 + fast-vect: 1.2.0 + fetch: 4.1.0 + fetch-argonaut: 1.0.1 + fetch-core: 5.1.0 + fetch-yoga-json: 1.1.0 + fft-js: 0.1.0 + filterable: 5.0.0 + fix-functor: 0.1.0 + fixed-points: 7.0.0 + fixed-precision: 5.0.0 + flame: 1.3.0 + float32: 2.0.0 + fmt: 0.2.1 + foldable-traversable: 6.0.0 + foldable-traversable-extra: 0.0.6 + foreign: 7.0.0 + foreign-object: 4.1.0 + foreign-readwrite: 3.4.0 + forgetmenot: 0.1.0 + fork: 6.0.0 + form-urlencoded: 7.0.0 + formatters: 7.0.0 + framer-motion: 1.0.1 + free: 7.1.0 + freeap: 7.0.0 + freer-free: 0.0.1 + freet: 7.0.0 + functions: 6.0.0 + functor1: 3.0.0 + functors: 5.0.0 + fuzzy: 0.4.0 + gen: 4.0.0 + generate-values: 1.0.1 + generic-router: 0.0.1 + geojson: 0.0.5 + geometry-plane: 1.0.3 + gojs: 0.1.1 + grain: 3.0.0 + grain-router: 3.0.0 + grain-virtualized: 3.0.0 + graphs: 8.1.0 + group: 4.1.1 + halogen: 7.0.0 + halogen-bootstrap5: 5.3.2 + halogen-canvas: 1.0.0 + halogen-css: 10.0.0 + halogen-echarts-simple: 0.0.4 + halogen-formless: 4.0.3 + halogen-helix: 1.0.0 + halogen-hooks: 0.6.3 + halogen-hooks-extra: 0.9.0 + halogen-infinite-scroll: 1.1.0 + halogen-store: 0.5.4 + halogen-storybook: 2.0.0 + halogen-subscriptions: 2.0.0 + halogen-svg-elems: 8.0.0 + halogen-typewriter: 1.0.4 + halogen-vdom: 8.0.0 + halogen-vdom-string-renderer: 0.5.0 + halogen-xterm: 2.0.0 + heckin: 2.0.1 + heterogeneous: 0.6.0 + homogeneous: 0.4.0 + http-methods: 6.0.0 + httpurple: 4.0.0 + humdrum: 0.0.1 + hyrule: 2.3.8 + identity: 6.0.0 + identy: 4.0.1 + indexed-db: 1.0.0 + indexed-monad: 3.0.0 + int64: 3.0.0 + integers: 6.0.0 + interpolate: 5.0.2 + intersection-observer: 1.0.1 + invariant: 6.0.0 + jarilo: 1.0.1 + jelly: 0.10.0 + jelly-router: 0.3.0 + jelly-signal: 0.4.0 + jest: 1.0.0 + js-abort-controller: 1.0.0 + js-bigints: 2.2.1 + js-date: 8.0.0 + js-fetch: 0.2.1 + js-fileio: 3.0.0 + js-intl: 1.0.4 + js-iterators: 0.1.1 + js-maps: 0.1.2 + js-promise: 1.0.0 + js-promise-aff: 1.0.0 + js-timers: 6.1.0 + js-uri: 3.1.0 + json: 1.0.0 + json-codecs: 5.0.0 + justifill: 0.5.0 + jwt: 0.0.9 + labeled-data: 0.2.0 + language-cst-parser: 0.14.0 + lazy: 6.0.0 + lazy-joe: 1.0.0 + lcg: 4.0.0 + leibniz: 5.0.0 + leveldb: 1.0.1 + liminal: 1.0.1 + linalg: 6.0.0 + lists: 7.0.0 + literals: 1.0.2 + logging: 3.0.0 + logging-journald: 0.4.0 + lumi-components: 18.0.0 + machines: 7.0.0 + maps-eager: 0.4.1 + marionette: 1.0.0 + marionette-react-basic-hooks: 0.1.1 + marked: 0.1.0 + matrices: 5.0.1 + matryoshka: 1.0.0 + maybe: 6.0.0 + media-types: 6.0.0 + meowclient: 1.0.0 + midi: 4.0.0 + milkis: 9.0.0 + minibench: 4.0.1 + mmorph: 7.0.0 + monad-control: 5.0.0 + monad-logger: 1.3.1 + monad-loops: 0.5.0 + monad-unlift: 1.0.1 + monoid-extras: 0.0.1 + monoidal: 0.16.0 + morello: 0.4.0 + mote: 3.0.0 + motsunabe: 2.0.0 + mvc: 0.0.1 + mysql: 6.0.1 + n3: 0.1.0 + nano-id: 1.1.0 + nanoid: 0.1.0 + naturals: 3.0.0 + nested-functor: 0.2.1 + newtype: 5.0.0 + nextjs: 0.1.1 + nextui: 0.2.0 + node-buffer: 9.0.0 + node-child-process: 11.1.0 + node-event-emitter: 3.0.0 + node-execa: 5.0.0 + node-fs: 9.1.0 + node-glob-basic: 1.3.0 + node-http: 9.1.0 + node-http2: 1.1.1 + node-human-signals: 1.0.0 + node-net: 5.1.0 + node-os: 5.1.0 + node-path: 5.0.0 + node-process: 11.2.0 + node-readline: 8.1.0 + node-sqlite3: 8.0.0 + node-streams: 9.0.0 + node-tls: 0.3.1 + node-url: 7.0.1 + node-zlib: 0.4.0 + nonempty: 7.0.0 + now: 6.0.0 + npm-package-json: 2.0.0 + nullable: 6.0.0 + numberfield: 0.1.0 + numbers: 9.0.1 + oak: 3.1.1 + oak-debug: 1.2.2 + object-maps: 0.3.0 + ocarina: 1.5.4 + open-folds: 6.3.0 + open-memoize: 6.1.0 + open-pairing: 6.1.0 + options: 7.0.0 + optparse: 5.0.1 + ordered-collections: 3.2.0 + ordered-set: 0.4.0 + orders: 6.0.0 + owoify: 1.2.0 + pairs: 9.0.1 + parallel: 7.0.0 + parsing: 10.2.0 + parsing-dataview: 3.2.4 + partial: 4.0.0 + pathy: 9.0.0 + pha: 0.13.0 + phaser: 0.7.0 + phylio: 1.1.2 + pipes: 8.0.0 + pirates-charm: 0.0.1 + pmock: 0.9.0 + point-free: 1.0.0 + pointed-list: 0.5.1 + polymorphic-vectors: 4.0.0 + posix-types: 6.0.0 + precise: 6.0.0 + precise-datetime: 7.0.0 + prelude: 6.0.1 + prettier-printer: 3.0.0 + profunctor: 6.0.1 + profunctor-lenses: 8.0.0 + protobuf: 4.3.0 + psa-utils: 8.0.0 + psci-support: 6.0.0 + punycode: 1.0.0 + qualified-do: 2.2.0 + quantities: 12.2.0 + quickcheck: 8.0.1 + quickcheck-combinators: 0.1.3 + quickcheck-laws: 7.0.0 + quickcheck-utf8: 0.0.0 + random: 6.0.0 + rationals: 6.0.0 + rdf: 0.1.0 + react: 11.0.0 + react-aria: 0.2.0 + react-basic: 17.0.0 + react-basic-classic: 3.0.0 + react-basic-dnd: 10.1.0 + react-basic-dom: 6.1.0 + react-basic-emotion: 7.1.0 + react-basic-hooks: 8.2.0 + react-basic-storybook: 2.0.0 + react-dom: 8.0.0 + react-halo: 3.0.0 + react-icons: 1.1.4 + react-markdown: 0.1.0 + react-testing-library: 4.0.1 + react-virtuoso: 1.0.0 + read: 1.0.1 + recharts: 1.1.0 + record: 4.0.0 + record-extra: 5.0.1 + record-ptional-fields: 0.1.2 + record-studio: 1.0.4 + refs: 6.0.0 + remotedata: 5.0.1 + resize-observer: 1.0.0 + resource: 2.0.1 + resourcet: 1.0.0 + result: 1.0.3 + return: 0.2.0 + ring-modules: 5.0.1 + rito: 0.3.4 + rough-notation: 1.0.2 + routing: 11.0.0 + routing-duplex: 0.7.0 + run: 5.0.0 + safe-coerce: 2.0.0 + safely: 4.0.1 + school-of-music: 1.3.0 + selection-foldable: 0.2.0 + selective-functors: 1.0.1 + semirings: 7.0.0 + signal: 13.0.0 + simple-emitter: 3.0.1 + simple-i18n: 2.0.1 + simple-json: 9.0.0 + simple-ulid: 3.0.0 + sized-matrices: 1.0.0 + sized-vectors: 5.0.2 + slug: 3.0.8 + small-ffi: 4.0.1 + soundfonts: 4.1.0 + sparse-matrices: 1.3.0 + sparse-polynomials: 2.0.5 + spec: 7.6.0 + spec-mocha: 5.1.0 + spec-quickcheck: 5.0.0 + splitmix: 2.1.0 + ssrs: 1.0.0 + st: 6.2.0 + statistics: 0.3.2 + strictlypositiveint: 1.0.1 + string-parsers: 8.0.0 + strings: 6.0.1 + strings-extra: 4.0.0 + stringutils: 0.0.12 + substitute: 0.2.3 + supply: 0.2.0 + svg-parser: 3.0.0 + systemd-journald: 0.3.0 + tagged: 4.0.2 + tailrec: 6.1.0 + tecton: 0.2.1 + tecton-halogen: 0.2.0 + test-unit: 17.0.0 + thermite: 6.3.1 + thermite-dom: 0.3.1 + these: 6.0.0 + transformation-matrix: 1.0.1 + transformers: 6.0.0 + tree-rose: 4.0.2 + ts-bridge: 4.0.0 + tuples: 7.0.0 + two-or-more: 1.0.0 + type-equality: 4.0.1 + typedenv: 2.0.1 + typelevel: 6.0.0 + typelevel-lists: 2.1.0 + typelevel-peano: 1.0.1 + typelevel-prelude: 7.0.0 + typelevel-regex: 0.0.3 + typelevel-rows: 0.1.0 + uint: 7.0.0 + ulid: 3.0.1 + uncurried-transformers: 1.1.0 + undefined: 2.0.0 + undefined-is-not-a-problem: 1.1.0 + unfoldable: 6.0.0 + unicode: 6.0.0 + unique: 0.6.1 + unlift: 1.0.1 + unordered-collections: 3.1.0 + unsafe-coerce: 6.0.0 + unsafe-reference: 5.0.0 + untagged-to-tagged: 0.1.4 + untagged-union: 1.0.0 + uri: 9.0.0 + uuid: 9.0.0 + uuidv4: 1.0.0 + validation: 6.0.0 + variant: 8.0.0 + variant-encodings: 2.0.0 + vectorfield: 1.0.1 + vectors: 2.1.0 + versions: 7.0.0 + visx: 0.0.2 + web-clipboard: 5.0.0 + web-cssom: 2.0.0 + web-cssom-view: 0.1.0 + web-dom: 6.0.0 + web-dom-parser: 8.0.0 + web-dom-xpath: 3.0.0 + web-encoding: 3.0.0 + web-events: 4.0.0 + web-fetch: 4.0.1 + web-file: 4.0.0 + web-geometry: 0.1.0 + web-html: 4.1.0 + web-pointerevents: 2.0.0 + web-proletarian: 1.0.0 + web-promise: 3.2.0 + web-resize-observer: 2.1.0 + web-router: 1.0.0 + web-socket: 4.0.0 + web-storage: 5.0.0 + web-streams: 4.0.0 + web-touchevents: 4.0.0 + web-uievents: 5.0.0 + web-url: 2.0.0 + web-workers: 1.1.0 + web-xhr: 5.0.1 + webextension-polyfill: 0.1.0 + webgpu: 0.0.1 + which: 2.0.0 + xterm: 1.0.0 + yoga-fetch: 1.0.1 + yoga-json: 5.1.0 + yoga-om: 0.1.0 + yoga-postgres: 6.0.0 + yoga-tree: 1.0.0 + z3: 0.0.2 + zipperarray: 2.0.0 extra_packages: {} packages: aff: @@ -497,6 +980,14 @@ packages: dependencies: - control - prelude + js-bigints: + type: registry + version: 2.2.1 + integrity: sha256-hKWZo9NxtsAaHmNXr6B8GY4c0olQbYLXPVGWm4TF2Ss= + dependencies: + - integers + - maybe + - prelude js-date: type: registry version: 8.0.0 @@ -745,8 +1236,8 @@ packages: - prelude parallel: type: registry - version: 6.0.0 - integrity: sha256-VJbkGD0rAKX+NUEeBJbYJ78bEKaZbgow+QwQEfPB6ko= + version: 7.0.0 + integrity: sha256-gUC9i4Txnx9K9RcMLsjujbwZz6BB1bnE2MLvw4GIw5o= dependencies: - control - effect diff --git a/spago.yaml b/spago.yaml index ba7aaef..6283a84 100644 --- a/spago.yaml +++ b/spago.yaml @@ -2,7 +2,7 @@ package: name: pg build: strict: true - pedantic_packages: true + pedanticPackages: true dependencies: - aff - aff-promise @@ -15,6 +15,7 @@ package: - foldable-traversable - foreign - integers + - js-bigints - lists - maybe - mmorph @@ -41,6 +42,6 @@ package: - spec - spec-quickcheck workspace: - extra_packages: {} + extraPackages: {} packageSet: registry: 50.5.0 diff --git a/src/Data.Postgres.Query.Builder.purs b/src/Data.Postgres.Query.Builder.purs new file mode 100644 index 0000000..41c4c18 --- /dev/null +++ b/src/Data.Postgres.Query.Builder.purs @@ -0,0 +1,107 @@ +module Data.Postgres.Query.Builder where + +import Prelude + +import Control.Monad.State (StateT, get, modify, runStateT) +import Data.Array as Array +import Data.Newtype (unwrap) +import Data.Newtype as Newtype +import Data.Postgres (class Rep, serialize, smash) +import Data.Postgres.Query (Query, emptyQuery) +import Data.Tuple (snd) +import Data.Tuple.Nested (type (/\)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Record as Record +import Type.Prelude (Proxy(..)) + +-- | Monad for building parameterized queries without managing positional +-- | parameters directly +-- | +-- | For example, given the table `CREATE TABLE foo (id INT NOT NULL PRIMARY KEY, bar TEXT NOT NULL)` +-- | +-- | ```purescript +-- | updateFoo :: Int -> String -> Effect Query +-- | updateFoo id newBar = +-- | build do +-- | idP <- param id +-- | newBarP <- param newBar +-- | pure $ +-- | [ "update foo" +-- | , "set bar = " <> newBarP +-- | , "where id = " <> idP +-- | ] +-- | ``` +-- | `updateFoo 1 "test"` will yield: +-- | ```purescript +-- | { text: "update foo\nset bar = $2\nwhere id = $1" +-- | , values: ["test", 1] +-- | } +-- | ``` +type QueryBuilderT m a = StateT Query m a +type QueryBuilder a = QueryBuilderT Effect a + +-- | Yields a SQL string referencing the last parameter in the parameter list +-- | +-- | Examples: +-- | - if no parameters have been appended this will yield `"$0"` (invalid) +-- | - if 1 parameter has been appended this will yield `"$1"` +-- | - if 5 parameters have been appended this will yield `"$5"` +lastParamString :: forall m. Monad m => QueryBuilderT m String +lastParamString = map (("$" <> _) <<< show <<< Array.length <<< _.values <<< unwrap) $ get + +-- | Append a serializable SQL value to the parameter list +appendParam :: forall m a. MonadEffect m => Rep a => a -> QueryBuilderT m Unit +appendParam a = + let + values = Proxy @"values" + in + do + a' <- liftEffect $ smash $ serialize a + void $ modify (Newtype.modify $ Record.modify values (_ <> [ a' ])) + +-- | Replace the builder's query string with a new value +putText :: forall m. Monad m => String -> QueryBuilderT m Unit +putText t = + let + text = Proxy @"text" + in + void $ modify $ Newtype.modify $ Record.set text t + +-- | Adds a parameter to the query +-- | +-- | This accepts any value `Rep`resentable in SQL, and +-- | yields the SQL string for the new parameter. +-- | +-- | ```purescript +-- | do +-- | p1 <- param 1 -- "$1" +-- | p2 <- param "foo" -- "$2" +-- | p3 <- param true -- "$3" +-- | pure unit +-- | ``` +param :: forall m a. MonadEffect m => Rep a => a -> QueryBuilderT m String +param a = do + appendParam a + lastParamString + +-- | Accepts a `QueryBuilder` monad that yields the built query string +-- | and yields the finished `Query`. +-- | +-- | ``` +-- | build $ pure "select 1" +-- | -- Query {text: "select 1", values: [], name: Nothing} +-- | ``` +-- |   +-- | ``` +-- | build do +-- | foo <- param "foo" +-- | pure $ "select " <> foo +-- | -- Query {text: "select $1", values: ["foo"], name: Nothing} +-- | ``` +build :: QueryBuilder String -> Effect Query +build m = map snd $ build' $ putText =<< m + +-- | Executes a `QueryBuilderT` +build' :: forall m a. MonadEffect m => QueryBuilderT m a -> m (a /\ Query) +build' = flip runStateT emptyQuery diff --git a/src/Data.Postgres.Query.purs b/src/Data.Postgres.Query.purs new file mode 100644 index 0000000..19259a8 --- /dev/null +++ b/src/Data.Postgres.Query.purs @@ -0,0 +1,54 @@ +module Data.Postgres.Query where + +import Prelude + +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype) +import Data.Nullable (Nullable, toNullable) +import Data.Postgres.Raw (Raw) +import Data.Tuple.Nested (type (/\), (/\)) +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 +-- | * `values` - query parameter values +-- | * `name` (optional) - providing this will create this query as a [prepared statement](https://node-postgres.com/features/queries#prepared-statements) +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 + +instance AsQuery Query where + asQuery = pure + +instance AsQuery String where + asQuery text = pure $ Query { text, values: [], name: Nothing } + +instance AsQuery (String /\ Array Raw) where + asQuery (text /\ values) = pure $ Query { text, values, name: Nothing } diff --git a/src/Data.Postgres.js b/src/Data.Postgres.js index b7470e4..5418c7f 100644 --- a/src/Data.Postgres.js +++ b/src/Data.Postgres.js @@ -1,9 +1,10 @@ import Pg from 'pg' import Range from 'postgres-range' -export const null_ = null +export const jsNull = null export const modifyPgTypes = () => { + // https://github.com/brianc/node-pg-types/blob/master/lib/textParsers.js const oid = { 'text[]': 1009, json: 114, diff --git a/src/Data.Postgres.purs b/src/Data.Postgres.purs index f6ed84b..a0f5e33 100644 --- a/src/Data.Postgres.purs +++ b/src/Data.Postgres.purs @@ -21,9 +21,12 @@ import Effect (Effect) import Effect.Exception (error) import Foreign (ForeignError(..)) import Foreign as F +import JS.BigInt (BigInt) +import JS.BigInt as BigInt import Node.Buffer (Buffer) import Simple.JSON (class ReadForeign, class WriteForeign, readJSON', writeJSON) +-- | Newtype hinting that this value should be serialized / deserialized as a JSON string. newtype JSON a = JSON a derive instance Newtype (JSON a) _ @@ -33,7 +36,8 @@ derive newtype instance Ord a => Ord (JSON a) derive newtype instance WriteForeign a => WriteForeign (JSON a) derive newtype instance ReadForeign a => ReadForeign (JSON a) -foreign import null_ :: Raw +-- | Literal javascript `null` +foreign import jsNull :: Raw -- | This mutates `import('pg').types`, setting deserialization -- | for some types to unmarshal as strings rather than JS values. @@ -51,7 +55,7 @@ instance Show Null where -- | The serialization & deserialization monad. type RepT a = ExceptT (NonEmptyList ForeignError) Effect a --- | Flatten to an Effect, rendering any `RepError`s to `String` using `Show`. +-- | Flatten to an Effect, `show`ing errors smash :: forall a. RepT a -> Effect a smash = liftEither <=< map (lmap (error <<< show)) <<< runExceptT @@ -68,20 +72,26 @@ class (Serialize a, Deserialize a) <= Rep a instance (Serialize a, Deserialize a) => Rep a --- | Coerces the value to `Raw` +-- | Coerces the value to `Raw`. +-- | +-- | This is only safe for values whose javascript representation +-- | can be directly serialized by `node-postgres` to the corresponding +-- | SQL type. unsafeSerializeCoerce :: forall m a. Monad m => a -> m Raw unsafeSerializeCoerce = pure <<< Raw.unsafeFromForeign <<< F.unsafeToForeign instance Serialize Raw where serialize = pure --- | Serializes as `Null`. +-- | `NULL` instance Serialize Unit where serialize _ = serialize Null +-- | `NULL` instance Serialize Null where - serialize _ = unsafeSerializeCoerce null_ + serialize _ = unsafeSerializeCoerce jsNull +-- | `json`, `jsonb` instance WriteForeign a => Serialize (JSON a) where serialize = serialize <<< writeJSON <<< unwrap @@ -89,45 +99,51 @@ instance WriteForeign a => Serialize (JSON a) where instance Serialize Buffer where serialize = unsafeSerializeCoerce +-- | `int2`, `int4` instance Serialize Int where serialize = unsafeSerializeCoerce +-- | `int8` +instance Serialize BigInt where + serialize = serialize <<< BigInt.toString + +-- | `bool` instance Serialize Boolean where serialize = unsafeSerializeCoerce +-- | `text`, `inet`, `tsquery`, `tsvector`, `uuid`, `xml`, `cidr`, `time`, `timetz` instance Serialize String where serialize = unsafeSerializeCoerce +-- | `float4`, `float8` instance Serialize Number where serialize = unsafeSerializeCoerce -instance Serialize Char where - serialize = unsafeSerializeCoerce - +-- | `timestamp`, `timestamptz` instance Serialize DateTime where serialize = serialize <<< unwrap <<< DateTime.ISO.fromDateTime +-- | `Just` -> `a`, `Nothing` -> `NULL` instance Serialize a => Serialize (Maybe a) where serialize (Just a) = serialize a - serialize Nothing = unsafeSerializeCoerce null_ + serialize Nothing = unsafeSerializeCoerce jsNull +-- | postgres `array` instance Serialize a => Serialize (Array a) where serialize = unsafeSerializeCoerce <=< traverse serialize instance Deserialize Raw where deserialize = pure --- | Note: this will always succeed, discarding --- | the actual raw value yielded. --- | --- | To explicitly deserialize NULL values and fail --- | when the value is non-null, use `Null`. +-- | `NULL` (always succeeds) instance Deserialize Unit where deserialize _ = pure unit +-- | `NULL` (fails if non-null) instance Deserialize Null where deserialize = map (const Null) <<< F.readNullOrUndefined <<< Raw.unsafeToForeign +-- | `json`, `jsonb` instance ReadForeign a => Deserialize (JSON a) where deserialize = map wrap <<< (hoist (pure <<< unwrap) <<< readJSON') <=< deserialize @String @@ -135,30 +151,43 @@ instance ReadForeign a => Deserialize (JSON a) where instance Deserialize Buffer where deserialize = (F.unsafeReadTagged "Buffer") <<< Raw.unsafeToForeign +-- | `int2`, `int4` instance Deserialize Int where deserialize = F.readInt <<< Raw.unsafeToForeign +-- | `int8` +instance Deserialize BigInt where + deserialize = + let + invalid s = pure $ ForeignError $ "Invalid bigint: " <> s + fromString s = liftMaybe (invalid s) $ BigInt.fromString s + in + fromString <=< deserialize @String + +-- | `bool` instance Deserialize Boolean where deserialize = F.readBoolean <<< Raw.unsafeToForeign +-- | `text`, `inet`, `tsquery`, `tsvector`, `uuid`, `xml`, `cidr`, `time`, `timetz` instance Deserialize String where deserialize = F.readString <<< Raw.unsafeToForeign +-- | `float4`, `float8` instance Deserialize Number where deserialize = F.readNumber <<< Raw.unsafeToForeign -instance Deserialize Char where - deserialize = F.readChar <<< Raw.unsafeToForeign - +-- | `timestamp`, `timestamptz` instance Deserialize DateTime where deserialize raw = do s :: String <- deserialize raw let invalid = pure $ ForeignError $ "Not a valid ISO8601 string: `" <> s <> "`" liftMaybe invalid $ DateTime.ISO.toDateTime $ wrap s +-- | postgres `array` instance Deserialize a => Deserialize (Array a) where deserialize = traverse (deserialize <<< Raw.unsafeFromForeign) <=< F.readArray <<< Raw.unsafeToForeign +-- | non-NULL -> `Just`, NULL -> `Nothing` instance Deserialize a => Deserialize (Maybe a) where deserialize raw = let diff --git a/src/Effect.Aff.Postgres.Client.purs b/src/Effect.Aff.Postgres.Client.purs index accfefd..b8b3d97 100644 --- a/src/Effect.Aff.Postgres.Client.purs +++ b/src/Effect.Aff.Postgres.Client.purs @@ -4,51 +4,21 @@ import Prelude import Control.Promise (Promise) import Control.Promise as Promise -import Data.Maybe (Maybe(..), fromMaybe) -import Data.Nullable (Nullable, toNullable) +import Data.Maybe (fromMaybe) import Data.Postgres (smash) -import Data.Postgres.Raw (Raw) +import Data.Postgres.Query (class AsQuery, QueryRaw, asQuery, queryToRaw) import Data.Postgres.Result (class FromResult, Result, fromRow, rows, rowsAffected) import Data.Traversable (traverse) -import Data.Tuple.Nested (type (/\), (/\)) import Effect (Effect) import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Postgres.Client (Client, Config, make) import Prim.Row (class Union) -import Record (insert, modify) -import Type.Prelude (Proxy(..)) - -type QueryRaw = { text :: String, values :: Array Raw, name :: Nullable String, rowMode :: String } foreign import connectImpl :: Client -> Effect (Promise Unit) foreign import endImpl :: Client -> Effect (Promise Unit) foreign import queryImpl :: QueryRaw -> Client -> Effect (Promise Result) -newtype Query = Query { text :: String, values :: Array Raw, name :: Maybe String } - -queryToRaw :: Query -> QueryRaw -queryToRaw (Query r) = - let - name = Proxy @"name" - rowMode = Proxy @"rowMode" - in - insert rowMode "array" - $ modify name toNullable - $ r - -class AsQuery a where - asQuery :: a -> Query - -instance AsQuery Query where - asQuery = identity - -instance AsQuery String where - asQuery text = Query { text, values: [], name: Nothing } - -instance AsQuery (String /\ Array Raw) where - asQuery (text /\ values) = Query { text, values, name: Nothing } - connected :: forall r trash. Union r trash (Config ()) => Record r -> Aff Client connected c = do client <- liftEffect $ make c @@ -62,7 +32,9 @@ end :: Client -> Aff Unit end = Promise.toAffE <<< endImpl queryRaw :: forall q. AsQuery q => q -> Client -> Aff Result -queryRaw q = Promise.toAffE <<< queryImpl (queryToRaw $ asQuery q) +queryRaw q c = do + q' <- queryToRaw <$> liftEffect (asQuery q) + Promise.toAffE $ queryImpl q' c exec :: forall q. AsQuery q => q -> Client -> Aff Int exec q = map (fromMaybe 0 <<< rowsAffected) <<< queryRaw q diff --git a/test/Test.Common.purs b/test/Test.Common.purs new file mode 100644 index 0000000..85de4e1 --- /dev/null +++ b/test/Test.Common.purs @@ -0,0 +1,26 @@ +module Test.Common where + +import Prelude + +import Effect (Effect) +import Effect.Aff (Aff, bracket) +import Effect.Aff.Postgres.Client (connected, end) +import Effect.Class (liftEffect) +import Effect.Postgres.Client (Client) +import Node.Path as Path +import Node.Process (cwd) + +config + :: Effect + { database :: String + , host :: String + , password :: String + , user :: String + } +config = do + cwd' <- liftEffect cwd + host <- liftEffect $ Path.resolve [ cwd' ] "./pg" + pure { host, user: "postgres", password: "password", database: "postgres" } + +withClient :: (Client -> Aff Unit) -> Aff Unit +withClient = bracket (connected =<< liftEffect config) end diff --git a/test/Test.Data.Postgres.js b/test/Test.Data.Postgres.js new file mode 100644 index 0000000..1221aba --- /dev/null +++ b/test/Test.Data.Postgres.js @@ -0,0 +1,4 @@ +/** @type {(_: Buffer) => () => bigint} */ +export const readBigInt64BE = buf => () => buf.readBigInt64BE(0) + +export const dbg = a => () => typeof a === 'string' ? console.log(Buffer.from(a).toString('hex')) : undefined diff --git a/test/Test.Data.Postgres.purs b/test/Test.Data.Postgres.purs index 4432895..00495d3 100644 --- a/test/Test.Data.Postgres.purs +++ b/test/Test.Data.Postgres.purs @@ -2,30 +2,129 @@ module Test.Data.Postgres where import Prelude -import Control.Monad.Error.Class (liftEither) -import Control.Monad.Except (runExceptT) -import Data.DateTime (DateTime(..)) +import Control.Monad.Gen (chooseInt, elements, oneOf) +import Data.Array as Array +import Data.Array.NonEmpty as Array.NonEmpty +import Data.DateTime (DateTime(..), canonicalDate) import Data.DateTime.Instant as Instant +import Data.Enum (toEnum) +import Data.Foldable (fold) +import Data.Identity (Identity) import Data.Int as Int -import Data.Maybe (Maybe, fromJust, fromMaybe, maybe) -import Data.Newtype (unwrap, wrap) -import Data.Postgres (class Rep, JSON(..), Null(..), deserialize, null_, serialize, smash) -import Data.Postgres.Range as Range +import Data.Maybe (Maybe(..), fromJust, maybe) +import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Number (abs) as Number +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.RFC3339String as DateTime.ISO -import Data.Tuple.Nested (type (/\), (/\)) +import Data.String as String +import Data.Time (Time(..)) +import Data.Traversable (for, sequence) +import Data.Tuple.Nested ((/\)) +import Effect (Effect) +import Effect.Aff (Aff) +import Effect.Aff.Postgres.Client (exec, query) import Effect.Class (liftEffect) -import Effect.Console (log) +import Effect.Postgres.Client (Client) import Effect.Unsafe (unsafePerformEffect) -import Foreign (unsafeToForeign) +import Foreign (Foreign, unsafeToForeign) import Foreign.Object as Object +import JS.BigInt (BigInt) +import JS.BigInt as BigInt +import Node.Buffer (Buffer) +import Node.Buffer as Buffer import Partial.Unsafe (unsafePartial) -import Simple.JSON (writeImpl, writeJSON) -import Test.QuickCheck (class Arbitrary, (==?)) -import Test.Spec (Spec, describe, it) -import Test.Spec.Assertions (shouldEqual) -import Test.Spec.QuickCheck (quickCheck) +import Simple.JSON (writeJSON) +import Test.Common (withClient) +import Test.QuickCheck (class Arbitrary, arbitrary, randomSeed) +import Test.QuickCheck.Gen (sample, vectorOf) +import Test.Spec (Spec, SpecT, around, describe, it) +import Test.Spec.Assertions (fail) + +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 + yr <- chooseInt 1970 2100 + mo <- chooseInt 1 12 + dy <- chooseInt 1 28 + hr <- chooseInt 0 23 + mn <- chooseInt 0 59 + sc <- chooseInt 0 59 + ms <- chooseInt 0 999 + let + date = unsafePartial fromJust $ Just canonicalDate <*> toEnum yr <*> toEnum mo <*> toEnum dy + time = unsafePartial fromJust $ Just Time <*> toEnum hr <*> toEnum mn <*> toEnum sc <*> toEnum ms + pure $ wrap $ DateTime date time + +newtype GenString = GenString String +derive instance Newtype GenString _ +instance Arbitrary GenString where + arbitrary = do + let chars = unsafePartial fromJust $ Array.NonEmpty.fromArray $ String.split (wrap "") "abcdefghijklmnopqrstuvwxyz01234567890 _-=><|\\/" + len <- chooseInt 0 100 + chars' <- vectorOf len (elements chars) + pure $ wrap $ fold chars' + +newtype GenSmallFloat = GenSmallFloat Number +derive instance Newtype GenSmallFloat _ +instance Arbitrary GenSmallFloat where + arbitrary = do + let byte = chooseInt 0 7 + bytes <- sequence $ Array.replicate 4 byte + pure + $ wrap + $ unsafePerformEffect do + buf <- Buffer.fromArray bytes + Buffer.read Buffer.FloatBE 0 buf + +newtype GenBigInt = GenBigInt BigInt + +derive instance Newtype GenBigInt _ + +instance Arbitrary GenBigInt where + arbitrary = do + let byte = chooseInt 0 7 + bytes <- sequence $ Array.replicate 8 byte + let + bigint = unsafePerformEffect do + buf <- Buffer.fromArray bytes + readBigInt64BE buf + pure $ wrap bigint + +newtype GenJSON = GenJSON Foreign + +derive instance Newtype GenJSON _ + +instance Arbitrary GenJSON where + arbitrary = + let + json _ = map wrap $ oneOf' [ prim, array unit, obj unit ] + oneOf' = oneOf <<< unsafePartial fromJust <<< Array.NonEmpty.fromArray + elements' = elements <<< unsafePartial fromJust <<< Array.NonEmpty.fromArray + prim = oneOf' + [ pure $ unsafeToForeign jsNull + , unsafeToForeign <$> arbitrary @Number + , unsafeToForeign <$> arbitrary @String + ] + array _ = map unsafeToForeign $ vectorOf 3 prim + obj _ = do + keys <- vectorOf 3 (elements' [ "foo", "bar", "baz", "quux", "duck", "dog", "cat", "cow" ]) + kvs <- for keys \k -> (k /\ _) <$> prim + pure $ unsafeToForeign $ Object.fromFoldable kvs + in + json unit asRaw :: forall a. a -> Raw asRaw = Raw.unsafeFromForeign <<< unsafeToForeign @@ -33,59 +132,52 @@ asRaw = Raw.unsafeFromForeign <<< unsafeToForeign spec :: Spec Unit spec = let - check :: forall @a @x. Eq a => Show a => Arbitrary x => Rep a => String -> (x -> a) -> (a -> Raw) -> Spec Unit - check s xa asRaw_ = - describe s do - it "serialize" $ quickCheck \(x :: x) -> (unsafePerformEffect $ runExceptT $ serialize $ xa x) ==? pure (asRaw_ $ xa x) - it "deserialize" $ quickCheck \(x :: x) -> (unsafePerformEffect $ runExceptT $ deserialize $ asRaw_ $ xa x) ==? pure (xa x) + 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 = + it (purs <> " <> " <> sql) \c -> do + let + tab = String.replace (wrap " ") (wrap "_") $ String.replace (wrap "[") (wrap "") $ String.replace (wrap "]") (wrap "") $ sql <> "_is_" <> String.toLower purs + ser x = + Q.build do + x' <- Q.param $ xa x + pure $ "insert into " <> tab <> " values (" <> x' <> " :: " <> sql <> ")" + de x = + Q.build do + x' <- Q.param $ xa x + pure $ "select " <> x' <> " :: " <> sql + void $ exec ("create temp table " <> tab <> " (val " <> sql <> ")") c + seed <- liftEffect randomSeed + let + xs = sample seed 20 (arbitrary @x) + void $ for xs \x -> do + void $ exec (ser x) c + res :: Array a <- query (de x) c + let + exp = xa x + 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 => Rep a => String -> Spec Unit - check_ s = check @a @a s identity asRaw + 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 in - describe "Data.Postgres" do - check_ @Int "Int" - check_ @String "String" - check_ @Boolean "Boolean" - check_ @Number "Number" - check_ @Char "Char" + around withClient + $ describe "Data.Postgres" + $ do + check @Int @GenSmallInt "Int" "int2" unwrap asRaw eq + check_ @Int "Int" "int4" - check @(Maybe String) "Maybe String" identity (maybe null_ asRaw) - check @(Array String) "Array String" identity asRaw - check @DateTime "DateTime" dateTimeFromArbitrary (asRaw <<< DateTime.ISO.fromDateTime) + check @String @GenString "String" "text" unwrap asRaw eq - describe "JSON" do - describe "Record" do - it "deserialize" $ - quickCheck \(a /\ b /\ c :: Int /\ String /\ Array { "foo" :: String }) -> unsafePerformEffect do - let - obj = { a, b, c } - json = writeJSON obj - act :: JSON _ <- smash $ deserialize $ asRaw json - pure $ obj ==? unwrap act - it "serialize" $ - quickCheck \(a /\ b /\ c :: Int /\ String /\ Array { "foo" :: String }) -> unsafePerformEffect do - let obj = { a, b, c } - act <- smash $ serialize $ JSON obj - pure $ asRaw (writeJSON obj) ==? act + check_ @Boolean "Boolean" "bool" - describe "Null" do - it "serialize" $ liftEffect $ shouldEqual null_ =<< (smash $ serialize Null) - it "deserialize" $ liftEffect $ shouldEqual Null =<< (smash $ deserialize null_) + check @Number @GenSmallFloat "Number" "float4" unwrap asRaw (\a b -> Number.abs (a - b) <= 0.0001) + check_ @Number "Number" "float8" - describe "Range" do - it "deserialize" do - quickCheck \(up /\ lo /\ uinc /\ linc :: Int /\ Int /\ Boolean /\ Boolean) -> unsafePerformEffect do - let - record = - { upper: unsafePerformEffect $ smash $ serialize up - , lower: unsafePerformEffect $ smash $ serialize lo - , upperIncl: uinc - , lowerIncl: linc - } - raw = asRaw $ Range.rangeRawFromRecord record - exp :: Range.Range Int <- smash $ Range.rangeFromRaw record - act :: Range.Range Int <- smash $ deserialize raw - pure $ exp ==? act + 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 diff --git a/test/Test.Effect.Postgres.Client.purs b/test/Test.Effect.Postgres.Client.purs index 5a32673..5700bb7 100644 --- a/test/Test.Effect.Postgres.Client.purs +++ b/test/Test.Effect.Postgres.Client.purs @@ -7,32 +7,12 @@ import Data.Either (Either, isLeft) import Data.Newtype (wrap) import Data.Postgres (JSON(..)) import Data.PreciseDateTime (fromRFC3339String, toDateTimeLossy) -import Effect (Effect) -import Effect.Aff (Aff, bracket) import Effect.Aff.Postgres.Client (query) import Effect.Aff.Postgres.Client as PG.Aff.Client -import Effect.Class (liftEffect) -import Effect.Postgres.Client as PG -import Node.Path as Path -import Node.Process (cwd) +import Test.Common (withClient) import Test.Spec (Spec, around, describe, it) import Test.Spec.Assertions (shouldEqual) -config - :: Effect - { database :: String - , host :: String - , password :: String - , user :: String - } -config = do - cwd' <- liftEffect cwd - host <- liftEffect $ Path.resolve [ cwd' ] "./pg" - pure { host, user: "postgres", password: "password", database: "postgres" } - -withClient :: (PG.Client -> Aff Unit) -> Aff Unit -withClient = bracket (PG.Aff.Client.connected =<< liftEffect config) PG.Aff.Client.end - spec :: Spec Unit spec = around withClient do @@ -46,12 +26,9 @@ spec = isLeft res `shouldEqual` true it "rowsAffected is correct" \c -> do void $ PG.Aff.Client.exec "create temp table foo (bar int);" c - cta <- PG.Aff.Client.exec "insert into foo values (1);" c - cta `shouldEqual` 1 - ctb <- PG.Aff.Client.exec "insert into foo values (1), (2), (3);" c - ctb `shouldEqual` 3 - ctc <- PG.Aff.Client.exec "update foo set bar = 10;" c - ctc `shouldEqual` 4 + shouldEqual 1 =<< PG.Aff.Client.exec "insert into foo values (1);" c + shouldEqual 3 =<< PG.Aff.Client.exec "insert into foo values (1), (2), (3);" c + shouldEqual 4 =<< PG.Aff.Client.exec "update foo set bar = 10;" c describe "timestamp" do it "unmarshals" \c -> do let exp = toDateTimeLossy <$> fromRFC3339String (wrap "2020-01-01T00:00:00Z")