diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for typson-selda + +## 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,4 @@ +# typson-selda + +This package provides the integration for using `typson-core` with the `selda` +PostgreSQL ORM. 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/Selda.hs b/src/Typson/Selda.hs new file mode 100644 --- /dev/null +++ b/src/Typson/Selda.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Typson.Selda +-- Description : Provides the Selda integration +-- Copyright : (c) Aaron Allen, 2020 +-- Maintainer : Aaron Allen +-- License : BSD-style (see the file LICENSE) +-- Stability : experimental +-- Portability : non-portable +-- +-------------------------------------------------------------------------------- +module Typson.Selda + ( jsonPath + , Json(..) + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.List (foldl') +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) +import qualified Database.Selda as S +import qualified Database.Selda.Backend as S +import Database.Selda.JSON () +import qualified Database.Selda.PostgreSQL as S +import qualified Database.Selda.Unsafe as S + +import Typson + +-- | Use a type-safe JSON path as part of a query. +-- +-- @ +-- query $ jsonPath (Proxy @("foo" :-> "bar")) fieldSchemaJ +-- . (! #field) +-- \<$> select someTable +-- @ +jsonPath :: ( TypeAtPath o tree path ~ target + , ReflectPath path + ) + => proxy (path :: k) -- ^ A path proxy + -> ObjectTree tree o -- ^ Typson schema + -> S.Col S.PG (Json o) -- ^ Column selector + -> S.Col S.PG (Json target) +jsonPath path _ col = + case reflectPath path of + p NE.:| ps -> foldl' buildPath (buildPath col p) ps + where + buildPath c (Key k) = S.operator "->" c (fromString k :: S.Col S.PG T.Text) + buildPath c (Idx i) = S.operator "->" c (S.rawExp (T.pack $ show i) :: S.Col S.PG Int) + -- had to resort to `rawExp` here because selda uses bigint for Int which + -- does not work with the -> operator + +-------------------------------------------------------------------------------- +-- Json Serialization Wrapper +-------------------------------------------------------------------------------- + +-- | Use this wrapper on fields that are serialized as JSON in the database. +-- It's deserialization treats SQL @NULL@ as JSON @null@. +newtype Json a = + Json + { unJson :: a + } deriving (Show, Eq, Ord) + deriving newtype (Aeson.ToJSON, Aeson.FromJSON) + +decodeError :: Show a => a -> b +decodeError x = error $ "fromSql: json column with invalid json: " ++ show x + +typeError :: Show a => a -> b +typeError x = error $ "fromSql: json column with non-text value: " ++ show x + +instance (Typeable a, Aeson.ToJSON a, Aeson.FromJSON a, Show a) => S.SqlType (Json a) where + mkLit j = + case S.mkLit $ Aeson.toJSON j of + S.LCustom rep l -> S.LCustom rep l + sqlType _ = S.TJSON + defaultValue = + case S.mkLit Aeson.Null of + S.LCustom rep l -> S.LCustom rep l + fromSql (S.SqlBlob t) = + fromMaybe (decodeError t) (Aeson.decode' $ BSL.fromStrict t) + fromSql (S.SqlString t) = + fromMaybe (decodeError t) (Aeson.decode' . BSL.fromStrict $ TE.encodeUtf8 t) + fromSql S.SqlNull = + case Aeson.fromJSON Aeson.Null of + Aeson.Success a -> a + _ -> typeError S.SqlNull + fromSql x = typeError x + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} + +import Control.Monad.Catch (handleAll) +import qualified Data.ByteString.Char8 as BS +import Data.List (sort) +import qualified Database.Selda as S +import qualified Database.Selda.Backend as S +import qualified Database.Selda.PostgreSQL as S +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 +import Typson.Selda +import Typson.Test.Selda.DbSchema +import Typson.Test.Generators +import Typson.Test.Types + +main :: IO () +main = defaultMain seldaTestTree + +seldaTestTree :: TestTree +seldaTestTree = withRunDb $ \runDb -> + testGroup "Selda Tests" + [ testCase "JSON Queries" $ do + graphs <- HH.sample (HH.list (HH.singleton 100) bazGen) + runDb (insertData graphs) + + r1 <- runDb . S.query $ + jsonPath basicPath1 bazJ <$> getAllGraphs + let a1 = Json . basicPath1Getter <$> graphs + assertEqual "Basic Path 1" (sort r1) (sort a1) + + r2 <- runDb . S.query $ + jsonPath basicPath2 bazJ <$> getAllGraphs + let a2 = Json . basicPath2Getter <$> graphs + assertEqual "Basic Path 2" (sort r2) (sort a2) + + r3 <- runDb . S.query $ + jsonPath basicPath3 bazJ <$> getAllGraphs + let a3 = Json . basicPath3Getter <$> graphs + assertEqual "Basic Path 3" (sort r3) (sort a3) + + r4 <- runDb . S.query $ + jsonPath optionalPath1 bazJ <$> getAllGraphs + let a4 = Json . optionalPath1Getter <$> graphs + assertEqual "Optional Path 1" (sort r4) (sort a4) + + r5 <- runDb . S.query $ + jsonPath optionalPath2 bazJ <$> getAllGraphs + let a5 = Json . optionalPath2Getter <$> graphs + assertEqual "Optional Path 2" (sort r5) (sort a5) + + r6 <- runDb . S.query $ + jsonPath optionalPath3 bazJ <$> getAllGraphs + let a6 = Json . optionalPath3Getter <$> graphs + assertEqual "Optional Path 3" (sort r6) (sort a6) + + r7 <- runDb . S.query $ + jsonPath listIdxPath1 bazJ <$> getAllGraphs + let a7 = Json . listIdxPath1Getter <$> graphs + assertEqual "List Idx Path 1" (sort r7) (sort a7) + + r8 <- runDb . S.query $ + jsonPath listIdxPath2 bazJ <$> getAllGraphs + let a8 = Json . listIdxPath2Getter <$> graphs + assertEqual "List Idx Path 2" (sort r8) (sort a8) + + r9 <- runDb . S.query $ + jsonPath listIdxPath3 bazJ <$> getAllGraphs + let a9 = Json . listIdxPath3Getter <$> graphs + assertEqual "List Idx Path 3" (sort r9) (sort a9) + + r10 <- runDb . S.query $ + jsonPath unionPath1 bazJ <$> getAllGraphs + let a10 = Json . unionPath1Getter <$> graphs + assertEqual "Union Path 1" (sort r10) (sort a10) + + r11 <- runDb . S.query $ + jsonPath unionPath2 bazJ <$> getAllGraphs + let a11 = Json . unionPath2Getter <$> graphs + assertEqual "Union Path 2" (sort r11) (sort a11) + + r12 <- runDb . S.query $ + jsonPath textMapPath1 bazJ <$> getAllGraphs + let a12 = Json . textMapPath1Getter <$> graphs + assertEqual "Text Map Path 1" (sort r12) (sort a12) + + r13 <- runDb . S.query $ + jsonPath textMapPath2 bazJ <$> getAllGraphs + let a13 = Json . textMapPath2Getter <$> graphs + assertEqual "Text Map Path 2" (sort r13) (sort a13) + ] + +getAllGraphs :: S.Query s (S.Col s (Json Baz)) +getAllGraphs = + (S.! #entityGraph) <$> S.select entityTable + +type DbRunner = forall b. S.SeldaM S.PG b -> IO b + +withRunDb :: (DbRunner -> TestTree) -> TestTree +withRunDb mkTree = withDb $ \ioConn -> mkTree $ \action -> do + conn <- ioConn + S.runSeldaT action conn + +withDb :: (IO (S.SeldaConnection S.PG) -> TestTree) -> TestTree +withDb = withResource connectToDb S.seldaClose + +connectToDb :: IO (S.SeldaConnection S.PG) +connectToDb = do + Just connString <- lookupEnv "CONN_STRING" + conn <- S.pgOpen' Nothing (BS.pack connString) + + -- reset the table + _ <- (`S.runSeldaT` conn) $ do + handleAll (const $ pure ()) $ S.dropTable entityTable + S.createTable entityTable + + pure conn + +insertData :: [Baz] -> S.SeldaM S.PG () +insertData graphs = + let mkEntity g = Entity { entityId = S.def + , entityGraph = Json g + } + + in S.insert_ entityTable + $ mkEntity <$> graphs diff --git a/test/Typson/Test/Selda/DbSchema.hs b/test/Typson/Test/Selda/DbSchema.hs new file mode 100644 --- /dev/null +++ b/test/Typson/Test/Selda/DbSchema.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +module Typson.Test.Selda.DbSchema where + +import qualified Database.Selda as S +import GHC.Generics (Generic) + +import Typson.Test.Types (Baz) +import Typson.Selda + +data Entity = + Entity + { entityId :: S.ID Entity + , entityGraph :: Json Baz + } deriving (Show, Generic) + +instance S.SqlRow Entity + +entityTable :: S.Table Entity +entityTable = S.table "selda-entity" [ #entityId S.:- S.autoPrimary ] diff --git a/typson-selda.cabal b/typson-selda.cabal new file mode 100644 --- /dev/null +++ b/typson-selda.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: 238d1648fa8954f5890d0683f87c5ecdafe5e5353baa61156a860ab4ed42d036 + +name: typson-selda +version: 0.1.0.0 +synopsis: Typson Selda 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.Selda + other-modules: + Paths_typson_selda + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , selda + , selda-json + , selda-postgresql + , text + , typson-core + default-language: Haskell2010 + +test-suite typson-selda-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Typson.Test.Selda.DbSchema + Paths_typson_selda + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit + , aeson + , base >=4.7 && <5 + , bytestring + , exceptions + , hedgehog + , microlens + , selda + , selda-json + , selda-postgresql + , tasty + , tasty-hedgehog + , tasty-hunit + , test-fixture + , text + , typson-core + , typson-selda + default-language: Haskell2010