postgresql-ltree (empty) → 0.0.0.0

raw patch · 7 files changed

+365/−0 lines, 7 filesdep +QuickCheckdep +aesondep +attoparsec

Dependencies added: QuickCheck, aeson, attoparsec, base, containers, hspec, postgresql-ltree, text, uuid

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• README.md +16/−0
• postgresql-ltree.cabal +57/−0
• src/Database/PostgreSQL/LQuery.hs +30/−0
• src/Database/PostgreSQL/LTree.hs +202/−0
• test/postgresql-ltree-test.hs +25/−0

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

@@ -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.

@@ -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.

@@ -0,0 +1,57 @@+cabal-version: 1.12++name:           postgresql-ltree+version:        0.0.0.0+description:    Please see the README on GitHub at <https://github.com/simspace/postgresql-ltree#readme>+synopsis:       Types and functions for representing PostgreSQL's ltree+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.LQuery+      Database.PostgreSQL.LTree+  other-modules:+      Paths_postgresql_ltree+  hs-source-dirs: src+  build-depends:+      base >=4.7 && <5+    , aeson >=1.5.6.0 && <2+    , attoparsec >=0.13.2.5 && <1+    , containers >=0.6.5.1 && <1+    , text >=1.2.4.1 && <2+    , uuid >=1.3.15 && <2+  default-language: Haskell2010+  ghc-options:+    -Wall -fwarn-tabs -Wincomplete-uni-patterns+    -Werror=missing-home-modules -eventlog +RTS -A32M -RTS++test-suite postgresql-ltree-test+  type: exitcode-stdio-1.0+  main-is: postgresql-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+    , hspec+    , postgresql-ltree+    , QuickCheck+    , text+  default-language: Haskell2010

@@ -0,0 +1,30 @@+-- | This module provides types and functions for PostgreSQL's @lquery@ https://www.postgresql.org/docs/current/ltree.html+--+-- You will want to use a specific implementation, e.g. @postgresql-simple-ltree@.+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module Database.PostgreSQL.LQuery+  ( LQuery(..)+  , contains+  ) where++import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))+import Data.Text (Text)++import qualified Database.PostgreSQL.LTree as LTree++-- | Wrapper for Postgres' @lquery@ (label tree query) type.+newtype LQuery = LQuery { unLQuery :: Text }+  deriving newtype (Show, Eq, Ord)++-- | Build an @lquery@ expression which matches any @ltree@ which contains+-- the given @label@.+contains :: LTree.Label -> LQuery+contains label = LQuery $ "*." <> LTree.unLabel label <> ".*"++instance FromJSON LQuery where+  parseJSON = fmap LQuery . parseJSON++instance ToJSON LQuery where+  toJSON = toJSON . unLQuery

@@ -0,0 +1,202 @@+-- | This module provides types and functions for PostgreSQL's @ltree@ https://www.postgresql.org/docs/current/ltree.html+--+-- You will want to use a specific implementation, e.g. @postgresql-simple-ltree@.+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module Database.PostgreSQL.LTree+  ( LTree(..)+  , Label(unLabel)+  , map+  , fromList+  , toList+  , rootLabel+  , parentLabel+  , parent+  , numLabels+  , mkLabel+  , unsafeMkLabel+  , uuidToLabel+  , empty+  , null+  , singleton+  , snoc+  , render+  , unsafeUncheckedParse+  , parse+  , isImmediateParentOf+  , isImmediateChildOf+  , parseUUIDFromLabel+  , allLabelsUnique+  ) where++import Prelude hiding (map, null)++import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))+import Data.Coerce (coerce)+import Data.Sequence (Seq((:<|), (:|>)), (|>))+import Data.Text (Text)+import Data.UUID (UUID)++import qualified Data.Attoparsec.Text as Atto+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.UUID as UUID++-- | Wrapper for Postgres' @ltree@ (label tree) type.+newtype LTree = LTree { unLTree :: Seq Label }+  deriving newtype (Show, Eq, Ord)++-- | Wrapper for a single label in an @ltree@.+-- The constructor IS NOT exported to ensure we only construct valid+-- labels. See 'mkLabel' for constructing a 'Label'.+newtype Label = Label { unLabel :: Text }+  deriving newtype (Show, Eq, Ord)++-- | Produce a new 'LTree' by applying the supplied function to each 'Label'.+map :: (Label -> Label) -> LTree -> LTree+map f = LTree . fmap f . unLTree++-- | Convert a list to an 'LTree'.+fromList :: [Label] -> LTree+fromList = LTree . Seq.fromList++-- | Convert an 'LTree' to a list.+toList :: LTree -> [Label]+toList = Foldable.toList . unLTree++-- | Get the first 'Label' from an 'LTree' if one exists.+rootLabel :: LTree -> Maybe Label+rootLabel (LTree (x :<| _)) = Just x+rootLabel _ = Nothing++-- | Get the second-to-last 'Label' in an 'LTree'.+parentLabel :: LTree -> Maybe Label+parentLabel (LTree x) = Seq.lookup (Seq.length x - 2) x++-- | Get the parent path of an 'LTree'.+parent :: LTree -> Maybe LTree+parent (LTree (xs :|> _)) = Just $ LTree xs+parent _ = Nothing++-- | Get the length of an 'LTree'.+numLabels :: LTree -> Int+numLabels (LTree x) = Seq.length x++-- | Safely construct a 'Label' from 'Text'. If the supplied 'Text'+-- contains characters unsupported by @ltree@. On failure, returns 'Left'+-- with an error message.+mkLabel :: Text -> Either String Label+mkLabel t =+  if Text.null t then+    Left "ltree label must be non-empty"+  else if List.null invalidChars then+    Right $ Label t+  else+    Left $ "Invalid ltree label chars found: " <> show invalidChars+  where+  invalidChars = List.nub $ Text.unpack $ Text.filter (not . isValidLabelChar) t++-- | Same as 'mkLabel' except throws an error for an invalid 'Text' input.+unsafeMkLabel :: Text -> Label+unsafeMkLabel = either error id . mkLabel++-- | A 'UUID' can always be converted into a 'Label' without error by+-- dropping the hyphens. The resulting 'Label' will only contain+-- numbers and lower-case alpha characters.+uuidToLabel :: UUID -> Label+uuidToLabel = Label . Text.filter (/= '-') . UUID.toText++-- | Predicate for which characters are supported by @ltree@.+isValidLabelChar :: Char -> Bool+isValidLabelChar = flip Set.member valid+  where+  valid = mconcat+    [ Set.singleton '_'+    , Set.fromList ['0'..'9']+    , Set.fromList ['A'..'Z']+    , Set.fromList ['a'..'z']+    ]++-- | An empty 'LTree'.+empty :: LTree+empty = LTree mempty++-- | Test whether an 'LTree' is empty.+null :: LTree -> Bool+null = Seq.null . unLTree++-- | Construct an 'LTree' from a single 'Label'.+singleton :: Label -> LTree+singleton = LTree . Seq.singleton++-- | Append a single 'Label' to the end of an 'LTree'; should be O(1)+-- since it's delegating to 'Data.Sequence.|>'+snoc :: LTree -> Label -> LTree+snoc (LTree xs) x = LTree (xs |> x)++-- | Render an @ltree@ as it would appear in the database.+render :: LTree -> Text+render = Text.intercalate "." . coerce . toList++-- | Unsafely parse an 'LTree' from 'Text' assuming each 'Label'+-- is valid. Use this only if you sure the input is a valid 'LTree';+-- e.g. it was fetched from a field the database of type @ltree@.+unsafeUncheckedParse :: Text -> LTree+unsafeUncheckedParse = fromList . coerce . Text.splitOn "."++-- | Parse an 'LTree' from 'Text'. If any 'Label' present is invalid,+-- returns 'Left'.+parse :: Text -> Either String LTree+parse = fmap fromList . traverse mkLabel . Text.splitOn "."++-- | Test whether the first 'LTree' is an immediate parent of the second;+-- e.g. @a.b@ is an immediate parent of @a.b.c@+isImmediateParentOf :: LTree -> LTree -> Bool+isImmediateParentOf (LTree xs) (LTree (ys :|> _)) | xs == ys = True+isImmediateParentOf _ _ = False++-- | Test whether the first 'LTree' is an immediate child of the second;+-- e.g. @a.b.c@ is an immediate child of @a.b@+isImmediateChildOf :: LTree -> LTree -> Bool+isImmediateChildOf = flip isImmediateParentOf++-- | Attempt to parse a 'UUID' from a 'Label'.+parseUUIDFromLabel :: Label -> Either String UUID+parseUUIDFromLabel (Label t) =+  Atto.parseOnly p t+  where+  p = do+    a <- Atto.take 8+    b <- Atto.take 4+    c <- Atto.take 4+    d <- Atto.take 4+    e <- Atto.take 12+    Atto.endOfInput+    maybe+      (fail "Label is not a valid UUID")+      pure+      (UUID.fromText $ Text.intercalate "-" [a, b, c, d, e])++-- | Test whether all labels in the 'LTree' are unique.+allLabelsUnique :: LTree -> Bool+allLabelsUnique (LTree xs) = length xs == (Set.size . Set.fromList . Foldable.toList $ xs)++instance FromJSON Label where+  parseJSON v = do+    text <- parseJSON v+    either fail pure $ mkLabel text++instance ToJSON Label where+  toJSON = toJSON . unLabel++instance FromJSON LTree where+  parseJSON v = do+    text <- parseJSON v+    either fail pure $ parse text++instance ToJSON LTree where+  toJSON = toJSON . render

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Data.Function ((&))+import Data.Text (Text)+import Database.PostgreSQL.LTree (Label(unLabel), mkLabel)+import Test.Hspec (describe, hspec, it, shouldBe)+import Test.QuickCheck (Gen, arbitrary, forAll, property)++import qualified Data.Text as Text++main :: IO ()+main = hspec $ do+  describe "mkLabel" $ do+    it "should not modify the input text" $+      property $ forAll genAnyText $ \t ->+        mkLabel t & either+          (const True)+          (\label -> unLabel label == t)+    it "should fail for null bytes" $+      mkLabel "foo\0bar"+        `shouldBe` Left "Invalid ltree label chars found: \"\\NUL\""+  where+  genAnyText :: Gen Text+  genAnyText = Text.pack <$> arbitrary