diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for typson-esqueleto + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# typson-esqueleto 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/src/Typson/Esqueleto.hs b/src/Typson/Esqueleto.hs new file mode 100644 --- /dev/null +++ b/src/Typson/Esqueleto.hs @@ -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 +-- 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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) diff --git a/test/Typson/Test/Esqueleto/DbSchema.hs b/test/Typson/Test/Esqueleto/DbSchema.hs new file mode 100644 --- /dev/null +++ b/test/Typson/Test/Esqueleto/DbSchema.hs @@ -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 +|] diff --git a/typson-esqueleto.cabal b/typson-esqueleto.cabal new file mode 100644 --- /dev/null +++ b/typson-esqueleto.cabal @@ -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 +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