diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for poseidon-postgis + +## 0.1.1.0 -- 2019-09-28 + +* First version. Released on an unsuspecting world. diff --git a/Data/Poseidon/Postgis.hs b/Data/Poseidon/Postgis.hs new file mode 100644 --- /dev/null +++ b/Data/Poseidon/Postgis.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Poseidon.Postgis +-- Copyright : (c) 2019 Florian Grignon +-- License : BSD3 +-- +-- Maintainer : grignon.florian@gmail.com +-- Stability : experimental +-- +-- This library provide a Simple and Extensible access to PostgreSQL. +-- +-- Simple: Poseidon runs a SQL query and returns a set of custom datatype. +-- **It is not an ORM.** +-- +-- Extensible: As a user of the library, you can map your custom PostgreSQL +-- type to your Haskell datatype easily, in a pluggable way (e.g. if you're +-- using postgis, you will be most likely interested by poseidon-postgis, +-- that maps GeoJSON WKT to GeospatialGeometry). +-- +----------------------------------------------------------------------------- +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Poseidon.Postgis where + +import GHC.Generics + +import Data.Geospatial.Internal.Geometry + +import Control.Monad +import Database.Poseidon.Internal +import Database.Poseidon + +import Prelude (error) + +import System.IO +import Text.Show +import Control.Applicative +import Data.Function +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Monoid +import Data.Either +import Data.Maybe +import Data.Binary.Get +import Data.Wkb + + +newtype PGGeospatialGeometry = PGGeospatialGeometry GeospatialGeometry + deriving (Generic, Show) + +toGeospatialGeometry :: PGGeospatialGeometry -> GeospatialGeometry +toGeospatialGeometry pgGeospatialGeometry = case pgGeospatialGeometry of + PGGeospatialGeometry value' -> value' + +deserializeGeospatialGeometry :: BSL.ByteString -> PGGeospatialGeometry +deserializeGeospatialGeometry bs = do + let eitherParsed = parseByteString bs + case eitherParsed of + Right location' -> PGGeospatialGeometry $ location' + Left _ -> error "Impossible to decode location" + +instance Deserialize PGGeospatialGeometry where + deserialize res row col = do + bs <- (fromMaybe mempty) <$> getBSValue res row col + pure $ deserializeGeospatialGeometry bs + +instance Deserialize (Maybe PGGeospatialGeometry) where + deserialize res row col = do + bs <- getBSValue res row col + pure $ deserializeGeospatialGeometry <$> bs + +-- Location +parseWkbByteString :: BSL.ByteString -> IO PGGeospatialGeometry +parseWkbByteString bs = do + let eitherBS = parseByteString bs + case eitherBS of + Right wkb -> pure $ PGGeospatialGeometry wkb + Left errorStr -> error errorStr + +instance Deserialize [PGGeospatialGeometry] where + deserialize res row col = do + bs <- (fromMaybe mempty) <$> getBSValue res row col + let pgArray = runGet getPGArray bs + let words8 = fmap pgArrayDataData $ pgArrayData pgArray + let bsList = BS.pack <$> words8 + sequence $ (parseWkbByteString . BSL.fromStrict) <$> bsList diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, FlogFR + +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 FlogFR 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/poseidon-postgis.cabal b/poseidon-postgis.cabal new file mode 100644 --- /dev/null +++ b/poseidon-postgis.cabal @@ -0,0 +1,104 @@ +cabal-version: >=1.10 + +-- The name of the package. +name: poseidon-postgis + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.1.0 + +-- A short (one-line) description of the package. +synopsis: Extension of Poseidon library for Postgis (Spatial and Geographic objects for PostgreSQL) + +-- A longer description of the package. +description: + Extension of Poseidon library to manage Postgis objects from PostgreSQL extension. + +-- URL for the project homepage or repository. +homepage: https://github.com/FlogFr/poseidon-postgis + +-- A URL where users can report bugs. +bug-reports: https://github.com/FlogFr/poseidon-postgis/issues + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Florian Grignon + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: grignon.florian@gmail.com + +-- A copyright notice. +-- copyright: + +category: Database, PostgreSQL + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: CHANGELOG.md + + +library + -- Modules exported by the library. + exposed-modules: + Data.Poseidon.Postgis + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + ghc-options: -Wall + + -- Other library packages from which modules are imported. + build-depends: + base >=4.12.0.0 && <5 + , binary >=0.8.6.0 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , poseidon >=0.1.1.0 && <0.2 + , geojson >=4.0.1 && <4.1 + , wkt-geom >=0.0.10 && <0.1 + + -- Directories containing source files. + hs-source-dirs: . + + -- Base language which the package is written in. + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: Tests.hs + ghc-options: -Wall -threaded -rtsopts + + build-depends: + aeson >=1.4.5.0 && <1.5 + , binary >=0.8.6.0 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , base >=4.12.0.0 && <5 + , hspec >=2.7.1 && <2.8 + , QuickCheck >= 2.10.0.1 && < 2.14 + , poseidon >=0.1.1.0 && <0.2 + , text >=1.2 && <1.3 + , time >=1.9 && <1.10 + , scientific >=0.3.6.2 && <0.4 + , postgresql-libpq >=0.9.4 && <0.10 + , unordered-containers >=0.2.10.0 && <0.3 + , uuid >=1.3 && <1.14 + +source-repository head + type: git + location: git://github.com/FlogFr/poseidon-postgis.git diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main (main) where + +import Prelude +import GHC.Generics + +import Data.Aeson as A +import Data.List ((!!)) +import Database.PostgreSQL.LibPQ +import Data.Poseidon +import Database.Poseidon + +import Test.Hspec +import Data.Scientific +import Data.Time +import qualified Data.UUID as U +import Data.HashMap.Strict +import Data.ByteString as B +import Data.ByteString.Lazy as BSL +import Data.Text hiding (head) +import Data.Text.Encoding (encodeUtf8) + +data User = User { + first_name :: Text + , is_admin :: Bool + } deriving (Generic, Eq, Show) + +data UserDetails = UserDetails { + age :: Integer + , extra_values :: Value + } deriving (Generic, Eq, Show) + +main :: IO () +main = do + conn <- connectdb . encodeUtf8 $ "service=test" + hspec $ do + describe "Single Value Deserialization tests" $ do + it "Single Value Text deserialization" $ do + dataResult <- queryFromText conn "SELECT CAST('Florian :)' AS TEXT);" mempty :: IO [PGText] + let resultExpected = "Florian :)" + resultExpected `shouldBe` (toText $ dataResult!!0) + it "Single Value Bool deserialization" $ do + dataResult <- queryFromText conn "SELECT CAST('t' AS BOOL);" mempty :: IO [PGBool] + let resultExpected = True + resultExpected `shouldBe` (toBool $ dataResult!!0) + it "Single Value Timestamp With TZ deserialization" $ do + dataResult <- queryFromText conn "SELECT CAST('2019-09-24 02:04:23+1' AS TIMESTAMPTZ);" mempty :: IO [PGTimestamp] + let resultExpected = UTCTime (ModifiedJulianDay 58750) (secondsToDiffTime 3863) + resultExpected `shouldBe` (toUTCTime $ dataResult!!0) + it "Single Value UUID deserialization" $ do + dataResult <- queryFromText conn "SELECT CAST('0cfa19ce-eed9-42f8-87b2-64f97dc27770' AS UUID);" mempty :: IO [PGUUID] + let resultExpected = U.fromString "0cfa19ce-eed9-42f8-87b2-64f97dc27770" + resultExpected `shouldBe` (Just (toUUID $ dataResult!!0)) + it "Single Value JSON deserialization" $ do + jsonResult <- queryFromText conn "SELECT '{\"username\": \"florian728\", \"age\": 28}'::JSON ;" mempty :: IO [PGJsonValue] + let resultExpected = A.Object . fromList $ [("username", "florian728"), ("age", A.Number ( read "28" :: Scientific ) )] + resultExpected `shouldBe` (toValue $ jsonResult!!0) + it "Single Value Strict Binary deserialization" $ do + jsonResult <- queryFromText conn "SELECT CAST(E'\\120\\121' AS BYTEA) ;" mempty :: IO [PGByteString] + let resultExpected = B.pack [80, 81] + resultExpected `shouldBe` (toByteString $ jsonResult!!0) + it "Single Value Lazy Binary deserialization" $ do + jsonResult <- queryFromText conn "SELECT CAST(E'\\120\\121' AS BYTEA) ;" mempty :: IO [PGLazyByteString] + let resultExpected = BSL.pack [80, 81] + resultExpected `shouldBe` (toLazyByteString $ jsonResult!!0) + describe "User Datatype Deserialization tests" $ do + it "Full User deserialization" $ do + dataResult <- queryFromText conn "SELECT CAST('Florian :)' AS TEXT), CAST('t' AS BOOL);" mempty :: IO [User] + let resultExpected = User "Florian :)" True + resultExpected `shouldBe` (dataResult!!0) + it "Full UserDetails deserialization" $ do + dataResult <- queryFromText conn "SELECT CAST(28 AS SMALLINT), CAST('{\"paid_user\": true, \"registered_at\": \"2019-08-27\"}' AS JSON);" mempty :: IO [UserDetails] + let resultExpected = UserDetails 28 (A.Object . fromList $ [("paid_user", A.Bool True), ("registered_at", "2019-08-27")]) + resultExpected `shouldBe` (dataResult!!0)