typson-esqueleto (empty) → 0.1.0.0

raw patch · 8 files changed

+361/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, esqueleto, exceptions, hedgehog, microlens, persistent, persistent-postgresql, persistent-template, postgresql-simple, tasty, tasty-hedgehog, tasty-hunit, test-fixture, text, typson-core, typson-esqueleto

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
src/Typson/Esqueleto.hs +90/−0
test/Spec.hs +138/−0
test/Typson/Test/Esqueleto/DbSchema.hs +22/−0
typson-esqueleto.cabal +75/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for typson-esqueleto++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Aaron Allen (c) 2020++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 Aaron Allen 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.

+ README.md view

@@ -0,0 +1,1 @@+# typson-esqueleto

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Typson/Esqueleto.hs view

@@ -0,0 +1,90 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+--------------------------------------------------------------------------------+-- |+-- Module      : Typson.Esqueleto+-- Description : Provides the Esqueleto integration+-- Copyright   : (c) Aaron Allen, 2020+-- Maintainer  : Aaron Allen <aaronallen8455@gmail.com>+-- License     : BSD-style (see the file LICENSE)+-- Stability   : experimental+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Typson.Esqueleto+  ( jsonPath+  , NullableJSONB(..)+  , PostgreSqlJSON+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import           Data.Bifunctor (first)+import           Data.List (foldl')+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified Database.Esqueleto as E+import qualified Database.Esqueleto.PostgreSQL.JSON as E+import qualified Database.Esqueleto.Internal.Internal as E+import           GHC.Generics (Generic)++import           Typson++-- | Use a type-safe JSON path as part of a query.+--+-- @+-- select . from $ \entity ->+--   pure . jsonPath (Proxy @("foo" :-> "bar")) fieldSchemaJ+--     $ entity ^. Field+-- @+jsonPath :: ( TypeAtPath o tree path ~ field+            , ReflectPath path+            , PostgreSqlJSON json+            )+         => proxy (path :: k) -- ^ A path proxy+         -> ObjectTree tree o -- ^ Typson schema+         -> E.SqlExpr (E.Value (json o)) -- ^ Column selector+         -> E.SqlExpr (E.Value (NullableJSONB field))+jsonPath path _ input =+  case reflectPath path of+    p NE.:| ps -> foldl' buildPath (buildPath input p) ps+  where+    buildPath p (Key k) = p `arrOp` E.val k+    buildPath p (Idx i) = p `arrOp` E.val (fromIntegral i :: Int)+    arrOp = E.unsafeSqlBinOp " -> "++-- | Treats SQL @NULL@ as a JSON @null@+newtype NullableJSONB a =+  NullableJSONB+    { unNullableJSONB :: a+    } deriving ( Generic+               , Aeson.FromJSON+               , Aeson.ToJSON+               , Foldable+               , Functor+               , Eq+               , Ord+               , Read+               , Show+               , Traversable+               )+      deriving E.PersistFieldSql via (E.JSONB a)++instance (Aeson.FromJSON a, Aeson.ToJSON a)+      => E.PersistField (NullableJSONB a) where+  toPersistValue = E.toPersistValue . E.JSONB . unNullableJSONB+  fromPersistValue pVal = fmap NullableJSONB $ case pVal of+      E.PersistNull -> first T.pack+                     $ Aeson.parseEither Aeson.parseJSON Aeson.Null+      _ -> E.unJSONB <$> E.fromPersistValue pVal++-- | Members of this class are type constructors used to respresent+-- Postgres JSON columns.+class PostgreSqlJSON (json :: * -> *)+instance PostgreSqlJSON NullableJSONB+instance PostgreSqlJSON E.JSONB

+ test/Spec.hs view

@@ -0,0 +1,138 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++import           Control.Monad (void)+import           Control.Monad.Catch (handleAll)+import qualified Data.ByteString.Char8 as BS+import           Data.List (sort)+import qualified Database.Esqueleto as E+import qualified Database.Esqueleto.PostgreSQL.JSON as E+import qualified Database.Persist.Postgresql as P+import qualified Database.PostgreSQL.Simple as Pg+import qualified Hedgehog.Gen as HH+import qualified Hedgehog.Range as HH+import           System.Environment (lookupEnv)+import           Test.Tasty+import           Test.Tasty.HUnit++import           Typson.Esqueleto+import           Typson.Test.Esqueleto.DbSchema (EsqueletoEntity(..), EntityField(EsqueletoEntityGraph), migrateAll)+import           Typson.Test.Generators+import           Typson.Test.Types++main :: IO ()+main = defaultMain esqueletoTestTree++esqueletoTestTree :: TestTree+esqueletoTestTree = withRunDb $ \runDb ->+  testGroup "Esqueleto Tests"+  [ testCase "JSON Queries" $ do+      graphs <- HH.sample (HH.list (HH.singleton 100) bazGen)+      runDb (insertData graphs)++      r1 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath basicPath1 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a1 = E.Value . NullableJSONB . basicPath1Getter <$> graphs+      assertEqual "Basic Path 1" (sort r1) (sort a1)++      r2 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath basicPath2 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a2 = E.Value . NullableJSONB . basicPath2Getter <$> graphs+      assertEqual "Basic Path 2" (sort r2) (sort a2)++      r3 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath basicPath3 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a3 = E.Value . NullableJSONB . basicPath3Getter <$> graphs+      assertEqual "Basic Path 3" (sort r3) (sort a3)++      r4 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath optionalPath1 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a4 = E.Value . NullableJSONB . optionalPath1Getter <$> graphs+      assertEqual "Optional Path 1" (sort r4) (sort a4)++      r5 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath optionalPath2 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a5 = E.Value . NullableJSONB . optionalPath2Getter <$> graphs+      assertEqual "Optional Path 2" (sort r5) (sort a5)++      r6 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath optionalPath3 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a6 = E.Value . NullableJSONB . optionalPath3Getter <$> graphs+      assertEqual "Optional Path 3" (sort r6) (sort a6)++      r7 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath listIdxPath1 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a7 = E.Value . NullableJSONB . listIdxPath1Getter <$> graphs+      assertEqual "List Idx Path 1" (sort r7) (sort a7)++      r8 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath listIdxPath2 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a8 = E.Value . NullableJSONB . listIdxPath2Getter <$> graphs+      assertEqual "List Idx Path 2" (sort r8) (sort a8)++      r9 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath listIdxPath3 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a9 = E.Value . NullableJSONB . listIdxPath3Getter <$> graphs+      assertEqual "List Idx Path 3" (sort r9) (sort a9)++      r10 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath unionPath1 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a10 = E.Value . NullableJSONB . unionPath1Getter <$> graphs+      assertEqual "Union Path 1" (sort r10) (sort a10)++      r11 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath unionPath2 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a11 = E.Value . NullableJSONB . unionPath2Getter <$> graphs+      assertEqual "Union Path 2" (sort r11) (sort a11)++      r12 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath textMapPath1 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a12 = E.Value . NullableJSONB . textMapPath1Getter <$> graphs+      assertEqual "Text Map Path 1" (sort r12) (sort a12)++      r13 <- runDb . E.select . E.from $ \entity ->+              pure . jsonPath textMapPath2 bazJ+                $ entity E.^. EsqueletoEntityGraph+      let a13 = E.Value . NullableJSONB . textMapPath2Getter <$> graphs+      assertEqual "Text Map Path 2" (sort r13) (sort a13)+  ]++type DbRunner = forall b. P.SqlPersistT IO b -> IO b++withRunDb :: (DbRunner -> TestTree) -> TestTree+withRunDb mkTree = withDb $ \ioBackend -> mkTree $ \action -> do+  backend <- ioBackend+  P.runSqlConn action backend++withDb :: (IO P.SqlBackend -> TestTree) -> TestTree+withDb = withResource connectToDb P.connClose++connectToDb :: IO P.SqlBackend+connectToDb = do+  Just connString <- lookupEnv "CONN_STRING"+  conn <- Pg.connectPostgreSQL $ BS.pack connString+  backend <- P.openSimpleConn (\_ _ _ _ -> pure ()) conn++  -- reset the table+  _ <- handleAll (const $ pure 0) $ Pg.execute_ conn "DROP TABLE \"esqueleto_entity\""++  P.runSqlConn (P.runMigration migrateAll) backend++  pure backend++insertData :: [Baz] -> P.SqlPersistT IO ()+insertData graphs =+  void $ P.insertMany (EsqueletoEntity . E.JSONB <$> graphs)

+ test/Typson/Test/Esqueleto/DbSchema.hs view

@@ -0,0 +1,22 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Typson.Test.Esqueleto.DbSchema where++import qualified Database.Esqueleto.PostgreSQL.JSON as E+import qualified Database.Persist.TH as P++import           Typson.Test.Types (Baz)++P.share [P.mkPersist P.sqlSettings, P.mkMigrate "migrateAll"] [P.persistLowerCase|+EsqueletoEntity+  graph (E.JSONB Baz)+  deriving Show Eq+|]

+ typson-esqueleto.cabal view

@@ -0,0 +1,75 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 7a0e7aa5be266845f2d78a10d41cc445864d4f220224bf926e92d1df3b1a119c++name:           typson-esqueleto+version:        0.1.0.0+synopsis:       Typson Esqueleto Integration+description:    Please see the README on GitHub at <https://github.com/aaronallen8455/typson#readme>+category:       Database+homepage:       https://github.com/aaronallen8455/typson#readme+bug-reports:    https://github.com/aaronallen8455/typson/issues+author:         Aaron Allen+maintainer:     aaronallen8455@gmail.com+copyright:      2020 Aaron Allen+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/aaronallen8455/typson++library+  exposed-modules:+      Typson.Esqueleto+  other-modules:+      Paths_typson_esqueleto+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , esqueleto+    , persistent+    , persistent-template+    , text+    , typson-core+  default-language: Haskell2010++test-suite typson-esqueleto-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Typson.Test.Esqueleto.DbSchema+      Paths_typson_esqueleto+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , esqueleto+    , exceptions+    , hedgehog+    , microlens+    , persistent+    , persistent-postgresql+    , persistent-template+    , postgresql-simple+    , tasty+    , tasty-hedgehog+    , tasty-hunit+    , test-fixture+    , text+    , typson-core+    , typson-esqueleto+  default-language: Haskell2010