packages feed

typson-selda (empty) → 0.1.0.0

raw patch · 8 files changed

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

Dependencies added: HUnit, aeson, base, bytestring, exceptions, hedgehog, microlens, selda, selda-json, selda-postgresql, tasty, tasty-hedgehog, tasty-hunit, test-fixture, text, typson-core, typson-selda

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for typson-selda++## 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,4 @@+# typson-selda++This package provides the integration for using `typson-core` with the `selda`+PostgreSQL ORM.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Typson/Selda.hs view
@@ -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 <aaronallen8455@gmail.com>+-- 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+
+ test/Spec.hs view
@@ -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
+ test/Typson/Test/Selda/DbSchema.hs view
@@ -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 ]
+ typson-selda.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: 238d1648fa8954f5890d0683f87c5ecdafe5e5353baa61156a860ab4ed42d036++name:           typson-selda+version:        0.1.0.0+synopsis:       Typson Selda 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.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