├── .dockerignore ├── .editorconfig ├── .gitattributes ├── .github ├── ISSUE_TEMPLATE.md ├── PULL_REQUEST_TEMPLATE.md ├── reproductionTemplates │ ├── mongo.hs │ ├── mysql.hs │ ├── postgresql.hs │ └── sqlite.hs └── workflows │ ├── haskell.yml │ └── restyled.yml ├── .gitignore ├── .gitmodules ├── .restyled.yaml ├── .travis.yml ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── bin └── test-backend ├── cabal.project ├── development.md ├── docker-compose.yml ├── docs ├── Database-Configuration.md ├── PersistValue instances.md ├── Persistent-brainstorms.md ├── Persistent-entity-syntax.md └── README.md ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── justfile ├── persistent-mongoDB ├── ChangeLog.md ├── Database │ └── Persist │ │ └── MongoDB.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── persistent-mongoDB.cabal └── test │ ├── EmbedTestMongo.hs │ ├── EntityEmbedTestMongo.hs │ ├── MongoInit.hs │ ├── RawMongoHelpers.hs │ └── main.hs ├── persistent-mysql ├── ChangeLog.md ├── Database │ └── Persist │ │ └── MySQL.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── persistent-mysql.cabal └── test │ ├── CustomConstraintTest.hs │ ├── ImplicitUuidSpec.hs │ ├── InsertDuplicateUpdate.hs │ ├── JSONTest.hs │ ├── MyInit.hs │ └── main.hs ├── persistent-postgresql ├── ChangeLog.md ├── Database │ └── Persist │ │ ├── Postgresql.hs │ │ └── Postgresql │ │ ├── Internal.hs │ │ └── JSON.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── conn-killed │ └── Main.hs ├── persistent-postgresql.cabal ├── test-settings.sh └── test │ ├── ArrayAggTest.hs │ ├── CustomConstraintTest.hs │ ├── EquivalentTypeTestPostgres.hs │ ├── ImplicitUuidSpec.hs │ ├── JSONTest.hs │ ├── MigrationReferenceSpec.hs │ ├── PgInit.hs │ ├── PgIntervalTest.hs │ ├── UpsertWhere.hs │ └── main.hs ├── persistent-qq ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.lhs ├── persistent-qq.cabal ├── src │ └── Database │ │ └── Persist │ │ └── Sql │ │ └── Raw │ │ └── QQ.hs └── test │ ├── CodeGenTest.hs │ ├── PersistTestPetCollarType.hs │ ├── PersistTestPetType.hs │ ├── PersistentTestModels.hs │ └── Spec.hs ├── persistent-redis ├── ChangeLog.md ├── Database │ └── Persist │ │ ├── Redis.hs │ │ └── Redis │ │ ├── Config.hs │ │ ├── Exception.hs │ │ ├── Internal.hs │ │ ├── Parser.hs │ │ ├── Store.hs │ │ └── Update.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── persistent-redis.cabal └── tests │ └── basic-test.hs ├── persistent-sqlite ├── ChangeLog.md ├── Database │ ├── Persist │ │ └── Sqlite.hs │ ├── Sqlite.hs │ └── Sqlite │ │ └── Internal.hs ├── LICENSE ├── Setup.lhs ├── cbits │ ├── config.c │ ├── sqlite3.c │ └── sqlite3.h ├── persistent-sqlite.cabal ├── test │ ├── Database │ │ └── Persist │ │ │ └── Sqlite │ │ │ └── CompositeSpec.hs │ ├── SqliteInit.hs │ ├── main.hs │ └── sanity.hs ├── test1.hs ├── test2.hs └── test3.hs ├── persistent-template ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.lhs └── persistent-template.cabal ├── persistent-test ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.lhs ├── persistent-test.cabal └── src │ ├── CompositeTest.hs │ ├── CustomPersistField.hs │ ├── CustomPersistFieldTest.hs │ ├── CustomPrimaryKeyReferenceTest.hs │ ├── DataTypeTest.hs │ ├── Dummy.hs │ ├── EmbedOrderTest.hs │ ├── EmbedTest.hs │ ├── EmptyEntityTest.hs │ ├── EntityEmbedTest.hs │ ├── EquivalentTypeTest.hs │ ├── ForeignKey.hs │ ├── GeneratedColumnTestSQL.hs │ ├── HtmlTest.hs │ ├── Init.hs │ ├── LargeNumberTest.hs │ ├── LongIdentifierTest.hs │ ├── MaxLenTest.hs │ ├── MaybeFieldDefsTest.hs │ ├── MigrationColumnLengthTest.hs │ ├── MigrationIdempotencyTest.hs │ ├── MigrationOnlyTest.hs │ ├── MigrationTest.hs │ ├── MpsCustomPrefixTest.hs │ ├── MpsNoPrefixTest.hs │ ├── PersistTestPetCollarType.hs │ ├── PersistTestPetType.hs │ ├── PersistUniqueTest.hs │ ├── PersistentTest.hs │ ├── PersistentTestModels.hs │ ├── PersistentTestModelsImports.hs │ ├── PrimaryTest.hs │ ├── RawSqlTest.hs │ ├── ReadWriteTest.hs │ ├── Recursive.hs │ ├── RenameTest.hs │ ├── SumTypeTest.hs │ ├── TransactionLevelTest.hs │ ├── TreeTest.hs │ ├── TypeLitFieldDefsTest.hs │ ├── UniqueTest.hs │ └── UpsertTest.hs ├── persistent ├── ChangeLog.md ├── Database │ ├── Persist.hs │ └── Persist │ │ ├── Class.hs │ │ ├── Class │ │ ├── PersistConfig.hs │ │ ├── PersistEntity.hs │ │ ├── PersistField.hs │ │ ├── PersistQuery.hs │ │ ├── PersistStore.hs │ │ └── PersistUnique.hs │ │ ├── Compatible.hs │ │ ├── Compatible │ │ ├── TH.hs │ │ └── Types.hs │ │ ├── EntityDef.hs │ │ ├── EntityDef │ │ └── Internal.hs │ │ ├── FieldDef.hs │ │ ├── FieldDef │ │ └── Internal.hs │ │ ├── ImplicitIdDef.hs │ │ ├── ImplicitIdDef │ │ └── Internal.hs │ │ ├── Names.hs │ │ ├── PersistValue.hs │ │ ├── Quasi.hs │ │ ├── Quasi │ │ ├── Internal.hs │ │ ├── Internal │ │ │ └── ModelParser.hs │ │ ├── PersistSettings.hs │ │ └── PersistSettings │ │ │ └── Internal.hs │ │ ├── Sql.hs │ │ ├── Sql │ │ ├── Class.hs │ │ ├── Internal.hs │ │ ├── Migration.hs │ │ ├── Orphan │ │ │ ├── PersistQuery.hs │ │ │ ├── PersistStore.hs │ │ │ └── PersistUnique.hs │ │ ├── Raw.hs │ │ ├── Run.hs │ │ ├── Types.hs │ │ ├── Types │ │ │ └── Internal.hs │ │ └── Util.hs │ │ ├── SqlBackend.hs │ │ ├── SqlBackend │ │ ├── Internal.hs │ │ ├── Internal │ │ │ ├── InsertSqlResult.hs │ │ │ ├── IsolationLevel.hs │ │ │ ├── MkSqlBackend.hs │ │ │ ├── SqlPoolHooks.hs │ │ │ ├── Statement.hs │ │ │ └── StatementCache.hs │ │ ├── SqlPoolHooks.hs │ │ └── StatementCache.hs │ │ ├── TH.hs │ │ ├── TH │ │ └── Internal.hs │ │ ├── Types.hs │ │ └── Types │ │ ├── Base.hs │ │ └── SourceSpan.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── bench │ ├── Main.hs │ ├── Models.hs │ └── models-slowly ├── persistent.cabal └── test │ ├── Database │ └── Persist │ │ ├── ClassSpec.hs │ │ ├── PersistValueSpec.hs │ │ ├── QuasiSpec.hs │ │ ├── TH │ │ ├── CommentSpec.hs │ │ ├── CompositeKeyStyleSpec.hs │ │ ├── DiscoverEntitiesSpec.hs │ │ ├── EmbedSpec.hs │ │ ├── EntityHaddockSpec.hs │ │ ├── ForeignRefSpec.hs │ │ ├── ImplicitIdColSpec.hs │ │ ├── JsonEncodingSpec.hs │ │ ├── KindEntitiesSpec.hs │ │ ├── KindEntitiesSpecImports.hs │ │ ├── MaybeFieldDefsSpec.hs │ │ ├── MigrationOnlySpec.hs │ │ ├── MultiBlockSpec.hs │ │ ├── MultiBlockSpec │ │ │ └── Model.hs │ │ ├── NestedSymbolsInTypeSpec.hs │ │ ├── NestedSymbolsInTypeSpecImports.hs │ │ ├── NoFieldSelectorsSpec.hs │ │ ├── OverloadedLabelSpec.hs │ │ ├── PersistWith │ │ │ ├── Model.hs │ │ │ └── Model2.hs │ │ ├── PersistWithSpec.hs │ │ ├── RequireOnlyPersistImportSpec.hs │ │ ├── SharedPrimaryKeyImportedSpec.hs │ │ ├── SharedPrimaryKeySpec.hs │ │ ├── SumSpec.hs │ │ ├── ToFromPersistValuesSpec.hs │ │ └── TypeLitFieldDefsSpec.hs │ │ └── THSpec.hs │ ├── TemplateTestImports.hs │ └── main.hs ├── sources.txt ├── stack-8.10.yaml ├── stack-8.10.yaml.lock ├── stack-docker.yaml ├── stack-nightly.yaml ├── stack.yaml ├── stack_lts-12.yaml └── travis └── run.sh /.dockerignore: -------------------------------------------------------------------------------- 1 | [a-zA-CE-Z]* 2 | .[a-zA-CE-Z]* 3 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | root = true 3 | 4 | [Makefile] 5 | indent_style = tabs 6 | indent_size = 8 7 | end_of_line = lf 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | 12 | [*.{hs,md}] 13 | indent_style = space 14 | indent_size = 4 15 | tab_width = 4 16 | end_of_line = lf 17 | charset = utf-8 18 | trim_trailing_whitespace = true 19 | insert_final_newline = true 20 | max_line_length = 80 21 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | persistent-sqlite/cbits/* linguist-vendored -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | 33 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Before submitting your PR, check that you've: 2 | 3 | - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html) 4 | - [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock 5 | - [ ] Ran `fourmolu` on any changed files (`restyled` will do this for you, so 6 | accept the suggested changes if it makes them) 7 | - [ ] Adhered to the code style (see the `.editorconfig` and `fourmolu.yaml` files for details) 8 | 9 | After submitting your PR: 10 | 11 | - [ ] Update the Changelog.md file with a link to your PR 12 | - [ ] Bumped the version number if there isn't an `(unreleased)` on the Changelog 13 | - [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts) 14 | 15 | 18 | -------------------------------------------------------------------------------- /.github/reproductionTemplates/mongo.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-9.21 script 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | import Control.Monad.Logger (runStdoutLoggingT) 13 | import Control.Monad.IO.Class (liftIO) 14 | import Database.Persist 15 | import Database.Persist.MongoDB 16 | import Database.Persist.TH 17 | import Control.Monad.Reader 18 | import Language.Haskell.TH.Syntax 19 | 20 | let mongoSettings = (mkPersistSettings (ConT ''MongoContext)) 21 | in share [mkPersist mongoSettings] 22 | [persistUpperCase| 23 | Person 24 | name String 25 | age Int Maybe 26 | deriving Show Eq 27 | BlogPost 28 | title String 29 | authorId PersonId 30 | deriving Show Eq 31 | |] 32 | 33 | main :: IO () 34 | main = withMongoPool (defaultMongoConf "persistent") $ runMongoDBPool master $ do 35 | 36 | johnId <- insert $ Person "John Doe" $ Just 35 37 | delete johnId 38 | -------------------------------------------------------------------------------- /.github/reproductionTemplates/mysql.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-9.21 script --package persistent-mysql --package monad-logger --package persistent-template --package mtl --package persistent 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | import Control.Monad.Logger (runStdoutLoggingT) 13 | import Control.Monad.IO.Class (liftIO) 14 | import Database.Persist 15 | import Database.Persist.MySQL 16 | import Database.Persist.TH 17 | import Control.Monad.Reader 18 | 19 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 20 | Person 21 | name String 22 | age Int Maybe 23 | deriving Show Eq 24 | BlogPost 25 | title String 26 | authorId PersonId 27 | deriving Show Eq 28 | |] 29 | 30 | main :: IO () 31 | main = runStdoutLoggingT $ withMySQLPool defaultConnectInfo { connectDatabase = "persistent" } 1 $ liftSqlPersistMPool $ do 32 | runMigration migrateAll 33 | 34 | johnId <- insert $ Person "John Doe" $ Just 35 35 | delete johnId 36 | -------------------------------------------------------------------------------- /.github/reproductionTemplates/postgresql.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-9.21 script 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | import Control.Monad.Logger (runStdoutLoggingT) 13 | import Control.Monad.IO.Class (liftIO) 14 | import Database.Persist 15 | import Database.Persist.Postgresql 16 | import Database.Persist.TH 17 | import Control.Monad.Reader 18 | 19 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 20 | Person 21 | name String 22 | age Int Maybe 23 | deriving Show Eq 24 | BlogPost 25 | title String 26 | authorId PersonId 27 | deriving Show Eq 28 | |] 29 | 30 | main :: IO () 31 | main = runStdoutLoggingT $ withPostgresqlPool "dbname=persistent" 1 $ liftSqlPersistMPool $ do 32 | runMigration migrateAll 33 | 34 | johnId <- insert $ Person "John Doe" $ Just 35 35 | delete johnId 36 | -------------------------------------------------------------------------------- /.github/reproductionTemplates/sqlite.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-9.21 script 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | import Control.Monad.IO.Class (liftIO) 13 | import Database.Persist 14 | import Database.Persist.Sqlite 15 | import Database.Persist.TH 16 | 17 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 18 | Person 19 | name String 20 | age Int Maybe 21 | deriving Show Eq 22 | BlogPost 23 | title String 24 | authorId PersonId 25 | deriving Show Eq 26 | |] 27 | 28 | main :: IO () 29 | main = runSqlite ":memory:" $ do 30 | runMigration migrateAll 31 | 32 | johnId <- insert $ Person "John Doe" $ Just 35 33 | delete johnId 34 | -------------------------------------------------------------------------------- /.github/workflows/restyled.yml: -------------------------------------------------------------------------------- 1 | # .github/workflows/restyled.yml 2 | 3 | name: Restyled 4 | 5 | on: 6 | pull_request: 7 | 8 | concurrency: 9 | group: ${{ github.workflow }}-${{ github.ref }} 10 | cancel-in-progress: true 11 | 12 | jobs: 13 | restyled: 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v4 17 | - uses: restyled-io/actions/setup@v4 18 | - uses: restyled-io/actions/run@v4 19 | with: 20 | suggestions: true 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Haskell build 2 | dist 3 | *.hi 4 | *.o 5 | .stack-work/ 6 | 7 | ## Editor ignores 8 | TAGS 9 | *~ 10 | *.swp 11 | 12 | ## databases 13 | test.db3 14 | *.sqlite3 15 | 16 | # ? 17 | tarballs/ 18 | 19 | # install script error messages 20 | # maybe should use shellyNoDir ? 21 | .shelly/ 22 | 23 | ## Cabal sandboxing tools 24 | .virthualenv 25 | cabal-dev/ 26 | cabal.sandbox.config 27 | .cabal-sandbox/ 28 | dist-newstyle/ 29 | .ghc.environment.* 30 | 31 | # for direnv 32 | .envrc 33 | 34 | # nix relation 35 | .direnv/ 36 | .env.local 37 | result/ 38 | 39 | ## Docker image ignores 40 | /.cabal/ 41 | /.stackage/ 42 | /.ghc/ 43 | /.bash_history 44 | /.bashrc 45 | .mongorc.js 46 | .dbshell 47 | crane.yml 48 | # can use this for Docker databases 49 | persistent-test/db/ 50 | 51 | # docker image with a mounted file system 52 | /x86_64-linux-ghc-7.8.3-packages.conf.d/ 53 | /packages/ 54 | 55 | # macOS 56 | .DS_Store 57 | 58 | # hspec nonsense 59 | .hspec-failures 60 | 61 | stack.yaml.lock 62 | *.yaml.lock 63 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "pool"] 2 | path = pool 3 | url = https://github.com/bos/pool.git 4 | -------------------------------------------------------------------------------- /.restyled.yaml: -------------------------------------------------------------------------------- 1 | restylers: 2 | - cabal-fmt 3 | - fourmolu 4 | - stylish-haskell: 5 | enabled: false 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /bin/test-backend: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -eu 3 | set -o pipefail 4 | 5 | function command_help() { 6 | echo "\ 7 | $0 [-h|--help] IMAGE:TAG 8 | " 9 | } 10 | 11 | function error_msg() { 12 | echo "" 13 | echo "ERROR: $*" 14 | echo "" 15 | } 16 | 17 | function exit_msg() { 18 | error_msg "$@" 19 | command_help 20 | echo "" 21 | exit 1 22 | } 23 | 24 | case "$1" in 25 | mongo|mongodb) 26 | docker-compose run --rm -d mongo 27 | sleep 2 28 | function finish() { 29 | docker rm -f persistent_mongo_run_1 30 | } 31 | trap finish EXIT 32 | stack test persistent-mongodb 33 | ;; 34 | postgresql|postgres) 35 | docker-compose run --rm -d postgres 36 | sleep 2 37 | function finish() { 38 | docker rm -f persistent_postgres_run_1 || { 39 | echo "startup failure" 40 | exit 1 41 | } 42 | } 43 | trap finish EXIT 44 | stack test persistent-postgresql 45 | ;; 46 | *) 47 | exit_msg "don't yet know how to test: $1, please teach me!" 48 | ;; 49 | esac 50 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | persistent 3 | persistent-sqlite 4 | persistent-test 5 | persistent-mongoDB 6 | persistent-mysql 7 | persistent-postgresql 8 | persistent-redis 9 | persistent-qq 10 | 11 | -- required by nix but breaks macOS cabal builds: 12 | --package postgresql-libpq 13 | -- flags: +use-pkg-config 14 | 15 | allow-newer: 16 | -- https://github.com/fizruk/http-api-data/pull/146 17 | http-api-data:base 18 | , postgresql-simple:base 19 | , postgresql-simple:template-haskell 20 | , bytestring-lexing:base 21 | 22 | source-repository-package 23 | type: git 24 | location: https://github.com/parsonsmatt/mysql 25 | tag: 1e7dc274bf9a2919c9dd4298ed46c1bd1a1b677d 26 | --sha256: 1zbwly28rpwkqqkj9cbsbr57rx2y79nbfcrvqmp7a0gxy0d9i4qy 27 | 28 | -- Needed to test that `persistent-redis` works with mtl-2.3 29 | -- https://github.com/informatikr/hedis/pull/190 30 | -- source-repository-package 31 | -- type: git 32 | -- location: https://github.com/ysangkok/hedis 33 | -- tag: 6f36989836b49974f51a6ee8edaf156490590980 34 | -------------------------------------------------------------------------------- /development.md: -------------------------------------------------------------------------------- 1 | # Style Guide 2 | 3 | ## `fourmolu` 4 | 5 | This repository uses 6 | [`fourmolu`](https://hackage.haskell.org/package/fourmolu) as an 7 | autoformatter. 8 | 9 | ## `editorconfig` 10 | 11 | This repository has an `.editorconfig` file for use with the 12 | [`EditorConfig`](https://editorconfig.org/) tool. It's recommended to install 13 | the tool so that the editor style is picked up automatically. 14 | 15 | ## General Style Guide 16 | 17 | Prefer 4 space indentation. If the line gets too long, refactor the code - pull 18 | out named terms into `let` or `where` bindings (or top-level functions). 19 | 20 | Prefer `case` expressions over combinators. Prefer `do` notation over combinators. 21 | It's easier, simpler, and faster to read and modify these forms than more 22 | concise versions, even where the more concise version is faster to write at 23 | first. 24 | 25 | # Building with Backends 26 | 27 | With all required backends installed, `stack build` can build all packages 28 | listed in `stack.yaml` and is equivalent to: 29 | 30 | ``` 31 | > stack build persistent persistent-template persistent-sqlite persistent-test 32 | persistent-mongoDB persistent-mysql persistent-postgresql persistent-redis 33 | ``` 34 | 35 | If backends such as mysql and postgres are not installed then the default build 36 | will fail as will builds for packages for those backends alone: 37 | 38 | ``` 39 | > stack build persistent-mysql 40 | ... 41 | Process exited with code: ExitFailure 1 42 | Configuring mysql-0.1.4... 43 | setup: The program 'mysql_config' is required but it could not be found 44 | 45 | > stack build persistent-postgresql 46 | ... 47 | Process exited with code: ExitFailure 1 48 | Configuring postgresql-libpq-0.9.4.0... 49 | setup: The program 'pg_config' is required but it could not be found. 50 | ``` 51 | 52 | To build all other packages, drop the failing package names as targets: 53 | 54 | ``` 55 | > stack build persistent persistent-template persistent-sqlite persistent-test 56 | persistent-mongoDB persistent-redis 57 | ... 58 | Completed 6 action(s). 59 | ``` 60 | 61 | # Running persistent tests using Stack 62 | 63 | To run all the tests for the repository, run: 64 | 65 | > stack test 66 | 67 | For testing specific packages, you can run: 68 | 69 | > stack test persistent-sqlite 70 | 71 | This will run the tests for the `persistent-sqlite` package alone. 72 | 73 | # Running persistent tests using Cabal 74 | 75 | > cabal new-test all 76 | 77 | To test a specific package, you'll pass the package names instead of `all`. 78 | 79 | # Testing Backends 80 | 81 | The different backend libraries (`persistent-postgresql`, `persistent-mysql`, etc) are tested in their respective package directories. 82 | `persistent-sqlite` requires 0 additional setup. 83 | The other packages require some amount of setup in order to run. 84 | Details for setup in these should be present in those package directories. 85 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3.4' 2 | services: 3 | postgres: 4 | image: postgres:9.5 5 | ports: 6 | - "5432:5432" 7 | network_mode: "host" 8 | environment: 9 | - "POSTGRES_USER=postgres" 10 | - "POSTGRES_DB=test" 11 | - "POSTGRES_PASSWORD=password" 12 | #volumes: 13 | # - ./postgres_data/persistent/data:/var/lib/postgresql/data 14 | 15 | mongo: 16 | command: ["--smallfiles"] 17 | image: mongo:3.4 18 | ports: 19 | - "27017:27017" 20 | network_mode: "host" 21 | -------------------------------------------------------------------------------- /docs/Database-Configuration.md: -------------------------------------------------------------------------------- 1 | # Database Configuration 2 | 3 | Database configuration may change the semantics of your database in important ways; this page lists options likely to affect Persistent users. 4 | 5 | ## MySQL 6 | 7 | ### Strict Mode 8 | 9 | By default, MySQL will truncate too-long values, which can corrupt data (by e.g. truncating a binary file) or cause [unexpected behavior](https://github.com/yesodweb/persistent/issues/122). If you'd like to have MySQL raise an error instead, enable [strict mode](https://dev.mysql.com/doc/refman/5.6/en/sql-mode.html#sql-mode-strict). You can enable this by editing your `my.cnf` file: 10 | 11 | ``` 12 | sql_mode="STRICT_ALL_TABLES" 13 | ``` 14 | 15 | or by setting the SQL mode from the MySQL console: 16 | 17 | ``` 18 | SET GLOBAL sql_mode = 'STRICT_ALL_TABLES'; 19 | ``` 20 | 21 | Note that strict mode causes slight changes in behavior; see the MySQL docs link above for details. 22 | 23 | ## SQLite 24 | 25 | ### Enable foreign key constraints 26 | 27 | Foreign key checks are not enabled by default in SQLite. [This wiki page](https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Activate-foreign-key-checking-in-Sqlite.md) explains how to enable foreign key checks when using Persistent/Yesod. 28 | 29 | ### URI Filenames 30 | 31 | Sqlite supports URI syntax with the advantage of additional configuration options via query parameters (cf. [Sqlite docs on URI filenames](https://www.sqlite.org/uri.html)). 32 | 33 | * The scheme of the URI must be "file:". Any other scheme results in the input being treated as an ordinary filename. 34 | * The authority may be omitted, may be blank, or may be "localhost". Any other authority results in an error. 35 | * The path is optional if the authority is present. If the authority is omitted then the path is required. 36 | 37 | If no further query parameter is provided, the database is opened in the mode "read-write" and "create file" (e.g. create new file if it does not yet exist), the default behavior. 38 | 39 | The mode query parameter determines if the new database is opened read-only, read-write, read-write and created if it does not exist, or that the database is a pure in-memory database that never interacts with disk, respectively. 40 | 41 | mode=ro 42 | mode=rw 43 | mode=rwc 44 | mode=memory 45 | 46 | #### Connection string example 47 | 48 | * Conventional style: "sqlite3.db" 49 | * URI filename style, relative path, read-only: "file:sqlite3.db?mode=ro" 50 | -------------------------------------------------------------------------------- /docs/PersistValue instances.md: -------------------------------------------------------------------------------- 1 | # PersistValue instances 2 | 3 | These are orphan instances that don't have a home yet. 4 | 5 | ``` haskell 6 | -- The Scientific type, in widespread use by aeson users and useful for financial, scientific data 7 | instance PersistField Scientific where 8 | toPersistValue = PersistRational . toRational 9 | fromPersistValue (PersistRational r) = Right $ fromRational r 10 | fromPersistValue (PersistDouble d) = Right $ fromFloatDigits d 11 | fromPersistValue (PersistInt64 i) = Right $ fromIntegral i 12 | fromPersistValue x = Left $ T.pack "PersistField Scientific: Expected Scientific, received: " <> T.pack (show x) 13 | 14 | instance PersistFieldSql Scientific where 15 | sqlType _ = SqlNumeric 32 20 -- Use your own judgement here 16 | ``` 17 | 18 | ```haskell 19 | import Numeric (showHex) 20 | 21 | -- Store a large integer in hexadecimal format (which is easier to inspect in the database) 22 | instance PersistField Integer where 23 | toPersistValue i = PersistText . T.pack $ showHex i "" 24 | fromPersistValue (PersistText s) = read $ "0x" <> T.unpack s 25 | fromPersistValue x = Left $ T.pack "PersistField Integer: Expected hexadecimal text, received: " <> T.pack (show x) 26 | instance PersistFieldSql Integer where 27 | sqlType _ = SqlString 28 | 29 | -- Alternatively, for a fixed length integer, pad the hexadecimal with zeros 30 | showHexFixed :: (Integral a, Show a) => Int -> a -> String 31 | showHexFixed len val = padZeros $ showHex val "" 32 | where padZeros s = if length s >= len then s else padZeros ('0' : s) 33 | 34 | instance PersistField Integer where 35 | toPersistValue i = PersistText . T.pack $ showHexFixed 30 i 36 | fromPersistValue (PersistText s) = read $ "0x" <> T.unpack s 37 | fromPersistValue x = Left $ T.pack "PersistField Integer: Expected hexadecimal char(30), received: " <> T.pack (show x) 38 | instance PersistFieldSql Integer where 39 | sqlType _ = SqlOther $ T.pack "char(30)" -- fixed length character string, stored inline 40 | ``` 41 | -------------------------------------------------------------------------------- /docs/Persistent-brainstorms.md: -------------------------------------------------------------------------------- 1 | # Persistent brainstorms 2 | 3 | # Simplified monad stack handling 4 | 5 | An issue I (Michael) have run into is complications with complex monad stacks. This is unfortunate, since all current backends could essentially drop their specialized monads and just expect a `Connection` value to be passed in to all functions. (This isn't true right now due to how the mongoDB package works, but that could be fixed upstream.) 6 | 7 | Ideally, I'd like all functions to have core signatures such as: 8 | 9 | getImpl :: Key entity -> backend -> IO (Maybe entity) 10 | 11 | And then have a monadic interface which is essentially just a `ReaderT` provided for convenience. 12 | 13 | 14 | 15 | # Triggers 16 | 17 | Code that executes on database changes. 18 | 19 | Ideally triggers would be a transformer layer, but an easier route may be to register them in IO (TCache does this). 20 | 21 | Thoughts on this are still raw 22 | 23 | What if you wanted to have an audit log of changes? Right now you would need to create [separate functions](http://devblog.soostone.com/posts/2013-05-10-snaplet-actionlog.html) such as loggedInsert. But then you need to have control over every insert and change it to loggedInsert. Loggging database changes could be handled in the background, even by a separate process via a queue. There are different types of triggers. 24 | 25 | * can be handled by database triggers 26 | * application triggers: the database doesn't have enough information to handle them 27 | 28 | If the database can handle a trigger, one still might want a trigger to be generated like a migration so that triggers can be verified and possibly made portable across databases. There is a library with support for writing postgres triggers in a persistent schema. 29 | 30 | Another thing to think about is if this concept ties in to the concept of auto-updating the client-side when data changes. If triggers exist only in an application, then we run into trouble if there is a second application that writes to the database. For example, it is easy enough to automatically send an e-mail from our Haskell application when a model changes. If we have multiple writers then we need our Haskell application to be automatically notified when the model changes. 31 | 32 | So the simple way to deal with triggers that can't be performed by the database is to put all triggers in a single application and tie them to the writes done by that application. The correct but hard way is to have the application triggers respond to changes in the database. In some cases both approaches may be needed: an application may want to ignore changes performed by other applications (allow admin access for data editing). 33 | -------------------------------------------------------------------------------- /docs/Persistent-entity-syntax.md: -------------------------------------------------------------------------------- 1 | # Persistent Entity Syntax 2 | 3 | Persistent's entity file syntax. 4 | 5 | This page has been superseded by the [documentation for 6 | Database.Persist.Quasi](http://hackage.haskell.org/package/persistent/docs/Database-Persist-Quasi.html). 7 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | Get started with Persistent at: http://www.yesodweb.com/book/persistent 2 | 3 | ## Wiki 4 | 5 | * [Entity Syntax](http://hackage.haskell.org/package/persistent/docs/Database-Persist-Quasi.html) is documented in the `Database.Persist.Quasi` module 6 | * [Database Configuration](./Database-Configuration.md) 7 | 8 | ## External Documentation 9 | 10 | * [School of Haskell documentation](https://www.fpcomplete.com/school/advanced-haskell/persistent-in-detail) 11 | * [uuid example](http://michaelxavier.net/posts/2015-04-14-Adding-a-UUID-Column-to-a-Persistent-Table.html) 12 | 13 | ## persistent libraries 14 | 15 | * [Triggers for SQL](https://github.com/jcristovao/migrationplus) 16 | * [ODBC](https://github.com/gbwey/persistent-odbc) 17 | * [Zookeeper](https://hackage.haskell.org/package/persistent-zookeeper) 18 | * [`persistent-typed-db`](https://hackage.haskell.org/package/persistent-typed-db) 19 | allows type safe access to multiple databases with different schemas 20 | * [`esqueleto`](https://hackage.haskell.org/package/esqueleto) allows for more 21 | complex SQL queries using the Persistent backend types 22 | 23 | 24 | ## Persistent with MongoDB 25 | 26 | Some code snippets: 27 | 28 | [Basic MongoDB connection and queries](https://github.com/yesodweb/yesod/wiki/Rawmongo) 29 | 30 | [Non scaffolded MongoDB app](https://github.com/yesodweb/yesod/wiki/Non-scaffolded-MongoDB-App) 31 | 32 | [Scaffolded without Foundation](https://github.com/yesodweb/yesod/wiki/Using-Database.Persist.runPool-without-Foundation) 33 | 34 | [Using the raw MongoDB driver](https://github.com/yesodweb/yesod/wiki/Raw-Mongo) 35 | 36 | 37 | Head to the [API docs](http://yesodweb.github.io/persistent/persistent-mongoDB/Database-Persist-MongoDB.html) for more detail 38 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = 3 | "Persistence interface for Haskell allowing multiple storage methods."; 4 | 5 | inputs = { 6 | haskellNix.url = "github:input-output-hk/haskell.nix"; 7 | nixpkgs.follows = "haskellNix/nixpkgs-unstable"; 8 | flake-utils.url = "github:numtide/flake-utils"; 9 | }; 10 | 11 | outputs = { self, nixpkgs, flake-utils, haskellNix }: 12 | flake-utils.lib.eachDefaultSystem (system: 13 | let 14 | pkgs = import nixpkgs { 15 | inherit system overlays; 16 | inherit (haskellNix) config; 17 | }; 18 | overlays = [ 19 | haskellNix.overlay 20 | (final: prev: { 21 | project = final.haskell-nix.project' { 22 | src = ./.; 23 | compiler-nix-name = "ghc966"; 24 | projectFileName = "cabal.project"; 25 | shell = { 26 | tools = { 27 | cabal = "latest"; 28 | cabal-fmt = "latest"; 29 | cabal-install = "latest"; 30 | fourmolu = "latest"; 31 | ghcid = "latest"; 32 | haskell-language-server = "latest"; 33 | }; 34 | buildInputs = with pkgs; [ 35 | mariadb 36 | mariadb-connector-c.dev 37 | postgresql 38 | redis 39 | sqlite 40 | ]; 41 | }; 42 | modules = [{ 43 | packages."mysql".components.library = with pkgs; { 44 | configureFlags = [ 45 | "--with-mysql_config=${mariadb-connector-c.dev}/bin/mysql_config" 46 | ]; 47 | includes = [ openssl zlib ]; 48 | libs = [ openssl zlib ]; 49 | }; 50 | }]; 51 | }; 52 | }) 53 | ]; 54 | flake = pkgs.project.flake { }; 55 | in flake); 56 | 57 | nixConfig = { 58 | extra-substituters = [ 59 | "https://cache.nixos.org/" 60 | "https://cache.iog.io" # use GHC binary cache. 61 | ]; 62 | extra-trusted-public-keys = 63 | [ "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" ]; 64 | allow-import-from-derivation = "true"; 65 | }; 66 | } 67 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 4 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 80 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: leading 15 | 16 | # Rules for grouping import declarations 17 | import-grouping: legacy 18 | 19 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 20 | indent-wheres: false 21 | 22 | # Whether to leave a space before an opening record brace 23 | record-brace-space: false 24 | 25 | # Number of spaces between top-level declarations 26 | newlines-between-decls: 1 27 | 28 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 29 | haddock-style: single-line 30 | 31 | # How to print module docstring 32 | haddock-style-module: null 33 | 34 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 35 | let-style: newline 36 | 37 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 38 | in-style: right-align 39 | 40 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 41 | single-constraint-parens: always 42 | 43 | # Whether to put parentheses around a single deriving class (choices: auto, always, or never) 44 | single-deriving-parens: always 45 | 46 | # Whether to sort constraints 47 | sort-constraints: false 48 | 49 | # Whether to sort derived classes 50 | sort-derived-classes: false 51 | 52 | # Whether to sort deriving clauses 53 | sort-deriving-clauses: false 54 | 55 | # Whether to place section operators (those that are infixr 0, such as $) in trailing position, continuing the expression indented below 56 | trailing-section-operators: true 57 | 58 | # Output Unicode syntax (choices: detect, always, or never) 59 | unicode: never 60 | 61 | # Give the programmer more choice on where to insert blank lines 62 | respectful: true 63 | 64 | # Fixity information for operators 65 | fixities: [] 66 | 67 | # Module reexports Fourmolu should know about 68 | reexports: [] 69 | 70 | # Modules defined by the current Cabal package for import grouping 71 | local-modules: [] 72 | -------------------------------------------------------------------------------- /justfile: -------------------------------------------------------------------------------- 1 | # vim: set ft=make : 2 | 3 | help: 4 | @echo "just is a convenient command runner. Try just -l" 5 | 6 | # Run the tests against mongo DB 7 | test backend: 8 | ./bin/test-backend {{backend}} 9 | -------------------------------------------------------------------------------- /persistent-mongoDB/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for persistent-mongoDB 2 | 3 | ## 2.13.1.0 4 | 5 | * Restore update write concern behavior with MongoDB Driver for MongoDB >= 6.0 [#1550](https://github.com/yesodweb/persistent/pull/1550) 6 | 7 | ## 2.13.0.2 8 | 9 | * Fix behavioral compatibility with MongoDB Driver for MongoDB >= 6.0 [#1545](https://github.com/yesodweb/persistent/pull/1545) 10 | 11 | ## 2.13.0.1 12 | 13 | * [#1367](https://github.com/yesodweb/persistent/pull/1367), 14 | [#1366](https://github.com/yesodweb/persistent/pull/1367), 15 | [#1338](https://github.com/yesodweb/persistent/pull/1338), 16 | [#1335](https://github.com/yesodweb/persistent/pull/1335) 17 | * Support GHC 9.2 18 | 19 | ## 2.13.0.0 20 | 21 | * Fix persistent 2.13 changes [#1286](https://github.com/yesodweb/persistent/pull/1286) 22 | 23 | ## 2.12.0.0 24 | 25 | * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) 26 | 27 | ## 2.11.0 28 | 29 | * Naive implementation of `exists` function from `PersistQueryRead` type class using `count`. [#1131](https://github.com/yesodweb/persistent/pull/1131/files) 30 | 31 | ## 2.10.0.1 32 | 33 | * Remove unnecessary deriving of Typeable [#1114](https://github.com/yesodweb/persistent/pull/1114) 34 | 35 | ## 2.10.0.0 36 | 37 | * Fix `ninList` filter operator [#1058](https://github.com/yesodweb/persistent/pull/1058) 38 | 39 | ## 2.9.0.2 40 | 41 | * Compatibility with latest mongoDB [#1012](https://github.com/yesodweb/persistent/pull/1012) 42 | 43 | ## 2.9.0.1 44 | 45 | * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) 46 | 47 | ## 2.9.0 48 | 49 | * Removed deprecated `entityToDocument`. Please use `recordToDocument` instead. [#894](https://github.com/yesodweb/persistent/pull/894) 50 | * Removed deprecated `multiBsonEq`. Please use `anyBsonEq` instead. [#894](https://github.com/yesodweb/persistent/pull/894) 51 | * Use `portID` from `mongoDB` instead of `network`. [#946](https://github.com/yesodweb/persistent/pull/946) 52 | 53 | ## 2.8.0 54 | 55 | * Switch from `MonadBaseControl` to `MonadUnliftIO` 56 | 57 | ## 2.6.0 58 | 59 | * Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613) 60 | * Relax bounds for http-api-data 61 | 62 | ## 2.5 63 | 64 | * changes for read/write typeclass split 65 | 66 | ## 2.1.4 67 | 68 | * support http-api-data for url serialization 69 | 70 | ## 2.1.3 71 | 72 | * Add list filtering functions `inList` and `ninList` 73 | 74 | ## 2.1.2 75 | 76 | * Add `nestAnyEq` filter function 77 | * Add `FromJSON` instance for `MongoConf` 78 | -------------------------------------------------------------------------------- /persistent-mongoDB/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-mongoDB/README.md: -------------------------------------------------------------------------------- 1 | # persistent-mongoDB 2 | 3 | `persistent-mongoDB` is on hiatus. 4 | 5 | There's a lot of complexity around the `EmbedEntityDef` stuff that makes it 6 | really annoying to use. 7 | 8 | A new version of `persistent` will make that easy to work with, and I'll fix it 9 | up then. 10 | 11 | If you want MongoDB *now* then PRs are welcome. 12 | -------------------------------------------------------------------------------- /persistent-mongoDB/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-mongoDB/persistent-mongoDB.cabal: -------------------------------------------------------------------------------- 1 | name: persistent-mongoDB 2 | version: 2.13.1.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Greg Weber 6 | maintainer: Andres Schmois 7 | synopsis: Backend for the persistent library using mongoDB. 8 | category: Database 9 | stability: Experimental 10 | cabal-version: >=1.10 11 | build-type: Simple 12 | homepage: http://www.yesodweb.com/book/persistent 13 | bug-reports: https://github.com/yesodweb/persistent/issues 14 | description: MongoDB backend for the persistent library. 15 | extra-source-files: ChangeLog.md 16 | 17 | flag high_precision_date 18 | description: for MongoDB use a time storage with nano second precision. 19 | default: False 20 | 21 | library 22 | build-depends: 23 | aeson >=1.0 24 | , base >=4.8 && <5 25 | , bson >=0.3.2 && <0.5 26 | , bytestring 27 | , cereal >=0.5 28 | , conduit >=1.2 29 | , http-api-data >=0.3.7 && <0.7 30 | , mongoDB >=2.7.1.2 && <2.8 31 | , network >=2.6 32 | , path-pieces >=0.2 33 | , persistent >=2.12 && <3 34 | , resource-pool >=0.2 && <0.5 35 | , resourcet >=1.1 36 | , text >=1.2 37 | , time 38 | , transformers >=0.5 39 | , unliftio-core 40 | 41 | exposed-modules: Database.Persist.MongoDB 42 | ghc-options: -Wall 43 | default-language: Haskell2010 44 | 45 | if flag(high_precision_date) 46 | cpp-options: -DHIGH_PRECISION_DATE 47 | 48 | test-suite test 49 | type: exitcode-stdio-1.0 50 | main-is: main.hs 51 | hs-source-dirs: test 52 | other-modules: 53 | EmbedTestMongo 54 | EntityEmbedTestMongo 55 | MongoInit 56 | RawMongoHelpers 57 | 58 | ghc-options: -Wall 59 | build-depends: 60 | base >=4.6 && <5 61 | , blaze-html 62 | , bytestring 63 | , containers 64 | , hspec >=2.4.0 65 | , HUnit 66 | , mongoDB 67 | , persistent 68 | , persistent-mongoDB 69 | , persistent-qq 70 | , persistent-test 71 | , process 72 | , QuickCheck 73 | , template-haskell 74 | , text 75 | , time 76 | , transformers 77 | , unliftio-core 78 | 79 | default-language: Haskell2010 80 | 81 | source-repository head 82 | type: git 83 | location: https://github.com/yesodweb/persistent.git 84 | -------------------------------------------------------------------------------- /persistent-mongoDB/test/EntityEmbedTestMongo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE DataKinds, ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE DerivingStrategies #-} 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | module EntityEmbedTestMongo where 14 | 15 | -- because we are using a type alias we need to declare in a separate module 16 | -- this is used in EmbedTest 17 | import MongoInit 18 | 19 | mkPersist persistSettings [persistUpperCase| 20 | ARecord 21 | name Text 22 | deriving Show Eq Read Ord 23 | |] 24 | 25 | type AnEntity = Entity ARecord 26 | -------------------------------------------------------------------------------- /persistent-mongoDB/test/RawMongoHelpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module RawMongoHelpers where 3 | 4 | import qualified Database.MongoDB as MongoDB 5 | import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument) 6 | 7 | import MongoInit 8 | import PersistentTest (cleanDB) 9 | import PersistentTestModels 10 | 11 | 12 | db :: ReaderT MongoDB.MongoContext IO () -> IO () 13 | db = db' cleanDB 14 | 15 | specs :: Spec 16 | specs = do 17 | describe "raw MongoDB helpers" $ do 18 | it "collectionName" $ do 19 | collectionName (Person "Duder" 0 Nothing) @?= "Person" 20 | 21 | it "toInsertFields, entityFields, & docToEntityThrow" $ db $ do 22 | let p1 = Person "Duder" 0 Nothing 23 | let doc = toInsertDoc p1 24 | MongoDB.ObjId _id <- MongoDB.insert "Person" $ doc 25 | let idSelector = "_id" MongoDB.=: _id 26 | Entity _ ent1 <- docToEntityThrow $ idSelector:doc 27 | liftIO $ p1 @?= ent1 28 | 29 | let p2 = p1 {personColor = Just "blue"} 30 | let doc2 = idSelector:recordToDocument p2 31 | MongoDB.save "Person" doc2 32 | Entity _ ent2 <- docToEntityThrow doc2 33 | liftIO $ p2 @?= ent2 34 | -------------------------------------------------------------------------------- /persistent-mysql/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-mysql/README.md: -------------------------------------------------------------------------------- 1 | # `persistent-mysql` 2 | 3 | [![Build Status](https://travis-ci.org/yesodweb/persistent-mysql.svg?branch=master)](https://travis-ci.org/yesodweb/persistent-mysql) [![Hackage](https://img.shields.io/hackage/v/persistent-mysql.svg)] ![Hackage-Deps](https://img.shields.io/hackage-deps/v/persistent-mysql.svg) 4 | 5 | A backend for the `persistent` database library for the MySQL database server. 6 | 7 | ## Development 8 | 9 | To run tests on this library, you will need to have a MySQL database server set up and running on your computer. 10 | The test suite expects to see a database named `test` with a username `test` and password `test`. You can set this up with roughly as follows: 11 | 12 | ``` 13 | mysql -u root # MySQL root username and password may vary 14 | CREATE DATABASE test; 15 | CREATE USER 'test'@'localhost' IDENTIFIED BY 'test'; 16 | GRANT ALL on test.* TO 'test'@'localhost'; 17 | ``` -------------------------------------------------------------------------------- /persistent-mysql/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-mysql/persistent-mysql.cabal: -------------------------------------------------------------------------------- 1 | name: persistent-mysql 2 | version: 2.13.1.5 3 | license: MIT 4 | license-file: LICENSE 5 | author: Felipe Lessa , Michael Snoyman 6 | maintainer: Felipe Lessa 7 | synopsis: 8 | Backend for the persistent library using MySQL database server. 9 | 10 | category: Database, Yesod 11 | stability: Stable 12 | cabal-version: >=1.10 13 | build-type: Simple 14 | homepage: http://www.yesodweb.com/book/persistent 15 | bug-reports: https://github.com/yesodweb/persistent/issues 16 | description: 17 | This package contains a backend for persistent using the 18 | MySQL database server. Internally it uses the @mysql-simple@ 19 | and @mysql@ packages in order to access the database. 20 | . 21 | This package supports only MySQL 5.1 and above. However, it 22 | has been tested only on MySQL 5.5. 23 | Only the InnoDB storage engine is officially supported. 24 | . 25 | Known problems: 26 | . 27 | * This package does not support statements inside other 28 | statements. 29 | 30 | extra-source-files: ChangeLog.md 31 | 32 | library 33 | build-depends: 34 | aeson >=1.0 35 | , base >=4.9 && <5 36 | , blaze-builder 37 | , bytestring >=0.10.8 38 | , conduit >=1.2.12 39 | , containers >=0.5 40 | , monad-logger 41 | , mysql >=0.2.1 && <0.3 42 | , mysql-simple >=0.4.7 && <0.5 43 | , persistent >=2.13.3 && <3 44 | , resource-pool 45 | , resourcet >=1.1 46 | , text >=1.2 47 | , transformers >=0.5 48 | , unliftio-core 49 | 50 | exposed-modules: Database.Persist.MySQL 51 | ghc-options: -Wall 52 | default-language: Haskell2010 53 | 54 | source-repository head 55 | type: git 56 | location: https://github.com/yesodweb/persistent.git 57 | 58 | test-suite test 59 | type: exitcode-stdio-1.0 60 | main-is: main.hs 61 | hs-source-dirs: test 62 | other-modules: 63 | CustomConstraintTest 64 | ImplicitUuidSpec 65 | InsertDuplicateUpdate 66 | JSONTest 67 | MyInit 68 | 69 | ghc-options: -Wall 70 | build-depends: 71 | aeson 72 | , base >=4.9 && <5 73 | , bytestring 74 | , conduit 75 | , containers 76 | , fast-logger 77 | , hspec >=2.4 78 | , http-api-data 79 | , HUnit 80 | , monad-logger 81 | , mysql 82 | , path-pieces 83 | , persistent 84 | , persistent-mysql 85 | , persistent-qq 86 | , persistent-test 87 | , QuickCheck 88 | , quickcheck-instances 89 | , resourcet 90 | , text 91 | , time 92 | , transformers 93 | , unliftio-core 94 | 95 | default-language: Haskell2010 96 | -------------------------------------------------------------------------------- /persistent-mysql/test/ImplicitUuidSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module ImplicitUuidSpec where 16 | 17 | import MyInit 18 | 19 | import Data.Proxy 20 | import Database.Persist.MySQL 21 | 22 | import Database.Persist.ImplicitIdDef 23 | import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) 24 | 25 | share 26 | [ mkPersist (sqlSettingsUuid "UUID()") 27 | , mkEntityDefList "entities" 28 | ] 29 | [persistLowerCase| 30 | 31 | WithDefUuid 32 | name Text 33 | 34 | deriving Eq Show Ord 35 | 36 | |] 37 | 38 | implicitUuidMigrate :: Migration 39 | implicitUuidMigrate = do 40 | migrateModels entities 41 | 42 | wipe :: IO () 43 | wipe = db $ do 44 | rawExecute "DROP TABLE IF EXISTS with_def_uuid;" [] 45 | void $ runMigrationSilent implicitUuidMigrate 46 | 47 | itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) 48 | itDb msg action = it msg $ db $ void action 49 | 50 | pass :: IO () 51 | pass = pure () 52 | 53 | spec :: Spec 54 | spec = describe "ImplicitUuidSpec" $ before_ wipe $ do 55 | describe "WithDefUuidKey" $ do 56 | it "works on UUIDs" $ do 57 | let withDefUuidKey = WithDefUuidKey (UUID "Hello") 58 | pass 59 | describe "getEntityId" $ do 60 | let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) 61 | it "has a SqlString SqlType" $ asIO $ do 62 | fieldSqlType idField `shouldBe` SqlString 63 | it "is an implicit ID column" $ asIO $ do 64 | fieldIsImplicitIdColumn idField `shouldBe` True 65 | 66 | describe "insert" $ do 67 | itDb "successfully has a default" $ do 68 | let matt = WithDefUuid 69 | { withDefUuidName = 70 | "Matt" 71 | } 72 | k <- insert matt 73 | mrec <- get k 74 | uuids <- selectList @WithDefUuid [] [] 75 | liftIO $ do 76 | -- MySQL's insert functionality is currently broken. The @k@ 77 | -- here is derived from @SELECT LAST_INSERT_ID()@ which only 78 | -- works on auto incrementing IDs. 79 | -- 80 | -- See #1251 for more details. 81 | mrec `shouldBe` Nothing 82 | 83 | map entityVal uuids `shouldSatisfy` (matt `elem`) 84 | -------------------------------------------------------------------------------- /persistent-mysql/test/JSONTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module JSONTest where 18 | 19 | import Data.Aeson 20 | import Test.HUnit (assertBool) 21 | 22 | import qualified Data.ByteString.Lazy as BSL 23 | import Data.Conduit (runConduit, (.|)) 24 | import qualified Data.Conduit.List as CL 25 | import Database.Persist.MySQL 26 | import MyInit 27 | 28 | specs :: Spec 29 | specs = describe "JSONTest" $ do 30 | it "can select json with rawsql" $ db $ do 31 | let testJSON = toJSON $ [object [ "test" .= ("value" :: Text) ]] 32 | [[PersistByteString value]] <- runConduit $ rawQuery "select JSON_ARRAY(JSON_OBJECT('test', 'value'))" [] .| CL.consume 33 | liftIO $ Just testJSON `shouldBe` (decode $ BSL.fromStrict value) 34 | -------------------------------------------------------------------------------- /persistent-postgresql/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-postgresql/README.md: -------------------------------------------------------------------------------- 1 | # `persistent-postgresql` 2 | 3 | [![Build Status](https://travis-ci.org/yesodweb/persistent-postgresql.svg?branch=master)](https://travis-ci.org/yesodweb/persistent-postgresql) [![Hackage](https://img.shields.io/hackage/v/persistent-postgresql.svg)] ![Hackage-Deps](https://img.shields.io/hackage-deps/v/persistent-postgresql.svg) 4 | 5 | A backend for the `persistent` database library for the PostgreSQL database server. 6 | 7 | ## Development 8 | 9 | To run tests on this library, you will need to have a PostgreSQL database server set up and running on your computer. 10 | The tests will expect to connect to a database named `test` using the `postgres` user and no password. 11 | This can be done either via the Postgresql command line or using the `createdb` tool: 12 | 13 | ``` 14 | $ psql -d postgres 15 | postgres=# CREATE DATABASE test; 16 | CREATE DATABASE 17 | 18 | -- or, 19 | $ createdb test 20 | ``` 21 | 22 | The tests do not pass a test and expect to connect with the `postgres` user. 23 | Ensure that peer authentication is allowed for this. 24 | An easy/insecure way to do this is to set the `METHOD` to `trust` for all the login methods in `/etc/postgresql/XX/main/pg_hba.conf`. 25 | (TODO: make this better?) 26 | -------------------------------------------------------------------------------- /persistent-postgresql/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-postgresql/test-settings.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -ex 2 | 3 | PGHOST=localhost PGPORT=5432 PGUSER=test PGPASS=test PGDATABASE=test runghc test-settings.hs 4 | -------------------------------------------------------------------------------- /persistent-postgresql/test/ArrayAggTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE DataKinds, FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} -- FIXME 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE DerivingStrategies #-} 13 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 14 | 15 | module ArrayAggTest where 16 | 17 | import Control.Monad.IO.Class (MonadIO) 18 | import Data.Aeson 19 | import Data.List (sort) 20 | import qualified Data.Text as T 21 | import Test.Hspec.Expectations () 22 | 23 | import PersistentTestModels 24 | import PgInit 25 | 26 | share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase| 27 | TestValue 28 | json Value 29 | |] 30 | 31 | cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m () 32 | cleanDB = deleteWhere ([] :: [Filter TestValue]) 33 | 34 | emptyArr :: Value 35 | emptyArr = toJSON ([] :: [Value]) 36 | 37 | specs :: Spec 38 | specs = do 39 | describe "rawSql/array_agg" $ do 40 | let runArrayAggTest :: (PersistField [a], Ord a, Show a) => Text -> [a] -> Assertion 41 | runArrayAggTest dbField expected = runConnAssert $ do 42 | void $ insertMany 43 | [ UserPT "a" $ Just "b" 44 | , UserPT "c" $ Just "d" 45 | , UserPT "e" Nothing 46 | , UserPT "g" $ Just "h" ] 47 | escape <- getEscapeRawNameFunction 48 | let query = T.concat [ "SELECT array_agg(", escape dbField, ") " 49 | , "FROM ", escape "UserPT" 50 | ] 51 | [Single xs] <- rawSql query [] 52 | liftIO $ sort xs @?= expected 53 | 54 | it "works for [Text]" $ do 55 | runArrayAggTest "ident" ["a", "c", "e", "g" :: Text] 56 | it "works for [Maybe Text]" $ do 57 | runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text] 58 | -------------------------------------------------------------------------------- /persistent-postgresql/test/EquivalentTypeTestPostgres.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE DataKinds, FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE DerivingStrategies #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 14 | 15 | module EquivalentTypeTestPostgres (specs) where 16 | 17 | import Control.Monad.Trans.Resource (runResourceT) 18 | import qualified Data.Text as T 19 | 20 | import Database.Persist.TH 21 | import PgInit 22 | 23 | share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| 24 | EquivalentType sql=equivalent_types 25 | field1 Int sqltype=bigint 26 | field2 T.Text sqltype=text 27 | field3 T.Text sqltype=us_postal_code 28 | deriving Eq Show 29 | |] 30 | 31 | share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| 32 | EquivalentType2 sql=equivalent_types 33 | field1 Int sqltype=int8 34 | field2 T.Text 35 | field3 T.Text sqltype=us_postal_code 36 | deriving Eq Show 37 | |] 38 | 39 | specs :: Spec 40 | specs = describe "doesn't migrate equivalent types" $ do 41 | it "works" $ asIO $ runResourceT $ runConn $ do 42 | 43 | _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code CASCADE" [] 44 | _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" [] 45 | 46 | _ <- runMigrationSilent migrateAll1 47 | xs <- getMigration migrateAll2 48 | liftIO $ xs @?= [] 49 | -------------------------------------------------------------------------------- /persistent-postgresql/test/ImplicitUuidSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | module ImplicitUuidSpec where 17 | 18 | import PgInit 19 | 20 | import Data.Proxy 21 | import Database.Persist.Postgresql 22 | 23 | import Database.Persist.ImplicitIdDef 24 | import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) 25 | 26 | share 27 | [ mkPersist (sqlSettingsUuid "uuid_generate_v1mc()") 28 | , mkEntityDefList "entities" 29 | ] 30 | [persistLowerCase| 31 | 32 | WithDefUuid 33 | name Text sqltype=varchar(80) 34 | 35 | deriving Eq Show Ord 36 | 37 | |] 38 | 39 | implicitUuidMigrate :: Migration 40 | implicitUuidMigrate = do 41 | runSqlCommand $ rawExecute "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\"" [] 42 | migrateModels entities 43 | 44 | wipe :: IO () 45 | wipe = runConnAssert $ do 46 | rawExecute "DROP TABLE with_def_uuid;" [] 47 | runMigration implicitUuidMigrate 48 | 49 | itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) 50 | itDb msg action = it msg $ runConnAssert $ void action 51 | 52 | pass :: IO () 53 | pass = pure () 54 | 55 | spec :: Spec 56 | spec = describe "ImplicitUuidSpec" $ before_ wipe $ do 57 | describe "WithDefUuidKey" $ do 58 | it "works on UUIDs" $ do 59 | let withDefUuidKey = WithDefUuidKey (UUID "Hello") 60 | pass 61 | describe "getEntityId" $ do 62 | let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) 63 | it "has a UUID SqlType" $ asIO $ do 64 | fieldSqlType idField `shouldBe` SqlOther "UUID" 65 | it "is an implicit ID column" $ asIO $ do 66 | fieldIsImplicitIdColumn idField `shouldBe` True 67 | 68 | describe "insert" $ do 69 | itDb "successfully has a default" $ do 70 | let matt = WithDefUuid 71 | { withDefUuidName = 72 | "Matt" 73 | } 74 | k <- insert matt 75 | mrec <- get k 76 | mrec `shouldBe` Just matt 77 | -------------------------------------------------------------------------------- /persistent-postgresql/test/MigrationReferenceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE OverloadedStrings, DataKinds, FlexibleInstances #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE DerivingStrategies #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 12 | 13 | module MigrationReferenceSpec where 14 | 15 | import PgInit 16 | 17 | import Control.Monad.Trans.Writer (censor, mapWriterT) 18 | import Data.Text (Text, isInfixOf) 19 | 20 | share [mkPersist sqlSettings, mkMigrate "referenceMigrate"] [persistLowerCase| 21 | 22 | LocationCapabilities 23 | Id Text 24 | bio Text 25 | 26 | LocationCapabilitiesPrintingProcess 27 | locationCapabilitiesId LocationCapabilitiesId 28 | 29 | LocationCapabilitiesPrintingFinish 30 | locationCapabilitiesId LocationCapabilitiesId 31 | 32 | LocationCapabilitiesSubstrate 33 | locationCapabilitiesId LocationCapabilitiesId 34 | 35 | |] 36 | 37 | spec :: Spec 38 | spec = describe "MigrationReferenceSpec" $ do 39 | it "works" $ runConnAssert $ do 40 | let 41 | noForeignKeys :: CautiousMigration -> CautiousMigration 42 | noForeignKeys = filter ((not . isReference) . snd) 43 | 44 | onlyForeignKeys :: CautiousMigration -> CautiousMigration 45 | onlyForeignKeys = filter (isReference . snd) 46 | 47 | isReference :: Text -> Bool 48 | isReference migration = "REFERENCES" `isInfixOf` migration 49 | 50 | runMigration 51 | $ mapWriterT (censor noForeignKeys) 52 | $ referenceMigrate 53 | 54 | runMigration 55 | $ mapWriterT (censor onlyForeignKeys) 56 | $ referenceMigrate 57 | -------------------------------------------------------------------------------- /persistent-postgresql/test/PgIntervalTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs, DataKinds, FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE DeriveAnyClass #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | 16 | module PgIntervalTest where 17 | 18 | import PgInit 19 | import Data.Time.Clock (NominalDiffTime) 20 | import Database.Persist.Postgresql (PgInterval(..)) 21 | import Test.Hspec.QuickCheck 22 | 23 | share [mkPersist sqlSettings, mkMigrate "pgIntervalMigrate"] [persistLowerCase| 24 | PgIntervalDb 25 | interval_field PgInterval 26 | deriving Eq 27 | deriving Show 28 | |] 29 | 30 | -- Postgres Interval has a 1 microsecond resolution, while NominalDiffTime has 31 | -- picosecond resolution. Round to the nearest microsecond so that we can be 32 | -- fine in the tests. 33 | truncate' :: NominalDiffTime -> NominalDiffTime 34 | truncate' x = (fromIntegral (round (x * 10^6))) / 10^6 35 | 36 | specs :: Spec 37 | specs = do 38 | describe "Postgres Interval Property tests" $ do 39 | prop "Round trips" $ \time -> runConnAssert $ do 40 | let eg = PgIntervalDb $ PgInterval (truncate' time) 41 | rid <- insert eg 42 | r <- getJust rid 43 | liftIO $ r `shouldBe` eg 44 | -------------------------------------------------------------------------------- /persistent-qq/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yesodweb/persistent/5a49753676696a5535576a918ef66a66e9d7d93c/persistent-qq/.gitignore -------------------------------------------------------------------------------- /persistent-qq/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for persistent-qq 2 | 3 | ## 2.12.0.6 4 | 5 | * Fix test compilation by importing `Control.Monad` explicitly [#1487](https://github.com/yesodweb/persistent/pull/1487) 6 | 7 | ## 2.12.0.5 8 | 9 | * Fix a bug where comments would break the quasiquoter. [#1436](https://github.com/yesodweb/persistent/pull/1436) 10 | 11 | ## 2.12.0.4 12 | 13 | * Improve compile-time performance of generated code, especially when building with -O2. 14 | Previously, the test suite took 1:16 to build with -O2, and after this patch, 15 | it only takes 5s. [#1434](https://github.com/yesodweb/persistent/pull/1434) 16 | 17 | ## 2.12.0.3 18 | 19 | * Require `persistent-2.14` in tests 20 | 21 | ## 2.12.0.2 22 | 23 | * Support aeson-2 in the test suite [#1351](https://github.com/yesodweb/persistent/pull/1351/) 24 | 25 | ## 2.12.0.1 26 | 27 | * Support GHC 9. [#1265](https://github.com/yesodweb/persistent/pull/1265) 28 | * Clarify lower bounds on `persistent` for the test suite. [#1274](https://github.com/yesodweb/persistent/pull/1274) 29 | 30 | ## 2.12.0.0 31 | 32 | * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) 33 | 34 | ## 2.9.2.1 35 | 36 | * Support `persistent-2.11` in the test suite [#1170](https://github.com/yesodweb/persistent/pull/1170) 37 | 38 | ## 2.9.2 39 | 40 | * Add interpolation support for multirow VALUES syntax (`*{rows}`) [#1111](https://github.com/yesodweb/persistent/pull/1111) 41 | 42 | ## 2.9.1.1 43 | 44 | * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) 45 | 46 | ## 2.9.1 47 | 48 | * Added support for list of values in `sqlQQ`. [#819](https://github.com/yesodweb/persistent/pull/819) 49 | 50 | ## 2.9.0 51 | 52 | * Initial release, code separated from `persistent` 53 | -------------------------------------------------------------------------------- /persistent-qq/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-qq/README.md: -------------------------------------------------------------------------------- 1 | # persistent-qq 2 | 3 | Provides `sqlQQ` and `executeQQ`. 4 | -------------------------------------------------------------------------------- /persistent-qq/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-qq/persistent-qq.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: persistent-qq 3 | version: 2.12.0.6 4 | synopsis: Provides a quasi-quoter for raw SQL for persistent 5 | description: 6 | Please see README and API docs at . 7 | 8 | category: Database, Yesod 9 | homepage: https://github.com/yesodweb/persistent#readme 10 | bug-reports: https://github.com/yesodweb/persistent/issues 11 | author: Michael Snoyman 12 | maintainer: Michael Snoyman 13 | license: MIT 14 | license-file: LICENSE 15 | build-type: Simple 16 | extra-source-files: 17 | ChangeLog.md 18 | README.md 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/yesodweb/persistent 23 | 24 | library 25 | exposed-modules: Database.Persist.Sql.Raw.QQ 26 | other-modules: Paths_persistent_qq 27 | hs-source-dirs: src 28 | ghc-options: -Wall 29 | build-depends: 30 | base >=4.9 && <5 31 | , haskell-src-meta 32 | , mtl 33 | , persistent >=2.12 34 | , template-haskell 35 | , text 36 | 37 | default-language: Haskell2010 38 | 39 | test-suite specs 40 | type: exitcode-stdio-1.0 41 | main-is: Spec.hs 42 | other-modules: 43 | CodeGenTest 44 | PersistentTestModels 45 | PersistTestPetCollarType 46 | PersistTestPetType 47 | 48 | hs-source-dirs: test 49 | ghc-options: -Wall 50 | build-depends: 51 | aeson 52 | , base 53 | , bytestring 54 | , fast-logger 55 | , haskell-src-meta 56 | , hspec 57 | , HUnit 58 | , monad-logger 59 | , mtl 60 | , persistent >=2.14 61 | , persistent-qq 62 | , persistent-sqlite 63 | , resourcet 64 | , template-haskell 65 | , text 66 | , unliftio 67 | 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /persistent-qq/test/CodeGenTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module CodeGenTest (query0, spec) where 8 | 9 | import Database.Persist.Sql 10 | import Test.Hspec 11 | import Database.Persist.Sql.Raw.QQ 12 | import PersistentTestModels 13 | import Control.Monad.Logger (LoggingT) 14 | import Control.Monad.Trans.Resource 15 | import Data.Text (Text) 16 | import Control.Monad.Reader 17 | 18 | spec :: (forall a. SqlPersistT (LoggingT (ResourceT IO)) a -> IO a) -> Spec 19 | spec db = describe "CodeGenTest" $ do 20 | it "works" $ do 21 | _ <- db $ mapReaderT liftIO query0 22 | pure () 23 | 24 | query0 :: SqlPersistT IO [(Single Text, Single Int, Single (Maybe Text))] 25 | query0 = -- 26 | [sqlQQ| 27 | select 28 | ^{Person}.@{PersonName}, ^{Person}.@{PersonAge}, ^{Person}.@{PersonColor} 29 | from ^{Person} 30 | where @{PersonAge} = 31 | #{int} + 32 | #{int} + 33 | #{int} + 34 | #{int} + -- comments work ok 35 | #{int} + 36 | #{int} + 37 | 0 38 | |] 39 | where 40 | int = 1 :: Int 41 | -------------------------------------------------------------------------------- /persistent-qq/test/PersistTestPetCollarType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module PersistTestPetCollarType where 4 | 5 | import GHC.Generics 6 | import Data.Aeson 7 | import Database.Persist.TH 8 | import Data.Text (Text) 9 | 10 | data PetCollar = PetCollar {tag :: Text, bell :: Bool} 11 | deriving (Generic, Eq, Show) 12 | instance ToJSON PetCollar 13 | instance FromJSON PetCollar 14 | 15 | derivePersistFieldJSON "PetCollar" 16 | -------------------------------------------------------------------------------- /persistent-qq/test/PersistTestPetType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module PersistTestPetType where 3 | 4 | import Database.Persist.TH 5 | 6 | data PetType = Cat | Dog 7 | deriving (Show, Read, Eq) 8 | derivePersistField "PetType" 9 | -------------------------------------------------------------------------------- /persistent-redis/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ### 2.13.0.2 2 | 3 | * [#1536](https://github.com/yesodweb/persistent/pull/1536) 4 | * Support GHC 9.10 5 | 6 | ## 2.13.0.1 7 | 8 | * [#1367](https://github.com/yesodweb/persistent/pull/1367), 9 | [#1366](https://github.com/yesodweb/persistent/pull/1367), 10 | [#1338](https://github.com/yesodweb/persistent/pull/1338), 11 | [#1335](https://github.com/yesodweb/persistent/pull/1335) 12 | * Support GHC 9.2 13 | 14 | ## 2.13.0.0 15 | 16 | * [#1123](https://github.com/yesodweb/persistent/pull/1223): 17 | * Changed the error message from trying to serialize a `PersistDbSpecific` value into `PersistLiteral_`. 18 | 19 | ## 2.12.0.0 20 | 21 | * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) 22 | 23 | # 2.5.2.5 24 | 25 | * Remove unnecessary deriving of Typeable [#1114](https://github.com/yesodweb/persistent/pull/1114) 26 | 27 | # 2.5.2.4 28 | 29 | * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) 30 | 31 | # 2.5.2.3 32 | 33 | * Added support for GHC 8.8 [#977](https://github.com/yesodweb/persistent/pull/977) 34 | 35 | # 2.5.2.2 36 | 37 | * Remove upper bounds in time 38 | 39 | # 2.5.2.1 40 | 41 | * Relax time constraint 42 | 43 | # 0.3.3 44 | 45 | * support http-api-data for url serialization 46 | -------------------------------------------------------------------------------- /persistent-redis/Database/Persist/Redis.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Redis 2 | ( module Database.Persist.Redis.Config 3 | , module Database.Persist.Redis.Store 4 | , module Database.Persist.Redis.Exception 5 | ) where 6 | 7 | import Database.Persist.Redis.Config 8 | import Database.Persist.Redis.Store 9 | import Database.Persist.Redis.Exception -------------------------------------------------------------------------------- /persistent-redis/Database/Persist/Redis/Exception.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Redis.Exception 2 | ( RedisException (..) 3 | ) where 4 | 5 | import Control.Exception (Exception) 6 | 7 | data RedisException = NotSupportedOperation String 8 | | ParserError String 9 | | NotSupportedValueType String 10 | | IncorrectUpdate String 11 | | IncorrectBehavior 12 | 13 | instance Show RedisException where 14 | show (NotSupportedOperation key) = "The operation is not supported: " ++ key 15 | show (ParserError msg) = "Error during parsing: " ++ msg 16 | show (NotSupportedValueType tp) = "The value type " ++ tp ++ " is not supported for Redis" 17 | show IncorrectBehavior = "The behavior of persistent-redis is incorrect" 18 | show (IncorrectUpdate msg) = "This update is not possible: " ++ msg 19 | instance Exception RedisException 20 | -------------------------------------------------------------------------------- /persistent-redis/Database/Persist/Redis/Internal.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Redis.Internal 2 | ( toKey 3 | , unKey 4 | , mkEntity 5 | , toKeyId 6 | , toKeyText 7 | , toInsertFields 8 | , toB 9 | ) where 10 | 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.UTF8 as U 13 | import Data.Text (Text, unpack) 14 | import qualified Data.Text as T 15 | import Control.Monad.Fail (MonadFail) 16 | 17 | import Database.Persist.EntityDef.Internal 18 | import Database.Persist.Class 19 | import Database.Persist.Types 20 | import Database.Persist.Redis.Parser 21 | 22 | toLabel :: FieldDef -> B.ByteString 23 | toLabel = U.fromString . unpack . unFieldNameDB . fieldDB 24 | 25 | toEntityString :: PersistEntity val => val -> Text 26 | toEntityString = unEntityNameDB . entityDB . entityDef . Just 27 | 28 | toEntityName :: EntityDef -> B.ByteString 29 | toEntityName = U.fromString . unpack . unEntityNameDB . entityDB 30 | 31 | mkEntity :: (MonadFail m, PersistEntity val) => Key val -> [(B.ByteString, B.ByteString)] -> m (Entity val) 32 | mkEntity key fields = do 33 | let values = redisToPerisistValues fields 34 | let v = fromPersistValues values 35 | case v of 36 | Right body -> return $ Entity key body 37 | Left a -> fail (unpack a) 38 | 39 | 40 | zipAndConvert :: PersistField t => [FieldDef] -> [t] -> [(B.ByteString, B.ByteString)] 41 | zipAndConvert [] _ = [] 42 | zipAndConvert _ [] = [] 43 | zipAndConvert (e:efields) (p:pfields) = 44 | let pv = toPersistValue p 45 | in 46 | if pv == PersistNull then zipAndConvert efields pfields 47 | else (toLabel e, toValue pv) : zipAndConvert efields pfields 48 | 49 | -- | Create a list for create/update in Redis store 50 | toInsertFields :: PersistEntity val => val -> [(B.ByteString, B.ByteString)] 51 | toInsertFields record = zipAndConvert entity fields 52 | where 53 | entity = entityFields $ entityDef $ Just record 54 | fields = toPersistFields record 55 | 56 | underscoreBs :: B.ByteString 57 | underscoreBs = U.fromString "_" 58 | 59 | -- | Make a key for given entity and id 60 | toKeyText :: PersistEntity val => val -> Integer -> Text 61 | toKeyText val k = toEntityString val `T.append` T.pack "_" `T.append` T.pack (show k) 62 | 63 | toB :: Text -> B.ByteString 64 | toB = U.fromString . unpack 65 | 66 | -- | Create a string key for given entity 67 | toObjectPrefix :: PersistEntity val => val -> B.ByteString 68 | toObjectPrefix val = B.append (toEntityName $ entityDef $ Just val) underscoreBs 69 | 70 | idBs :: B.ByteString 71 | idBs = U.fromString "id" 72 | 73 | -- | Construct an id key, that is incremented for access 74 | toKeyId :: PersistEntity val => val -> B.ByteString 75 | toKeyId val = B.append (toObjectPrefix val) idBs 76 | 77 | unKey :: (PersistEntity val) => Key val -> B.ByteString 78 | unKey = toValue . head . keyToValues 79 | 80 | toKey :: (Monad m, MonadFail m, PersistEntity val) => Text -> m (Key val) 81 | toKey x = case q of 82 | Right z -> return z 83 | Left a -> fail (unpack a) 84 | where 85 | q = keyFromValues [PersistText x] 86 | -------------------------------------------------------------------------------- /persistent-redis/Database/Persist/Redis/Update.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Redis.Update 2 | ( cmdUpdate 3 | ) where 4 | 5 | import Control.Exception (throw) 6 | import Data.Either() 7 | import Data.Functor.Identity 8 | import Data.Functor.Constant 9 | 10 | import Database.Persist 11 | import Database.Persist.Redis.Exception 12 | 13 | type ASetter s t a b = (a -> Identity b) -> s -> Identity t 14 | 15 | set :: ASetter s t a b -> b -> s -> t 16 | set l b = runIdentity . l (\_ -> Identity b) 17 | 18 | type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t 19 | 20 | view :: s -> Getting a s t a b -> a 21 | view s l = getConstant (l Constant s) 22 | 23 | cmdUpdate :: PersistEntity val => Entity val -> [Update val] -> Entity val 24 | cmdUpdate = foldr updateOneField 25 | 26 | updateOneField :: PersistEntity val => Update val -> Entity val -> Entity val 27 | updateOneField (BackendUpdate _) _ = throw $ NotSupportedOperation "Backend specific update" 28 | updateOneField (Update field v Assign) oldValue = set (fieldLens field) v oldValue 29 | updateOneField (Update _ _ (BackendSpecificUpdate _)) _ = 30 | throw $ NotSupportedOperation "Backend specific update withing update operation" 31 | 32 | updateOneField (Update field v up) oldValue = set (fieldLens field) newValue oldValue 33 | where 34 | lens = fieldLens field 35 | pv = toPersistValue v 36 | oldV = toPersistValue $ view oldValue lens 37 | eitherNewValue = fromPersistValue $ apply up oldV pv 38 | newValue = either (\_ -> throw IncorrectBehavior) id eitherNewValue 39 | 40 | 41 | apply :: PersistUpdate -> PersistValue -> PersistValue -> PersistValue 42 | 43 | apply Assign _ _ = throw IncorrectBehavior 44 | 45 | apply Add (PersistInt64 x) (PersistInt64 y) = PersistInt64 (x + y) 46 | apply Add (PersistDouble x) (PersistDouble y) = PersistDouble (x + y) 47 | apply Add (PersistRational x) (PersistRational y) = PersistRational (x + y) 48 | apply Add _ _ = throw $ IncorrectUpdate "Unable to apply addition to this field" 49 | 50 | apply Subtract (PersistInt64 x) (PersistInt64 y) = PersistInt64 (x - y) 51 | apply Subtract (PersistDouble x) (PersistDouble y) = PersistDouble (x - y) 52 | apply Subtract (PersistRational x) (PersistRational y) = PersistRational (x - y) 53 | apply Subtract _ _ = throw $ IncorrectUpdate "Unable to apply subtraction to this field" 54 | 55 | apply Multiply (PersistInt64 x) (PersistInt64 y) = PersistInt64 (x * y) 56 | apply Multiply (PersistDouble x) (PersistDouble y) = PersistDouble (x * y) 57 | apply Multiply (PersistRational x) (PersistRational y) = PersistRational (x * y) 58 | apply Multiply _ _ = throw $ IncorrectUpdate "Unable to apply subtraction to this field" 59 | 60 | apply Divide (PersistInt64 x) (PersistInt64 y) = PersistInt64 (div x y) 61 | apply Divide (PersistDouble x) (PersistDouble y) = PersistDouble (x / y) 62 | apply Divide (PersistRational x) (PersistRational y) = PersistRational (x / y) 63 | apply Divide _ _ = throw $ IncorrectUpdate "Unable to apply subtraction to this field" 64 | 65 | apply (BackendSpecificUpdate _) _ _ = throw IncorrectBehavior -------------------------------------------------------------------------------- /persistent-redis/LICENSE: -------------------------------------------------------------------------------- 1 | The following license covers this documentation, and the source code, except 2 | where otherwise indicated. 3 | 4 | Copyright 2013, Pavel Ryzhov. All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO 19 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 22 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 23 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 24 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 25 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /persistent-redis/README.md: -------------------------------------------------------------------------------- 1 | persistent-redis 2 | ================ 3 | 4 | Yesod Persistent for Redis 5 | 6 | It supports now only strings, bool, double and integers. 7 | 8 | This version is compatible with persistent 2.1. -------------------------------------------------------------------------------- /persistent-redis/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-redis/persistent-redis.cabal: -------------------------------------------------------------------------------- 1 | name: persistent-redis 2 | version: 2.13.0.2 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Pavel Ryzhov 6 | synopsis: Backend for persistent library using Redis. 7 | description: Based on the Redis package. 8 | category: Database 9 | stability: Experimental 10 | cabal-version: >=1.10 11 | maintainer: Pavel Ryzhov 12 | build-type: Simple 13 | bug-reports: https://github.com/yesodweb/persistent/issues 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/yesodweb/persistent.git 18 | 19 | library 20 | build-depends: 21 | aeson >=1.0 22 | , base >=4.9 && <5 23 | , binary >=0.8 && <0.9 24 | , bytestring >=0.10.8 && <0.13 25 | , hedis >=0.9 26 | , http-api-data 27 | , mtl >=2.2.1 && <2.4 28 | , path-pieces >=0.2 29 | , persistent >=2.12 && <3.0 30 | , scientific >=0.3.5 && <0.4 31 | , text >=1.2 32 | , time >=1.6 33 | , transformers >=0.5 34 | , utf8-string >=1.0 && <1.1 35 | 36 | exposed-modules: Database.Persist.Redis 37 | other-modules: 38 | Database.Persist.Redis.Config 39 | Database.Persist.Redis.Exception 40 | Database.Persist.Redis.Internal 41 | Database.Persist.Redis.Parser 42 | Database.Persist.Redis.Store 43 | Database.Persist.Redis.Update 44 | 45 | ghc-options: -Wall 46 | default-language: Haskell2010 47 | 48 | test-suite basic 49 | type: exitcode-stdio-1.0 50 | main-is: tests/basic-test.hs 51 | build-depends: 52 | aeson 53 | , base 54 | , binary 55 | , bytestring 56 | , hedis 57 | , http-api-data 58 | , mtl 59 | , path-pieces 60 | , persistent 61 | , persistent-redis 62 | , scientific 63 | , template-haskell 64 | , text 65 | , time 66 | , transformers 67 | , utf8-string 68 | 69 | other-modules: 70 | Database.Persist.Redis 71 | Database.Persist.Redis.Config 72 | Database.Persist.Redis.Exception 73 | Database.Persist.Redis.Internal 74 | Database.Persist.Redis.Parser 75 | Database.Persist.Redis.Store 76 | Database.Persist.Redis.Update 77 | 78 | default-language: Haskell2010 79 | -------------------------------------------------------------------------------- /persistent-redis/tests/basic-test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | module Main where 15 | 16 | import Control.Monad.IO.Class (MonadIO, liftIO) 17 | import Data.Text (Text, pack, unpack) 18 | import qualified Database.Redis as R 19 | import Language.Haskell.TH.Syntax 20 | 21 | import Database.Persist 22 | import Database.Persist.Redis 23 | import Database.Persist.TH 24 | 25 | let redisSettings = mkPersistSettings (ConT ''RedisBackend) 26 | in share [mkPersist redisSettings] [persistLowerCase| 27 | Person 28 | name String 29 | age Int 30 | deriving Show 31 | |] 32 | 33 | d :: R.ConnectInfo 34 | d = R.defaultConnectInfo 35 | 36 | host :: Text 37 | host = pack $ R.connectHost d 38 | 39 | redisConf :: RedisConf 40 | redisConf = RedisConf host (R.connectPort d) Nothing 10 41 | 42 | mkKey :: (MonadIO m, PersistEntity val) => Text -> m (Key val) 43 | mkKey s = case keyFromValues [PersistText s] of 44 | Right z -> return z 45 | Left a -> liftIO $ fail (unpack a) 46 | 47 | main :: IO () 48 | main = 49 | withRedisConn redisConf $ runRedisPool $ do 50 | _ <- liftIO $ print "Inserting..." 51 | s <- insert $ Person "Test" 12 52 | _ <- liftIO $ print ("Received the key" ++ show s) 53 | key <- mkKey (pack "person_test") 54 | insertKey key $ Person "Test2" 45 55 | repsert s (Person "Test3" 55) 56 | g <- get key :: RedisT IO (Maybe Person) 57 | liftIO $ print g 58 | delete s 59 | return () 60 | -------------------------------------------------------------------------------- /persistent-sqlite/Database/Sqlite/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | Utterly unsafe internals of the "Database.Sqlite" module. Useful for 2 | -- people who want access to the SQLite database pointer to manually call 3 | -- SQLite API functions via the FFI. 4 | -- 5 | -- Types and functions in this module are *NOT* covered by the PVP and may 6 | -- change breakingly in any future version of the package. 7 | module Database.Sqlite.Internal where 8 | 9 | import Data.IORef (IORef) 10 | import Foreign.Ptr (Ptr) 11 | 12 | -- | SQLite connection type, consist of an IORef tracking whether the 13 | -- connection has been closed and the raw SQLite C API pointer, wrapped in a 14 | -- 'Connection\'' newtype. 15 | -- 16 | -- @since 2.10.2 17 | data Connection = Connection !(IORef Bool) Connection' 18 | 19 | -- | Newtype wrapping SQLite C API pointer for a database connection. 20 | -- 21 | -- @since 2.10.2 22 | newtype Connection' = Connection' (Ptr ()) 23 | 24 | -- | Newtype wrapping SQLite C API pointer for a prepared statement. 25 | -- 26 | -- @since 2.10.2 27 | newtype Statement = Statement (Ptr ()) 28 | -------------------------------------------------------------------------------- /persistent-sqlite/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-sqlite/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-sqlite/cbits/config.c: -------------------------------------------------------------------------------- 1 | /* This file defines auxiliary functions to help dealing with sqlite vararg stuff. */ 2 | #include 3 | 4 | int persistent_sqlite_set_log(void (*logFn)(void*, int, const char*), void* arg) { 5 | return sqlite3_config(SQLITE_CONFIG_LOG, logFn, arg); 6 | } 7 | -------------------------------------------------------------------------------- /persistent-sqlite/test/sanity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | import Control.Monad.Logger 4 | 5 | import Database.Persist.Sqlite 6 | 7 | $(return []) -- just force TH to run 8 | 9 | main :: IO () 10 | main = runStderrLoggingT $ withSqliteConn ":memory:" $ runSqlConn waitForDatabase 11 | -------------------------------------------------------------------------------- /persistent-sqlite/test2.hs: -------------------------------------------------------------------------------- 1 | -- some degenerate cases 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | 8 | import Prelude hiding (filter) 9 | import Database.Persist 10 | import Database.Persist.State 11 | import Database.Persist.Sqlite3 12 | import Control.Monad.IO.Class 13 | import qualified Data.Map as Map 14 | import Database.HDBC.Sqlite3 (connectSqlite3) 15 | 16 | derivePersistSqlite3 $ Table "Foo" 17 | [ ("field", ("Int", False)) 18 | ] 19 | [] 20 | [] 21 | [] 22 | [] 23 | 24 | main = putStrLn "degenerates work!" 25 | -------------------------------------------------------------------------------- /persistent-sqlite/test3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | import Database.Persist.Quasi 8 | import Prelude hiding (filter) 9 | import Database.Persist 10 | import Database.Persist.State 11 | import Database.Persist.Sqlite3 12 | import Control.Monad.IO.Class 13 | import qualified Data.Map as Map 14 | import Database.HDBC.Sqlite3 (connectSqlite3) 15 | 16 | persistSqlite3 [$persist| 17 | Person 18 | name String update Eq Ne Desc 19 | age Int update Lt Asc 20 | color String null Eq Ne 21 | PersonNameKey name 22 | |] 23 | 24 | deriving instance Show Person 25 | 26 | main = do 27 | --evalPersistState go (Map.empty :: Map.Map Int Person) 28 | conn <- connectSqlite3 "test.db3" 29 | runSqlite3 go conn 30 | 31 | go = do 32 | initialize (undefined :: Person) 33 | pid <- insert $ Person "Michael" 25 Nothing 34 | liftIO $ print pid 35 | 36 | p1 <- get pid 37 | liftIO $ print p1 38 | 39 | replace pid $ Person "Michael" 26 Nothing 40 | p2 <- get pid 41 | liftIO $ print p2 42 | 43 | p3 <- select [PersonNameEq "Michael"] [] 44 | liftIO $ print p3 45 | 46 | insert_ $ Person "Michael2" 27 Nothing 47 | deleteWhere [PersonNameEq "Michael2"] 48 | p4 <- select [PersonAgeLt 28] [] 49 | liftIO $ print p4 50 | 51 | update pid [PersonAge 28] 52 | p5 <- get pid 53 | liftIO $ print p5 54 | 55 | updateWhere [PersonNameEq "Michael"] [PersonAge 29] 56 | p6 <- get pid 57 | liftIO $ print p6 58 | 59 | insert $ Person "Eliezer" 2 $ Just "blue" 60 | p7 <- select [] [PersonAgeAsc] 61 | liftIO $ print p7 62 | 63 | insert $ Person "Abe" 30 $ Just "black" 64 | p8 <- select [PersonAgeLt 30] [PersonNameDesc] 65 | liftIO $ print p8 66 | 67 | insertR $ Person "Abe" 31 $ Just "brown" 68 | p9 <- select [PersonNameEq "Abe"] [] 69 | liftIO $ print p9 70 | 71 | p10 <- getBy $ PersonNameKey "Michael" 72 | liftIO $ print p10 73 | 74 | p11 <- select [PersonColorEq $ Just "blue"] [] 75 | liftIO $ print p11 76 | 77 | p12 <- select [PersonColorEq Nothing] [] 78 | liftIO $ print p12 79 | 80 | p13 <- select [PersonColorNe Nothing] [] 81 | liftIO $ print p13 82 | 83 | delete pid 84 | plast <- get pid 85 | liftIO $ print plast 86 | -------------------------------------------------------------------------------- /persistent-template/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-template/README.md: -------------------------------------------------------------------------------- 1 | # Begone! 2 | 3 | This package was absorbed into `persistent` with the 2.12.0.1 release. 4 | 5 | ## persistent-template 6 | 7 | Provides Template Haskell helpers for persistent. For more information, see 8 | [the chapter in the Yesod book](http://www.yesodweb.com/book/persistent). 9 | 10 | ### code organization 11 | 12 | The TH.hs module contains code generators. 13 | persistent-template uses `EntityDef`s that it gets from the quasi-quoter. 14 | The quasi-quoter is in persistent Quasi.hs 15 | Similarly many of the types come from the persistent library 16 | 17 | ### Development tips 18 | 19 | To get a better idea of what code you're generating, you can output the content of Template Haskell expressions to a file: 20 | 21 | ``` 22 | stack test persistent-template --ghc-options='-ddump-splices -ddump-to-file' 23 | ``` 24 | 25 | The output will be in the `.stack-work` directory. The exact path will depend on your specific setup, but if you search for files ending in `.dump-splices` you'll find the output (`find .stack-work -type f -name '*.dump-splices'`) 26 | 27 | If you make changes to the generated code, it is highly recommended to compare the output with your changes to output from `master` (even better if this diff is included in your PR!). Seemingly small changes can have dramatic changes on the generated code. 28 | 29 | For example, embedding an `EntityDef` in a function that was called for every field of that `Entity` made the number of generated lines O(N^2) for that function—very bad! 30 | -------------------------------------------------------------------------------- /persistent-template/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-template/persistent-template.cabal: -------------------------------------------------------------------------------- 1 | name: persistent-template 2 | version: 2.12.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Michael Snoyman 6 | maintainer: 7 | Michael Snoyman , Greg Weber 8 | 9 | synopsis: Type-safe, non-relational, multi-backend persistence. 10 | description: 11 | Hackage documentation generation is not reliable. For up to date documentation, please see: . 12 | 13 | category: Database, Yesod 14 | stability: Stable 15 | cabal-version: >=1.10 16 | build-type: Simple 17 | homepage: http://www.yesodweb.com/book/persistent 18 | bug-reports: https://github.com/yesodweb/persistent/issues 19 | extra-source-files: 20 | ChangeLog.md 21 | README.md 22 | 23 | library 24 | build-depends: base >=4.10 && <5 25 | exposed-modules: 26 | ghc-options: -Wall 27 | default-language: Haskell2010 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/yesodweb/persistent.git 32 | -------------------------------------------------------------------------------- /persistent-test/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yesodweb/persistent/5a49753676696a5535576a918ef66a66e9d7d93c/persistent-test/.gitignore -------------------------------------------------------------------------------- /persistent-test/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## Unreleased changes 2 | 3 | ## 2.13.1.4 4 | 5 | * Support `persistent-2.17` 6 | 7 | ## 2.13.1.3 8 | 9 | * Support persistent-2.14 with `SafeToInsert` class 10 | 11 | ## 2.13.1.2 12 | 13 | * [#1367](https://github.com/yesodweb/persistent/pull/1367), 14 | [#1366](https://github.com/yesodweb/persistent/pull/1367), 15 | [#1338](https://github.com/yesodweb/persistent/pull/1338), 16 | [#1335](https://github.com/yesodweb/persistent/pull/1335) 17 | * Support GHC 9.2 18 | * Test migration idempotency on additional integer types [#1359](https://github.com/yesodweb/persistent/pull/1359) 19 | 20 | ## 2.13.1.0 21 | 22 | * Support `persistent-2.13.3.0` [#1341](https://github.com/yesodweb/persistent/pull/1341) 23 | 24 | ## 2.13.0.4 25 | 26 | * `aeson-2.0` support 27 | 28 | ## 2.13.0.3 29 | 30 | * Accidentally released 2.13.0.2 with some testing changes. 31 | 32 | ## 2.13.0.2 33 | 34 | * [#1275](https://github.com/yesodweb/persistent/pull/1275) 35 | * Add a test for SafeToRemove fields 36 | 37 | ## 2.13.0.1 38 | 39 | * [#1265](https://github.com/yesodweb/persistent/pull/1265) 40 | * Support GHC 9 41 | 42 | ## 2.13.0.0 43 | 44 | * [#1225](https://github.com/yesodweb/persistent/pull/1225) 45 | * Support `persistent-2.13` changes for SqlBackend being made internal. 46 | 47 | ## 2.12.0.0 48 | 49 | * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) 50 | 51 | ## 2.0.3.5 52 | 53 | * Tighter version bounds on `persistent` and `persistent-template`. 54 | * [#1155](https://github.com/yesodweb/persistent/pull/1155) 55 | 56 | ## 2.0.3.4 57 | 58 | * lots of stuff actually :\ should probably start tracking this more! 59 | 60 | ## 2.0.3.3 61 | 62 | * Fix RawSqlTest, which could fail non-deterministically for Postgres [#1139](https://github.com/yesodweb/persistent/pull/1139) 63 | 64 | ## 2.0.3.2 65 | 66 | * Remove unnecessary deriving of Typeable [#1114](https://github.com/yesodweb/persistent/pull/1114) 67 | 68 | ## 2.0.3.1 69 | 70 | * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) 71 | -------------------------------------------------------------------------------- /persistent-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent-test/README.md: -------------------------------------------------------------------------------- 1 | # `persistent-test` 2 | 3 | This package defines scenarios and helpers that are shared among the `persistent` backends. 4 | -------------------------------------------------------------------------------- /persistent-test/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent-test/src/CustomPersistField.hs: -------------------------------------------------------------------------------- 1 | -- This module is used for CustomPersistFieldTest; the TH GHC stage restriction requires it to be here. 2 | -- The code is taken from the Yesod.Text.Markdown package; see https://github.com/yesodweb/persistent/issues/448 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | module CustomPersistField where 5 | 6 | import Data.String (IsString) 7 | import Data.Text (pack) 8 | import Data.Text.Lazy (toStrict, fromStrict) 9 | import qualified Data.Text.Lazy as TL (Text) 10 | 11 | import Init 12 | 13 | newtype Markdown = Markdown TL.Text 14 | deriving (Eq, Ord, IsString, Show) 15 | 16 | instance PersistField Markdown where 17 | toPersistValue (Markdown t) = PersistText $ toStrict t 18 | fromPersistValue (PersistText t) = Right $ Markdown $ fromStrict t 19 | fromPersistValue wrongValue = Left $ pack $ "Received " ++ show wrongValue ++ " when a value of type PersistText was expected." 20 | 21 | 22 | instance PersistFieldSql Markdown where 23 | sqlType _ = SqlString 24 | -------------------------------------------------------------------------------- /persistent-test/src/CustomPersistFieldTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 4 | module CustomPersistFieldTest (specsWith, customFieldMigrate) where 5 | 6 | import CustomPersistField 7 | import Init 8 | 9 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "customFieldMigrate"] [persistLowerCase| 10 | BlogPost 11 | article Markdown 12 | deriving Show Eq 13 | |] 14 | 15 | specsWith :: Runner backend m => RunDb backend m -> Spec 16 | specsWith runDB = describe "Custom persist field" $ do 17 | it "should read what it wrote" $ runDB $ do 18 | let originalBlogPost = BlogPost "article" 19 | blogPostId <- insert originalBlogPost 20 | Just newBlogPost <- get blogPostId 21 | liftIO $ originalBlogPost @?= newBlogPost 22 | -------------------------------------------------------------------------------- /persistent-test/src/CustomPrimaryKeyReferenceTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- This test is based on this issue: https://github.com/yesodweb/persistent/issues/421 5 | -- The primary thing this is testing is the migration, thus the test code itself being mostly negligible. 6 | module CustomPrimaryKeyReferenceTest where 7 | 8 | import Init 9 | 10 | -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs 11 | share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase| 12 | Tweet 13 | tweetId Int 14 | statusText Text sqltype=varchar(170) 15 | Primary tweetId 16 | UniqueTweetId tweetId 17 | deriving Show 18 | TweetUrl 19 | tweetId TweetId 20 | tweetUrl Text sqltype=varchar(255) 21 | finalUrl Text Maybe sqltype=varchar(255) 22 | UniqueTweetIdTweetUrl tweetId tweetUrl 23 | deriving Show 24 | |] 25 | 26 | cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m () 27 | cleanDB = do 28 | deleteWhere ([] :: [Filter Tweet]) 29 | deleteWhere ([] :: [Filter TweetUrl]) 30 | 31 | specsWith :: (MonadFail m, MonadIO m) => RunDb SqlBackend m -> Spec 32 | specsWith runDb = describe "custom primary key reference" $ do 33 | let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"} 34 | 35 | it "can insert a Tweet" $ runDb $ do 36 | tweetId <- insert tweet 37 | let url = TweetUrl {tweetUrlTweetId = tweetId, tweetUrlTweetUrl = "http://google.com", tweetUrlFinalUrl = Just "http://example.com"} 38 | insert_ url 39 | -------------------------------------------------------------------------------- /persistent-test/src/Dummy.hs: -------------------------------------------------------------------------------- 1 | module Dummy where 2 | -------------------------------------------------------------------------------- /persistent-test/src/EmbedOrderTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 4 | module EmbedOrderTest (specsWith, embedOrderMigrate, cleanDB) where 5 | 6 | import qualified Data.Map as Map 7 | import Debug.Trace (trace) 8 | 9 | import Init 10 | 11 | debug :: Show s => s -> s 12 | debug x = trace (show x) x 13 | 14 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedOrderMigrate"] [persistUpperCase| 15 | Foo sql=foo_embed_order 16 | bars [Bar] 17 | deriving Eq Show 18 | Bar sql=bar_embed_order 19 | b String 20 | u String 21 | g String 22 | deriving Eq Show 23 | |] 24 | 25 | cleanDB :: Runner backend m => ReaderT backend m () 26 | cleanDB = do 27 | deleteWhere ([] :: [Filter (FooGeneric backend)]) 28 | deleteWhere ([] :: [Filter (BarGeneric backend)]) 29 | 30 | specsWith :: Runner backend m => RunDb backend m -> Spec 31 | specsWith db = describe "embedded entities" $ do 32 | it "preserves ordering" $ db $ do 33 | let foo = Foo [Bar "b" "u" "g"] 34 | fooId <- insert foo 35 | Just otherFoo <- get fooId 36 | foo @== otherFoo 37 | 38 | it "PersistMap PersistValue serializaion" $ db $ do 39 | let record = Map.fromList [("b" :: Text,"b" :: Text),("u","u"),("g","g")] 40 | record @== (fromRight . fromPersistValue . toPersistValue) record 41 | 42 | fromRight :: Show a => Either a b -> b 43 | fromRight (Left e) = error $ "expected Right, got Left " ++ show e 44 | fromRight (Right x) = x 45 | -------------------------------------------------------------------------------- /persistent-test/src/EmptyEntityTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 4 | module EmptyEntityTest (specsWith, migration, cleanDB) where 5 | 6 | import Database.Persist.Sql 7 | import Database.Persist.TH 8 | 9 | import Init 10 | 11 | -- Test lower case names 12 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| 13 | EmptyEntity 14 | |] 15 | 16 | cleanDB 17 | :: 18 | ( PersistQueryWrite backend 19 | , MonadIO m 20 | , PersistStoreWrite (BaseBackend backend) 21 | ) 22 | => ReaderT backend m () 23 | cleanDB = deleteWhere ([] :: [Filter (EmptyEntityGeneric backend)]) 24 | 25 | specsWith 26 | :: Runner backend m 27 | => RunDb backend m 28 | -> Maybe (ReaderT backend m a) 29 | -> Spec 30 | specsWith runConn mmigrate = describe "empty entity" $ 31 | it "inserts" $ asIO $ runConn $ do 32 | _ <- sequence_ mmigrate 33 | -- Ensure reading the data from the database works... 34 | _ <- sequence_ mmigrate 35 | x <- insert EmptyEntity 36 | Just EmptyEntity <- get x 37 | return () 38 | -------------------------------------------------------------------------------- /persistent-test/src/EntityEmbedTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module EntityEmbedTest where 4 | 5 | -- because we are using a type alias we need to declare in a separate module 6 | -- this is used in EmbedTest 7 | import Init 8 | 9 | mkPersist persistSettings { mpsGeneric = True } [persistUpperCase| 10 | ARecord 11 | name Text 12 | deriving Show Eq Read Ord 13 | |] 14 | 15 | type AnEntity = Entity ARecord 16 | -------------------------------------------------------------------------------- /persistent-test/src/EquivalentTypeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 5 | 6 | module EquivalentTypeTest (specsWith) where 7 | 8 | import UnliftIO 9 | 10 | import Database.Persist.TH 11 | import Init 12 | 13 | share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| 14 | EquivalentType sql=equivalent_types 15 | field1 Int 16 | deriving Eq Show 17 | |] 18 | 19 | share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| 20 | EquivalentType2 sql=equivalent_types 21 | field1 Int 22 | deriving Eq Show 23 | |] 24 | 25 | specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec 26 | specsWith runDb = describe "doesn't migrate equivalent types" $ do 27 | it "works" $ runDb $ do 28 | _ <- runMigrationSilent migrateAll1 29 | xs <- getMigration migrateAll2 30 | liftIO $ xs @?= [] 31 | -------------------------------------------------------------------------------- /persistent-test/src/GeneratedColumnTestSQL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 5 | module GeneratedColumnTestSQL (specsWith) where 6 | 7 | import Database.Persist.TH 8 | import Init 9 | 10 | share [mkPersist sqlSettings, mkMigrate "migrate1"] [persistLowerCase| 11 | GenTest sql=gen_test 12 | fieldOne Text Maybe 13 | fieldTwo Text Maybe 14 | fieldThree Text Maybe generated=COALESCE(field_one,field_two) 15 | deriving Show Eq 16 | 17 | MigrateTestV1 sql=gen_migrate_test 18 | sickness Int 19 | cromulence Int generated=5 20 | |] 21 | 22 | share [mkPersist sqlSettings, mkMigrate "migrate2"] [persistLowerCase| 23 | MigrateTestV2 sql=gen_migrate_test 24 | sickness Int generated=3 25 | cromulence Int 26 | |] 27 | 28 | specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec 29 | specsWith runDB = describe "PersistLiteral field" $ do 30 | it "should read a generated column" $ runDB $ do 31 | rawExecute "DROP TABLE IF EXISTS gen_test;" [] 32 | rawExecute "DROP TABLE IF EXISTS gen_migrate_test;" [] 33 | runMigration migrate1 34 | 35 | insert_ GenTest 36 | { genTestFieldOne = Just "like, literally this exact string" 37 | , genTestFieldTwo = Just "like, totally some other string" 38 | , genTestFieldThree = Nothing 39 | } 40 | Just (Entity _ GenTest{..}) <- selectFirst [] [] 41 | liftIO $ genTestFieldThree @?= Just "like, literally this exact string" 42 | 43 | k1 <- insert $ MigrateTestV1 0 0 44 | Just (MigrateTestV1 sickness1 cromulence1) <- get k1 45 | liftIO $ sickness1 @?= 0 46 | liftIO $ cromulence1 @?= 5 47 | 48 | it "should support adding or removing generation expressions from columns" $ runDB $ do 49 | runMigration migrate2 50 | 51 | k2 <- insert $ MigrateTestV2 0 0 52 | Just (MigrateTestV2 sickness2 cromulence2) <- get k2 53 | liftIO $ sickness2 @?= 3 54 | liftIO $ cromulence2 @?= 0 55 | -------------------------------------------------------------------------------- /persistent-test/src/HtmlTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, UndecidableInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 4 | module HtmlTest (specsWith, cleanDB, htmlMigrate) where 5 | 6 | import Data.Char (generalCategory, GeneralCategory(..)) 7 | import qualified Data.Text as T 8 | import System.Random (randomIO, randomRIO, Random) 9 | import Text.Blaze.Html 10 | import Text.Blaze.Html.Renderer.Text 11 | 12 | import Init 13 | 14 | -- Test lower case names 15 | share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "htmlMigrate"] [persistLowerCase| 16 | HtmlTable 17 | html Html 18 | deriving 19 | |] 20 | 21 | cleanDB :: Runner backend m => ReaderT backend m () 22 | cleanDB = do 23 | deleteWhere ([] :: [Filter (HtmlTableGeneric backend)]) 24 | 25 | specsWith 26 | :: Runner backend m 27 | => RunDb backend m 28 | -> Maybe (ReaderT backend m a) 29 | -> Spec 30 | specsWith runConn mmigrate = describe "html" $ do 31 | it "works" $ asIO $ runConn $ do 32 | sequence_ mmigrate 33 | -- Ensure reading the data from the database works... 34 | sequence_ mmigrate 35 | 36 | sequence_ $ replicate 1000 $ do 37 | x <- liftIO randomValue 38 | key <- insert $ HtmlTable x 39 | Just htmlTableY <- get key 40 | liftIO $ do 41 | renderHtml x @?= renderHtml (htmlTableHtml htmlTableY) 42 | 43 | randomValue :: IO Html 44 | randomValue = 45 | preEscapedToMarkup 46 | . T.pack 47 | . filter ((`notElem` forbidden) . generalCategory) 48 | . filter (<= '\xFFFF') -- only BMP 49 | . filter (/= '\0') -- no nulls 50 | <$> randomIOs 51 | where forbidden = [NotAssigned, PrivateUse] 52 | 53 | randomIOs :: Random a => IO [a] 54 | randomIOs = do 55 | len <- randomRIO (0, 20) 56 | sequence $ replicate len randomIO 57 | -------------------------------------------------------------------------------- /persistent-test/src/LargeNumberTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module LargeNumberTest where 4 | 5 | import Data.Word 6 | 7 | import Init 8 | 9 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "numberMigrate"] [persistLowerCase| 10 | Number 11 | intx Int 12 | int32 Int32 13 | word32 Word32 14 | int64 Int64 15 | word64 Word64 16 | deriving Show Eq 17 | |] 18 | 19 | cleanDB 20 | :: Runner backend m => ReaderT backend m () 21 | cleanDB = do 22 | deleteWhere ([] :: [Filter (NumberGeneric backend)]) 23 | 24 | specsWith :: Runner backend m => RunDb backend m -> Spec 25 | specsWith runDb = describe "Large Numbers" $ do 26 | it "preserves their values in the database" $ runDb $ do 27 | let go x = do 28 | xid <- insert x 29 | x' <- get xid 30 | liftIO $ x' @?= Just x 31 | 32 | go $ Number maxBound 0 0 0 0 33 | go $ Number 0 maxBound 0 0 0 34 | go $ Number 0 0 maxBound 0 0 35 | go $ Number 0 0 0 maxBound 0 36 | go $ Number 0 0 0 0 maxBound 37 | 38 | go $ Number minBound 0 0 0 0 39 | go $ Number 0 minBound 0 0 0 40 | go $ Number 0 0 minBound 0 0 41 | go $ Number 0 0 0 minBound 0 42 | go $ Number 0 0 0 0 minBound 43 | 44 | -------------------------------------------------------------------------------- /persistent-test/src/LongIdentifierTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | module LongIdentifierTest where 15 | 16 | import Database.Persist.TH 17 | import Init 18 | 19 | -- This test creates very long identifier names. The generated foreign key is over the length limit for Postgres and MySQL 20 | -- persistent-postgresql handles this by truncating foreign key names using the same algorithm that Postgres itself does (see 'refName' in Postgresql.hs) 21 | -- MySQL currently doesn't run this test, and needs truncation logic for it to pass. 22 | share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| 23 | TableAnExtremelyFantasticallySuperLongNameParent 24 | field1 Int 25 | TableAnExtremelyFantasticallySuperLongNameChild 26 | columnAnExtremelyFantasticallySuperLongNameParentId TableAnExtremelyFantasticallySuperLongNameParentId 27 | |] 28 | 29 | specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec 30 | specsWith runDb = describe "Long identifiers" $ do 31 | -- See 'refName' in Postgresql.hs for why these tests are necessary. 32 | it "migrating is idempotent" $ runDb $ do 33 | again <- getMigration migration 34 | liftIO $ again @?= [] 35 | it "migrating really is idempotent" $ runDb $ do 36 | runMigration migration 37 | again <- getMigration migration 38 | liftIO $ again @?= [] 39 | -------------------------------------------------------------------------------- /persistent-test/src/MaxLenTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 4 | 5 | module MaxLenTest (specsWith, maxlenMigrate) where 6 | 7 | import Data.String (IsString) 8 | 9 | import Init 10 | 11 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maxlenMigrate"] [persistLowerCase| 12 | MaxLen 13 | text1 Text 14 | text2 Text maxlen=3 15 | bs1 ByteString 16 | bs2 ByteString maxlen=3 17 | str1 String 18 | str2 String maxlen=3 19 | MLText1 text1 20 | MLText2 text2 21 | MLBs1 bs1 22 | MLBs2 bs2 23 | MLStr1 str1 24 | MLStr2 str2 25 | deriving Show Eq 26 | |] 27 | 28 | specsWith :: Runner backend m => RunDb backend m -> Spec 29 | specsWith runDb = describe "Maximum length attribute" $ do 30 | it "truncates values that are too long" $ runDb $ do 31 | let t1 = MaxLen a a a a a a 32 | t2 = MaxLen b b b b b b 33 | t2' = MaxLen b b' b b' b b' 34 | a, b, b' :: IsString t => t 35 | a = "a" 36 | b = "12345" 37 | b' = "123" 38 | t1k <- insert t1 39 | t2k <- insert t2 40 | Just t1v <- get t1k 41 | Just t2v <- get t2k 42 | liftIO $ do t1v @?= t1 43 | if t2v == t2 44 | then t2v @?= t2 -- FIXME: why u no truncate? 45 | else t2v @?= t2' 46 | 47 | -------------------------------------------------------------------------------- /persistent-test/src/MaybeFieldDefsTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 5 | 6 | module MaybeFieldDefsTest (specsWith, maybeFieldDefMigrate) where 7 | 8 | import Data.String (IsString) 9 | 10 | import Init 11 | 12 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maybeFieldDefMigrate"] [persistLowerCase| 13 | MaybeFieldDefEntity 14 | optionalString (Maybe String) 15 | optionalInt (Maybe Int) 16 | deriving Eq Show 17 | |] 18 | 19 | specsWith :: (Runner backend m) => RunDb backend m -> Spec 20 | specsWith runDb = describe "Maybe Field Definitions" $ do 21 | it "runs appropriate migrations" $ runDb $ do 22 | emptyEntity <- insert $ MaybeFieldDefEntity Nothing Nothing 23 | emptyResult <- get emptyEntity 24 | liftIO $ emptyResult @?= Just (MaybeFieldDefEntity Nothing Nothing) 25 | populatedEntity <- insert $ MaybeFieldDefEntity (Just "text") (Just 8) 26 | populatedResult <- get populatedEntity 27 | liftIO $ populatedResult @?= Just (MaybeFieldDefEntity (Just "text") (Just 8)) 28 | -------------------------------------------------------------------------------- /persistent-test/src/MigrationColumnLengthTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module MigrationColumnLengthTest where 5 | 6 | import qualified Data.Text as T 7 | 8 | import Init 9 | 10 | share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| 11 | VaryingLengths 12 | field1 Int 13 | field2 T.Text sqltype=varchar(5) 14 | |] 15 | 16 | specsWith :: MonadIO m => RunDb SqlBackend m -> Spec 17 | specsWith runDb = 18 | it "is idempotent" $ runDb $ do 19 | again <- getMigration migration 20 | liftIO $ again @?= [] 21 | -------------------------------------------------------------------------------- /persistent-test/src/MigrationIdempotencyTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module MigrationIdempotencyTest where 5 | 6 | import Data.Int (Int32, Int64) 7 | import qualified Data.Text as T 8 | 9 | import Database.Persist.TH 10 | import Init 11 | 12 | share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| 13 | Idempotency 14 | field1 Int64 15 | field2 T.Text sqltype=varchar(5) 16 | field3 T.Text sqltype=mediumtext 17 | field4 T.Text sqltype=longtext 18 | field5 T.Text sqltype=mediumblob 19 | field6 T.Text sqltype=longblob 20 | field7 Double sqltype=double(6,5) 21 | field8 Int32 22 | field9 Bool 23 | |] 24 | 25 | specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec 26 | specsWith runDb = describe "MySQL migration with backend-specific sqltypes" $ do 27 | it "is idempotent" $ runDb $ do 28 | again <- getMigration migration 29 | liftIO $ again @?= [] 30 | -------------------------------------------------------------------------------- /persistent-test/src/MigrationOnlyTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications, TypeOperators, UndecidableInstances #-} 2 | 3 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 4 | 5 | module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where 6 | 7 | import qualified Data.Text as T 8 | 9 | import Database.Persist.TH 10 | import Init 11 | import Database.Persist.EntityDef 12 | 13 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase| 14 | TwoField1 sql=two_field 15 | field1 Int 16 | field2 T.Text 17 | field3 Bool Maybe 18 | deriving Eq Show 19 | |] 20 | 21 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2"] [persistLowerCase| 22 | TwoField 23 | field1 Int 24 | field2 T.Text 25 | field3 Bool Maybe MigrationOnly 26 | deriving Eq Show 27 | 28 | Referencing 29 | field1 Int 30 | field2 TwoFieldId MigrationOnly 31 | |] 32 | 33 | specsWith 34 | :: (MonadIO m, PersistQueryWrite backend, PersistStoreWrite backend, PersistQueryWrite (BaseBackend backend)) 35 | => RunDb backend m 36 | -> Maybe (ReaderT backend m a) 37 | -> Spec 38 | specsWith runDb mmigrate = describe "MigrationOnly field" $ do 39 | let 40 | edef = 41 | entityDef $ Proxy @TwoField 42 | describe "getEntityFields" $ do 43 | let 44 | fields = 45 | getEntityFields edef 46 | it "should have two fields" $ do 47 | length fields `shouldBe` 2 48 | it "should not have any migration only fields" $ do 49 | fields `shouldSatisfy` all isHaskellField 50 | 51 | describe "getEntityFieldsDatabase" $ do 52 | let 53 | fields = 54 | getEntityFieldsDatabase edef 55 | it "should have three fields" $ do 56 | length fields `shouldBe` 3 57 | it "should have at one migration only field" $ do 58 | length (filter (not . isHaskellField) fields) `shouldBe` 1 59 | 60 | it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do 61 | sequence_ mmigrate 62 | sequence_ mmigrate 63 | let tf = TwoField 5 "hello" 64 | tid <- insert tf 65 | mtf <- get tid 66 | liftIO $ mtf @?= Just tf 67 | deleteWhere ([] :: [Filter (TwoFieldGeneric backend)]) 68 | -------------------------------------------------------------------------------- /persistent-test/src/MigrationTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module MigrationTest where 5 | 6 | import Database.Persist.TH 7 | import qualified Data.Text as T 8 | 9 | import Init 10 | 11 | share [mkPersist sqlSettings, mkMigrate "migrationMigrate"] [persistLowerCase| 12 | Target 13 | field1 Int 14 | field2 T.Text 15 | UniqueTarget field1 field2 16 | deriving Eq Show 17 | 18 | Source 19 | field3 Int 20 | field4 TargetId 21 | 22 | CustomSqlId 23 | pk Int sql=id 24 | Primary pk 25 | |] 26 | 27 | share [mkPersist sqlSettings, mkMigrate "migrationAddCol"] [persistLowerCase| 28 | Target1 sql=target 29 | field1 Int 30 | field2 T.Text 31 | UniqueTarget1 field1 field2 32 | deriving Eq Show 33 | 34 | Source1 sql=source 35 | field3 Int 36 | extra Int 37 | field4 Target1Id 38 | |] 39 | 40 | specsWith :: (MonadUnliftIO m) => RunDb SqlBackend m -> Spec 41 | specsWith runDb = describe "Migration" $ do 42 | it "is idempotent" $ runDb $ do 43 | again <- getMigration migrationMigrate 44 | liftIO $ again @?= [] 45 | it "really is idempotent" $ runDb $ do 46 | void $ runMigrationSilent migrationMigrate 47 | void $ runMigrationSilent migrationMigrate 48 | again <- getMigration migrationMigrate 49 | liftIO $ again @?= [] 50 | it "can add an extra column" $ runDb $ do 51 | -- Failing test case for #735. Foreign-key checking, switched on in 52 | -- version 2.6.1, caused persistent-sqlite to generate a `references` 53 | -- constraint in a *temporary* table during migration, which fails. 54 | void $ runMigrationSilent migrationAddCol 55 | again <- getMigration migrationAddCol 56 | liftIO $ again @?= [] 57 | -------------------------------------------------------------------------------- /persistent-test/src/MpsCustomPrefixTest.hs: -------------------------------------------------------------------------------- 1 | module MpsCustomPrefixTest where 2 | 3 | import Init 4 | import PersistentTestModels 5 | 6 | specsWith :: MonadIO m => RunDb SqlBackend m -> Spec 7 | specsWith runDb = describe "mpsCustomPrefix" $ 8 | it "works" $ runDb $ do 9 | deleteWhere ([] :: [Filter CustomPrefix2]) 10 | deleteWhere ([] :: [Filter CustomPrefix1]) 11 | cp1a <- insert $ CustomPrefix1 1 12 | update cp1a [CP1CustomFieldName =. 2] 13 | cp1b <- insert $ CustomPrefix1 3 14 | cp2 <- insert $ CustomPrefix2 4 cp1a 15 | update cp2 [CP2CustomPrefixedRef =. cp1b, CP2OtherCustomFieldName =. 5] 16 | 17 | mcp1a <- get cp1a 18 | liftIO $ mcp1a @?= Just (CustomPrefix1 2) 19 | liftIO $ fmap _cp1CustomFieldName mcp1a @?= Just 2 20 | mcp2 <- get cp2 21 | liftIO $ fmap _cp2CustomPrefixedRef mcp2 @?= Just cp1b 22 | liftIO $ fmap _cp2OtherCustomFieldName mcp2 @?= Just 5 23 | 24 | cpls <- insert $ CPCustomPrefixedLeftSum 5 25 | cprs <- insert $ CPCustomPrefixedRightSum "Hello" 26 | update cpls [CPCustomPrefixedLeft =. 6] 27 | update cprs [CPCustomPrefixedRight =. "World"] 28 | mcpls <- get cpls 29 | mcprs <- get cprs 30 | 31 | liftIO $ mcpls @?= Just (CPCustomPrefixedLeftSum 6) 32 | liftIO $ mcprs @?= Just (CPCustomPrefixedRightSum "World") 33 | -------------------------------------------------------------------------------- /persistent-test/src/MpsNoPrefixTest.hs: -------------------------------------------------------------------------------- 1 | module MpsNoPrefixTest where 2 | 3 | import Init 4 | import PersistentTestModels 5 | 6 | specsWith :: MonadIO m => RunDb SqlBackend m -> Spec 7 | specsWith runDb = describe "mpsNoPrefix" $ do 8 | it "works" $ runDb $ do 9 | deleteWhere ([] :: [Filter NoPrefix2]) 10 | deleteWhere ([] :: [Filter NoPrefix1]) 11 | np1a <- insert $ NoPrefix1 1 12 | update np1a [SomeFieldName =. 2] 13 | np1b <- insert $ NoPrefix1 3 14 | np2 <- insert $ NoPrefix2 4 np1a 15 | update np2 [UnprefixedRef =. np1b, SomeOtherFieldName =. 5] 16 | 17 | mnp1a <- get np1a 18 | liftIO $ mnp1a @?= Just (NoPrefix1 2) 19 | liftIO $ fmap someFieldName mnp1a @?= Just 2 20 | mnp2 <- get np2 21 | liftIO $ fmap unprefixedRef mnp2 @?= Just np1b 22 | liftIO $ fmap someOtherFieldName mnp2 @?= Just 5 23 | 24 | insert_ $ UnprefixedLeftSum 5 25 | insert_ $ UnprefixedRightSum "Hello" 26 | 27 | it "IsSqlKey instance" $ runDb $ do 28 | let p = Person "Alice" 30 Nothing 29 | key@(PersonKey (SqlBackendKey i)) <- insert p 30 | liftIO $ fromSqlKey key `shouldBe` (i :: Int64) 31 | mp <- get $ toSqlKey i 32 | liftIO $ mp `shouldBe` Just p 33 | -------------------------------------------------------------------------------- /persistent-test/src/PersistTestPetCollarType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | module PersistTestPetCollarType where 3 | 4 | import Data.Aeson 5 | import Data.Text (Text) 6 | import GHC.Generics 7 | 8 | import Database.Persist.TH 9 | 10 | data PetCollar = PetCollar {tag :: Text, bell :: Bool} 11 | deriving (Generic, Eq, Show) 12 | instance ToJSON PetCollar 13 | instance FromJSON PetCollar 14 | 15 | derivePersistFieldJSON "PetCollar" 16 | -------------------------------------------------------------------------------- /persistent-test/src/PersistTestPetType.hs: -------------------------------------------------------------------------------- 1 | module PersistTestPetType where 2 | 3 | import Database.Persist.TH 4 | 5 | data PetType = Cat | Dog 6 | deriving (Show, Read, Eq) 7 | derivePersistField "PetType" 8 | -------------------------------------------------------------------------------- /persistent-test/src/PersistentTestModelsImports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# language UndecidableInstances #-} 3 | 4 | -- | this just needs to compile 5 | module PersistentTestModelsImports where 6 | 7 | import Database.Persist.TH 8 | 9 | share [mkPersist sqlSettings] [persistUpperCase| 10 | 11 | User 12 | name String 13 | age Int 14 | deriving Eq Show 15 | 16 | |] 17 | -------------------------------------------------------------------------------- /persistent-test/src/PrimaryTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module PrimaryTest where 7 | 8 | import Init 9 | 10 | -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs 11 | share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase| 12 | Foo 13 | name String 14 | Primary name 15 | 16 | Bar 17 | quux FooId 18 | 19 | Trees sql=trees 20 | name String 21 | parent String Maybe 22 | Primary name 23 | Foreign Trees fkparent parent 24 | 25 | CompositePrimary 26 | name String 27 | age Int 28 | Primary name age 29 | |] 30 | 31 | 32 | cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) => ReaderT backend m () 33 | cleanDB = do 34 | deleteWhere ([] :: [Filter Foo]) 35 | deleteWhere ([] :: [Filter Bar]) 36 | 37 | specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec 38 | specsWith runDb = describe "primary key reference" $ do 39 | it "insert a primary reference" $ runDb $ do 40 | kf <- insert $ Foo "name" 41 | _kb <- insert $ Bar kf 42 | return () 43 | it "uses RawSql for a Primary key" $ runDb $ do 44 | key <- insert $ Foo "name" 45 | keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" [] 46 | [key] @== keyFromRaw 47 | describe "keyFromRecordM" $ do 48 | it "works on singleton case" $ do 49 | let 50 | foo = Foo "hello" 51 | fooKey = fmap ($ foo) keyFromRecordM 52 | fooKey `shouldBe` Just (FooKey "hello") 53 | it "works on multiple fields" $ do 54 | let 55 | name = "hello" 56 | age = 31 57 | rec = CompositePrimary name age 58 | fmap ($ rec) keyFromRecordM 59 | `shouldBe` 60 | Just (CompositePrimaryKey name age) 61 | -------------------------------------------------------------------------------- /persistent-test/src/ReadWriteTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module ReadWriteTest where 3 | 4 | import Init 5 | import PersistentTestModels 6 | 7 | 8 | specsWith :: forall m. Runner SqlBackend m => RunDb SqlBackend m -> Spec 9 | specsWith originalRunDb = describe "ReadWriteTest" $ do 10 | let personFilters = [] :: [Filter Person] 11 | describe "SqlReadBackend" $ do 12 | let runDb :: RunDb SqlReadBackend m 13 | runDb = changeBackend SqlReadBackend originalRunDb 14 | it "type checks on all PersistStoreRead functions" $ do 15 | runDb $ do 16 | _ <- get (PersonKey 3) 17 | _ <- getMany [PersonKey 1, PersonKey 2] 18 | pure () 19 | 20 | it "type checks on all PersistQueryRead functions" $ do 21 | runDb $ do 22 | _ <- selectList personFilters [] 23 | _ <- count personFilters 24 | pure () 25 | 26 | it "type checks on PersistUniqueRead functions" $ do 27 | runDb $ do 28 | _ <- getBy (PersonNameKey "Matt") 29 | pure () 30 | 31 | describe "SqlWriteBackend" $ do 32 | let runDb :: RunDb SqlWriteBackend m 33 | runDb = changeBackend SqlWriteBackend originalRunDb 34 | 35 | it "type checks on PersistStoreWrite and Read functions" $ do 36 | runDb $ do 37 | let person = Person "Matt Parsons" 30 Nothing 38 | k <- insert person 39 | mperson <- get k 40 | Just person @== mperson 41 | 42 | it "type checks on PersistQueryWrite and Read functions" $ do 43 | runDb $ do 44 | _ <- selectList personFilters [] 45 | updateWhere personFilters [] 46 | 47 | it "type checks on PersistUniqueWrite/Read functions" $ do 48 | runDb $ do 49 | let name_ = "Matt Parsons New" 50 | person = Person name_ 30 Nothing 51 | _mkey0 <- insertUnique person 52 | mkey1 <- insertUnique person 53 | mkey1 @== Nothing 54 | mperson <- selectFirst [PersonName ==. name_] [] 55 | fmap entityVal mperson @== Just person 56 | 57 | let nameLuke = "Luke Seale New" 58 | personLuke = Person nameLuke 31 Nothing 59 | mkey2 <- insertUnique_ personLuke 60 | mkey3 <- insertUnique_ personLuke 61 | mkey3 @== Nothing 62 | mpersonLuke <- selectFirst [PersonName ==. nameLuke] [] 63 | fmap entityVal mpersonLuke @== Just personLuke 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /persistent-test/src/Recursive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 5 | 6 | module Recursive (specsWith, recursiveMigrate, cleanup) where 7 | 8 | import Init 9 | 10 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase| 11 | 12 | SubType 13 | object [MenuObject] 14 | deriving Show Eq 15 | 16 | MenuObject 17 | sub SubType Maybe 18 | deriving Show Eq 19 | 20 | |] 21 | 22 | cleanup 23 | :: (PersistStoreWrite (BaseBackend backend), PersistQueryWrite backend) 24 | => ReaderT backend IO () 25 | cleanup = do 26 | deleteWhere ([] :: [Filter (MenuObjectGeneric backend)]) 27 | deleteWhere ([] :: [Filter (SubTypeGeneric backend)]) 28 | 29 | specsWith 30 | :: 31 | ( PersistStoreWrite backend 32 | , PersistStoreWrite (BaseBackend backend) 33 | , MonadIO m 34 | ) 35 | => RunDb backend m 36 | -> Spec 37 | specsWith runDb = describe "recursive definitions" $ do 38 | it "mutually recursive" $ runDb $ do 39 | let m1 = MenuObject $ Just $ SubType [] 40 | let m2 = MenuObject $ Just $ SubType [m1] 41 | let m3 = MenuObject $ Just $ SubType [m2] 42 | k3 <- insert m3 43 | m3' <- get k3 44 | m3' @== Just m3 45 | -------------------------------------------------------------------------------- /persistent-test/src/SumTypeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 5 | module SumTypeTest (specsWith, sumTypeMigrate) where 6 | 7 | import qualified Data.Text as T 8 | 9 | import Database.Persist.TH 10 | import Init 11 | 12 | share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "sumTypeMigrate"] [persistLowerCase| 13 | Bicycle 14 | brand T.Text 15 | Car 16 | make T.Text 17 | model T.Text 18 | +Vehicle 19 | bicycle BicycleId 20 | car CarId 21 | |] 22 | 23 | -- This is needed for mpsGeneric = True 24 | -- The typical persistent user sets mpsGeneric = False 25 | -- https://ghc.haskell.org/trac/ghc/ticket/8100 26 | deriving instance Show (BackendKey backend) => Show (VehicleGeneric backend) 27 | deriving instance Eq (BackendKey backend) => Eq (VehicleGeneric backend) 28 | 29 | specsWith 30 | :: 31 | ( PersistQueryWrite backend 32 | , BaseBackend backend ~ backend 33 | , MonadIO m, MonadFail m 34 | ) 35 | => RunDb backend m 36 | -> Maybe (ReaderT backend m a) 37 | -- ^ Optional migrations for SQL backends 38 | -> Spec 39 | specsWith runDb mmigrate = describe "sum types" $ 40 | it "works" $ asIO $ runDb $ do 41 | sequence_ mmigrate 42 | car1 <- insert $ Car "Ford" "Thunderbird" 43 | car2 <- insert $ Car "Kia" "Rio" 44 | bike1 <- insert $ Bicycle "Shwinn" 45 | 46 | vc1 <- insert $ VehicleCarSum car1 47 | vc2 <- insert $ VehicleCarSum car2 48 | vb1 <- insert $ VehicleBicycleSum bike1 49 | 50 | x1 <- get vc1 51 | liftIO $ x1 @?= Just (VehicleCarSum car1) 52 | 53 | x2 <- get vc2 54 | liftIO $ x2 @?= Just (VehicleCarSum car2) 55 | 56 | x3 <- get vb1 57 | liftIO $ x3 @?= Just (VehicleBicycleSum bike1) 58 | -------------------------------------------------------------------------------- /persistent-test/src/TransactionLevelTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module TransactionLevelTest where 6 | 7 | import Init 8 | 9 | share [mkPersist sqlSettings, mkMigrate "migration"] [persistUpperCase| 10 | Wombat 11 | name Text sqltype=varchar(80) 12 | 13 | Primary name 14 | deriving Eq Show Ord 15 | 16 | |] 17 | 18 | specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec 19 | specsWith runDb = describe "IsolationLevel" $ do 20 | let item = Wombat "uno" 21 | isolationLevels = [minBound..maxBound] 22 | forM_ isolationLevels $ \il -> describe "insertOnDuplicateKeyUpdate" $ do 23 | it (show il ++ " works") $ runDb $ do 24 | transactionUndoWithIsolation il 25 | deleteWhere ([] :: [Filter Wombat]) 26 | insert_ item 27 | Just item' <- get (WombatKey "uno") 28 | item' @== item 29 | -------------------------------------------------------------------------------- /persistent-test/src/TreeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE RecordWildCards, TypeOperators, UndecidableInstances #-} 3 | 4 | module TreeTest where 5 | 6 | import Init 7 | 8 | 9 | -- mpsGeneric = False is due to a bug or at least lack of a feature in 10 | -- mkKeyTypeDec TH.hs 11 | share 12 | [ mkPersist persistSettings { mpsGeneric = False } 13 | , mkMigrate "treeMigrate" 14 | ] [persistLowerCase| 15 | Tree sql=trees 16 | name Text 17 | parent Text Maybe 18 | Primary name 19 | Foreign Tree fkparent parent 20 | |] 21 | 22 | 23 | cleanDB 24 | :: (PersistQuery backend, PersistEntityBackend Tree ~ backend, MonadIO m) 25 | => ReaderT backend m () 26 | cleanDB = do 27 | deleteWhere ([] :: [Filter Tree]) 28 | 29 | specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec 30 | specsWith runDb = describe "tree" $ do 31 | it "Tree relationships" $ runDb $ do 32 | kgp@(TreeKey gpt) <- insert $ Tree "grandpa" Nothing 33 | kdad@(TreeKey dadt) <- insert $ Tree "dad" $ Just gpt 34 | kc <- insert $ Tree "child" $ Just dadt 35 | c <- getJust kc 36 | treeFkparent c @== Just kdad 37 | dad <- getJust kdad 38 | treeFkparent dad @== Just kgp 39 | gp <- getJust kgp 40 | treeFkparent gp @== Nothing 41 | describe "entityDef" $ do 42 | let ed = entityDef (Proxy :: Proxy Tree) 43 | it "has the right haskell name" $ do 44 | getEntityHaskellName ed `shouldBe` EntityNameHS "Tree" 45 | it "has the right DB name" $ do 46 | getEntityDBName ed `shouldBe` EntityNameDB "trees" 47 | 48 | describe "foreign ref" $ do 49 | let [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree)) 50 | it "has the right haskell name" $ do 51 | foreignRefTableHaskell `shouldBe` 52 | EntityNameHS "Tree" 53 | it "has the right db name" $ do 54 | foreignRefTableDBName `shouldBe` 55 | EntityNameDB "trees" 56 | it "has the right constraint name" $ do 57 | foreignConstraintNameHaskell `shouldBe` 58 | ConstraintNameHS "fkparent" 59 | it "has the right DB constraint name" $ do 60 | foreignConstraintNameDBName `shouldBe` 61 | ConstraintNameDB "treefkparent" 62 | it "has the right fields" $ do 63 | foreignFields `shouldBe` 64 | [ ( (FieldNameHS "parent", FieldNameDB "parent") 65 | , (FieldNameHS "name", FieldNameDB "name") 66 | ) 67 | ] 68 | -------------------------------------------------------------------------------- /persistent-test/src/TypeLitFieldDefsTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 6 | 7 | module TypeLitFieldDefsTest (specsWith, typeLitFieldDefsMigrate) where 8 | 9 | import Data.Maybe (fromJust) 10 | import GHC.TypeLits 11 | import Init 12 | 13 | newtype Finite (n :: Nat) = Finite Int 14 | deriving (Show, Eq) 15 | 16 | instance PersistField (Finite n) where 17 | toPersistValue (Finite n) = toPersistValue n 18 | fromPersistValue = fmap Finite . fromPersistValue 19 | 20 | instance PersistFieldSql (Finite n) where 21 | sqlType _ = sqlType (Proxy :: Proxy Int) 22 | 23 | newtype Labelled (t :: Symbol) = Labelled Int 24 | deriving (Show, Eq) 25 | 26 | instance PersistField (Labelled n) where 27 | toPersistValue (Labelled n) = toPersistValue n 28 | fromPersistValue = fmap Labelled . fromPersistValue 29 | 30 | instance PersistFieldSql (Labelled n) where 31 | sqlType _ = sqlType (Proxy :: Proxy Int) 32 | 33 | share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "typeLitFieldDefsMigrate"] [persistLowerCase| 34 | TypeLitFieldDefsNumeric 35 | one (Finite 1) 36 | twenty (Finite 20) 37 | deriving Eq Show 38 | 39 | TypeLitFieldDefsLabelled 40 | one (Labelled "one") 41 | twenty (Labelled "twenty") 42 | deriving Eq Show 43 | |] 44 | 45 | one :: Finite 1 46 | one = Finite 1 47 | 48 | oneLabelled :: Labelled "one" 49 | oneLabelled = Labelled 1 50 | 51 | twenty :: Finite 20 52 | twenty = Finite 20 53 | 54 | twentyLabelled :: Labelled "twenty" 55 | twentyLabelled = Labelled 20 56 | 57 | specsWith :: Runner backend m => RunDb backend m -> Spec 58 | specsWith runDb = 59 | describe "Type Lit Field Definitions" $ do 60 | it "runs appropriate migrations" $ runDb $ do 61 | numKey <- insert $ TypeLitFieldDefsNumeric one twenty 62 | num <- getJust numKey 63 | liftIO $ typeLitFieldDefsNumericOne num @?= one 64 | liftIO $ typeLitFieldDefsNumericTwenty num @?= twenty 65 | 66 | labelledKey <- insert $ TypeLitFieldDefsLabelled oneLabelled twentyLabelled 67 | lbl <- getJust labelledKey 68 | liftIO $ typeLitFieldDefsLabelledOne lbl @?= oneLabelled 69 | liftIO $ typeLitFieldDefsLabelledTwenty lbl @?= twentyLabelled 70 | -------------------------------------------------------------------------------- /persistent-test/src/UniqueTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module UniqueTest where 5 | 6 | import Init 7 | 8 | share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase| 9 | TestNonNull 10 | fieldA Int 11 | UniqueTestNonNull fieldA sql=UniqueTestNonNull !force 12 | deriving Eq Show 13 | TestNull 14 | fieldA Int 15 | fieldB Int Maybe 16 | UniqueTestNull fieldA fieldB sql=UniqueTestNonNullSqlName !force 17 | deriving Eq Show 18 | 19 | TestCheckmark 20 | name Text 21 | value Text 22 | active Checkmark nullable 23 | UniqueTestCheckmark name active !force 24 | deriving Eq Show 25 | |] 26 | 27 | cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m () 28 | cleanDB = do 29 | deleteWhere ([] :: [Filter TestNonNull]) 30 | deleteWhere ([] :: [Filter TestNull]) 31 | 32 | specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec 33 | specsWith runDb = 34 | describe "uniqueness constraints" $ do 35 | it "are respected for non-nullable Ints" $ do 36 | let ins = insert . TestNonNull 37 | (runDb $ void $ ins 1 >> ins 2) 38 | (runDb $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException 39 | (runDb $ void $ ins 1 >>= \k -> ins 2 >> delete k >> ins 1) 40 | it "are respected for nullable Ints" $ do 41 | let ins a b = insert $ TestNull a b 42 | ctx = ins 1 Nothing >> ins 1 Nothing >> ins 1 Nothing >> 43 | ins 1 (Just 3) >> ins 1 (Just 4) 44 | (runDb $ void ctx) 45 | (runDb $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException 46 | (runDb $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException 47 | (runDb $ void $ ctx >>= \k -> delete k >> ins 1 (Just 4)) 48 | it "work for Checkmark" $ do 49 | let ins k v a = insert $ TestCheckmark k v a 50 | ctx = ins "name" "John" Inactive 51 | >> ins "name" "Stewart" Inactive 52 | >> ins "name" "Doroty" Active 53 | >> ins "color" "blue" Inactive 54 | (runDb $ void ctx) 55 | (runDb $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException 56 | (runDb $ void $ ctx >> ins "name" "Melissa" Inactive) 57 | (runDb $ void $ ctx >>= flip update [TestCheckmarkActive =. Active]) 58 | (runDb $ void $ do 59 | void ctx 60 | updateWhere [TestCheckmarkName ==. "name"] 61 | [TestCheckmarkActive =. Inactive] 62 | ins "name" "Melissa" Active) 63 | -------------------------------------------------------------------------------- /persistent/Database/Persist/Class/PersistConfig.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module Database.Persist.Class.PersistConfig 5 | ( PersistConfig (..) 6 | ) where 7 | 8 | import Control.Monad.IO.Unlift (MonadUnliftIO) 9 | import Data.Aeson (Value (Object)) 10 | import Data.Aeson.Types (Parser) 11 | 12 | #if MIN_VERSION_aeson(2,0,0) 13 | import qualified Data.Aeson.KeyMap as AM 14 | #else 15 | import qualified Data.HashMap.Strict as AM 16 | #endif 17 | 18 | import Data.Kind (Type) 19 | 20 | -- | Represents a value containing all the configuration options for a specific 21 | -- backend. This abstraction makes it easier to write code that can easily swap 22 | -- backends. 23 | class PersistConfig c where 24 | type PersistConfigBackend c :: (Type -> Type) -> Type -> Type 25 | type PersistConfigPool c 26 | 27 | -- | Load the config settings from a 'Value', most likely taken from a YAML 28 | -- config file. 29 | loadConfig :: Value -> Parser c 30 | 31 | -- | Modify the config settings based on environment variables. 32 | applyEnv :: c -> IO c 33 | applyEnv = return 34 | 35 | -- | Create a new connection pool based on the given config settings. 36 | createPoolConfig :: c -> IO (PersistConfigPool c) 37 | 38 | -- | Run a database action by taking a connection from the pool. 39 | runPool :: MonadUnliftIO m 40 | => c 41 | -> PersistConfigBackend c m a 42 | -> PersistConfigPool c 43 | -> m a 44 | 45 | instance 46 | ( PersistConfig c1 47 | , PersistConfig c2 48 | , PersistConfigPool c1 ~ PersistConfigPool c2 49 | , PersistConfigBackend c1 ~ PersistConfigBackend c2 50 | ) => PersistConfig (Either c1 c2) where 51 | type PersistConfigBackend (Either c1 c2) = PersistConfigBackend c1 52 | type PersistConfigPool (Either c1 c2) = PersistConfigPool c1 53 | 54 | loadConfig (Object o) = 55 | case AM.lookup "left" o of 56 | Just v -> Left <$> loadConfig v 57 | Nothing -> 58 | case AM.lookup "right" o of 59 | Just v -> Right <$> loadConfig v 60 | Nothing -> fail "PersistConfig for Either: need either a left or right" 61 | loadConfig _ = fail "PersistConfig for Either: need an object" 62 | 63 | createPoolConfig = either createPoolConfig createPoolConfig 64 | 65 | runPool (Left c) = runPool c 66 | runPool (Right c) = runPool c 67 | -------------------------------------------------------------------------------- /persistent/Database/Persist/Compatible.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Compatible 2 | ( Compatible(..) 3 | , makeCompatibleInstances 4 | , makeCompatibleKeyInstances 5 | ) where 6 | 7 | import Database.Persist.Compatible.Types 8 | import Database.Persist.Compatible.TH 9 | 10 | -------------------------------------------------------------------------------- /persistent/Database/Persist/EntityDef/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | The 'EntityDef' type, fields, and constructor are exported from this 2 | -- module. Breaking changes to the 'EntityDef' type are not reflected in 3 | -- the major version of the API. Please import from 4 | -- "Database.Persist.EntityDef" instead. 5 | -- 6 | -- If you need this module, please file a GitHub issue why. 7 | -- 8 | -- @since 2.13.0.0 9 | module Database.Persist.EntityDef.Internal 10 | ( EntityDef(..) 11 | , entityPrimary 12 | , entitiesPrimary 13 | , keyAndEntityFields 14 | , keyAndEntityFieldsDatabase 15 | , toEmbedEntityDef 16 | , EntityIdDef(..) 17 | ) where 18 | 19 | import Database.Persist.Types.Base 20 | -------------------------------------------------------------------------------- /persistent/Database/Persist/FieldDef.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- @since 2.13.0.0 4 | module Database.Persist.FieldDef 5 | ( -- * The 'FieldDef' type 6 | FieldDef 7 | -- ** Setters 8 | , setFieldAttrs 9 | , overFieldAttrs 10 | , addFieldAttr 11 | -- ** Helpers 12 | , isFieldNullable 13 | , isFieldMaybe 14 | , isFieldNotGenerated 15 | , isHaskellField 16 | -- * 'FieldCascade' 17 | , FieldCascade(..) 18 | , renderFieldCascade 19 | , renderCascadeAction 20 | , noCascade 21 | , CascadeAction(..) 22 | ) where 23 | 24 | import Database.Persist.FieldDef.Internal 25 | 26 | import Database.Persist.Types.Base 27 | ( FieldAttr(..) 28 | , FieldType(..) 29 | , IsNullable(..) 30 | , fieldAttrsContainsNullable 31 | , isHaskellField 32 | ) 33 | 34 | -- | Replace the 'FieldDef' 'FieldAttr' with the new list. 35 | -- 36 | -- @since 2.13.0.0 37 | setFieldAttrs :: [FieldAttr] -> FieldDef -> FieldDef 38 | setFieldAttrs fas fd = fd { fieldAttrs = fas } 39 | 40 | -- | Modify the list of field attributes. 41 | -- 42 | -- @since 2.13.0.0 43 | overFieldAttrs :: ([FieldAttr] -> [FieldAttr]) -> FieldDef -> FieldDef 44 | overFieldAttrs k fd = fd { fieldAttrs = k (fieldAttrs fd) } 45 | 46 | -- | Add an attribute to the list of field attributes. 47 | -- 48 | -- @since 2.13.0.0 49 | addFieldAttr :: FieldAttr -> FieldDef -> FieldDef 50 | addFieldAttr fa = overFieldAttrs (fa :) 51 | 52 | -- | Check if the field definition is nullable 53 | -- 54 | -- @since 2.13.0.0 55 | isFieldNullable :: FieldDef -> IsNullable 56 | isFieldNullable = 57 | fieldAttrsContainsNullable . fieldAttrs 58 | 59 | -- | Check if the field is `Maybe a` 60 | -- 61 | -- @since 2.13.0.0 62 | isFieldMaybe :: FieldDef -> Bool 63 | isFieldMaybe field = 64 | case fieldType field of 65 | FTApp (FTTypeCon _ "Maybe") _ -> 66 | True 67 | _ -> 68 | False 69 | -------------------------------------------------------------------------------- /persistent/Database/Persist/FieldDef/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | TODO: standard Internal moduel boilerplate 2 | -- 3 | -- @since 2.13.0.0 4 | module Database.Persist.FieldDef.Internal 5 | ( FieldDef(..) 6 | , isFieldNotGenerated 7 | , FieldCascade(..) 8 | , renderFieldCascade 9 | , renderCascadeAction 10 | , noCascade 11 | , CascadeAction(..) 12 | ) where 13 | 14 | import Database.Persist.Types.Base 15 | -------------------------------------------------------------------------------- /persistent/Database/Persist/ImplicitIdDef.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | 3 | -- | This module contains types and functions for creating an 'ImplicitIdDef', 4 | -- which allows you to customize the implied ID column that @persistent@ 5 | -- generates. 6 | -- 7 | -- If this module doesn't suit your needs, you may want to import 8 | -- "Database.Persist.ImplicitIdDef.Internal" instead. If you do so, please file 9 | -- an issue on GitHub so we can support your needs. Breaking changes to that 10 | -- module will *not* be accompanied with a major version bump. 11 | -- 12 | -- @since 2.13.0.0 13 | module Database.Persist.ImplicitIdDef 14 | ( -- * The Type 15 | ImplicitIdDef 16 | -- * Construction 17 | , mkImplicitIdDef 18 | -- * Autoincrementing Integer Key 19 | , autoIncrementingInteger 20 | -- * Getters 21 | -- * Setters 22 | , setImplicitIdDefMaxLen 23 | , unsafeClearDefaultImplicitId 24 | ) where 25 | 26 | import Language.Haskell.TH 27 | 28 | import Database.Persist.ImplicitIdDef.Internal 29 | import Database.Persist.Types.Base 30 | ( FieldType(..) 31 | , SqlType(..) 32 | ) 33 | import Database.Persist.Class (BackendKey) 34 | import Database.Persist.Names 35 | 36 | -- | This is the default variant. Setting the implicit ID definition to this 37 | -- value should not have any change at all on how entities are defined by 38 | -- default. 39 | -- 40 | -- @since 2.13.0.0 41 | autoIncrementingInteger :: ImplicitIdDef 42 | autoIncrementingInteger = 43 | ImplicitIdDef 44 | { iidFieldType = \entName -> 45 | FTTypeCon Nothing $ unEntityNameHS entName `mappend` "Id" 46 | , iidFieldSqlType = 47 | SqlInt64 48 | , iidType = \isMpsGeneric mpsBackendType -> 49 | ConT ''BackendKey `AppT` 50 | if isMpsGeneric 51 | then VarT (mkName "backend") 52 | else mpsBackendType 53 | , iidDefault = 54 | Nothing 55 | , iidMaxLen = 56 | Nothing 57 | } 58 | -------------------------------------------------------------------------------- /persistent/Database/Persist/Names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveLift #-} 2 | 3 | -- | This module contains types and functions for working with and 4 | -- disambiguating database and Haskell names. 5 | -- 6 | -- @since 2.13.0.0 7 | module Database.Persist.Names where 8 | 9 | import Data.Text (Text) 10 | import Language.Haskell.TH.Syntax (Lift) 11 | -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` 12 | -- instance on pre-1.2.4 versions of `text` 13 | import Instances.TH.Lift () 14 | 15 | -- | Convenience operations for working with '-NameDB' types. 16 | -- 17 | -- @since 2.12.0.0 18 | class DatabaseName a where 19 | escapeWith :: (Text -> str) -> (a -> str) 20 | 21 | -- | A 'FieldNameDB' represents the datastore-side name that @persistent@ 22 | -- will use for a field. 23 | -- 24 | -- @since 2.12.0.0 25 | newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text } 26 | deriving (Show, Eq, Read, Ord, Lift) 27 | 28 | -- | @since 2.12.0.0 29 | instance DatabaseName FieldNameDB where 30 | escapeWith f (FieldNameDB n) = f n 31 | 32 | -- | A 'FieldNameHS' represents the Haskell-side name that @persistent@ 33 | -- will use for a field. 34 | -- 35 | -- @since 2.12.0.0 36 | newtype FieldNameHS = FieldNameHS { unFieldNameHS :: Text } 37 | deriving (Show, Eq, Read, Ord, Lift) 38 | 39 | -- | An 'EntityNameHS' represents the Haskell-side name that @persistent@ 40 | -- will use for an entity. 41 | -- 42 | -- @since 2.12.0.0 43 | newtype EntityNameHS = EntityNameHS { unEntityNameHS :: Text } 44 | deriving (Show, Eq, Read, Ord, Lift) 45 | 46 | -- | An 'EntityNameDB' represents the datastore-side name that @persistent@ 47 | -- will use for an entity. 48 | -- 49 | -- @since 2.12.0.0 50 | newtype EntityNameDB = EntityNameDB { unEntityNameDB :: Text } 51 | deriving (Show, Eq, Read, Ord, Lift) 52 | 53 | instance DatabaseName EntityNameDB where 54 | escapeWith f (EntityNameDB n) = f n 55 | 56 | -- | A 'ConstraintNameDB' represents the datastore-side name that @persistent@ 57 | -- will use for a constraint. 58 | -- 59 | -- @since 2.12.0.0 60 | newtype ConstraintNameDB = ConstraintNameDB { unConstraintNameDB :: Text } 61 | deriving (Show, Eq, Read, Ord, Lift) 62 | 63 | -- | @since 2.12.0.0 64 | instance DatabaseName ConstraintNameDB where 65 | escapeWith f (ConstraintNameDB n) = f n 66 | 67 | -- | An 'ConstraintNameHS' represents the Haskell-side name that @persistent@ 68 | -- will use for a constraint. 69 | -- 70 | -- @since 2.12.0.0 71 | newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } 72 | deriving (Show, Eq, Read, Ord, Lift) 73 | -------------------------------------------------------------------------------- /persistent/Database/Persist/Quasi/PersistSettings.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Quasi.PersistSettings 2 | ( PersistSettings 3 | , defaultPersistSettings 4 | , upperCaseSettings 5 | , lowerCaseSettings 6 | , ParserErrorLevel (..) 7 | , ParserWarning 8 | , warningPos 9 | , parserWarningMessage 10 | 11 | -- ** Getters and Setters 12 | , getPsToDBName 13 | , setPsToDBName 14 | , setPsToFKName 15 | , setPsUseSnakeCaseForeignKeys 16 | , setPsUseSnakeCaseForiegnKeys 17 | , getPsStrictFields 18 | , setPsStrictFields 19 | , getPsIdName 20 | , setPsIdName 21 | , getPsTabErrorLevel 22 | , setPsTabErrorLevel 23 | ) where 24 | 25 | import Database.Persist.Quasi.PersistSettings.Internal 26 | -------------------------------------------------------------------------------- /persistent/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.SqlBackend.Internal.InsertSqlResult where 2 | 3 | import Database.Persist.Types.Base (PersistValue) 4 | import Data.Text (Text) 5 | 6 | data InsertSqlResult 7 | = ISRSingle Text 8 | | ISRInsertGet Text Text 9 | | ISRManyKeys Text [PersistValue] 10 | -------------------------------------------------------------------------------- /persistent/Database/Persist/SqlBackend/Internal/IsolationLevel.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.SqlBackend.Internal.IsolationLevel where 2 | 3 | import Data.String (IsString(..)) 4 | 5 | -- | Please refer to the documentation for the database in question for a full 6 | -- overview of the semantics of the varying isolation levels 7 | data IsolationLevel = ReadUncommitted 8 | | ReadCommitted 9 | | RepeatableRead 10 | | Serializable 11 | deriving (Show, Eq, Enum, Ord, Bounded) 12 | 13 | makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s 14 | makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of 15 | ReadUncommitted -> "READ UNCOMMITTED" 16 | ReadCommitted -> "READ COMMITTED" 17 | RepeatableRead -> "REPEATABLE READ" 18 | Serializable -> "SERIALIZABLE" 19 | -------------------------------------------------------------------------------- /persistent/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.SqlBackend.Internal.SqlPoolHooks 2 | ( SqlPoolHooks(..) 3 | ) where 4 | import Control.Exception (SomeException) 5 | import Database.Persist.SqlBackend.Internal.IsolationLevel 6 | 7 | -- | A set of hooks that may be used to alter the behaviour 8 | -- of @runSqlPoolWithExtensibleHooks@ in a backwards-compatible 9 | -- fashion. 10 | data SqlPoolHooks m backend = SqlPoolHooks 11 | { alterBackend :: backend -> m backend 12 | -- ^ Alter the backend prior to executing any actions with it. 13 | , runBefore :: backend -> Maybe IsolationLevel -> m () 14 | -- ^ Run this action immediately before the action is performed. 15 | , runAfter :: backend -> Maybe IsolationLevel -> m () 16 | -- ^ Run this action immediately after the action is completed. 17 | , runOnException :: backend -> Maybe IsolationLevel -> SomeException -> m () 18 | -- ^ This action is performed when an exception is received. The 19 | -- exception is provided as a convenience - it is rethrown once this 20 | -- cleanup function is complete. 21 | } 22 | -------------------------------------------------------------------------------- /persistent/Database/Persist/SqlBackend/Internal/Statement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Database.Persist.SqlBackend.Internal.Statement where 4 | 5 | import Conduit 6 | import Data.Acquire 7 | import Data.Int 8 | import Database.Persist.Types.Base 9 | 10 | -- | A 'Statement' is a representation of a database query that has been 11 | -- prepared and stored on the server side. 12 | data Statement = Statement 13 | { stmtFinalize :: IO () 14 | , stmtReset :: IO () 15 | , stmtExecute :: [PersistValue] -> IO Int64 16 | , stmtQuery 17 | :: forall m 18 | . (MonadIO m) 19 | => [PersistValue] 20 | -> Acquire (ConduitM () [PersistValue] m ()) 21 | } 22 | -------------------------------------------------------------------------------- /persistent/Database/Persist/SqlBackend/Internal/StatementCache.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.SqlBackend.Internal.StatementCache where 2 | 3 | import Data.Text (Text) 4 | import Database.Persist.SqlBackend.Internal.Statement 5 | 6 | -- | A statement cache used to lookup statements that have already been prepared 7 | -- for a given query. 8 | -- 9 | -- @since 2.13.3 10 | data StatementCache = StatementCache 11 | { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) 12 | , statementCacheInsert :: StatementCacheKey -> Statement -> IO () 13 | , statementCacheClear :: IO () 14 | , statementCacheSize :: IO Int 15 | } 16 | 17 | newtype StatementCacheKey = StatementCacheKey { cacheKey :: Text } 18 | -- Wrapping around this to allow for more efficient keying mechanisms 19 | -- in the future, perhaps. 20 | 21 | -- | Construct a `StatementCacheKey` from a raw SQL query. 22 | mkCacheKeyFromQuery :: Text -> StatementCacheKey 23 | mkCacheKeyFromQuery = StatementCacheKey 24 | -------------------------------------------------------------------------------- /persistent/Database/Persist/SqlBackend/StatementCache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Database.Persist.SqlBackend.StatementCache 3 | ( StatementCache 4 | , StatementCacheKey 5 | , mkCacheKeyFromQuery 6 | , MkStatementCache(..) 7 | , mkSimpleStatementCache 8 | , mkStatementCache 9 | ) where 10 | 11 | import Data.Foldable 12 | import Data.IORef 13 | import qualified Data.Map as Map 14 | import Database.Persist.SqlBackend.Internal.Statement 15 | import Database.Persist.SqlBackend.Internal.StatementCache 16 | import Data.Map (Map) 17 | import Data.Text (Text) 18 | 19 | -- | Configuration parameters for creating a custom statement cache 20 | -- 21 | -- @since 2.13.3 22 | data MkStatementCache = MkStatementCache 23 | { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) 24 | -- ^ Retrieve a statement from the cache, or return nothing if it is not found. 25 | -- 26 | -- @since 2.13.3 27 | , statementCacheInsert :: StatementCacheKey -> Statement -> IO () 28 | -- ^ Put a new statement into the cache. An immediate lookup of 29 | -- the statement MUST return the inserted statement for the given 30 | -- cache key. Depending on the implementation, the statement cache MAY 31 | -- choose to evict other statements from the cache within this function. 32 | -- 33 | -- @since 2.13.3 34 | , statementCacheClear :: IO () 35 | -- ^ Remove all statements from the cache. Implementations of this 36 | -- should be sure to call `stmtFinalize` on all statements removed 37 | -- from the cache. 38 | -- 39 | -- @since 2.13.3 40 | , statementCacheSize :: IO Int 41 | -- ^ Get the current size of the cache. 42 | -- 43 | -- @since 2.13.3 44 | } 45 | 46 | 47 | -- | Make a simple statement cache that will cache statements if they are not currently cached. 48 | -- 49 | -- @since 2.13.3 50 | mkSimpleStatementCache :: IORef (Map Text Statement) -> MkStatementCache 51 | mkSimpleStatementCache stmtMap = 52 | MkStatementCache 53 | { statementCacheLookup = \sql -> Map.lookup (cacheKey sql) <$> readIORef stmtMap 54 | , statementCacheInsert = \sql stmt -> 55 | modifyIORef' stmtMap (Map.insert (cacheKey sql) stmt) 56 | , statementCacheClear = do 57 | oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) 58 | traverse_ stmtFinalize oldStatements 59 | , statementCacheSize = Map.size <$> readIORef stmtMap 60 | } 61 | 62 | -- | Create a statement cache. 63 | -- 64 | -- @since 2.13.0 65 | mkStatementCache :: MkStatementCache -> StatementCache 66 | mkStatementCache MkStatementCache{..} = StatementCache { .. } 67 | -------------------------------------------------------------------------------- /persistent/Database/Persist/TH.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides the tools for defining your database schema and using 2 | -- it to generate Haskell data types and migrations. 3 | -- 4 | -- For documentation on the domain specific language used for defining database 5 | -- models, see "Database.Persist.Quasi". 6 | -- 7 | -- 8 | module Database.Persist.TH 9 | ( -- * Parse entity defs 10 | persistWith 11 | , persistUpperCase 12 | , persistLowerCase 13 | , persistFileWith 14 | , persistManyFileWith 15 | -- * Turn @EntityDef@s into types 16 | , mkPersist 17 | , mkPersistWith 18 | -- ** Configuring Entity Definition 19 | , MkPersistSettings 20 | , mkPersistSettings 21 | , sqlSettings 22 | -- *** Record Fields (for update/viewing settings) 23 | , mpsBackend 24 | , mpsGeneric 25 | , mpsPrefixFields 26 | , mpsFieldLabelModifier 27 | , mpsAvoidHsKeyword 28 | , mpsConstraintLabelModifier 29 | , mpsEntityHaddocks 30 | , mpsEntityJSON 31 | , mpsGenerateLenses 32 | , mpsDeriveInstances 33 | , mpsCamelCaseCompositeKeySelector 34 | , EntityJSON(..) 35 | -- ** Implicit ID Columns 36 | , ImplicitIdDef 37 | , setImplicitIdDef 38 | -- * Various other TH functions 39 | , mkMigrate 40 | , migrateModels 41 | , discoverEntities 42 | , mkEntityDefList 43 | , share 44 | , derivePersistField 45 | , derivePersistFieldJSON 46 | , persistFieldFromEntity 47 | ) where 48 | 49 | import Database.Persist.TH.Internal 50 | -------------------------------------------------------------------------------- /persistent/Database/Persist/Types/SourceSpan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveLift #-} 2 | 3 | module Database.Persist.Types.SourceSpan (SourceSpan (..)) where 4 | 5 | import Data.Text (Text) 6 | import Language.Haskell.TH.Syntax (Lift) 7 | 8 | -- | A pair of (start line/col, end line/col) coordinates. The end column will 9 | -- be one past the final character (i.e. the span (1,1)->(1,1) is zero 10 | -- characters long). 11 | -- 12 | -- SourceSpans are 1-indexed in both lines and columns. 13 | -- 14 | -- Conceptually identical to GHC's @RealSourceSpan@. 15 | -- 16 | -- @since 2.16.0.0 17 | data SourceSpan = SourceSpan 18 | { spanFile :: !Text 19 | , spanStartLine :: !Int 20 | , spanStartCol :: !Int 21 | , spanEndLine :: !Int 22 | , spanEndCol :: !Int 23 | } 24 | deriving (Show, Eq, Read, Ord, Lift) 25 | -------------------------------------------------------------------------------- /persistent/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /persistent/README.md: -------------------------------------------------------------------------------- 1 | ## persistent 2 | 3 | Type-safe, data serialization. You must use a specific backend in order to make 4 | this useful. For more information, see [the chapter in the Yesod 5 | book](http://www.yesodweb.com/book/persistent). 6 | -------------------------------------------------------------------------------- /persistent/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /persistent/bench/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Models where 3 | 4 | import Data.Monoid 5 | import Language.Haskell.TH 6 | import qualified Data.Text as Text 7 | 8 | import Database.Persist.Quasi 9 | import Database.Persist.Quasi.Internal 10 | import Database.Persist.TH 11 | import Database.Persist.TH.Internal 12 | import Database.Persist.Sql 13 | 14 | -- TODO: we use lookupName and reify etc which breaks in IO. somehow need to 15 | -- test this out elsewise 16 | mkPersist' :: [UnboundEntityDef] -> IO [Dec] 17 | mkPersist' = runQ . mkPersist sqlSettings 18 | 19 | parseReferences' :: String -> IO Exp 20 | parseReferences' = runQ . parseReferencesQ 21 | 22 | parseReferencesQ :: String -> Q Exp 23 | parseReferencesQ = parseReferences lowerCaseSettings . pure . (Nothing,) . Text.pack 24 | 25 | -- | # of models, # of fields 26 | mkModels :: Int -> Int -> String 27 | mkModels = mkModelsWithFieldModifier id 28 | 29 | mkNullableModels :: Int -> Int -> String 30 | mkNullableModels = mkModelsWithFieldModifier maybeFields 31 | 32 | mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String 33 | mkModelsWithFieldModifier k i f = 34 | unlines . fmap unlines . take i . map mkModel . zip [0..] . cycle $ 35 | [ "Model" 36 | , "Foobar" 37 | , "User" 38 | , "King" 39 | , "Queen" 40 | , "Dog" 41 | , "Cat" 42 | ] 43 | where 44 | mkModel :: (Int, String) -> [String] 45 | mkModel (i', m) = 46 | (m <> show i') : indent 4 (map k (mkFields f)) 47 | 48 | indent :: Int -> [String] -> [String] 49 | indent i = map (replicate i ' ' ++) 50 | 51 | mkFields :: Int -> [String] 52 | mkFields i = take i $ map mkField $ zip [0..] $ cycle 53 | [ "Bool" 54 | , "Int" 55 | , "String" 56 | , "Double" 57 | , "Text" 58 | ] 59 | where 60 | mkField :: (Int, String) -> String 61 | mkField (i', typ) = "field" <> show i' <> "\t\t" <> typ 62 | 63 | maybeFields :: String -> String 64 | maybeFields = (++ " Maybe") 65 | -------------------------------------------------------------------------------- /persistent/bench/models-slowly: -------------------------------------------------------------------------------- 1 | MyTable 2 | field1 Text Maybe 3 | field2 Text Maybe 4 | field3 Text Maybe 5 | field4 Text Maybe 6 | field5 Text Maybe 7 | field6 Text Maybe 8 | field7 Text Maybe 9 | field8 Text Maybe 10 | field9 Text Maybe 11 | field10 Text Maybe 12 | field11 Text Maybe 13 | field12 Text Maybe 14 | field13 Text Maybe 15 | field14 Text Maybe 16 | field15 Text Maybe 17 | field16 Text Maybe 18 | field17 Text Maybe 19 | field18 Text Maybe 20 | field19 Text Maybe 21 | field20 Text Maybe 22 | field21 Text Maybe 23 | field22 Text Maybe 24 | field23 Text Maybe 25 | field24 Text Maybe 26 | field25 Text Maybe 27 | field26 Text Maybe 28 | field27 Text Maybe 29 | field28 Text Maybe 30 | field29 Text Maybe 31 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/ClassSpec.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.ClassSpec where 2 | 3 | import Data.Time 4 | import Database.Persist.Class 5 | import Database.Persist.Types 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = describe "Class" $ do 10 | describe "PersistField" $ do 11 | describe "UTCTime" $ do 12 | it "fromPersistValue with ISO8601 format including UTC timezone Z (canonical)" $ 13 | fromPersistValue (PersistText "2018-02-27T10:49:42.123Z") 14 | `shouldBe` Right 15 | (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) 16 | it "fromPersistValue with ISO8601 format no timezone (backwards-compatibility)" $ 17 | fromPersistValue (PersistText "2018-02-27T10:49:42.123") 18 | `shouldBe` Right 19 | (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) 20 | it "fromPersistValue with pretty format (backwards-compatibility)" $ 21 | fromPersistValue (PersistText "2018-02-27 10:49:42.123") 22 | `shouldBe` Right 23 | (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) 24 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/PersistValueSpec.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.PersistValueSpec where 2 | 3 | import Test.Hspec 4 | import Database.Persist.PersistValue 5 | import Data.List.NonEmpty (NonEmpty(..), (<|)) 6 | import qualified Data.Text as T 7 | import Test.Hspec 8 | import Test.Hspec.QuickCheck 9 | import Test.QuickCheck 10 | import Data.Aeson 11 | import qualified Data.ByteString.Char8 as BS8 12 | 13 | 14 | spec :: Spec 15 | spec = describe "PersistValueSpec" $ do 16 | describe "PersistValue" $ do 17 | describe "Aeson" $ do 18 | let 19 | testPrefix constr prefixChar bytes = 20 | takePrefix (toJSON (constr (BS8.pack bytes))) 21 | === 22 | String (T.singleton prefixChar) 23 | roundTrip constr bytes = 24 | fromJSON (toJSON (constr (BS8.pack bytes))) 25 | === 26 | Data.Aeson.Success (constr (BS8.pack bytes)) 27 | subject constr prefixChar = do 28 | prop ("encodes with a " ++ [prefixChar] ++ " prefix") $ 29 | testPrefix constr prefixChar 30 | prop "Round Trips" $ 31 | roundTrip constr 32 | 33 | describe "PersistDbSpecific" $ do 34 | subject (PersistLiteral_ DbSpecific) 'p' 35 | describe "PersistLiteral" $ do 36 | subject PersistLiteral 'l' 37 | describe "PersistLiteralEscaped" $ do 38 | subject PersistLiteralEscaped 'e' 39 | 40 | takePrefix :: Value -> Value 41 | takePrefix (String a) = String (T.take 1 a) 42 | takePrefix a = a 43 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/CommentSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {-# OPTIONS_GHC -haddock #-} 16 | 17 | module Database.Persist.TH.CommentSpec 18 | ( CommentModel (..) 19 | , spec 20 | ) where 21 | 22 | import TemplateTestImports 23 | 24 | import Database.Persist.EntityDef.Internal (EntityDef(..)) 25 | import Database.Persist.FieldDef.Internal (FieldDef(..)) 26 | 27 | mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase| 28 | 29 | -- | Doc comments work. 30 | -- | Has multiple lines. 31 | CommentModel 32 | -- | First line of comment on column. 33 | -- | Second line of comment on column. 34 | name String 35 | 36 | deriving Eq Show 37 | 38 | |] 39 | 40 | pass :: IO () 41 | pass = pure () 42 | 43 | asIO :: IO a -> IO a 44 | asIO = id 45 | 46 | spec :: Spec 47 | spec = describe "CommentSpec" $ do 48 | let 49 | ed = 50 | entityDef (Proxy @CommentModel) 51 | it "has entity comments" $ do 52 | entityComments ed 53 | `shouldBe` do 54 | Just $ mconcat 55 | [ "Doc comments work.\n" 56 | , "Has multiple lines.\n" 57 | ] 58 | 59 | describe "fieldComments" $ do 60 | let 61 | [nameComments] = 62 | map fieldComments $ entityFields ed 63 | it "has the right name comments" $ do 64 | nameComments 65 | `shouldBe` do 66 | Just $ mconcat 67 | [ "First line of comment on column.\n" 68 | , "Second line of comment on column.\n" 69 | ] 70 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/CompositeKeyStyleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} 14 | 15 | module Database.Persist.TH.CompositeKeyStyleSpec where 16 | 17 | import Data.Data (Data, constrFields, toConstr) 18 | import Data.Text (Text) 19 | import Database.Persist.Sql 20 | import Database.Persist.TH 21 | import Test.Hspec hiding (Selector) 22 | 23 | mkPersist sqlSettings 24 | [persistLowerCase| 25 | CompanyUserLegacyStyle 26 | companyName Text 27 | userName Text 28 | Primary companyName userName 29 | |] 30 | 31 | deriving instance Data CompanyUserLegacyStyle 32 | deriving instance Data (Key CompanyUserLegacyStyle) 33 | 34 | mkPersist sqlSettings {mpsCamelCaseCompositeKeySelector = True} 35 | [persistLowerCase| 36 | CompanyUserCamelStyle 37 | companyName Text 38 | userName Text 39 | Primary companyName userName 40 | |] 41 | 42 | deriving instance Data CompanyUserCamelStyle 43 | deriving instance Data (Key CompanyUserCamelStyle) 44 | 45 | spec :: Spec 46 | spec = describe "CompositeKeyStyleSpec" $ do 47 | describe "mpsCamelCaseCompositeKeySelector is False" $ do 48 | it "Should generate Legacy style key selectors" $ do 49 | let key = CompanyUserLegacyStyleKey "cName" "uName" 50 | 51 | constrFields (toConstr key) 52 | `shouldBe` 53 | [ "companyUserLegacyStyleKeycompanyName" 54 | , "companyUserLegacyStyleKeyuserName" 55 | ] 56 | describe "mpsCamelCaseCompositeKeySelector is True" $ do 57 | it "Should generate CamelCase style key selectors" $ do 58 | let key = CompanyUserCamelStyleKey "cName" "uName" 59 | 60 | constrFields (toConstr key) 61 | `shouldBe` 62 | [ "companyUserCamelStyleKeyCompanyName" 63 | , "companyUserCamelStyleKeyUserName" 64 | ] 65 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/DiscoverEntitiesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Database.Persist.TH.DiscoverEntitiesSpec where 16 | 17 | import TemplateTestImports 18 | 19 | import Data.Aeson 20 | 21 | import Data.Text (Text) 22 | 23 | import Language.Haskell.TH.Syntax 24 | 25 | import Database.Persist.ImplicitIdDef 26 | import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) 27 | 28 | mkPersist sqlSettings [persistLowerCase| 29 | 30 | User 31 | name String 32 | age Int 33 | 34 | Dog 35 | user UserId 36 | name String 37 | 38 | Cat 39 | enemy DogId 40 | name String 41 | 42 | |] 43 | 44 | pass :: IO () 45 | pass = pure () 46 | 47 | asIO :: IO a -> IO a 48 | asIO = id 49 | 50 | $(pure []) 51 | 52 | spec :: Spec 53 | spec = describe "DiscoverEntitiesSpec" $ do 54 | let entities = $(discoverEntities) 55 | it "should have all three entities" $ do 56 | entities `shouldMatchList` 57 | [ entityDef $ Proxy @User 58 | , entityDef $ Proxy @Dog 59 | , entityDef $ Proxy @Cat 60 | ] 61 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/EntityHaddockSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Database.Persist.TH.EntityHaddockSpec (spec) where 5 | 6 | import TemplateTestImports 7 | 8 | #if MIN_VERSION_template_haskell(2,18,0) 9 | import Database.Persist.TH.CommentSpec (CommentModel (..)) 10 | import Language.Haskell.TH (DocLoc (DeclDoc), getDoc) 11 | import Language.Haskell.TH.Syntax (lift) 12 | 13 | [d| 14 | commentModelDoc :: Maybe String 15 | commentModelDoc = $(lift =<< getDoc (DeclDoc ''CommentModel)) 16 | 17 | commentFieldDoc :: Maybe String 18 | commentFieldDoc = $(lift =<< getDoc (DeclDoc 'commentModelName)) 19 | |] 20 | 21 | spec :: Spec 22 | spec = describe "EntityHaddockSpec" $ do 23 | it "generates entity Haddock" $ do 24 | let expected = unlines [ "Doc comments work." 25 | , "Has multiple lines." 26 | ] 27 | commentModelDoc `shouldBe` Just expected 28 | it "generates field Haddock" $ do 29 | let expected = unlines [ "First line of comment on column." 30 | , "Second line of comment on column." 31 | ] 32 | commentFieldDoc `shouldBe` Just expected 33 | #else 34 | spec :: Spec 35 | spec = pure () 36 | #endif 37 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Database.Persist.TH.ImplicitIdColSpec where 16 | 17 | import TemplateTestImports 18 | 19 | import Data.Text (Text) 20 | 21 | import Database.Persist.ImplicitIdDef 22 | import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) 23 | 24 | do 25 | let 26 | uuidDef = 27 | mkImplicitIdDef @Text "uuid_generate_v1mc()" 28 | settings = 29 | setImplicitIdDef uuidDef sqlSettings 30 | 31 | mkPersist settings [persistLowerCase| 32 | 33 | User 34 | name String 35 | age Int 36 | 37 | |] 38 | 39 | pass :: IO () 40 | pass = pure () 41 | 42 | asIO :: IO a -> IO a 43 | asIO = id 44 | 45 | spec :: Spec 46 | spec = describe "ImplicitIdColSpec" $ do 47 | describe "UserKey" $ do 48 | it "has type Text -> Key User" $ do 49 | let 50 | userKey = UserKey "Hello" 51 | _ = UserKey :: Text -> UserId 52 | pass 53 | 54 | describe "getEntityId" $ do 55 | let 56 | EntityIdField idField = 57 | getEntityId (entityDef (Nothing @User)) 58 | it "has SqlString SqlType" $ asIO $ do 59 | fieldSqlType idField `shouldBe` SqlString 60 | it "has Text FieldType" $ asIO $ do 61 | pendingWith "currently returns UserId, may not be an issue" 62 | fieldType idField 63 | `shouldBe` 64 | fieldTypeFromTypeable @Text 65 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/KindEntitiesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE OverloadedLabels #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Database.Persist.TH.KindEntitiesSpec where 13 | 14 | import Database.Persist.TH.KindEntitiesSpecImports 15 | import TemplateTestImports 16 | 17 | mkPersist sqlSettings [persistLowerCase| 18 | 19 | Customer 20 | name String 21 | age Int 22 | 23 | CustomerTransfer 24 | customerId CustomerId 25 | moneyAmount (MoneyAmount 'CustomerOwned 'Debit) 26 | |] 27 | 28 | spec :: Spec 29 | spec = describe "KindEntities" $ do 30 | it "should support DataKinds in entity definition" $ do 31 | let mkTransfer :: CustomerId -> MoneyAmount 'CustomerOwned 'Debit -> CustomerTransfer 32 | mkTransfer = CustomerTransfer 33 | getAmount :: CustomerTransfer -> MoneyAmount 'CustomerOwned 'Debit 34 | getAmount = customerTransferMoneyAmount 35 | compiles 36 | 37 | compiles :: Expectation 38 | compiles = True `shouldBe` True 39 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Database.Persist.TH.KindEntitiesSpecImports where 5 | 6 | import Data.Proxy 7 | import qualified Data.Text as T 8 | import TemplateTestImports 9 | 10 | data Owner = MerchantOwned | CustomerOwned 11 | data AccountKind = Debit | Credit 12 | 13 | newtype MoneyAmount (a :: Owner) (b :: AccountKind) = MoneyAmount Rational 14 | 15 | instance PersistFieldSql (MoneyAmount a b) where 16 | sqlType _ = sqlType (Proxy :: Proxy Rational) 17 | 18 | instance PersistField (MoneyAmount a b) where 19 | toPersistValue (MoneyAmount n) = 20 | toPersistValue n 21 | fromPersistValue v = 22 | MoneyAmount <$> fromPersistValue v 23 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/MaybeFieldDefsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE OverloadedLabels #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Database.Persist.TH.MaybeFieldDefsSpec where 13 | 14 | import TemplateTestImports 15 | 16 | mkPersist sqlSettings [persistLowerCase| 17 | Account 18 | name (Maybe String) 19 | email String 20 | |] 21 | 22 | spec :: Spec 23 | spec = describe "MaybeFieldDefs" $ do 24 | it "should support literal `Maybe` declaration in entity definition" $ do 25 | let mkAccount :: Maybe String -> String -> Account 26 | mkAccount = Account 27 | compiles 28 | 29 | compiles :: Expectation 30 | compiles = True `shouldBe` True 31 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/MigrationOnlySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Database.Persist.TH.MigrationOnlySpec where 16 | 17 | import TemplateTestImports 18 | 19 | import Data.Text (Text) 20 | 21 | import Database.Persist.ImplicitIdDef 22 | import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) 23 | import Database.Persist.Types 24 | 25 | mkPersist sqlSettings [persistLowerCase| 26 | 27 | HasMigrationOnly 28 | name String 29 | blargh Int MigrationOnly 30 | 31 | deriving Eq Show 32 | |] 33 | 34 | pass :: IO () 35 | pass = pure () 36 | 37 | asIO :: IO a -> IO a 38 | asIO = id 39 | 40 | spec :: Spec 41 | spec = describe "MigrationOnlySpec" $ do 42 | describe "HasMigrationOnly" $ do 43 | let 44 | edef = 45 | entityDef $ Proxy @HasMigrationOnly 46 | describe "getEntityFields" $ do 47 | it "has one field" $ do 48 | length (getEntityFields edef) 49 | `shouldBe` 1 50 | describe "getEntityFieldsDatabase" $ do 51 | it "has two fields" $ do 52 | length (getEntityFieldsDatabase edef) 53 | `shouldBe` 2 54 | describe "toPersistFields" $ do 55 | it "should have one field" $ do 56 | map toPersistValue (toPersistFields (HasMigrationOnly "asdf")) 57 | `shouldBe` 58 | [PersistText ("asdf" :: Text)] 59 | describe "fromPersistValues" $ do 60 | it "should work with only item in list" $ do 61 | fromPersistValues [PersistText "Hello"] 62 | `shouldBe` 63 | Right (HasMigrationOnly "Hello") 64 | 65 | 66 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/MultiBlockSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedLabels #-} 9 | {-# LANGUAGE PartialTypeSignatures #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Database.Persist.TH.MultiBlockSpec where 18 | 19 | import TemplateTestImports 20 | 21 | 22 | import Database.Persist.TH.MultiBlockSpec.Model 23 | 24 | share 25 | [ mkPersistWith sqlSettings importDefList 26 | ] 27 | [persistLowerCase| 28 | 29 | Thing 30 | name Text 31 | Primary name 32 | 33 | ThingAuto 34 | name Text 35 | 36 | MBBar 37 | name Text 38 | age Int 39 | user UserId 40 | thing ThingId 41 | thingAuto ThingAutoId 42 | profile MBDogId 43 | 44 | Foreign MBCompositePrimary bar_to_comp name age 45 | |] 46 | 47 | spec :: Spec 48 | spec = describe "MultiBlockSpec" $ do 49 | describe "MBBar" $ do 50 | let 51 | edef = 52 | entityDef $ Proxy @MBBar 53 | describe "Foreign Key Works" $ do 54 | let 55 | [n, a, userRef, thingRef, thingAutoRef, profileRef] = 56 | getEntityFields edef 57 | it "User reference works" $ do 58 | fieldReference userRef 59 | `shouldBe` 60 | ForeignRef 61 | (EntityNameHS "User") 62 | 63 | it "Primary key reference works" $ do 64 | fieldReference profileRef 65 | `shouldBe` 66 | ForeignRef 67 | (EntityNameHS "MBDog") 68 | 69 | it "Thing ref works (same block)" $ do 70 | fieldReference thingRef 71 | `shouldBe` 72 | ForeignRef 73 | (EntityNameHS "Thing") 74 | 75 | it "ThingAuto ref works (same block)" $ do 76 | fieldReference thingAutoRef 77 | `shouldBe` 78 | ForeignRef 79 | (EntityNameHS "ThingAuto") 80 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/MultiBlockSpec/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedLabels #-} 10 | {-# LANGUAGE PartialTypeSignatures #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Database.Persist.TH.MultiBlockSpec.Model where 19 | 20 | import TemplateTestImports 21 | 22 | share 23 | [ mkPersist sqlSettings 24 | , mkEntityDefList "importDefList" 25 | ] 26 | [persistLowerCase| 27 | 28 | User 29 | name Text 30 | age Int 31 | 32 | deriving Eq Show 33 | 34 | MBDog 35 | name Text 36 | Primary name 37 | 38 | MBCompositePrimary 39 | name Text 40 | age Int 41 | 42 | Primary name age 43 | 44 | |] 45 | 46 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE OverloadedLabels #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module Database.Persist.TH.NestedSymbolsInTypeSpec where 14 | 15 | import Data.Map 16 | import Database.Persist.TH.NestedSymbolsInTypeSpecImports 17 | import TemplateTestImports 18 | 19 | mkPersist sqlSettings [persistLowerCase| 20 | PathEntitySimple 21 | readOnly (Maybe (SomePath ReadOnly)) 22 | 23 | PathEntityNested 24 | paths (Maybe (Map Text [SomePath ReadWrite])) 25 | |] 26 | 27 | spec :: Spec 28 | spec = describe "NestedSymbolsInType" $ do 29 | it "should support nested parens" $ do 30 | let mkPathEntitySimple :: Maybe (SomePath ReadOnly) -> PathEntitySimple 31 | mkPathEntitySimple = PathEntitySimple 32 | pathEntitySimpleReadOnly' :: PathEntitySimple -> Maybe (SomePath ReadOnly) 33 | pathEntitySimpleReadOnly' = pathEntitySimpleReadOnly 34 | compiles 35 | 36 | it "should support deeply nested parens + square brackets" $ do 37 | let mkPathEntityNested :: Maybe (Map Text [SomePath ReadWrite]) -> PathEntityNested 38 | mkPathEntityNested = PathEntityNested 39 | pathEntityNestedPaths' :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite]) 40 | pathEntityNestedPaths' = pathEntityNestedPaths 41 | compiles 42 | 43 | compiles :: Expectation 44 | compiles = True `shouldBe` True 45 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Database.Persist.TH.NestedSymbolsInTypeSpecImports where 5 | 6 | import Data.Proxy 7 | import TemplateTestImports 8 | 9 | data ReadOnly 10 | data ReadWrite 11 | 12 | newtype SomePath a = SomePath Text 13 | 14 | instance PersistFieldSql (SomePath a) where 15 | sqlType _ = SqlString 16 | 17 | instance PersistField (SomePath a) where 18 | toPersistValue (SomePath n) = 19 | toPersistValue n 20 | fromPersistValue v = 21 | SomePath <$> fromPersistValue v 22 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/NoFieldSelectorsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 902 3 | {-# LANGUAGE NoFieldSelectors #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | #endif 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE DerivingStrategies #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | 16 | module Database.Persist.TH.NoFieldSelectorsSpec where 17 | 18 | import TemplateTestImports 19 | 20 | #if __GLASGOW_HASKELL__ >= 902 21 | 22 | mkPersist sqlSettings {mpsFieldLabelModifier = const id} [persistLowerCase| 23 | User 24 | ident Text 25 | name Text 26 | Primary ident 27 | team TeamId 28 | type Text 29 | 30 | Team 31 | name Text 32 | |] 33 | 34 | spec :: Spec 35 | spec = it "compiles" True 36 | 37 | #else 38 | 39 | spec :: Spec 40 | spec = do 41 | it "only works with GHC 9.2 or greater" $ do 42 | pendingWith "only works with GHC 9.2 or greater" 43 | 44 | #endif 45 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedLabels #-} 9 | {-# LANGUAGE PartialTypeSignatures #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} 17 | 18 | module Database.Persist.TH.OverloadedLabelSpec where 19 | 20 | import TemplateTestImports 21 | 22 | mkPersist sqlSettings [persistUpperCase| 23 | 24 | User 25 | name String 26 | age Int 27 | 28 | Dog 29 | userId UserId 30 | name String 31 | age Int 32 | 33 | Organization 34 | name String 35 | 36 | Student 37 | userId UserId 38 | departmentName String 39 | Primary userId 40 | |] 41 | 42 | spec :: Spec 43 | spec = describe "OverloadedLabels" $ do 44 | it "works for monomorphic labels" $ do 45 | let UserName = #name 46 | OrganizationName = #name 47 | DogName = #name 48 | 49 | compiles 50 | 51 | it "works for polymorphic labels" $ do 52 | let name :: _ => EntityField rec a 53 | name = #name 54 | 55 | UserName = name 56 | OrganizationName = name 57 | DogName = name 58 | 59 | compiles 60 | 61 | it "works for id labels" $ do 62 | let UserId = #id 63 | orgId = #id :: EntityField Organization OrganizationId 64 | 65 | compiles 66 | 67 | it "works for Primary labels" $ do 68 | let StudentId = #id 69 | studentId = #id :: EntityField Student StudentId 70 | 71 | compiles 72 | 73 | compiles :: IO () 74 | compiles = pure () 75 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/PersistWith/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Database.Persist.TH.PersistWith.Model where 16 | 17 | import TemplateTestImports 18 | 19 | import Database.Persist.TH.PersistWith.Model2 as Model2 20 | 21 | mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| 22 | 23 | IceCream 24 | flavor FlavorId 25 | otherFlavor Model2.FlavorId 26 | 27 | |] 28 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/PersistWith/Model2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Database.Persist.TH.PersistWith.Model2 where 16 | 17 | import TemplateTestImports 18 | 19 | mkPersist sqlSettings [persistLowerCase| 20 | 21 | Flavor 22 | name Text 23 | 24 | |] 25 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/PersistWithSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | module Database.Persist.TH.PersistWithSpec where 17 | 18 | import Control.Monad 19 | import TemplateTestImports 20 | import Database.Persist.TH.PersistWith.Model as Model (IceCream, IceCreamId) 21 | import Language.Haskell.TH as TH 22 | 23 | mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| 24 | 25 | BestTopping 26 | iceCream IceCreamId 27 | otherCream Model.IceCreamId 28 | keyCream (Key IceCream) 29 | qualifiedKeyCream (Key Model.IceCream) 30 | nullableCream IceCreamId Maybe 31 | maybeCream (Maybe IceCreamId) 32 | maybeQualifiedCream (Maybe Model.IceCreamId) 33 | maybeQualifiedKeyCream (Maybe (Key Model.IceCream)) 34 | maybeKeyCream (Maybe (Key IceCream)) 35 | 36 | |] 37 | 38 | deriving instance Show (EntityField BestTopping a) 39 | deriving instance Eq (EntityField BestTopping a) 40 | 41 | data SomeField where 42 | SomeField :: EntityField BestTopping a -> SomeField 43 | 44 | allFields = 45 | [ SomeField BestToppingIceCream 46 | , SomeField BestToppingOtherCream 47 | , SomeField BestToppingKeyCream 48 | , SomeField BestToppingQualifiedKeyCream 49 | , SomeField BestToppingMaybeCream 50 | , SomeField BestToppingNullableCream 51 | , SomeField BestToppingMaybeQualifiedCream 52 | , SomeField BestToppingMaybeQualifiedKeyCream 53 | , SomeField BestToppingMaybeKeyCream 54 | ] 55 | 56 | spec :: Spec 57 | spec = describe "mkPersistWith" $ do 58 | describe "finds references" $ do 59 | forM_ allFields $ \(SomeField field) -> 60 | it (show field) (shouldReferToIceCream field) 61 | 62 | shouldReferToIceCream :: EntityField BestTopping a -> IO () 63 | shouldReferToIceCream field = 64 | unless (reference == iceCreamRef) $ do 65 | expectationFailure $ mconcat 66 | [ "The field '", show field, "' does not have a reference to IceCream.\n" 67 | , "Got Reference: ", show reference, "\n" 68 | , "Expected : ", show iceCreamRef 69 | ] 70 | where 71 | reference = 72 | fieldReference (persistFieldDef field) 73 | iceCreamRef = 74 | ForeignRef (EntityNameHS "IceCream") 75 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Database.Persist.TH.RequireOnlyPersistImportSpec where 13 | 14 | -- This test asserts this is the only import required to define entities 15 | -- See: https://github.com/yesodweb/persistent/pull/1369 16 | import Database.Persist.TH 17 | 18 | -- always explicitly import qualified Hspec in the context of this spec 19 | import qualified Test.Hspec as HS 20 | 21 | mkPersist sqlSettings [persistLowerCase| 22 | Plain 23 | name String 24 | age Int 25 | deriving Show Eq 26 | 27 | JsonEncoded json 28 | name String 29 | age Int 30 | deriving Show Eq 31 | |] 32 | 33 | spec :: HS.Spec 34 | spec = 35 | HS.describe "RequireOnlyPersistImport" $ do 36 | HS.it "Plain" $ do 37 | let typeSigPlain :: String -> Int -> Plain 38 | typeSigPlain = Plain 39 | compiles 40 | 41 | HS.it "JsonEncoded" $ do 42 | let typeSigJsonEncoded :: String -> Int -> JsonEncoded 43 | typeSigJsonEncoded = JsonEncoded 44 | compiles 45 | 46 | compiles :: HS.Expectation 47 | compiles = True `HS.shouldBe` True 48 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications, DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds, ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | 14 | module Database.Persist.TH.SharedPrimaryKeyImportedSpec where 15 | 16 | import TemplateTestImports 17 | 18 | import Data.Proxy 19 | import Test.Hspec 20 | import Database.Persist 21 | import Database.Persist.Sql 22 | import Database.Persist.Sql.Util 23 | import Database.Persist.TH 24 | import Language.Haskell.TH 25 | import Control.Monad.IO.Class 26 | 27 | import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) 28 | 29 | mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| 30 | 31 | ProfileX 32 | Id UserId 33 | email String 34 | 35 | |] 36 | 37 | -- This test is very similar to the one in SharedPrimaryKeyTest, but it is 38 | -- able to use 'UserId' directly, since the type is imported from another 39 | -- module. 40 | spec :: Spec 41 | spec = describe "Shared Primary Keys Imported" $ do 42 | 43 | describe "PersistFieldSql" $ do 44 | it "should match underlying key" $ do 45 | sqlType (Proxy @UserId) 46 | `shouldBe` 47 | sqlType (Proxy @ProfileXId) 48 | 49 | describe "getEntityId FieldDef" $ do 50 | it "should match underlying primary key" $ do 51 | let 52 | getSqlType :: PersistEntity a => Proxy a -> SqlType 53 | getSqlType p = 54 | case getEntityId (entityDef p) of 55 | EntityIdField fd -> 56 | fieldSqlType fd 57 | _ -> 58 | SqlOther "Composite Key" 59 | getSqlType (Proxy @User) 60 | `shouldBe` 61 | getSqlType (Proxy @ProfileX) 62 | 63 | 64 | describe "foreign reference should work" $ do 65 | it "should have a foreign reference" $ do 66 | pendingWith "issue #1289" 67 | let 68 | Just fd = 69 | getEntityIdField (entityDef (Proxy @ProfileX)) 70 | fieldReference fd 71 | `shouldBe` 72 | ForeignRef (EntityNameHS "User") 73 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/SumSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedLabels #-} 9 | {-# LANGUAGE PartialTypeSignatures #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Database.Persist.TH.SumSpec where 18 | 19 | import TemplateTestImports 20 | 21 | 22 | import Database.Persist.TH.MultiBlockSpec.Model 23 | 24 | share 25 | [ mkPersistWith sqlSettings importDefList 26 | ] 27 | [persistLowerCase| 28 | 29 | What 30 | name Text 31 | 32 | Lamp 33 | name Text 34 | 35 | +Please 36 | what WhatId 37 | lamp LampId 38 | |] 39 | 40 | spec :: Spec 41 | spec = do 42 | it "should warn" True 43 | 44 | -------------------------------------------------------------------------------- /persistent/test/Database/Persist/TH/TypeLitFieldDefsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE OverloadedLabels #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# OPTIONS_GHC -Wno-unused-local-binds #-} 12 | 13 | module Database.Persist.TH.TypeLitFieldDefsSpec where 14 | 15 | import GHC.TypeLits 16 | import TemplateTestImports 17 | 18 | newtype Finite (n :: Nat) = Finite Int 19 | 20 | instance PersistField (Finite n) where 21 | toPersistValue (Finite n) = toPersistValue n 22 | fromPersistValue = fmap Finite . fromPersistValue 23 | 24 | instance PersistFieldSql (Finite n) where 25 | sqlType _ = sqlType (Proxy :: Proxy Int) 26 | 27 | newtype Labelled (t :: Symbol) = Labelled Int 28 | 29 | instance PersistField (Labelled n) where 30 | toPersistValue (Labelled n) = toPersistValue n 31 | fromPersistValue = fmap Labelled . fromPersistValue 32 | 33 | instance PersistFieldSql (Labelled n) where 34 | sqlType _ = sqlType (Proxy :: Proxy Int) 35 | 36 | mkPersist sqlSettings [persistLowerCase| 37 | WithFinite 38 | one (Finite 1) 39 | twenty (Finite 20) 40 | 41 | WithLabelled 42 | one (Labelled "one") 43 | twenty (Labelled "twenty") 44 | |] 45 | 46 | spec :: Spec 47 | spec = describe "TypeLitFieldDefs" $ do 48 | it "should support numeric type literal fields in entity definition" $ do 49 | let mkFinite :: Finite 1 -> Finite 20 -> WithFinite 50 | mkFinite = WithFinite 51 | compiles 52 | 53 | it "should support string based type literal fields in entity definition" $ do 54 | let mkLabelled :: Labelled "one" -> Labelled "twenty" -> WithLabelled 55 | mkLabelled = WithLabelled 56 | compiles 57 | 58 | compiles :: Expectation 59 | compiles = True `shouldBe` True 60 | -------------------------------------------------------------------------------- /persistent/test/TemplateTestImports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module TemplateTestImports 6 | ( module TemplateTestImports 7 | , module X 8 | ) where 9 | 10 | import Data.Aeson.TH 11 | import Test.QuickCheck 12 | 13 | import Data.Int as X 14 | import Database.Persist.Sql as X 15 | import Database.Persist.TH as X 16 | import Test.Hspec as X 17 | import Data.Proxy as X 18 | import Data.Text as X (Text) 19 | import Data.Maybe 20 | import Control.Monad 21 | import Language.Haskell.TH.Syntax 22 | 23 | data Foo = Bar | Baz 24 | deriving (Show, Eq) 25 | 26 | deriveJSON defaultOptions ''Foo 27 | 28 | derivePersistFieldJSON "Foo" 29 | 30 | instance Arbitrary Foo where 31 | arbitrary = elements [Bar, Baz] 32 | -------------------------------------------------------------------------------- /persistent/test/main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | 5 | import qualified Database.Persist.ClassSpec as ClassSpec 6 | import qualified Database.Persist.PersistValueSpec as PersistValueSpec 7 | import qualified Database.Persist.QuasiSpec as QuasiSpec 8 | import qualified Database.Persist.THSpec as THSpec 9 | 10 | main :: IO () 11 | main = hspec $ do 12 | describe "Database" $ describe "Persist" $ do 13 | THSpec.spec 14 | QuasiSpec.spec 15 | QuasiSpec.warningSpecs 16 | ClassSpec.spec 17 | PersistValueSpec.spec 18 | -------------------------------------------------------------------------------- /sources.txt: -------------------------------------------------------------------------------- 1 | ./persistent 2 | ./persistent-template 3 | ./persistent-sqlite 4 | ./persistent-postgresql 5 | ./persistent-mysql 6 | ./persistent-mongoDB 7 | ./persistent-zookeeper 8 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.8 2 | packages: 3 | - ./persistent 4 | - ./persistent-sqlite 5 | - ./persistent-test 6 | - ./persistent-mongoDB 7 | - ./persistent-mysql 8 | - ./persistent-postgresql 9 | - ./persistent-redis 10 | - ./persistent-qq 11 | 12 | extra-deps: 13 | - lift-type-0.1.0.0 14 | - mysql-0.2.1 15 | - mysql-simple-0.4.7 16 | -------------------------------------------------------------------------------- /stack-8.10.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: lift-type-0.1.0.0@sha256:b52c172fc19635e53fa72874ac0e09b08b4bc2c711f57f883181f348799abd6f,1095 9 | pantry-tree: 10 | size: 360 11 | sha256: 2ae816ebaef99ad169d95189cefa2113600ae2185e6af861984d91cbcd4bb3f0 12 | original: 13 | hackage: lift-type-0.1.0.0 14 | - completed: 15 | hackage: mysql-0.2.1@sha256:156061d432d29b3a56037e8a67e16589b1d370fb9ad0dd71a81ea2c4b0b195bb,2188 16 | pantry-tree: 17 | size: 640 18 | sha256: 567eaea9d842f5ece8702d3d895b7573c168faa986ad9071019877bf8edacf39 19 | original: 20 | hackage: mysql-0.2.1 21 | - completed: 22 | hackage: mysql-simple-0.4.7@sha256:bf7c4a1ed0971d11c21f14796c3850a623a43ea83d158877f05380c52abad4a9,2581 23 | pantry-tree: 24 | size: 877 25 | sha256: e1e868b577503a0e414de3172d09284596b070519806d1de2721daa0b33f1a82 26 | original: 27 | hackage: mysql-simple-0.4.7 28 | snapshots: 29 | - completed: 30 | size: 565720 31 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/8.yaml 32 | sha256: 76bf8992ff8dfe6eda9c02f81866138c2369344d5011ab39ae403457c4448b03 33 | original: lts-17.8 34 | -------------------------------------------------------------------------------- /stack-docker.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.17 2 | packages: 3 | - ./persistent 4 | - ./persistent-sqlite 5 | - ./persistent-test 6 | - ./persistent-mongoDB 7 | - ./persistent-mysql 8 | - ./persistent-postgresql 9 | - ./persistent-redis 10 | - ./persistent-qq 11 | 12 | docker: 13 | enable: true 14 | image: fpco/stack-build:lts-9.17 15 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2022-04-05 2 | packages: 3 | - ./persistent 4 | - ./persistent-sqlite 5 | - ./persistent-test 6 | - ./persistent-mongoDB 7 | - ./persistent-mysql 8 | - ./persistent-postgresql 9 | - ./persistent-redis 10 | - ./persistent-qq 11 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2024-05-03 # GHC 9.4.5 2 | 3 | packages: 4 | - ./persistent 5 | - ./persistent-sqlite 6 | - ./persistent-test 7 | - ./persistent-mongoDB 8 | - ./persistent-mysql 9 | - ./persistent-postgresql 10 | - ./persistent-redis 11 | - ./persistent-qq 12 | 13 | extra-deps: 14 | # - attoparsec-aeson-2.1.0.0 15 | - postgresql-libpq-0.11.0.0 16 | - postgresql-libpq-configure-0.11 17 | - postgresql-simple-0.7.0.0 18 | - hashable-1.4.3.0 19 | -------------------------------------------------------------------------------- /stack_lts-12.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.26 2 | packages: 3 | - ./persistent 4 | - ./persistent-sqlite 5 | - ./persistent-test 6 | - ./persistent-mongoDB 7 | - ./persistent-mysql 8 | - ./persistent-postgresql 9 | - ./persistent-redis 10 | - ./persistent-qq 11 | extra-deps: 12 | - aeson-1.4.1.0 13 | - postgresql-libpq-0.9.4.2 14 | - postgresql-simple-0.6.1 15 | - th-lift-0.8.0.1 16 | - th-lift-instances-0.1.14 17 | - lift-type-0.1.0.1 18 | - mysql-0.2.1 19 | - mysql-simple-0.4.7 20 | -------------------------------------------------------------------------------- /travis/run.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euxo pipefail 4 | 5 | psql -c 'create database persistent;' -U postgres 6 | mysql -e 'create database persistent;' 7 | 8 | case "$BUILD" in 9 | stack) 10 | exec stack --no-terminal $ARGS test --bench --no-run-benchmarks 11 | ;; 12 | cabal) 13 | cabal new-test all 14 | ;; 15 | esac 16 | set +ex 17 | --------------------------------------------------------------------------------