add postgres polygon support

IHP/Controller/Param.hs

@@ -366,6 +366,29 @@ instance ParamReader ModelSupport.Point where
     readParameterJSON (Aeson.String string) = let byteString :: ByteString = cs string in  readParameter byteString
     readParameterJSON _ = Left "Expected Point"
 
+instance ParamReader ModelSupport.Polygon where
+    {-# INLINABLE readParameter #-}
+    readParameter byteString =
+        let
+            pointParser = do
+                Attoparsec.char '('
+                x <- Attoparsec.double
+                Attoparsec.char ','
+                y <- Attoparsec.double
+                Attoparsec.char ')'
+                pure ModelSupport.Point { .. }
+            parser = do
+                points <- pointParser `Attoparsec.sepBy` (Attoparsec.char ',')
+                Attoparsec.endOfInput
+                pure ModelSupport.Polygon { .. }
+        in
+        case Attoparsec.parseOnly parser byteString of
+            Right value -> Right value
+            Left error -> Left "has to be points wrapped in parenthesis, separated with a comma, e.g. '(1,2),(3,4)'"
+
+    readParameterJSON (Aeson.String string) = let byteString :: ByteString = cs string in  readParameter byteString
+    readParameterJSON _ = Left "Expected Polygon"
+
 instance ParamReader Text where
     {-# INLINABLE readParameter #-}
     readParameter byteString = pure (cs byteString)

IHP/IDE/SchemaDesigner/Compiler.hs

@@ -146,6 +146,7 @@ compilePostgresType PTimestampWithTimezone = "TIMESTAMP WITH TIME ZONE"
 compilePostgresType PReal = "REAL"
 compilePostgresType PDouble = "DOUBLE PRECISION"
 compilePostgresType PPoint = "POINT"
+compilePostgresType PPolygon = "POLYGON"
 compilePostgresType PDate = "DATE"
 compilePostgresType PBinary = "BYTEA"
 compilePostgresType PTime = "TIME"

IHP/IDE/SchemaDesigner/Parser.hs

@@ -207,6 +207,7 @@ sqlType = choice $ map optionalArray
         , real
         , double
         , point
+        , polygon
         , date
         , binary
         , time
@@ -275,6 +276,10 @@ sqlType = choice $ map optionalArray
                     try (symbol' "POINT")
                     pure PPoint
 
+                polygon = do
+                    try (symbol' "POLYGON")
+                    pure PPolygon
+
                 date = do
                     try (symbol' "DATE")
                     pure PDate

IHP/IDE/SchemaDesigner/Types.hs

@@ -176,6 +176,7 @@ data PostgresType
     | PReal
     | PDouble
     | PPoint
+    | PPolygon
     | PDate
     | PBinary
     | PTime

IHP/IDE/SchemaDesigner/View/Columns/Edit.hs

@@ -126,6 +126,7 @@ typeSelector postgresType enumNames = [hsx|
                 {option isSelected "REAL" "Float"}
                 {option isSelected "DOUBLE PRECISION" "Double"}
                 {option isSelected "POINT" "Point"}
+                {option isSelected "POLYGON" "Polygon"}
                 {option isSelected "BYTEA" "Binary"}
                 {option isSelected "Time" "Time"}
                 {option isSelected "BIGSERIAL" "Bigserial"}

IHP/ModelSupport.hs

@@ -3,6 +3,7 @@
 module IHP.ModelSupport
 ( module IHP.ModelSupport
 , module IHP.Postgres.Point
+, module IHP.Postgres.Polygon
 , module IHP.Postgres.Inet
 , module IHP.Postgres.TSVector
 ) where
@@ -38,6 +39,7 @@ import qualified Text.Read as Read
 import qualified Data.Pool as Pool
 import qualified GHC.Conc
 import IHP.Postgres.Point
+import IHP.Postgres.Polygon
 import IHP.Postgres.Inet ()
 import IHP.Postgres.TSVector
 import IHP.Log.Types
@@ -173,6 +175,9 @@ instance Default Bool where
 instance Default Point where
     def = Point def def
 
+instance Default Polygon where
+    def = Polygon [def]
+
 instance Default TSVector where
     def = TSVector def
 

IHP/Postgres/Polygon.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-|
+Module: IHP.Postgres.Polygon
+Description: Adds support for the Postgres Polygon type
+Copyright: (c) digitally induced GmbH, 2020
+-}
+module IHP.Postgres.Polygon 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 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 ')')
+            ]

IHP/SchemaCompiler.hs

@@ -70,6 +70,7 @@ atomicType = \case
     (PCharacterN _) -> "Text"
     PArray type_ -> "[" <> atomicType type_ <> "]"
     PPoint -> "Point"
+    PPolygon -> "Polygon"
     PInet -> "Net.IP.IP"
     PTSVector -> "TSVector"
 

Test/Controller/ParamSpec.hs

@@ -224,6 +224,23 @@ tests = do
                     (readParameterJSON @Point (json "\"1\"")) `shouldBe` (Left "has to be two numbers with a comma, e.g. '1,2'")
                     (readParameterJSON @Point (json "\"1.2\"")) `shouldBe` (Left "has to be two numbers with a comma, e.g. '1,2'")
 
+            describe "Polygon" do
+                it "should accept integer input" do
+                    (readParameter @Polygon "(100,200),(300,400)") `shouldBe`
+                        (Right Polygon { points = [ Point { x = 100, y = 200 }, Point { x = 300, y = 400 } ] })
+
+                it "should accept floating-point input" do
+                    (readParameter @Polygon "(100.1,200.2),(300.3,400.4)") `shouldBe`
+                        (Right Polygon { points = [ Point { x = 100.1, y = 200.2 }, Point { x = 300.3, y = 400.4 } ] })
+
+                it "should accept JSON integer input" do
+                    (readParameterJSON @Polygon (json "\"(100,200),(300,400)\"")) `shouldBe`
+                        (Right Polygon { points = [ Point { x = 100, y = 200 }, Point { x = 300, y = 400 } ] })
+
+                it "should accept JSON floating-point input" do
+                    (readParameterJSON @Polygon (json "\"(100.1,200.2),(300.3,400.4)\"")) `shouldBe`
+                        (Right Polygon { points = [ Point { x = 100.1, y = 200.2 }, Point { x = 300.3, y = 400.4 } ] })
+
             describe "Text" do
                 it "should handle text input" do
                     (readParameter @Text "test") `shouldBe` (Right "test")

Test/IDE/SchemaDesigner/CompilerSpec.hs

@@ -391,6 +391,16 @@ tests = do
                     }
             compileSql [statement] `shouldBe` sql
 
+        it "should compile a CREATE TABLE statement with an polygon column" do
+            let sql = cs [plain|CREATE TABLE polygon_tests (\n    poly POLYGON\n);\n|]
+            let statement = StatementCreateTable CreateTable
+                    { name = "polygon_tests"
+                    , columns = [ col { name = "poly", columnType = PPolygon } ]
+                    , primaryKeyConstraint = PrimaryKeyConstraint []
+                    , constraints = []
+                    }
+            compileSql [statement] `shouldBe` sql
+
         it "should compile a CREATE INDEX statement" do
             let sql = cs [plain|CREATE INDEX users_index ON users (user_name);\n|]
             let statement = CreateIndex

Test/IDE/SchemaDesigner/ParserSpec.hs

@@ -418,6 +418,14 @@ tests = do
                     , constraints = []
                     }
 
+        it "should parse a CREATE TABLE statement with a polygon column" do
+            parseSql "CREATE TABLE polygons (\n    poly POLYGON\n);\n" `shouldBe` StatementCreateTable CreateTable
+                    { name = "polygons"
+                    , columns = [ col { name = "poly", columnType = PPolygon } ]
+                    , primaryKeyConstraint = PrimaryKeyConstraint []
+                    , constraints = []
+                    }
+
         it "should parse a CREATE INDEX statement" do
             parseSql "CREATE INDEX users_index ON users (user_name);\n" `shouldBe` CreateIndex
                     { indexName = "users_index"

Test/Main.hs

@@ -42,6 +42,7 @@ import qualified Test.RouterSupportSpec
 import qualified Test.ServerSideComponent.HtmlParserSpec
 import qualified Test.ServerSideComponent.HtmlDiffSpec
 import qualified Test.Postgres.Point
+import qualified Test.Postgres.Polygon
 import qualified Test.Postgres.TSVector
 import qualified Test.FileStorage.MimeTypesSpec
 import qualified Test.DataSync.DynamicQueryCompiler
@@ -74,6 +75,7 @@ main = hspec do
     Test.ServerSideComponent.HtmlParserSpec.tests
     Test.ServerSideComponent.HtmlDiffSpec.tests
     Test.Postgres.Point.tests
+    Test.Postgres.Polygon.tests
     Test.Postgres.TSVector.tests
     Test.FileStorage.MimeTypesSpec.tests
     Test.DataSync.DynamicQueryCompiler.tests

Test/Postgres/Polygon.hs

@@ -0,0 +1,49 @@
+{-|
+Module: Test.Postgres.Polygon
+Copyright: (c) digitally induced GmbH, 2021
+-}
+module Test.Postgres.Polygon where
+
+import Test.Hspec
+import Test.Postgres.Support
+import IHP.Prelude
+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

ihp.cabal

@@ -248,6 +248,7 @@ library
         , IHP.Version
         , IHP.Postgres.TypeInfo
         , IHP.Postgres.Point
+        , IHP.Postgres.Polygon
         , IHP.Postgres.Inet
         , IHP.Postgres.TSVector
         , Paths_ihp