diff --git a/IHP/Postgres/Inet.hs b/IHP/Postgres/Inet.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/Inet.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: IHP.Postgres.Inet +Description: Adds support for storing IP addresses in INET fields. CIDR Notation is not supported at the moment. +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.Postgres.Inet where + +import BasicPrelude + +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromField +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI +import Database.PostgreSQL.Simple.TypeInfo.Macro as TI +import Data.Attoparsec.ByteString.Char8 as Attoparsec + +-- We use the @ip@ package for representing IP addresses +import qualified Net.IP as IP +import Net.IP (IP) +import qualified Data.Text.Encoding as Text + +instance FromField IP where + fromField f v = + if typeOid f /= $(inlineTypoid TI.inet) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly parser bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + where + parser = do + ip <- Attoparsec.takeWhile (\char -> char /= ' ') + case IP.decode (Text.decodeUtf8 ip) of + Just ip -> pure ip + Nothing -> fail "Invalid IP" + +instance ToField IP where + toField ip = toField (IP.encode ip) diff --git a/IHP/Postgres/Interval.hs b/IHP/Postgres/Interval.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/Interval.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: IHP.Postgres.Interval +Description: Adds support for the Postgres Interval type +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.Postgres.Interval where + +import BasicPrelude + +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromField +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI +import Database.PostgreSQL.Simple.TypeInfo.Macro as TI +import Data.Attoparsec.ByteString.Char8 as Attoparsec +import Data.Aeson + +import IHP.Postgres.TimeParser (PGInterval(..)) +import qualified Data.Text.Encoding as Text + +instance FromField PGInterval where + fromField f v = + if typeOid f /= $(inlineTypoid TI.interval) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> case parseOnly pPGInterval bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + +pPGInterval = do + bs <- takeByteString + pure (PGInterval bs) + +instance ToField PGInterval where + toField (PGInterval interval) = toField (interval) + +instance FromJSON PGInterval where + parseJSON = withText "PGInterval" $ \text -> pure (PGInterval (encodeUtf8 text)) + +instance ToJSON PGInterval where + toJSON (PGInterval pgInterval) = String (Text.decodeUtf8 pgInterval) diff --git a/IHP/Postgres/Point.hs b/IHP/Postgres/Point.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/Point.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: IHP.Postgres.Point +Description: Adds support for the Postgres Point type +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.Postgres.Point where + +import GHC.Float +import BasicPrelude + +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromField +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI +import Database.PostgreSQL.Simple.TypeInfo.Macro as TI +import Data.ByteString.Builder (byteString, char8) +import Data.Attoparsec.ByteString.Char8 hiding (Result, char8, Parser(..)) +import Data.Attoparsec.Internal.Types (Parser) +import Data.Aeson + +-- | Represents a Postgres Point +-- +-- See https://www.postgresql.org/docs/9.5/datatype-geometric.html +data Point = Point { x :: Double, y :: Double } + deriving (Eq, Show, Ord) + +instance FromField Point where + fromField f v = + if typeOid f /= $(inlineTypoid TI.point) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly parsePoint bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + +parsePoint :: Parser ByteString Point +parsePoint = do + string "(" + x <- doubleOrNaN + string "," + y <- doubleOrNaN + string ")" + pure $ Point { x, y } + where + -- Postgres supports storing NaN inside a point, so we have to deal + -- with that here as well + doubleOrNaN = double <|> (string "NaN" >> (pure $ 0 / 0)) + + +instance ToField Point where + toField = serializePoint + +serializePoint :: Point -> Action +serializePoint Point { x, y } = Many + [ Plain (byteString "point(") + , toField x + , Plain (char8 ',') + , toField y + , Plain (char8 ')') + ] + + +instance FromJSON Point where + parseJSON = withObject "Point" $ \v -> Point + <$> v .: "x" + <*> v .: "y" + +instance ToJSON Point where + toJSON Point { x, y } = object [ "x" .= x, "y" .= y ] diff --git a/IHP/Postgres/Polygon.hs b/IHP/Postgres/Polygon.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/Polygon.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: IHP.Postgres.Polygon +Description: Adds support for the Postgres Polygon type +Copyright: (c) digitally induced GmbH, 2022 +-} +module IHP.Postgres.Polygon where + +import BasicPrelude + +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromField +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI +import Database.PostgreSQL.Simple.TypeInfo.Macro as TI +import Data.ByteString.Builder (byteString, char8) +import Data.Attoparsec.ByteString.Char8 hiding (Result, char8, Parser(..)) +import Data.Attoparsec.Internal.Types (Parser) +import IHP.Postgres.Point + +-- | Represents a Postgres Polygon +-- +-- See https://www.postgresql.org/docs/9.5/datatype-geometric.html +data Polygon = Polygon { points :: [Point] } + deriving (Eq, Show, Ord) + +instance FromField Polygon where + fromField f v = + if typeOid f /= $(inlineTypoid TI.polygon) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly parsePolygon bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + +parsePolygon :: Parser ByteString Polygon +parsePolygon = do + string "(" + points <- parsePoint `sepBy` (char ',') + string ")" + pure $ Polygon points + +instance ToField Polygon where + toField = serializePolygon + +serializePolygon :: Polygon -> Action +serializePolygon Polygon { points } = Many $ + (Plain (byteString "polygon'")): + ( (intersperse (Plain $ char8 ',') $ map serializePoint' points) + ++ [ Plain (char8 '\'') ]) + where + serializePoint' :: Point -> Action + serializePoint' Point { x, y } = Many $ + [ Plain (char8 '(') + , toField x + , Plain (char8 ',') + , toField y + , Plain (char8 ')') + ] diff --git a/IHP/Postgres/TSVector.hs b/IHP/Postgres/TSVector.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/TSVector.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: IHP.Postgres.TSVector +Description: Adds support for the Postgres tsvector type +Copyright: (c) digitally induced GmbH, 2021 +-} +module IHP.Postgres.TSVector where + +import BasicPrelude +import IHP.Postgres.TypeInfo +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.TypeInfo.Macro +import Data.Attoparsec.ByteString.Char8 as Attoparsec hiding (Parser(..)) +import Data.Attoparsec.Internal.Types (Parser) +import Data.ByteString.Builder (byteString, charUtf8) +import qualified Data.Text.Encoding as Text + +-- | Represents a Postgres tsvector +-- +-- See https://www.postgresql.org/docs/current/datatype-textsearch.html +data TSVector + = TSVector [Lexeme] + deriving (Eq, Show, Ord) + +data Lexeme + = Lexeme { token :: Text, ranking :: [LexemeRanking] } + deriving (Eq, Show, Ord) + +data LexemeRanking + = LexemeRanking { position :: Int, weight :: Char } + deriving (Eq, Show, Ord) + +instance FromField TSVector where + fromField f v = + if typeOid f /= $(inlineTypoid tsvector) + then returnError Incompatible f "" + else case v of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly parseTSVector bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + +-- 'a:1A fat:2B,4C cat:5D' +-- 'descript':4 'one':1,3 'titl':2 +parseTSVector :: Parser ByteString TSVector +parseTSVector = TSVector <$> many' parseLexeme + where + parseLexeme = do + skipSpace + + char '\'' + token <- Attoparsec.takeWhile (/= '\'') + char '\'' + + char ':' + ranking <- many1 do + skipMany $ char ',' + + position <- double + -- The Default Weight Is `D` So Postgres Does Not Include It In The Result + weight <- option 'D' $ choice [char 'A', char 'B', char 'C', char 'D'] + pure $ LexemeRanking { position = truncate position, weight } + + pure $ Lexeme { token = Text.decodeUtf8 token, ranking } + + +instance ToField TSVector where + toField = serializeTSVector + +serializeTSVector :: TSVector -> Action +serializeTSVector (TSVector lexemes) = Many $ map serializeLexeme lexemes + where + serializeLexeme Lexeme { token, ranking } = Many + [ Plain $ byteString $ Text.encodeUtf8 token + , toField ':' + , Many $ intersperse (toField ',') (map serializeLexemeRanking ranking) + ] + serializeLexemeRanking LexemeRanking { position, weight } = Many [toField position, toField weight] + +instance ToField Char where + toField char = Plain $ charUtf8 char diff --git a/IHP/Postgres/TimeParser.hs b/IHP/Postgres/TimeParser.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/TimeParser.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes, RecordWildCards #-} +module IHP.Postgres.TimeParser where + +import BasicPrelude hiding (takeWhile) +import Data.Attoparsec.ByteString.Char8 +import Data.Bits ((.&.)) +import Data.Char (ord) + +import Data.Fixed (Pico, Fixed(MkFixed)) +import Data.Time.Clock.Compat (NominalDiffTime) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Time.LocalTime.Compat as Local + +--Simple newtype wrapper around a postgres interval bytestring. +newtype PGInterval = PGInterval ByteString deriving (Eq, Show) + +-- The mapping of the "interval" bytestring into application +-- logic depends on the Interval Output Style of the postgres database +-- and the semantics of the interval quantity in the application code (if they differ from the postgres +-- interpretation for some reason). +-- This module provides the PGInterval wrapper type and a parser for the default +-- `postgres` output style into a a PGTimeInterval data struct of years, months, days, and NominalDiffTime. +-- These can be combined with the standard Calendar/Time library to perform Calendar Arithmetic +-- Days and Years are big Integers and can be added to the Gregorian year and Julian Day respectively +-- Months are small Int (up to 1-11) denoting a month of the year, and the pgClock is a Nominal DiffTime +-- representing the time as measured by a clock without leap seconds. + +data PGTimeInterval = PGTimeInterval { pgYears :: !Integer + , pgMonths :: !Int + , pgDays :: !Integer + , pgClock :: !NominalDiffTime } deriving (Eq, Show) + +-- To support the default postgres output style PGInterval -> PGTimeInterval +-- in Application Code we provide the parser combinators for the `postgres` output style. +-- for parsing (optional combination of): Y year[s] M mon[s] D day[s] [-]HH:MM:SS.[SSSs]. +-- This corresponds to the default interval `postgres` format. +-- (https://www.postgresql.org/docs/current/datatype-datetime.html). +-- alternative parsers would need to be provided for the `sql_standard`, `postgres_verbose`, and `iso_8601` +-- styles/ + +unpackInterval :: PGInterval -> PGTimeInterval +unpackInterval (PGInterval bs) = case parseOnly pPGInterval bs of + Left err -> error ("Couldn't parse PGInterval. " <> err) + Right val -> val + + +pPGInterval :: Parser PGTimeInterval +pPGInterval = do + year <- option 0 ((signed decimal <* space <* (string "years" <|> string "year"))) + skipSpace + mons <- option 0 ((signed decimal <* space <* (string "mons" <|> string "mon"))) + skipSpace + days <- option 0 ((signed decimal <* space <* (string "days" <|> "day"))) + skipSpace + timeOfDay <- option 0 nominalDiffTime + pure (PGTimeInterval year mons days timeOfDay) + + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + pure $! c2d a * 10 + c2d b + + +-- Take from Postgresql Internal to facilitate a definition of a NominalDiffTime FromField +-- | See https://stackoverflow.com/questions/32398878/converting-postgres-interval-to-haskell-nominaltimediff-with-postgresql-simple +-- | +-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser +-- Copyright: (c) 2012-2015 Leon P Smith +-- (c) 2015 Bryan O'Sullivan +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Parsers for parsing dates and times. + +toPico :: Integer -> Pico +toPico = MkFixed +-- | Parse a time of the form @HH:MM[:SS[.SSS]]@. + +pClockInterval :: Parser Local.TimeOfDay +pClockInterval = do + h <- twoDigits <* char ':' + m <- twoDigits + mc <- peekChar + s <- case mc of + Just ':' -> anyChar *> seconds + _ -> return 0 + if h < 24 && m < 60 && s <= 60 + then return (Local.TimeOfDay h m s) + else fail "invalid time" + +-- | Parse a count of seconds, with the integer part being two digits +-- long. +seconds :: Parser Pico +seconds = do + real <- twoDigits + mc <- peekChar + case mc of + Just '.' -> do + t <- anyChar *> takeWhile1 isDigit + pure $! parsePicos (fromIntegral real) t + _ -> pure $! fromIntegral real + where + parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) + where n = max 0 (12 - B8.length t) + t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 + (B8.take 12 t) + +nominalDiffTime :: Parser NominalDiffTime +nominalDiffTime = do + (h, m, s) <- pClockTime + pure . fromRational . toRational $ s + 60*(fromIntegral m) + 60*60*(fromIntegral h) + + +-- | Parse a limited postgres interval of the form [-]HHH:MM:SS.[SSSS] (no larger units than hours). +pClockTime :: Parser (Int, Int, Pico) +pClockTime = do + h <- try $ signed decimal <* char ':' + m <- try $ twoDigits <* char ':' + s <- try seconds + pure (h,m,s) diff --git a/IHP/Postgres/TypeInfo.hs b/IHP/Postgres/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/IHP/Postgres/TypeInfo.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: IHP.Postgres.TypeInfo +Description: Extension Of The Database.PostgreSQL.Simple.TypeInfo Module +Copyright: (c) digitally induced GmbH, 2021 +-} +module IHP.Postgres.TypeInfo where + +import Database.PostgreSQL.Simple.FromField + +tsvector :: TypeInfo +tsvector = Basic { + typoid = tsvectorOid, + typcategory = 'U', + typdelim = ',', + typname = "tsvector" + } + +-- `SELECT oid, typname FROM pg_type WHERE typname ~ 'tsvector';` +tsvectorOid :: Oid +tsvectorOid = Oid 3614 +{-# INLINE tsvector #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# ihp-postgres-simple-extra + +This package is included by default in IHP apps and implements support for postgres data types that are not supported by the `postgresql-simple` package by default: + +- `INET` +- `INTERVAL` +- `POINT` +- `POLYGON` +- `TSVECTOR` diff --git a/Test/Postgres/Interval.hs b/Test/Postgres/Interval.hs new file mode 100644 --- /dev/null +++ b/Test/Postgres/Interval.hs @@ -0,0 +1,21 @@ +{-| +Module: Test.Postgres.Interval +Copyright: (c) digitally induced GmbH, 2023 +-} +module Test.Postgres.Interval where + +import Test.Hspec +import IHP.Postgres.Interval +import IHP.Postgres.TimeParser +import Database.PostgreSQL.Simple.ToField +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec + +tests = do + describe "Interval" do + describe "Parser" do + it "Should Parse" do + unpackInterval (PGInterval "25 years 6 mons 4 days 114:00:00.123") `shouldBe` (PGTimeInterval 25 6 4 410400.123) + it "Should Parse" do + unpackInterval (PGInterval "25 years 01:00:00") `shouldBe` (PGTimeInterval 25 0 0 3600) + it "Should Parse" do + unpackInterval (PGInterval "11 years 10 mons 683 days") `shouldBe` (PGTimeInterval 11 10 683 0) diff --git a/Test/Postgres/Point.hs b/Test/Postgres/Point.hs new file mode 100644 --- /dev/null +++ b/Test/Postgres/Point.hs @@ -0,0 +1,26 @@ +{-| +Module: Test.Postgres.Point +Copyright: (c) digitally induced GmbH, 2021 +-} +module Test.Postgres.Point where + +import Data.Either +import Test.Hspec +import Test.Postgres.Support () +import IHP.Postgres.Point +import Database.PostgreSQL.Simple.ToField +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec + +tests = do + let raw = "(100,200)" + let parsed = Point { x = 100.0, y = 200.0 } + let serialized = Many [ Plain "point(", Plain "100.0", Plain ",", Plain "200.0",Plain ")" ] + + describe "Point" do + describe "Parser" do + it "Should Parse" do + Attoparsec.parseOnly parsePoint raw `shouldBe` Right parsed + + describe "Serializer" do + it "Should Serialize" do + serializePoint parsed `shouldBe` serialized diff --git a/Test/Postgres/Polygon.hs b/Test/Postgres/Polygon.hs new file mode 100644 --- /dev/null +++ b/Test/Postgres/Polygon.hs @@ -0,0 +1,50 @@ +{-| +Module: Test.Postgres.Polygon +Copyright: (c) digitally induced GmbH, 2022 +-} +module Test.Postgres.Polygon where + +import CorePrelude +import Data.Either +import Test.Hspec +import Test.Postgres.Support +import IHP.Postgres.Point +import IHP.Postgres.Polygon +import Database.PostgreSQL.Simple.ToField +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec + +tests = do + let rawPoint1 = "(100,200)" + let parsedPoint1 = Point { x = 100, y = 200 } + let rawPoint2 = "(300,400)" + let parsedPoint2 = Point { x = 300, y = 400 } + let raw = "(" <> rawPoint1 <> "," <> rawPoint2 <> ")" + let parsed = Polygon { points = [ parsedPoint1, parsedPoint2 ] } + let serialized = Many + [ Plain "polygon'" + , Many + [ Plain "(" + , Plain "100.0" + , Plain "," + , Plain "200.0" + , Plain ")" + ] + , Plain "," + , Many + [ Plain "(" + , Plain "300.0" + , Plain "," + , Plain "400.0" + , Plain ")" + ] + , Plain "'" + ] + + describe "Polygon" do + describe "Parser" do + it "Should Parse" do + Attoparsec.parseOnly parsePolygon raw `shouldBe` Right parsed + + describe "Serializer" do + it "Should Serialize" do + serializePolygon parsed `shouldBe` serialized diff --git a/Test/Postgres/Support.hs b/Test/Postgres/Support.hs new file mode 100644 --- /dev/null +++ b/Test/Postgres/Support.hs @@ -0,0 +1,15 @@ +{-| +Module: Test.Postgres.Support +Copyright: (c) digitally induced GmbH, 2021 +-} +module Test.Postgres.Support where + +import Prelude +import Data.ByteString.Builder (toLazyByteString) +import Database.PostgreSQL.Simple.ToField +import qualified Data.ByteString.Builder as Builder + +deriving instance Eq Action + +instance Eq Builder.Builder where + a == b = (Builder.toLazyByteString a) == (Builder.toLazyByteString b) diff --git a/Test/Postgres/TSVector.hs b/Test/Postgres/TSVector.hs new file mode 100644 --- /dev/null +++ b/Test/Postgres/TSVector.hs @@ -0,0 +1,44 @@ +{-| +Module: Test.Postgres.TSVector +Copyright: (c) digitally induced GmbH, 2021 +-} +module Test.Postgres.TSVector where + +import Prelude +import Test.Hspec +import Test.Postgres.Support +import IHP.Postgres.TSVector +import Database.PostgreSQL.Simple.ToField +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec + +tests = do + let raw = "'dummi':9 'industri':16 'ipsum':4,6 'lorem':3,5 'print':13 'simpli':8 'text':10 'typeset':15" + let parsed = TSVector + [ Lexeme { token = "dummi", ranking = [ LexemeRanking { position = 9, weight = 'D'} ] } + , Lexeme { token = "industri", ranking = [ LexemeRanking { position = 16, weight = 'D' } ] } + , Lexeme { token = "ipsum", ranking = [ LexemeRanking { position = 4, weight = 'D' }, LexemeRanking { position = 6, weight = 'D'} ] } + , Lexeme { token = "lorem", ranking = [ LexemeRanking { position = 3, weight = 'D' }, LexemeRanking { position = 5, weight = 'D'} ] } + , Lexeme { token = "print", ranking = [ LexemeRanking { position = 13, weight = 'D' } ] } + , Lexeme { token = "simpli", ranking = [ LexemeRanking { position = 8, weight = 'D' } ] } + , Lexeme { token = "text", ranking = [ LexemeRanking { position = 10, weight = 'D' } ] } + , Lexeme { token = "typeset", ranking = [ LexemeRanking { position = 15, weight = 'D' } ] } + ] + let serialized = Many + [ Many [ Plain "dummi", Plain ":", Many [ Many [ Plain "9", Plain "D" ] ] ] + , Many [ Plain "industri", Plain ":", Many [ Many [ Plain "16", Plain "D" ] ] ] + , Many [ Plain "ipsum", Plain ":", Many [ Many [ Plain "4", Plain "D" ], Plain ",", Many [ Plain "6", Plain "D" ] ] ] + , Many [ Plain "lorem", Plain ":", Many [ Many [ Plain "3", Plain "D" ], Plain ",", Many [ Plain "5", Plain "D" ] ] ] + , Many [ Plain "print", Plain ":", Many [ Many [ Plain "13", Plain "D" ] ] ] + , Many [ Plain "simpli", Plain ":", Many [ Many [ Plain "8", Plain "D" ] ] ] + , Many [ Plain "text", Plain ":", Many [ Many [ Plain "10", Plain "D" ] ] ] + , Many [ Plain "typeset", Plain ":", Many [ Many [ Plain "15", Plain "D" ] ] ] + ] + + describe "TSVector" do + describe "Parser" do + it "Should Parse" do + Attoparsec.parseOnly parseTSVector raw `shouldBe` Right parsed + + describe "Serializer" do + it "Should Serialize" do + serializeTSVector parsed `shouldBe` serialized diff --git a/Test/Spec.hs b/Test/Spec.hs new file mode 100644 --- /dev/null +++ b/Test/Spec.hs @@ -0,0 +1,16 @@ +module Main where + +import CorePrelude +import Test.Hspec + +import qualified Test.Postgres.Point +import qualified Test.Postgres.Polygon +import qualified Test.Postgres.Interval +import qualified Test.Postgres.TSVector + +main :: IO () +main = hspec do + Test.Postgres.Point.tests + Test.Postgres.Polygon.tests + Test.Postgres.Interval.tests + Test.Postgres.TSVector.tests diff --git a/ihp-postgresql-simple-extra.cabal b/ihp-postgresql-simple-extra.cabal new file mode 100644 --- /dev/null +++ b/ihp-postgresql-simple-extra.cabal @@ -0,0 +1,93 @@ +cabal-version: 2.2 +name: ihp-postgresql-simple-extra +version: 1.3.0 +synopsis: Extra data types for postgresql-simple +description: This package is included by default in IHP apps and implements support for postgres data types that are not supported by the postgresql-simple package by default +license: MIT +license-file: LICENSE +author: digitally induced GmbH +maintainer: support@digitallyinduced.com +bug-reports: https://github.com/digitallyinduced/ihp/issues +category: Database +build-type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp.git + +common shared-properties + default-language: Haskell2010 + build-depends: + base >= 4.17.0 && < 4.22 + , bytestring + , attoparsec + , basic-prelude + , text + , postgresql-simple + , ip + , time + , time-compat + , aeson + default-extensions: + OverloadedStrings + , NoImplicitPrelude + , ImplicitParams + , Rank2Types + , NamedFieldPuns + , TypeSynonymInstances + , FlexibleInstances + , DisambiguateRecordFields + , DuplicateRecordFields + , OverloadedLabels + , FlexibleContexts + , DataKinds + , QuasiQuotes + , TypeFamilies + , PackageImports + , ScopedTypeVariables + , RecordWildCards + , TypeApplications + , DataKinds + , InstanceSigs + , DeriveGeneric + , MultiParamTypeClasses + , TypeOperators + , DeriveDataTypeable + , DefaultSignatures + , BangPatterns + , FunctionalDependencies + , PartialTypeSignatures + , BlockArguments + , LambdaCase + , StandaloneDeriving + , TemplateHaskell + , OverloadedRecordDot + +library + import: shared-properties + hs-source-dirs: . + exposed-modules: + IHP.Postgres.TypeInfo + , IHP.Postgres.Point + , IHP.Postgres.Interval + , IHP.Postgres.TimeParser + , IHP.Postgres.Polygon + , IHP.Postgres.Inet + , IHP.Postgres.TSVector + +test-suite spec + import: shared-properties + type: exitcode-stdio-1.0 + other-modules: + Test.Postgres.Interval + , Test.Postgres.Point + , Test.Postgres.Polygon + , Test.Postgres.Support + , Test.Postgres.TSVector + hs-source-dirs: . + main-is: Test/Spec.hs + build-depends: + hspec >= 2.7 + , hspec-discover >= 2.7 + , ihp-postgresql-simple-extra