postgresql-simple-ltree (empty) → 0.0.0.0

raw patch · 7 files changed

+276/−0 lines, 7 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, bytestring, hspec, monad-logger, postgresql-ltree, postgresql-simple, postgresql-simple-ltree, text, tmp-postgres

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
README.md +16/−0
postgresql-simple-ltree.cabal +62/−0
src/Database/PostgreSQL/Simple/LQuery.hs +34/−0
src/Database/PostgreSQL/Simple/LTree.hs +36/−0
test/postgresql-simple-ltree-test.hs +93/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Changelog for postgresql-simple-ltree ++## 0.0.0.0++* First release

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright SimSpace (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of SimSpace nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,16 @@+# postgresql-ltree++Haskell support for PostgreSQL's [ltree](https://www.postgresql.org/docs/current/ltree.html).++## postgresql-ltree [![postgresql-ltree](https://img.shields.io/hackage/v/postgresql-ltree.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/postgresql-ltree)++Core types and functions for use in Haskell code.+Does not provide support for any database library; use one of the+following libraries instead.+++## postgresql-simple-ltree [![postgresql-simple-ltree](https://img.shields.io/hackage/v/postgresql-simple-ltree.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/postgresql-simple-ltree)++Contains type class instances for `FromField` and `ToField` for use with [postgresql-simple](https://hackage.haskell.org/package/postgresql-simple).+Re-exports types and functions from `postgresql-ltree` so there should be no+need to depend on both.

+ postgresql-simple-ltree.cabal view

@@ -0,0 +1,62 @@+cabal-version: 1.12++name:           postgresql-simple-ltree+version:        0.0.0.0+description:    Please see the README on GitHub at <https://github.com/simspace/postgresql-ltree#readme>+synopsis:       Instances for using ltree with postgresql-simple+category:       Database+homepage:       https://github.com/simspace/postgresql-ltree#readme+bug-reports:    https://github.com/simspace/postgresql-ltree/issues+author:         Cary Robbins+maintainer:     carymrobbins@gmail.com+copyright:      2022 SimSpace+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/simspace/postgresql-ltree++library+  exposed-modules:+      Database.PostgreSQL.Simple.LQuery+      Database.PostgreSQL.Simple.LTree+  other-modules:+      Paths_postgresql_simple_ltree+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , aeson >=1.5.6.0 && <2+    , postgresql-ltree ==0.0.0.0+    , postgresql-simple >=0.6.4 && <1+    , text >=1.2.4.1 && <2+  default-language: Haskell2010+  ghc-options:+    -Wall -fwarn-tabs -Wincomplete-uni-patterns+    -Werror=missing-home-modules -eventlog +RTS -A32M -RTS++test-suite postgresql-simple-ltree-test+  type: exitcode-stdio-1.0+  main-is: postgresql-simple-ltree-test.hs+  hs-source-dirs: test+  ghc-options:+    -Wall -fwarn-tabs -Wincomplete-uni-patterns+    -Werror=missing-home-modules -eventlog +RTS -A32M -RTS+    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring+    , hspec+    , monad-logger+    , postgresql-ltree+    , postgresql-simple+    , postgresql-simple-ltree+    , QuickCheck+    , text+    , tmp-postgres+  default-language: Haskell2010

+ src/Database/PostgreSQL/Simple/LQuery.hs view

@@ -0,0 +1,34 @@+-- | This module is a wrapper for PostgreSQL's @lquery@ https://www.postgresql.org/docs/current/ltree.html+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.PostgreSQL.Simple.LQuery+  ( module Database.PostgreSQL.LQuery+  ) where++import Prelude++import Database.PostgreSQL.LQuery++import Control.Monad (when)+import Database.PostgreSQL.Simple.FromField+  ( FromField(fromField), ResultError(Incompatible, UnexpectedNull), returnError, typename+  )+import Database.PostgreSQL.Simple.ToField (ToField(toField))++import qualified Data.Text.Encoding as Text++instance ToField LQuery where+  toField = toField . unLQuery++instance FromField LQuery where+  fromField fld mbs = do+    -- There might be a more efficient way to check this, need to see+    -- if the @lquery@ type has a stable typoid or not.+    typ <- typename fld+    -- Ensure we don't accidentally deserialize a @text@ field which+    -- would produce corrupted @lquery@s.+    when (typ /= "lquery") $+      returnError Incompatible fld $ "Expected type lquery, got: " <> show typ+    case mbs of+      Nothing -> returnError UnexpectedNull fld ""+      Just bs -> pure $ LQuery $ Text.decodeUtf8 bs

+ src/Database/PostgreSQL/Simple/LTree.hs view

@@ -0,0 +1,36 @@+-- | This module is a wrapper for PostgreSQL's @ltree@ https://www.postgresql.org/docs/current/ltree.html+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.PostgreSQL.Simple.LTree+  ( module Database.PostgreSQL.LTree+  ) where++import Prelude hiding (map, null)++import Database.PostgreSQL.LTree++import Control.Monad (when)+import Database.PostgreSQL.Simple.FromField+  ( FromField(fromField), ResultError(Incompatible, UnexpectedNull), returnError, typename+  )+import Database.PostgreSQL.Simple.ToField (ToField(toField))++import qualified Data.Text.Encoding as Text++instance ToField LTree where+  toField = toField . render++instance FromField LTree where+  fromField fld mbs = do+    -- There might be a more efficient way to check this, need to see+    -- if the @ltree@ type has a stable typoid or not.+    typ <- typename fld+    -- Ensure we don't accidentally deserialize a @text@ field which+    -- would produce corrupted @label@s.+    when (typ /= "ltree") $+      returnError Incompatible fld $ "Expected type ltree, got: " <> show typ+    case mbs of+      Nothing -> returnError UnexpectedNull fld ""+      -- Since this is coming from postgres and we've confirmed the type matches+      -- @ltree@, it is safe to use 'unsafeUncheckedParse' here.+      Just bs -> pure $ unsafeUncheckedParse $ Text.decodeUtf8 bs

+ test/postgresql-simple-ltree-test.hs view

@@ -0,0 +1,93 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Main where++import Control.Exception (bracket, throw, throwIO, try)+import Control.Monad.Logger.CallStack (logWarn, runStderrLoggingT)+import Data.Function ((&))+import Data.Functor ((<&>), void)+import Data.Text (Text)+import Database.PostgreSQL.Simple+  ( Only(..), SqlError(sqlErrorMsg), Connection, close, connectPostgreSQL, execute_, query+  )+import Database.PostgreSQL.Simple.LTree (mkLabel)+import System.Environment (lookupEnv)+import Test.Hspec (describe, expectationFailure, hspec, it)+import Test.QuickCheck (Gen, arbitrary, property, suchThat)+import Test.QuickCheck.Monadic (forAllM, monadicIO, run)++import qualified Data.Bifunctor as Bifunctor+import qualified Data.ByteString.Char8 as C8+import qualified Data.Text as Text+import qualified Database.Postgres.Temp as TmpPostgres++main :: IO ()+main = withTmpPostgres $ \conn -> hspec $ do+  describe "mkLabel" $ do+    it "should only produce valid labels" $+      property $ monadicIO $ forAllM genPGText $ \t ->+        run $ mkLabel t & either+          (const $ verifyTextCannotBeALabel conn t)+          (const $ verifyTextCanBeALabel conn t)+  where+  withTmpPostgres f = do+    let go conn = do+          _ <- execute_ conn "create extension if not exists ltree"+          f conn+    -- Checks for the PGDATABASE env var. If it's not set, use+    -- tmp-postgres. Otherwise, connect to the database+    -- specified via env vars.+    lookupEnv "PGDATABASE" >>= \case+      Nothing ->+        either throwIO pure =<<+          TmpPostgres.with+            (\db ->+                bracket+                (connectPostgreSQL $ TmpPostgres.toConnectionString db)+                close+                go+            )+      Just _ ->+        -- Uses the env vars as specified here -+        -- https://www.postgresql.org/docs/13/libpq-envars.html+        bracket+          (connectPostgreSQL "")+          close+          go++  verifyTextCanBeALabel :: Connection -> Text -> IO ()+  verifyTextCanBeALabel conn t = tryConvertTextToLabelInPG conn t >>= \case+    Left msg -> expectationFailure msg+    Right () -> pure ()++  -- Making this throw an expectationFailure is a bit too strong of a test.+  -- It's probably ok if 'mkLabel' is too strict; it's mostly important that+  -- it's not too lenient. We'll just log a warning for cases found in which+  -- 'mkLabel' is too strict.+  verifyTextCannotBeALabel :: Connection -> Text -> IO ()+  verifyTextCannotBeALabel conn t = tryConvertTextToLabelInPG conn t >>= \case+    Left _ -> pure ()+    Right () -> runStderrLoggingT $+      logWarn $ "PostgreSQL unexpectedly parsed label: " <> Text.pack (show t)++  tryConvertTextToLabelInPG :: Connection -> Text -> IO (Either String ())+  tryConvertTextToLabelInPG conn t =+    try (void $ query @_ @[Int] conn "select ?::ltree where false" $ Only ltree)+      <&>+      Bifunctor.first+        (\(e :: SqlError) ->+          if "syntax error at position " `C8.isPrefixOf` sqlErrorMsg e then+            "Failed to parse label via PostgreSQL: " <> show t+          else+            throw e)+    where+    -- Produce an ltree by joining a label with itself+    ltree = t <> "." <> t++  genAnyText :: Gen Text+  genAnyText = Text.pack <$> arbitrary++  genPGText :: Gen Text+  genPGText = genAnyText `suchThat` (not . Text.isInfixOf "\0")