packages feed

poseidon-postgis (empty) → 0.1.1.0

raw patch · 6 files changed

+312/−0 lines, 6 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, binary, bytestring, geojson, hspec, poseidon, postgresql-libpq, scientific, text, time, unordered-containers, uuid, wkt-geom

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for poseidon-postgis++## 0.1.1.0 -- 2019-09-28++* First version. Released on an unsuspecting world.
+ Data/Poseidon/Postgis.hs view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ poseidon-postgis.cabal view
@@ -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
+ tests/Tests.hs view
@@ -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)