diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9a4678b --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +.stack-work/ +.idea +*.iml +*~ +dist-newstyle +.dir-locals.el +*.local +dist-local-build/ diff --git a/README.md b/README.md new file mode 100644 index 0000000..d3cafb4 --- /dev/null +++ b/README.md @@ -0,0 +1,129 @@ +# haskell-sequelize + +A port of +[juspay/purescript-sequelize](https://github.com/juspay/purescript-sequelize) +into Haskell, mimicking [Sequelize.js v4](https://sequelize.org/v4). + +## Status + +Has not been tried in production yet. + +Does not provide INSERT or DELETE yet. + +## Usage + +### Table definition + +Define a Beam table: + +```haskell +data TestT f = Test + { email :: B.Columnar f Text, + enabled :: B.Columnar (B.Nullable f) Bool + } + deriving (Generic) + +type Test = TestT Identity + +instance B.Beamable TestT + +instance B.Table TestT where + data PrimaryKey TestT f = TestId (B.Columnar f Text) deriving (Generic, B.Beamable) + primaryKey = TestId . email +``` + +Define a `ModelMeta` instance. You can modify table properties here. + +```haskell +instance ModelMeta TestT where + modelFieldModification = B.tableModification + modelTableName = "test" +``` + +### SELECT + +Simple SELECT: + +```haskell +{-# LANGUAGE OverloadedLabels #-} + +import Named + +getDisabled :: SqlSelect MySQL Test +getDisabled = + sqlSelect + ! #where_ [Is enabled Null] + ! defaults +``` + +A more complex SELECT: + +```haskell +{-# LANGUAGE OverloadedLabels #-} + +import Named + +getSpecificPeople :: SqlSelect MySQL Test +getSpecificPeople = + sqlSelect + ! #where_ + [ Is enabled (Not Null), + Or [Is email (Eq "a@example.com"), Is email (Eq "b@example.com")] + ] + ! #orderBy [Asc enabled, Desc email] + ! #offset 8 + ! #limit 10 +``` + +### UPDATE + +Set some fields: + +```haskell +{-# LANGUAGE OverloadedLabels #-} + +import Named + +busted :: SqlUpdate MySQL TestT +busted = + sqlUpdate + ! #set [Set enabled Nothing] + ! #where_ [Is enabled (Not Null)] +``` + +Set all fields: + +```haskell +{-# LANGUAGE OverloadedLabels #-} + +import Named + +disableSomeone :: SqlUpdate MySQL TestT +disableSomeone = + sqlUpdate' + ! #save (Test "a@example.com" (Just False)) + ! #where_ [Is email (Eq "a@example.com")] +``` + +We support `Set` and `SetDefault`. + +## Developing + +Nix: + +```bash +$ nix-shell + +(nix-shell) $ cabal build +(nix-shell) $ cabal test +``` + +Stack: + +```bash +$ stack build +$ stack test +``` +`stack test` doesn't work, because stack does not able to set `lenient` flag for cabal. +Use cabal tests instead. +Be sure the repo has `cabal.project.local` with `packages: ../beam-mysql` inside. Then run `euler dev` and then `cabal test -f lenient` diff --git a/euler.yaml b/euler.yaml new file mode 100644 index 0000000..ce5859f --- /dev/null +++ b/euler.yaml @@ -0,0 +1,19 @@ +name: haskell-sequelize +haskell-name: sequelize +allowed-paths: +- sequelize.cabal +- src +- test + +# Disabling tests as they use outdated beam-mysql +disable-tests: true +dependencies: + euler-build: + branch: master + revision: c6af205a7adb1b7abac18f06830f4ed196bfd6e4 + beam: + branch: master + revision: 372542ec6c49d18e8c1c4ef9da15ff0b97c07ed8 + beam-mysql: + branch: master + revision: 1371202ebc3ec7e9ef3e16d1e99f805596022217 diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..56cd666 --- /dev/null +++ b/flake.lock @@ -0,0 +1,139 @@ +{ + "nodes": { + "beam": { + "inputs": { + "euler-build": [ + "euler-build" + ] + }, + "locked": { + "lastModified": 1618840279, + "narHash": "sha256-Pbn0ZwbZTj9TdjfyjDk5coC9tvV6DgQiN/XR9Jha4aM=", + "owner": "juspay", + "repo": "beam", + "rev": "372542ec6c49d18e8c1c4ef9da15ff0b97c07ed8", + "type": "github" + }, + "original": { + "id": "beam", + "type": "indirect" + } + }, + "beam-mysql": { + "inputs": { + "beam": [ + "beam" + ], + "euler-build": [ + "euler-build" + ] + }, + "locked": { + "lastModified": 1638188779, + "narHash": "sha256-hSv5Hg40NZFNDnFJ7sKndZq5xiDzeUB2CZOxN4umTwk=", + "owner": "juspay", + "repo": "beam-mysql", + "rev": "1371202ebc3ec7e9ef3e16d1e99f805596022217", + "type": "github" + }, + "original": { + "id": "beam-mysql", + "type": "indirect" + } + }, + "euler-build": { + "inputs": { + "flake-utils": "flake-utils", + "nix-inclusive": "nix-inclusive", + "nixpkgs": "nixpkgs" + }, + "locked": { + "lastModified": 1620054696, + "narHash": "sha256-316JgoGBQs+29untwjJokSWc0OW2PoCCL33aC/hvPKw=", + "ref": "master", + "rev": "c6af205a7adb1b7abac18f06830f4ed196bfd6e4", + "revCount": 41, + "type": "git", + "url": "ssh://git@bitbucket.org/juspay/euler-build" + }, + "original": { + "id": "euler-build", + "type": "indirect" + } + }, + "flake-utils": { + "locked": { + "lastModified": 1600209923, + "narHash": "sha256-zoOWauTliFEjI++esk6Jzk7QO5EKpddWXQm9yQK24iM=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cd06d3c1df6879c9e41cb2c33113df10566c760", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nix-inclusive": { + "inputs": { + "stdlib": "stdlib" + }, + "locked": { + "lastModified": 1604413592, + "narHash": "sha256-3cr2RRBCXNb+6Q1s3tEQiN4LjoFC8OsMSG8WuCyGe/g=", + "owner": "juspay", + "repo": "nix-inclusive", + "rev": "2ca1706029bfcf4bb7eaf17b4f32e49f436a148e", + "type": "github" + }, + "original": { + "owner": "juspay", + "repo": "nix-inclusive", + "rev": "2ca1706029bfcf4bb7eaf17b4f32e49f436a148e", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1618072958, + "narHash": "sha256-QDKj58ECixtb4EJMWV5D5Lb2xdCgab1Opi4zjQWbDOg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a73020b2a150322c9832b50baeb0296ba3b13dd7", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a73020b2a150322c9832b50baeb0296ba3b13dd7", + "type": "github" + } + }, + "root": { + "inputs": { + "beam": "beam", + "beam-mysql": "beam-mysql", + "euler-build": "euler-build" + } + }, + "stdlib": { + "locked": { + "lastModified": 1590026685, + "narHash": "sha256-E5INrVvYX/P/UpcoUFDAsuHem+lsqT+/teBs9O7oc9Q=", + "owner": "manveru", + "repo": "nix-lib", + "rev": "99088cf7febcdb21afd375a335dcafa959bef3ed", + "type": "github" + }, + "original": { + "owner": "manveru", + "repo": "nix-lib", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/sequelize.cabal b/sequelize.cabal new file mode 100644 index 0000000..d2ac6d5 --- /dev/null +++ b/sequelize.cabal @@ -0,0 +1,72 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 492410794b7d56b74a2a0cc2cb2d4ea37d2c1711251fc612e511aab5adfc35e6 + +name: sequelize +version: 1.1.1.0 +description: A port of into Haskell +author: Artyom Kazak +maintainer: artyom.kazak@juspay.in +copyright: 2020 Juspay +license: BSD3 +build-type: Simple +extra-source-files: + README.md + +library + exposed-modules: + Sequelize + Sequelize.Encode + other-modules: + Paths_sequelize + hs-source-dirs: + src + default-extensions: AllowAmbiguousTypes RankNTypes ScopedTypeVariables StandaloneDeriving EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies KindSignatures TypeOperators MultiParamTypeClasses TypeFamilies OverloadedLabels OverloadedStrings DeriveFunctor DeriveGeneric DataKinds DerivingStrategies ConstraintKinds UndecidableInstances InstanceSigs BlockArguments LambdaCase EmptyDataDeriving TypeOperators ViewPatterns KindSignatures + ghc-options: -Wall + build-depends: + aeson + , base >=4.7 && <5 + , beam-core ^>=0.9.0.0 + , beam-mysql ^>=1.3.0.4 + , beam-postgres ^>=0.5.0.0 + , beam-sqlite ^>=0.5.0.0 + , bytestring + , containers + , generic-lens + , named + , text + , unordered-containers + , vector + default-language: Haskell2010 + +test-suite sequelize-test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Paths_sequelize + hs-source-dirs: + test + default-extensions: AllowAmbiguousTypes RankNTypes ScopedTypeVariables StandaloneDeriving EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies KindSignatures TypeOperators MultiParamTypeClasses TypeFamilies OverloadedLabels OverloadedStrings DeriveFunctor DeriveGeneric DataKinds DerivingStrategies ConstraintKinds UndecidableInstances InstanceSigs BlockArguments LambdaCase EmptyDataDeriving TypeOperators ViewPatterns KindSignatures + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , beam-core ^>=0.9.0.0 + , beam-mysql ^>=1.3.0.4 + , beam-postgres ^>=0.5.0.0 + , beam-sqlite ^>=0.5.0.0 + , bytestring + , containers + , generic-lens + , named + , sequelize + , tasty + , tasty-hunit + , text + , unordered-containers + , vector + default-language: Haskell2010 diff --git a/src/Sequelize.hs b/src/Sequelize.hs new file mode 100644 index 0000000..c63fc3d --- /dev/null +++ b/src/Sequelize.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Sequelize + ( -- * Types + Column, + Model, + ModelMeta (..), + + -- * Statements + sqlSelect, + sqlSelectQ, + sqlUpdate, + sqlUpdate', + + -- * WHERE + Where, + Clause (..), + Term (..), + WHERE, + IS(..), + isClausesToWhere, + + -- * ORDER BY + OrderBy (..), + + -- * SET + Set (..), + + -- * Internals + whereQ, + clauseQ, + termQ, + setQ, + orderByQ, + HasTableField (..), + GModelToSets (..), + modelToSets, + ModelToSets, + modelTableEntity, + modelTableEntityDescriptor, + DatabaseWith (..), + columnize, + fromColumnar', + retypeQOrd, + ) +where + +import Data.Aeson (ToJSON) +import Data.Functor.Identity (Identity) +import qualified Data.Generics.Product.Fields as L +import Data.Kind () +import Data.Monoid (appEndo) +import Data.Text (Text) +import Data.Typeable (Typeable) +import qualified Database.Beam as B +import qualified Database.Beam.Backend.SQL as B +import qualified Database.Beam.Query.Internal as B +import qualified Database.Beam.Schema.Tables as B +import GHC.Generics (Generic) +import qualified GHC.Generics as G +import GHC.TypeLits (Symbol) +import Named ((:!), (:?), arg, argF) + +---------------------------------------------------------------------------- +-- Column +---------------------------------------------------------------------------- + +-- | A table column identifier. Any field accessor is a 'Column'. +-- +-- Sample: @lastUpdated :: Column UserT LocalTime@ +-- +-- 'Column's can be written in any way as long as they are field accessors. +-- E.g. you can write @Is (^. #email)@ instead of @Is email@. +type Column table value = forall f. table (B.Columnar' f) -> B.Columnar' f value + +---------------------------------------------------------------------------- +-- Where +---------------------------------------------------------------------------- + +-- | Sample sig: @Where MySQL UserT@ +type Where be table = [Clause be table] + +type WHERE be table = [IS be table] + +isClausesToWhere :: WHERE be table -> Where be table +isClausesToWhere = fmap (\(IS c v) -> Is c (Eq v)) + +data IS be table where + IS :: (ToJSON value, Eq value, EqValue be value) => Column table value -> value -> IS be table + +data Clause be (table :: (* -> *) -> *) where + And :: [Clause be table] -> Clause be table + Or :: [Clause be table] -> Clause be table + Is :: + (ToJSON value, Eq value) => + Column table value -> + Term be value -> + Clause be table + +-- sequelize.js operations that were not ported: +-- +-- Contains :: [a] -> Term be a +-- Contained :: [a] -> Term be a +-- Any :: [a] -> Term be a +-- Between :: [Int] -> Term be Int (nb: not actually [Int]) +-- NotBetween :: [Int] -> Term be Int +-- Overlap :: [Int] -> Term be Int +-- ILike :: Text -> Term be Text +-- NotILike :: Text -> Term be Text +-- RegExp :: Text -> Term be Text +-- NotRegExp :: Text -> Term be Text +-- IRegExp :: Text -> Term be Text +-- NotIRegExp :: Text -> Term be Text +-- Col :: Text -> Term be Text + +data Term be a where + In :: B.BeamSqlBackendCanSerialize be a => [a] -> Term be a + Eq :: EqValue be a => a -> Term be a + Null :: Term be (Maybe a) + GreaterThan :: B.BeamSqlBackendCanSerialize be a => a -> Term be a + GreaterThanOrEq :: B.BeamSqlBackendCanSerialize be a => a -> Term be a + LessThan :: B.BeamSqlBackendCanSerialize be a => a -> Term be a + LessThanOrEq :: B.BeamSqlBackendCanSerialize be a => a -> Term be a + Like :: (B.BeamSqlBackendCanSerialize be Text, B.BeamSqlBackendIsString be Text) => Text -> Term be Text + Not :: Term be a -> Term be a + +whereQ :: + forall be table s. + (B.BeamSqlBackend be, B.Beamable table) => + Where be table -> + (table (B.QExpr be s) -> B.QExpr be s B.SqlBool) +whereQ = clauseQ . And + +clauseQ :: + forall be table s. + (B.BeamSqlBackend be, B.Beamable table) => + Clause be table -> + (table (B.QExpr be s) -> B.QExpr be s B.SqlBool) +clauseQ p = \item -> case p of + And [] -> B.sqlBool_ (B.val_ True) + And xs -> foldr1 (B.&&?.) (map (flip clauseQ item) xs) + Or [] -> B.sqlBool_ (B.val_ False) + Or xs -> foldr1 (B.||?.) (map (flip clauseQ item) xs) + Is column' term -> + let column = fromColumnar' . column' . columnize + in termQ (column item) term + +termQ :: + B.BeamSqlBackend be => + B.QExpr be s a -> + Term be a -> + B.QExpr be s B.SqlBool +termQ val = \case + In lits -> B.sqlBool_ (val `B.in_` map B.val_ lits) + Null -> B.sqlBool_ (B.isNothing_ val) + Eq lit -> eqValue val lit + GreaterThan lit -> B.sqlBool_ (val B.>. B.val_ lit) + GreaterThanOrEq lit -> B.sqlBool_ (val B.>=. B.val_ lit) + LessThan lit -> B.sqlBool_ (val B.<. B.val_ lit) + LessThanOrEq lit -> B.sqlBool_ (val B.<=. B.val_ lit) + Like s -> B.sqlBool_ (val `B.like_` B.val_ s) + -- Nots + Not Null -> B.sqlBool_ (B.isJust_ val) + Not (Eq lit) -> neqValue val lit + Not t -> B.sqlNot_ (termQ val t) + +-- Needed because comparisons with Maybe are tricky +class EqValue be a where + eqValue :: B.QExpr be s a -> a -> B.QExpr be s B.SqlBool + neqValue :: B.QExpr be s a -> a -> B.QExpr be s B.SqlBool + +instance + (B.BeamSqlBackendCanSerialize be a, B.HasSqlEqualityCheck be a) => + EqValue be a + where + eqValue expr x = expr B.==?. B.val_ x + neqValue expr x = expr B./=?. B.val_ x + +instance + {-# OVERLAPPING #-} + (B.BeamSqlBackendCanSerialize be (Maybe a), B.HasSqlEqualityCheck be (Maybe a)) => + EqValue be (Maybe a) + where + eqValue expr = \case + Nothing -> B.sqlBool_ (B.isNothing_ expr) + Just x -> expr B.==?. B.val_ (Just x) + neqValue expr = \case + Nothing -> B.sqlBool_ (B.isJust_ expr) + Just x -> expr B./=?. B.val_ (Just x) + +---------------------------------------------------------------------------- +-- Ordering +---------------------------------------------------------------------------- + +data OrderBy table + = forall value. Asc (Column table value) + | forall value. Desc (Column table value) + +orderByQ :: + (B.BeamSqlBackend be, B.Beamable table) => + OrderBy table -> + table (B.QExpr be s) -> + B.QOrd be s () +orderByQ (Asc column) item = + retypeQOrd $ B.asc_ (fromColumnar' . column . columnize $ item) +orderByQ (Desc column) item = + retypeQOrd $ B.desc_ (fromColumnar' . column . columnize $ item) + +---------------------------------------------------------------------------- +-- Set +---------------------------------------------------------------------------- + +data Set be table + = forall value. + (B.BeamSqlBackendCanSerialize be value, ToJSON value) => + Set (Column table value) value + | forall value. + SetDefault (Column table value) + +setQ :: + (B.Beamable table, B.BeamSqlBackend be) => + table (B.QField s) -> + Set be table -> + B.QAssignment be s +setQ item = \case + Set column' value -> + let column = fromColumnar' . column' . columnize + in column item B.<-. B.val_ value + SetDefault column' -> + let column = fromColumnar' . column' . columnize + in column item B.<-. B.default_ + +---------------------------------------------------------------------------- +-- Data to assignment +---------------------------------------------------------------------------- + +class HasTableField (name :: Symbol) table value where + getTableField :: Column table value + +-- TODO: can avoid generic-lens here +instance + (forall f. L.HasField' name (table (B.Columnar' f)) (B.Columnar' f a)) => + HasTableField name table a + where + getTableField = L.getField @name + +class GModelToSets be (table :: (* -> *) -> *) g where + gModelToSets :: g x -> [Set be table] + +instance + GModelToSets be table g => + GModelToSets be table (G.D1 c g) + where + gModelToSets (G.M1 g) = gModelToSets g + +instance + GModelToSets be table g => + GModelToSets be table (G.C1 c g) + where + gModelToSets (G.M1 g) = gModelToSets g + +instance + (GModelToSets be table g1, GModelToSets be table g2) => + GModelToSets be table (g1 G.:*: g2) + where + gModelToSets (g1 G.:*: g2) = gModelToSets g1 ++ gModelToSets g2 + +-- If we have e.g. "id PRIMARY KEY AUTO_INCREMENT", we don't want to insert +-- a NULL into the table - we want to insert a default. Unfortunately, we +-- can't distinguish between NULL and DEFAULT at the model level. +-- +-- So we just insert DEFAULT for all Nothings - in most cases it will be the +-- same thing, and when not, the column's default value is a better choice. +instance + {-# OVERLAPPING #-} + ( c ~ 'G.MetaSel ('Just name) _u _s _d, + HasTableField name table (Maybe value), + B.BeamSqlBackendCanSerialize be (Maybe value), + ToJSON value + ) => + GModelToSets be table (G.S1 c (G.Rec0 (Maybe value))) + where + gModelToSets (G.M1 (G.K1 mbValue)) = + case mbValue of + Nothing -> + [SetDefault (getTableField @name @table @(Maybe value))] + Just value -> + [Set (getTableField @name @table @(Maybe value)) (Just value)] + +instance + {-# OVERLAPPABLE #-} + ( c ~ 'G.MetaSel ('Just name) _u _s _d, + HasTableField name table value, + B.BeamSqlBackendCanSerialize be value, + ToJSON value + ) => + GModelToSets be table (G.S1 c (G.Rec0 value)) + where + gModelToSets (G.M1 (G.K1 value)) = + [Set (getTableField @name @table @value) value] + +-- | Use this if you want to assign all fields. +modelToSets :: ModelToSets be table => table Identity -> [Set be table] +modelToSets = gModelToSets . G.from + +-- | Use this constraint to indicate that a model supports 'modelToSets'. +type ModelToSets be table = + ( Typeable table, + B.Beamable table, + Generic (table Identity), + GModelToSets be table (G.Rep (table Identity)) + ) + +---------------------------------------------------------------------------- +-- Options to Beam +---------------------------------------------------------------------------- + +applyLimit :: + (B.Beamable table) => + Maybe Int -> + (forall s. B.Q be db s (table (B.QExpr be s))) -> + (forall s. B.Q be db s (table (B.QExpr be s))) +applyLimit mbLimit_ x = case mbLimit_ of + Nothing -> x + Just n -> B.limit_ (toInteger n) x + +applyOffset :: + (B.Beamable table) => + Maybe Int -> + (forall s. B.Q be db s (table (B.QExpr be s))) -> + (forall s. B.Q be db s (table (B.QExpr be s))) +applyOffset mbOffset_ x = case mbOffset_ of + Nothing -> x + Just n -> B.offset_ (toInteger n) x + +applyOrderBy :: + (B.BeamSqlBackend be, B.Beamable table) => + Maybe [OrderBy table] -> + (forall s. B.Q be db s (table (B.QExpr be s))) -> + (forall s. B.Q be db s (table (B.QExpr be s))) +applyOrderBy mbOrderBy_ x = case mbOrderBy_ of + Nothing -> x + Just ords -> B.orderBy_ (mapM orderByQ ords) x + +applyWhere :: + (B.BeamSqlBackend be, B.Beamable table) => + Maybe (Where be table) -> + (forall s. B.Q be db s (table (B.QExpr be s))) -> + (forall s. B.Q be db s (table (B.QExpr be s))) +applyWhere mbWhere_ = maybe id (B.filter_' . whereQ) mbWhere_ + +---------------------------------------------------------------------------- +-- Class +---------------------------------------------------------------------------- + +class ModelMeta table where + modelFieldModification :: table (B.FieldModification (B.TableField table)) + modelTableName :: Text + modelSchemaName :: Maybe Text + modelSchemaName = Nothing + mkExprWithDefault :: forall be s. + (B.BeamSqlBackend be, B.Beamable table, + B.FieldsFulfillConstraint (B.BeamSqlBackendCanSerialize be) table) => + table Identity -> + B.SqlInsertValues be (table (B.QExpr be s)) + mkExprWithDefault t = B.insertExpressions ( [B.val_ t] :: forall s'. [table (B.QExpr be s')]) + +type Model be table = + ( B.BeamSqlBackend be, + Typeable table, + Generic (table Identity), + Generic (table B.Exposed), + B.FieldsFulfillConstraint (B.BeamSqlBackendCanSerialize be) table, + B.FromBackendRow be (table Identity), + B.DatabaseEntityDefaultRequirements be (B.TableEntity table), + B.Beamable table, + ModelMeta table + ) + +modelTableEntity :: + forall table be db. + Model be table => + B.DatabaseEntity be db (B.TableEntity table) +modelTableEntity = + let B.EntityModification modification = + B.modifyTableFields (modelFieldModification @table) + <> B.setEntityName (modelTableName @table) + <> B.setEntitySchema (modelSchemaName @table) + in appEndo modification $ B.DatabaseEntity $ B.dbEntityAuto (modelTableName @table) + +modelTableEntityDescriptor :: + forall table be. + Model be table => + B.DatabaseEntityDescriptor be (B.TableEntity table) +modelTableEntityDescriptor = let B.DatabaseEntity x = modelTableEntity @table in x + +---------------------------------------------------------------------------- +-- End-to-end +---------------------------------------------------------------------------- + +-- | You can use 'DatabaseWith' for operations like 'all_' that demand a +-- 'Database' instance but don't actually do anything with the instance. +data DatabaseWith table f = DatabaseWith + { dwTable :: f (B.TableEntity table) + } + deriving (Generic, B.Database be) + +sqlSelect :: + forall be table. + (B.HasQBuilder be, Model be table) => + -- Note: using 'where_' instead of 'where' because #where messes up indentation in Emacs + "where_" :? Where be table -> + "orderBy" :? [OrderBy table] -> + "offset" :? Int -> + "limit" :? Int -> + B.SqlSelect be (table Identity) +sqlSelect argWhere argOrder argOffset argLimit = + B.select (sqlSelectQ @(DatabaseWith table) argWhere argOrder argOffset argLimit) + +-- | Like 'sqlSelect', but can be used as a part of a bigger SELECT. +sqlSelectQ :: + forall db be table. + (B.Database be db, B.HasQBuilder be, Model be table) => + "where_" :? Where be table -> + "orderBy" :? [OrderBy table] -> + "offset" :? Int -> + "limit" :? Int -> + (forall s. B.Q be db s (table (B.QExpr be s))) +sqlSelectQ + (argF #where_ -> mbWhere_) + (argF #orderBy -> mbOrderBy_) + (argF #offset -> mbOffset_) + (argF #limit -> mbLimit_) = + applyLimit mbLimit_ + $ applyOffset mbOffset_ + $ applyOrderBy mbOrderBy_ + $ applyWhere mbWhere_ + $ B.all_ (modelTableEntity @table @be @db) + +sqlUpdate :: + forall be table. + (B.HasQBuilder be, Model be table) => + "set" :! [Set be table] -> + "where_" :? Where be table -> + B.SqlUpdate be table +sqlUpdate + (arg #set -> set_) + (argF #where_ -> mbWhere_) = + B.update' + modelTableEntity + (\item -> mconcat $ map (setQ item) set_) + (\item -> maybe (B.sqlBool_ (B.val_ True)) (flip whereQ item) mbWhere_) + +sqlUpdate' :: + forall be table. + (B.HasQBuilder be, Model be table, ModelToSets be table) => + "save" :! table Identity -> + "where_" :? Where be table -> + B.SqlUpdate be table +sqlUpdate' + (arg #save -> save_) + (argF #where_ -> mbWhere_) = + B.update' + modelTableEntity + (\item -> mconcat $ map (setQ item) (modelToSets save_)) + (\item -> maybe (B.sqlBool_ (B.val_ True)) (flip whereQ item) mbWhere_) + +---------------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------------- + +-- TODO: this is probably expensive, and it doesn't have to be because table +-- f and table (Columnar' f) should have the same representation. Ideally +-- 'Beamable' should provide a way to columnize a table without doing any +-- work. +columnize :: B.Beamable table => table f -> table (B.Columnar' f) +columnize = B.changeBeamRep B.Columnar' + +fromColumnar' :: B.Columnar' f value -> B.Columnar f value +fromColumnar' (B.Columnar' x) = x + +retypeQOrd :: B.QOrd be s a -> B.QOrd be s b +retypeQOrd (B.QOrd x) = B.QOrd x diff --git a/src/Sequelize/Encode.hs b/src/Sequelize/Encode.hs new file mode 100644 index 0000000..30faca4 --- /dev/null +++ b/src/Sequelize/Encode.hs @@ -0,0 +1,103 @@ +-- | Sequelize.js-compatible JSON encoder. +module Sequelize.Encode + ( modelEncodeWhere, + encodeWhere, + encodeClause, + encodeTerm, + ) +where + +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HM +import Data.Kind () +import Data.Text (Text) +import qualified Database.Beam as B +import qualified Database.Beam.Schema.Tables as B +import Sequelize + +-- | Like 'encodeWhere', but takes the entity descriptor from 'Model'. +modelEncodeWhere :: + forall be table. + Model be table => + Where be table -> + Aeson.Object +modelEncodeWhere w = encodeWhere modelTableEntityDescriptor w + +encodeWhere :: + forall be table. + B.Beamable table => + B.DatabaseEntityDescriptor be (B.TableEntity table) -> + Where be table -> + Aeson.Object +encodeWhere dt = encodeClause dt . And + +encodeClause :: + forall be table. + B.Beamable table => + B.DatabaseEntityDescriptor be (B.TableEntity table) -> + Clause be table -> + Aeson.Object +encodeClause dt w = + let foldWhere' = \case + And cs -> foldAnd cs + Or cs -> foldOr cs + Is column val -> foldIs column val + foldAnd = \case + [] -> HM.empty + [x] -> foldWhere' x + xs + | Just maps <- mapM fromIs xs -> mconcat maps + | otherwise -> HM.singleton "$and" (Aeson.toJSON $ map foldWhere' xs) + foldOr = \case + [] -> HM.empty + [x] -> foldWhere' x + xs -> HM.singleton "$or" (Aeson.toJSON $ map foldWhere' xs) + foldIs :: Aeson.ToJSON a => Column table value -> Term be a -> Aeson.Object + foldIs column val = + let key = + B._fieldName . fromColumnar' . column . columnize $ + B.dbTableSettings dt + in HM.singleton key $ encodeTerm val + fromIs :: Clause be table -> Maybe Aeson.Object + fromIs = \case + Is column val -> Just (foldIs column val) + _ -> Nothing + in foldWhere' w + +-- Warning: the behavior for @Not (Like _)@, @Not (In _)@, @Not (Eq _)@ is +-- the same as in Sequelize.js, but for all other 'Not's it isn't. +encodeTerm :: Aeson.ToJSON a => Term be a -> Aeson.Value +encodeTerm = \case + -- Contains vals -> array Aeson.toJSON "$contains" vals + -- Contained vals -> array Aeson.toJSON "$contained" vals + -- Any vals -> array Aeson.toJSON "$any" vals + -- Between vals -> array Aeson.toJSON "$between" vals + -- NotBetween vals -> array Aeson.toJSON "$notBetween" vals + -- Overlap vals -> array Aeson.toJSON "$overlap" vals + -- ILike val -> single Aeson.toJSON "$iLike" val + -- NotILike val -> single Aeson.toJSON "$notILike" val + -- RegExp val -> single Aeson.toJSON "$regexp" val + -- NotRegExp val -> single Aeson.toJSON "$notRegexp" val + -- IRegExp val -> single Aeson.toJSON "$iRegexp" val + -- NotIRegExp val -> single Aeson.toJSON "$notIRegexp" val + -- Col val -> single Aeson.toJSON "$col" val + -- Not val -> single Aeson.toJSON "$not" val + In vals -> array Aeson.toJSON "$in" vals + Eq val -> Aeson.toJSON val + Null -> Aeson.Null + GreaterThan val -> single Aeson.toJSON "$gt" val + GreaterThanOrEq val -> single Aeson.toJSON "$gte" val + LessThan val -> single Aeson.toJSON "$lt" val + LessThanOrEq val -> single Aeson.toJSON "$lte" val + Like val -> single Aeson.toJSON "$like" val + Not (Like val) -> single Aeson.toJSON "$notLike" val + Not (In vals) -> array Aeson.toJSON "$notIn" vals + Not (Eq val) -> single Aeson.toJSON "$ne" val + Not Null -> single id "$ne" Aeson.Null + Not term -> single encodeTerm "$not" term + +array :: (a -> Aeson.Value) -> Text -> [a] -> Aeson.Value +array f k vs = Aeson.toJSON $ HM.singleton k $ map f vs + +single :: (a -> Aeson.Value) -> Text -> a -> Aeson.Value +single f k v = Aeson.toJSON $ HM.singleton k $ f v diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..d88c7b7 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,38 @@ +resolver: lts-15.15 + +# NixOS support. +# Disabled by default; use as `stack run --nix` or `stack build --nix`. +nix: + enable: false # Enable manually by passing --nix + packages: [mysql57, openssl, zlib, postgresql] + +packages: +- . + +extra-deps: + - ../beam/beam-core + - ../beam/beam-migrate + - ../beam/beam-sqlite + - ../beam/beam-postgres + - ../beam-mysql + + - named-0.3.0.1@sha256:2975d50c9c5d88095026ffc1303d2d9be52e5f588a8f8bcb7003a04b79f10a06,2312 + # Needed for beam + - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + - haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541 + - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 + - constraints-extras-0.3.0.2@sha256:bf6884be65958e9188ae3c9e5547abfd6d201df021bff8a4704c2c4fe1e1ae5b,1784 + - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 + # Needed for compatibility with euler-hs + - generic-lens-1.1.0.0 + - mason-0.2.4@sha256:9de93b2f429fee78f758bd11bea7e183756567bfae4acef369405733bb0538be,1226 + - mysql-haskell-0.8.4.3@sha256:d3ca21ae8cc88670f8adb17c7cacb8bb770f1a58d60b5bff346d1f3fc843d98c,3489 + - record-dot-preprocessor-0.2.13@sha256:8eb71fdeb5286c71d5c4b0e7768ad14e19a79ae8a102c65c649b64419678332b,2538 + - tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329 + - wire-streams-0.1.1.0@sha256:08816c7fa53b20f52e5c465252c106d9de8e6d9580ec0b6d9f000a34c7bcefc8,2130 + +extra-include-dirs: + - /usr/local/opt/openssl/include +extra-lib-dirs: + - /usr/local/opt/openssl/lib diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..d448fa2 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,103 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: named-0.3.0.1@sha256:2975d50c9c5d88095026ffc1303d2d9be52e5f588a8f8bcb7003a04b79f10a06,2312 + pantry-tree: + size: 426 + sha256: e0df5f146ecd48ef129dd74f868e8d2d754f0a11b36c5d0e56bd4b1947433c9f + original: + hackage: named-0.3.0.1@sha256:2975d50c9c5d88095026ffc1303d2d9be52e5f588a8f8bcb7003a04b79f10a06,2312 +- completed: + hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 + pantry-tree: + size: 551 + sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5 + original: + hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 +- completed: + hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 + pantry-tree: + size: 290 + sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50 + original: + hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 +- completed: + hackage: haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541 + pantry-tree: + size: 95170 + sha256: 487db8defe20a7c8bdf5b4a9a68ec616a4349bdb643f2dc7c9d71e1a6495c8c7 + original: + hackage: haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541 +- completed: + hackage: sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 + pantry-tree: + size: 1930 + sha256: e58b9955e483d51ee0966f8ba4384305d871480e2a38b32ee0fcd4573d74cf95 + original: + hackage: sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 +- completed: + hackage: constraints-extras-0.3.0.2@sha256:bf6884be65958e9188ae3c9e5547abfd6d201df021bff8a4704c2c4fe1e1ae5b,1784 + pantry-tree: + size: 594 + sha256: b0bcc96d375ee11b1972a2e9e8e42039b3f420b0e1c46e9c70652470445a6505 + original: + hackage: constraints-extras-0.3.0.2@sha256:bf6884be65958e9188ae3c9e5547abfd6d201df021bff8a4704c2c4fe1e1ae5b,1784 +- completed: + hackage: direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 + pantry-tree: + size: 770 + sha256: 11874ab21e10c5b54cd1e02a037b677dc1e2ee9986f38c599612c56654dc01c3 + original: + hackage: direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 +- completed: + hackage: generic-lens-1.1.0.0@sha256:caaab13ae4f2a68e43671d25fb56746ba14bc9d5d787d594a66c7f56eba3fa66,6412 + pantry-tree: + size: 4174 + sha256: 33e1509b7d786d816a0974f08cfb6208a7d02c7d45937bec2c91586523b14440 + original: + hackage: generic-lens-1.1.0.0 +- completed: + hackage: mason-0.2.4@sha256:9de93b2f429fee78f758bd11bea7e183756567bfae4acef369405733bb0538be,1226 + pantry-tree: + size: 574 + sha256: 52308ea42ca423d9f243d31a7d1f88515ccb8497d1bc07f857beb4b0428613f5 + original: + hackage: mason-0.2.4@sha256:9de93b2f429fee78f758bd11bea7e183756567bfae4acef369405733bb0538be,1226 +- completed: + hackage: mysql-haskell-0.8.4.3@sha256:d3ca21ae8cc88670f8adb17c7cacb8bb770f1a58d60b5bff346d1f3fc843d98c,3489 + pantry-tree: + size: 1754 + sha256: c974f4d4f24bb7e17d633301a442a0a5162d30e163cad618a961d61192b6debc + original: + hackage: mysql-haskell-0.8.4.3@sha256:d3ca21ae8cc88670f8adb17c7cacb8bb770f1a58d60b5bff346d1f3fc843d98c,3489 +- completed: + hackage: record-dot-preprocessor-0.2.13@sha256:8eb71fdeb5286c71d5c4b0e7768ad14e19a79ae8a102c65c649b64419678332b,2538 + pantry-tree: + size: 1078 + sha256: d975de7bc84e142449273228bbfab0d8958e8a3503e7386bc1cd23417e301aba + original: + hackage: record-dot-preprocessor-0.2.13@sha256:8eb71fdeb5286c71d5c4b0e7768ad14e19a79ae8a102c65c649b64419678332b,2538 +- completed: + hackage: tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329 + pantry-tree: + size: 1004 + sha256: 572071fca40a0b6c4cc950d10277a6f12e83cf4846882b6ef83fcccaa2c18c45 + original: + hackage: tcp-streams-1.0.1.1@sha256:35e9ecfa515797052f8c3c01834d2daebd5e93f3152c7fc98b32652bf6f0c052,2329 +- completed: + hackage: wire-streams-0.1.1.0@sha256:08816c7fa53b20f52e5c465252c106d9de8e6d9580ec0b6d9f000a34c7bcefc8,2130 + pantry-tree: + size: 506 + sha256: c99a12bfcbeacc5da8f166fbed1eb105a45f08be1a3a071fe9f903b386b14e1d + original: + hackage: wire-streams-0.1.1.0@sha256:08816c7fa53b20f52e5c465252c106d9de8e6d9580ec0b6d9f000a34c7bcefc8,2130 +snapshots: +- completed: + size: 496112 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/15.yaml + sha256: 86169722ad0056ffc9eacc157ef80ee21d7024f92c0d2961c89ccf432db230a3 + original: lts-15.15 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 index 0000000..5cbaca7 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Main where + +import Data.Functor.Identity (Identity) +import Data.Kind () +import Data.Text (Text) +import qualified Database.Beam as B +import GHC.Generics (Generic) +import Named ((!), defaults) +import Sequelize +import Test.Tasty +import Test.Tasty.HUnit +import Database.Beam.MySQL.Extra + + +---------------------------------------------------------------------------- +-- Setup +---------------------------------------------------------------------------- + +data TestDb f = TestDb + { testTable :: f (B.TableEntity TestT) + } + deriving (Generic, B.Database be) + +testDb :: B.DatabaseSettings be TestDb +testDb = B.defaultDbSettings + +data TestT f = Test + { email :: B.Columnar f Text, + enabled :: B.Columnar (B.Nullable f) Bool + } + deriving (Generic) + +type Test = TestT Identity + +instance B.Beamable TestT + +instance B.Table TestT where + data PrimaryKey TestT f = TestId (B.Columnar f Text) deriving (Generic, B.Beamable) + primaryKey = TestId . email + +instance ModelMeta TestT where + modelFieldModification = B.tableModification + modelTableName = "test" + + +---------------------------------------------------------------------------- +-- Tests +---------------------------------------------------------------------------- + +main :: IO () +main = + defaultMain $ + testGroup + "tests" + [ testCase "simple SELECT" unit_select_simple, + testCase "Eq (x :: Maybe _)" unit_select_eq_maybe, + testCase "full SELECT" unit_select_full, + testCase "simple UPDATE" unit_update_simple, + testCase "simple UPDATE setting all columns" unit_update'_simple, + testCase "modelToSets" unit_modelToSets + ] + +unit_select_simple :: IO () +unit_select_simple = + dumpSelectSQL + (sqlSelect + ! #where_ [Is enabled Null] + ! defaults + ) + @?= Just "SELECT `t0`.`email` AS `res0`, `t0`.`enabled` AS `res1` \ + \FROM `test` AS `t0` \ + \WHERE (`t0`.`enabled`) IS NULL;" + +unit_select_eq_maybe :: IO () +unit_select_eq_maybe = do + dumpSelectSQL (sqlSelect ! #where_ [Is enabled (Eq Nothing)] ! defaults) + @?= Just "SELECT `t0`.`email` AS `res0`, `t0`.`enabled` AS `res1` \ + \FROM `test` AS `t0` WHERE (`t0`.`enabled`) IS NULL;" + dumpSelectSQL (sqlSelect ! #where_ [Is enabled (Eq (Just True))] ! defaults) + @?= Just "SELECT `t0`.`email` AS `res0`, `t0`.`enabled` AS `res1` \ + \FROM `test` AS `t0` WHERE (`t0`.`enabled`) = (TRUE);" + dumpSelectSQL (sqlSelect ! #where_ [Is enabled (Not (Eq Nothing))] ! defaults) + @?= Just "SELECT `t0`.`email` AS `res0`, `t0`.`enabled` AS `res1` \ + \FROM `test` AS `t0` WHERE (`t0`.`enabled`) IS NOT NULL;" + dumpSelectSQL (sqlSelect ! #where_ [Is enabled (Not (Eq (Just True)))] ! defaults) + @?= Just "SELECT `t0`.`email` AS `res0`, `t0`.`enabled` AS `res1` \ + \FROM `test` AS `t0` WHERE (`t0`.`enabled`) <> (TRUE);" + +unit_select_full :: IO () +unit_select_full = + dumpSelectSQL + ( sqlSelect + ! #where_ + [ Is enabled (Not Null), + Or [Is email (Eq "a@example.com"), Is email (Eq "b@example.com")] + ] + ! #orderBy [Asc enabled, Desc email] + ! #offset 8 + ! #limit 10 + ) + @?= Just "SELECT `t0`.`email` AS `res0`, `t0`.`enabled` AS `res1` \ + \FROM `test` AS `t0` \ + \WHERE ((`t0`.`enabled`) IS NOT NULL) \ + \AND (((`t0`.`email`) = ('a@example.com')) OR ((`t0`.`email`) = ('b@example.com'))) \ + \ORDER BY `t0`.`enabled` ASC, `t0`.`email` DESC \ + \LIMIT 8, 10;" + +unit_update_simple :: IO () +unit_update_simple = + dumpUpdateSQL + ( sqlUpdate + ! #set [Set enabled Nothing] + ! #where_ [Is enabled (Not Null)] + ) + @?= Just "UPDATE `test` \ + \SET `enabled`=NULL \ + \WHERE (`enabled`) IS NOT NULL;" + +unit_update'_simple :: IO () +unit_update'_simple = + dumpUpdateSQL + ( sqlUpdate' + ! #save (Test "a@example.com" (Just False)) + ! #where_ [Is email (Eq "a@example.com")] + ) + @?= Just "UPDATE `test` \ + \SET `email`='a@example.com', `enabled`=FALSE \ + \WHERE (`email`) = ('a@example.com');" + +unit_modelToSets :: IO () +unit_modelToSets = do + dumpUpdateSQL + ( sqlUpdate' + ! #save (Test "a@example.com" Nothing) + ! #where_ [Is email (Eq "a@example.com")] + ) + @?= Just "UPDATE `test` \ + \SET `email`='a@example.com', `enabled`=DEFAULT \ + \WHERE (`email`) = ('a@example.com');"