packages feed

typson-beam (empty) → 0.1.0.0

raw patch · 8 files changed

+398/−0 lines, 8 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, beam-core, beam-migrate, beam-postgres, bytestring, exceptions, hedgehog, microlens, postgresql-simple, tasty, tasty-hedgehog, tasty-hunit, test-fixture, typson-beam, typson-core

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for typson-beam++## 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-beam
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Typson/Beam.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+--------------------------------------------------------------------------------+-- |+-- Module      : Typson.Beam+-- Description : Provides the Beam 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.Beam+  ( jsonPath+  , JNullable(..)+  , nullableJsonb+  , nullableJson+  ) where++import qualified Data.Aeson as Aeson+import           Data.Coerce (Coercible, coerce)+import           Data.Kind (Type)+import           Data.List (foldl')+import qualified Data.List.NonEmpty as NE+import           Data.Maybe (fromMaybe)+import           Data.String (fromString)+import qualified Database.Beam as B+import qualified Database.Beam.Backend.SQL.SQL92 as B (HasSqlValueSyntax)+import qualified Database.Beam.Postgres as B+import qualified Database.PostgreSQL.Simple.FromField as Pg++import           Typson++-- | Use a type-safe JSON path as part of a query.+--+-- @+-- select $ jsonPath (Proxy @("foo" :-> "bar")) fieldSchemaJ+--        . fieldAccessor+--      \<$> all_ someTable+-- @+jsonPath :: ( TypeAtPath o tree path ~ field+            , ReflectPath path+            , B.IsPgJSON json+            , Coercible (json field) (JNullable json' field)+            )+         => proxy (path :: k) -- ^ A path proxy+         -> ObjectTree tree o -- ^ Typson schema+         -> B.QGenExpr ctxt B.Postgres s (json o) -- ^ Column selector+         -> B.QGenExpr ctxt B.Postgres s (JNullable json' field)+jsonPath path _ input = coerce $+  case reflectPath path of+    p NE.:| ps -> foldl' buildPath (buildPath input p) ps+  where+    buildPath p (Key k) = p B.->$ fromString k+    buildPath p (Idx i) = p B.-># fromInteger i++--------------------------------------------------------------------------------+-- Selecting Optional JSON+--------------------------------------------------------------------------------++-- | Wraps a @PgJSON@ or @PgJSONB@, treating deserialization of SQL @NULL@ as+-- json @null@. This is so that if you query for a path that might not exist,+-- i.e. a path into an optional field, then an exception will not be raised+-- when attempting to decode the result as JSON.+newtype JNullable json a = JNullable (json a)+  deriving (Ord, Eq, Show) via json a+  deriving B.IsPgJSON via json++deriving via (json a :: Type) instance (B.HasSqlValueSyntax syn (json a))+  => B.HasSqlValueSyntax syn (JNullable json a)++instance ( Pg.FromField (json a :: Type)+         , B.Typeable (a :: Type)+         , B.Typeable json+         )+  => B.FromBackendRow B.Postgres (JNullable json a)++instance Pg.FromField (json a) => Pg.FromField (JNullable json a) where+  fromField f mbBs = JNullable+                 <$> Pg.fromField f (Just $ fromMaybe "null" mbBs)++--------------------------------------------------------------------------------+-- Schema DataTypes+--------------------------------------------------------------------------------++-- | Declares a nullable @PgJSONB@ field in a migration schema+nullableJsonb :: forall a. (Aeson.ToJSON a, Aeson.FromJSON a)+              => B.DataType B.Postgres (JNullable B.PgJSONB a)+nullableJsonb = coerce (B.jsonb :: B.DataType B.Postgres (B.PgJSONB a))++-- | Declares a nullable @PgJSON@ field in a migration schema+nullableJson :: forall a. (Aeson.ToJSON a, Aeson.FromJSON a)+             => B.DataType B.Postgres (JNullable B.PgJSON a)+nullableJson = coerce (B.json :: B.DataType B.Postgres (B.PgJSON a))+
+ test/Spec.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++import           Control.Monad.Catch (handleAll)+import qualified Data.ByteString.Char8 as BS+import           Data.List (sort)+import qualified Database.Beam as B+import qualified Database.Beam.Migrate as B+import qualified Database.Beam.Postgres as B+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.Beam+import           Typson.Test.Beam.DbSchema (Db(..), EntityT(..), createTableMigration, db)+import           Typson.Test.Generators+import           Typson.Test.Types++main :: IO ()+main = defaultMain beamTestTree++beamTestTree :: TestTree+beamTestTree = withRunDb $ \runDb ->+  testGroup "Beam Tests"+  [ testCase "JSON Queries" $ do+      graphs <- HH.sample (HH.list (HH.singleton 100) bazGen)+      runDb (insertData graphs)++      r1 <- runDb . B.runSelectReturningList . B.select $+              jsonPath basicPath1 bazJ <$> getAllGraphs+      let a1 = JNullable . B.PgJSONB . basicPath1Getter <$> graphs+      assertEqual "Basic Path 1" (sort r1) (sort a1)++      r2 <- runDb . B.runSelectReturningList . B.select $+              jsonPath basicPath2 bazJ <$> getAllGraphs+      let a2 = JNullable . B.PgJSONB . basicPath2Getter <$> graphs+      assertEqual "Basic Path 2" (sort r2) (sort a2)++      r3 <- runDb . B.runSelectReturningList . B.select $+              jsonPath basicPath3 bazJ <$> getAllGraphs+      let a3 = JNullable . B.PgJSONB . basicPath3Getter <$> graphs+      assertEqual "Basic Path 3" (sort r3) (sort a3)++      r4 <- runDb . B.runSelectReturningList . B.select $+              jsonPath optionalPath1 bazJ <$> getAllGraphs+      let a4 = JNullable . B.PgJSONB . optionalPath1Getter <$> graphs+      assertEqual "Optional Path 1" (sort r4) (sort a4)++      r5 <- runDb . B.runSelectReturningList . B.select $+              jsonPath optionalPath2 bazJ <$> getAllGraphs+      let a5 = JNullable . B.PgJSONB . optionalPath2Getter <$> graphs+      assertEqual "Optional Path 2" (sort r5) (sort a5)++      r6 <- runDb . B.runSelectReturningList . B.select $+              jsonPath optionalPath3 bazJ <$> getAllGraphs+      let a6 = JNullable . B.PgJSONB . optionalPath3Getter <$> graphs+      assertEqual "Optional Path 3" (sort r6) (sort a6)++      r7 <- runDb . B.runSelectReturningList . B.select $+              jsonPath listIdxPath1 bazJ <$> getAllGraphs+      let a7 = JNullable . B.PgJSONB . listIdxPath1Getter <$> graphs+      assertEqual "List Idx Path 1" (sort r7) (sort a7)++      r8 <- runDb . B.runSelectReturningList . B.select $+              jsonPath listIdxPath2 bazJ <$> getAllGraphs+      let a8 = JNullable . B.PgJSONB . listIdxPath2Getter <$> graphs+      assertEqual "List Idx Path 2" (sort r8) (sort a8)++      r9 <- runDb . B.runSelectReturningList . B.select $+              jsonPath listIdxPath3 bazJ <$> getAllGraphs+      let a9 = JNullable . B.PgJSONB . listIdxPath3Getter <$> graphs+      assertEqual "List Idx Path 3" (sort r9) (sort a9)++      r10 <- runDb . B.runSelectReturningList . B.select $+              jsonPath unionPath1 bazJ <$> getAllGraphs+      let a10 = JNullable . B.PgJSONB . unionPath1Getter <$> graphs+      assertEqual "Union Query 1" (sort r10) (sort a10)++      r11 <- runDb . B.runSelectReturningList . B.select $+              jsonPath unionPath2 bazJ <$> getAllGraphs+      let a11 = JNullable . B.PgJSONB . unionPath2Getter <$> graphs+      assertEqual "Union Query 2" (sort r11) (sort a11)++      r12 <- runDb . B.runSelectReturningList . B.select $+               jsonPath textMapPath1 bazJ <$> getAllGraphs+      let a12 = JNullable . B.PgJSONB . textMapPath1Getter <$> graphs+      assertEqual "Text Map Query 1" (sort r12) (sort a12)++      r13 <- runDb . B.runSelectReturningList . B.select $+               jsonPath textMapPath2 bazJ <$> getAllGraphs+      let a13 = JNullable . B.PgJSONB . textMapPath2Getter <$> graphs+      assertEqual "Text Map Query 2" (sort r13) (sort a13)+  ]++getAllGraphs :: B.Q B.Postgres Db s (B.QGenExpr B.QValueContext B.Postgres s (JNullable B.PgJSONB Baz))+getAllGraphs = _entityGraph <$> B.all_ (_dbEntity db)++type DbRunner = forall b. B.Pg b -> IO b++withRunDb :: (DbRunner -> TestTree) -> TestTree+withRunDb mkTree = withDb $ \ioConn -> mkTree $ \action -> do+  conn <- ioConn+  B.runBeamPostgres conn action++withDb :: (IO B.Connection -> TestTree) -> TestTree+withDb = withResource connectToDb B.close++connectToDb :: IO B.Connection+connectToDb = do+  Just connString <- lookupEnv "CONN_STRING"+  conn <- B.connectPostgreSQL (BS.pack connString)++  -- reset the table+  _ <- handleAll (const $ pure 0) $ Pg.execute_ conn "DROP TABLE \"beam-entity\""++  _ <- B.runBeamPostgres conn $+    B.executeMigration B.runNoReturn createTableMigration++  pure conn++insertData :: [Baz] -> B.Pg ()+insertData graphs =+  let mkEntity g = EntityT { _entityId = B.default_+                           , _entityGraph = B.val_ (JNullable $ B.PgJSONB g)+                           }+   in B.runInsert+    . B.insert (_dbEntity db)+    $ B.insertExpressions+    $ map mkEntity graphs
+ test/Typson/Test/Beam/DbSchema.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveAnyClass #-}+module Typson.Test.Beam.DbSchema+  ( Db(..)+  , db+  , EntityT(..)+  , createTableMigration+  ) where++import qualified Database.Beam as B+import qualified Database.Beam.Postgres as B+import qualified Database.Beam.Migrate as B+import qualified Database.Beam.Backend.SQL.Types as B+import           GHC.Generics (Generic)++import           Typson.Beam (JNullable, nullableJsonb)+import           Typson.Test.Types (Baz)++newtype Db entity+  = Db { _dbEntity :: entity (B.TableEntity EntityT) }+  deriving (Generic, B.Database be)++db :: B.DatabaseSettings be Db+db = B.defaultDbSettings `B.withDbModification`+       B.dbModification+         { _dbEntity = B.setEntityName "beam-entity"+         }++data EntityT f+  = EntityT+    { _entityId :: B.C f (B.SqlSerial Int)+    , _entityGraph :: B.C f (JNullable B.PgJSONB Baz)+    } deriving (Generic, B.Beamable)++instance B.Table EntityT where+  newtype PrimaryKey EntityT f = EntityKey (B.C f (B.SqlSerial Int))+    deriving (Generic, B.Beamable)++  primaryKey = EntityKey . _entityId++tableSchema :: B.Migration B.Postgres (B.CheckedDatabaseEntity B.Postgres db (B.TableEntity EntityT))+tableSchema =+  B.createTable "beam-entity"+    ( EntityT (B.field "id" B.serial B.notNull B.unique)+              (B.field "graph" nullableJsonb B.notNull)+    )++createTableMigration :: B.Migration B.Postgres (Db (B.CheckedDatabaseEntity B.Postgres db))+createTableMigration = Db <$> tableSchema
+ typson-beam.cabal view
@@ -0,0 +1,73 @@+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: a8b6266051ddd3dedc036b170c169caf7d6474cdb0912c3abc4a6cd2d1be17f1++name:           typson-beam+version:        0.1.0.0+synopsis:       Typson Beam 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.Beam+  other-modules:+      Paths_typson_beam+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , beam-core >=0.9.0.0 && <0.10.0.0+    , beam-postgres >=0.5.0.0 && <0.6.0.0+    , postgresql-simple+    , typson-core+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Typson.Test.Beam.DbSchema+      Paths_typson_beam+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror=missing-fields -Werror=incomplete-patterns+  build-depends:+      HUnit+    , aeson+    , base >=4.7 && <5+    , beam-core+    , beam-migrate+    , beam-postgres+    , bytestring+    , exceptions+    , hedgehog+    , microlens+    , postgresql-simple+    , tasty+    , tasty-hedgehog+    , tasty-hunit+    , test-fixture+    , typson-beam+    , typson-core+  default-language: Haskell2010