├── with-db ├── in-memory-db │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ ├── stack.yaml │ ├── LICENSE │ ├── in-memory-db.cabal │ ├── test │ │ └── Test.hs │ └── src │ │ └── Lib.hs └── testing-db │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── stack.yaml │ ├── LICENSE │ ├── testing-db.cabal │ ├── test │ └── Test.hs │ └── src │ └── Lib.hs ├── without-db ├── datatype │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ ├── stack.yaml │ ├── LICENSE │ ├── datatype.cabal │ ├── test │ │ └── Test.hs │ └── src │ │ └── Lib.hs ├── typeclass │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ ├── stack.yaml │ ├── LICENSE │ ├── typeclass.cabal │ ├── test │ │ └── Test.hs │ └── src │ │ └── Lib.hs └── free-monad │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── stack.yaml │ ├── LICENSE │ ├── free-monad.cabal │ ├── test │ └── Test.hs │ └── src │ └── Lib.hs ├── .gitignore ├── README.md └── LICENSE /with-db/in-memory-db/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /with-db/testing-db/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /without-db/datatype/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /without-db/typeclass/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /without-db/free-monad/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /with-db/testing-db/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (defaultMain) 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /without-db/datatype/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (defaultMain) 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /with-db/in-memory-db/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (defaultMain) 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /without-db/free-monad/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (defaultMain) 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /without-db/typeclass/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (defaultMain) 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | 18 | # database files 19 | production.sqlite* 20 | testing.sqlite* 21 | -------------------------------------------------------------------------------- /with-db/in-memory-db/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.8 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /with-db/testing-db/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.8 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /without-db/datatype/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.8 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /without-db/free-monad/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.8 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /without-db/typeclass/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-3.8 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Control whether we use the GHC we find on the path 17 | # system-ghc: true 18 | 19 | # Require a specific version of stack, using version ranges 20 | # require-stack-version: -any # Default 21 | # require-stack-version: >= 0.1.4.0 22 | 23 | # Override the architecture used by stack, especially useful on Windows 24 | # arch: i386 25 | # arch: x86_64 26 | 27 | # Extra directories used by stack for building 28 | # extra-include-dirs: [/path/to/dir] 29 | # extra-lib-dirs: [/path/to/dir] 30 | -------------------------------------------------------------------------------- /with-db/in-memory-db/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /with-db/testing-db/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /without-db/datatype/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /without-db/free-monad/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /without-db/typeclass/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /without-db/datatype/datatype.cabal: -------------------------------------------------------------------------------- 1 | name: datatype 2 | version: 0.1.0.0 3 | synopsis: Testing a Haskell REST API based on datatypes. 4 | description: Please see README.md 5 | homepage: http://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdepillabout@gmail.com 10 | copyright: 2015 Dennis Gosnell 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Lib 18 | build-depends: base >= 4.7 && < 5 19 | , aeson >= 0.8 && < 1 20 | , either >= 4 && < 5 21 | , exceptions >= 0.8 && < 1 22 | , lens >= 4 && < 5 23 | , monad-logger >= 0.3 && < 1 24 | , mtl >= 2 && < 3 25 | , operational >= 0.2 && < 1 26 | , persistent >= 2 && < 3 27 | , persistent-sqlite >= 2 && < 3 28 | , persistent-template >= 2 && < 3 29 | , servant >= 0.4 && < 5 30 | , servant-server >= 0.4 && < 5 31 | , text >= 1 && < 2 32 | , transformers >= 0.4 && < 1 33 | , warp >= 3 && < 4 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | 37 | executable datatype-exe 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 41 | build-depends: base 42 | , datatype 43 | default-language: Haskell2010 44 | 45 | test-suite datatype-test 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: Test.hs 49 | build-depends: base 50 | , aeson 51 | , bytestring >= 0.10 && < 1 52 | , containers >= 0.5 && < 1 53 | , either 54 | , exceptions 55 | , datatype 56 | , hspec >= 2 && < 3 57 | , hspec-wai >= 0.6 && < 1 58 | , hspec-wai-json >= 0.6 && < 1 59 | , http-types >= 0.8 && < 1 60 | , mtl 61 | , operational 62 | , persistent 63 | , servant-server 64 | , transformers 65 | , wai >= 3 && < 4 66 | , wai-extra >= 3 && < 4 67 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /without-db/typeclass/typeclass.cabal: -------------------------------------------------------------------------------- 1 | name: typeclass 2 | version: 0.1.0.0 3 | synopsis: Testing a Haskell REST API based on a typeclass. 4 | description: Please see README.md 5 | homepage: http://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdepillabout@gmail.com 10 | copyright: 2015 Dennis Gosnell 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Lib 18 | build-depends: base >= 4.7 && < 5 19 | , aeson >= 0.8 && < 1 20 | , either >= 4 && < 5 21 | , exceptions >= 0.8 && < 1 22 | , lens >= 4 && < 5 23 | , monad-logger >= 0.3 && < 1 24 | , mtl >= 2 && < 3 25 | , operational >= 0.2 && < 1 26 | , persistent >= 2 && < 3 27 | , persistent-sqlite >= 2 && < 3 28 | , persistent-template >= 2 && < 3 29 | , servant >= 0.4 && < 5 30 | , servant-server >= 0.4 && < 5 31 | , text >= 1 && < 2 32 | , transformers >= 0.4 && < 1 33 | , warp >= 3 && < 4 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | 37 | executable typeclass-exe 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 41 | build-depends: base 42 | , typeclass 43 | default-language: Haskell2010 44 | 45 | test-suite typeclass-test 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: Test.hs 49 | build-depends: base 50 | , aeson 51 | , bytestring >= 0.10 && < 1 52 | , containers >= 0.5 && < 1 53 | , either 54 | , exceptions 55 | , typeclass 56 | , hspec >= 2 && < 3 57 | , hspec-wai >= 0.6 && < 1 58 | , hspec-wai-json >= 0.6 && < 1 59 | , http-types >= 0.8 && < 1 60 | , mtl 61 | , operational 62 | , persistent 63 | , servant-server 64 | , transformers 65 | , wai >= 3 && < 4 66 | , wai-extra >= 3 && < 4 67 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /without-db/free-monad/free-monad.cabal: -------------------------------------------------------------------------------- 1 | name: free-monad 2 | version: 0.1.0.0 3 | synopsis: Testing a Haskell REST API based on a free monad. 4 | description: Please see README.md 5 | homepage: http://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdepillabout@gmail.com 10 | copyright: 2015 Dennis Gosnell 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Lib 18 | build-depends: base >= 4.7 && < 5 19 | , aeson >= 0.8 && < 1 20 | , either >= 4 && < 5 21 | , exceptions >= 0.8 && < 1 22 | , lens >= 4 && < 5 23 | , monad-logger >= 0.3 && < 1 24 | , mtl >= 2 && < 3 25 | , operational >= 0.2 && < 1 26 | , persistent >= 2 && < 3 27 | , persistent-sqlite >= 2 && < 3 28 | , persistent-template >= 2 && < 3 29 | , servant >= 0.4 && < 5 30 | , servant-server >= 0.4 && < 5 31 | , text >= 1 && < 2 32 | , transformers >= 0.4 && < 1 33 | , warp >= 3 && < 4 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | 37 | executable free-monad-exe 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 41 | build-depends: base 42 | , free-monad 43 | default-language: Haskell2010 44 | 45 | test-suite free-monad-test 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: Test.hs 49 | build-depends: base 50 | , aeson 51 | , bytestring >= 0.10 && < 1 52 | , containers >= 0.5 && < 1 53 | , either 54 | , exceptions 55 | , free-monad 56 | , hspec >= 2 && < 3 57 | , hspec-wai >= 0.6 && < 1 58 | , hspec-wai-json >= 0.6 && < 1 59 | , http-types >= 0.8 && < 1 60 | , mtl 61 | , operational 62 | , persistent 63 | , servant-server 64 | , transformers 65 | , wai >= 3 && < 4 66 | , wai-extra >= 3 && < 4 67 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /with-db/testing-db/testing-db.cabal: -------------------------------------------------------------------------------- 1 | name: testing-db 2 | version: 0.1.0.0 3 | synopsis: Testing a Haskell REST API based on datatypes. 4 | description: Please see README.md 5 | homepage: http://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdepillabout@gmail.com 10 | copyright: 2015 Dennis Gosnell 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Lib 18 | build-depends: base >= 4.7 && < 5 19 | , aeson >= 0.8 && < 1 20 | , either >= 4 && < 5 21 | , exceptions >= 0.8 && < 1 22 | , lens >= 4 && < 5 23 | , monad-logger >= 0.3 && < 1 24 | , mtl >= 2 && < 3 25 | , operational >= 0.2 && < 1 26 | , persistent >= 2 && < 3 27 | , persistent-sqlite >= 2 && < 3 28 | , persistent-template >= 2 && < 3 29 | , servant >= 0.4 && < 5 30 | , servant-server >= 0.4 && < 5 31 | , text >= 1 && < 2 32 | , transformers >= 0.4 && < 1 33 | , warp >= 3 && < 4 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | 37 | executable testing-db-exe 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 41 | build-depends: base 42 | , testing-db 43 | default-language: Haskell2010 44 | 45 | test-suite testing-db-test 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: Test.hs 49 | build-depends: base 50 | , aeson 51 | , bytestring >= 0.10 && < 1 52 | , containers >= 0.5 && < 1 53 | , either 54 | , exceptions 55 | , testing-db 56 | , hspec >= 2 && < 3 57 | , hspec-wai >= 0.6 && < 1 58 | , hspec-wai-json >= 0.6 && < 1 59 | , http-types >= 0.8 && < 1 60 | , monad-logger 61 | , mtl 62 | , operational 63 | , persistent 64 | , persistent-sqlite 65 | , servant-server 66 | , transformers 67 | , wai >= 3 && < 4 68 | , wai-extra >= 3 && < 4 69 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /with-db/in-memory-db/in-memory-db.cabal: -------------------------------------------------------------------------------- 1 | name: in-memory-db 2 | version: 0.1.0.0 3 | synopsis: Testing a Haskell REST API based on datatypes. 4 | description: Please see README.md 5 | homepage: http://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Dennis Gosnell 9 | maintainer: cdepillabout@gmail.com 10 | copyright: 2015 Dennis Gosnell 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: Lib 18 | build-depends: base >= 4.7 && < 5 19 | , aeson >= 0.8 && < 1 20 | , either >= 4 && < 5 21 | , exceptions >= 0.8 && < 1 22 | , lens >= 4 && < 5 23 | , monad-logger >= 0.3 && < 1 24 | , mtl >= 2 && < 3 25 | , operational >= 0.2 && < 1 26 | , persistent >= 2 && < 3 27 | , persistent-sqlite >= 2 && < 3 28 | , persistent-template >= 2 && < 3 29 | , servant >= 0.4 && < 5 30 | , servant-server >= 0.4 && < 5 31 | , text >= 1 && < 2 32 | , transformers >= 0.4 && < 1 33 | , warp >= 3 && < 4 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | 37 | executable in-memory-db-exe 38 | hs-source-dirs: app 39 | main-is: Main.hs 40 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 41 | build-depends: base 42 | , in-memory-db 43 | default-language: Haskell2010 44 | 45 | test-suite in-memory-db-test 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: Test.hs 49 | build-depends: base 50 | , aeson 51 | , bytestring >= 0.10 && < 1 52 | , containers >= 0.5 && < 1 53 | , either 54 | , exceptions 55 | , in-memory-db 56 | , hspec >= 2 && < 3 57 | , hspec-wai >= 0.6 && < 1 58 | , hspec-wai-json >= 0.6 && < 1 59 | , http-types >= 0.8 && < 1 60 | , monad-logger 61 | , mtl 62 | , operational 63 | , persistent 64 | , persistent-sqlite 65 | , servant-server 66 | , transformers 67 | , wai >= 3 && < 4 68 | , wai-extra >= 3 && < 4 69 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /with-db/testing-db/test/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | -- These are the tests for our api. The only real interesting part is the 3 | -- 'main' function, were we specific that the test database is different 4 | -- from the production database. 5 | 6 | {-# LANGUAGE DeriveFunctor #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE InstanceSigs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE QuasiQuotes #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | 17 | module Main (main) where 18 | 19 | import Control.Monad.IO.Class (liftIO) 20 | import Control.Monad.Logger (NoLoggingT(..)) 21 | import Data.Aeson (ToJSON, encode) 22 | import Data.ByteString (ByteString) 23 | import Database.Persist ((>=.), deleteWhere) 24 | import Database.Persist.Sql (toSqlKey) 25 | import Database.Persist.Sqlite (runMigration, runSqlConn, withSqliteConn) 26 | import Network.HTTP.Types.Method (methodPost, methodPut) 27 | import Network.Wai (Application) 28 | import Network.Wai.Test (SResponse) 29 | import Servant.Server (serve) 30 | import Test.Hspec (Spec, describe, hspec, it) 31 | import Test.Hspec.Wai 32 | ( WaiExpectation, WaiSession, delete, get, matchBody, request 33 | , shouldRespondWith, with ) 34 | 35 | import Lib (BlogPost(..), EntityField(..), blogPostApiProxy, migrateAll, server) 36 | 37 | -- | These are our actual unit tests. They should be relatively 38 | -- straightforward. 39 | -- 40 | -- This function is using 'app', which in turn accesses our testing 41 | -- database. 42 | spec :: IO Application -> Spec 43 | spec app = with app $ do 44 | describe "GET blogpost" $ do 45 | 46 | it "responds with 200 after inserting something" $ do 47 | postJson "/create" testBlogPost `shouldRespondWith` 201 48 | get "/read/1" `shouldRespondWithJson` (200, testBlogPost) 49 | it "responds with 404 because nothing has been inserted" $ do 50 | get "/read/1" `shouldRespondWith` 404 51 | 52 | describe "PUT blogpost" $ do 53 | it "responds with 204 even when key doesn't exist in DB" $ do 54 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 55 | 56 | it "can't GET after PUT" $ do 57 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 58 | get "/read/1" `shouldRespondWith` 404 59 | 60 | describe "DELETE blogpost" $ do 61 | it "responds with 204 even when key doesn't exist in DB" $ do 62 | delete "/delete/1" `shouldRespondWith` 204 63 | 64 | it "GET after DELETE returns 404" $ do 65 | postJson "/create" testBlogPost `shouldRespondWith` 201 66 | get "/read/1" `shouldRespondWith` 200 67 | delete "/delete/1" `shouldRespondWith` 204 68 | get "/read/1" `shouldRespondWith` 404 69 | where 70 | -- Send a type that can be turned into JSON (@a@) to the Wai 71 | -- 'Application' at the 'ByteString' url. This returns a 'SResponse' 72 | -- in the 'WaiSession' monad. This is similar to the 'post' function. 73 | postJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 74 | postJson path = 75 | request methodPost path [("Content-Type", "application/json")] . encode 76 | 77 | -- Similar to 'postJson'. 78 | putJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 79 | putJson path = 80 | request methodPut path [("Content-Type", "application/json")] . encode 81 | 82 | -- Similar to 'shouldRespondWith', but converts the second argument to 83 | -- JSON before it compares with the 'SResponse'. 84 | shouldRespondWithJson :: (ToJSON a) 85 | => WaiSession SResponse 86 | -> (Integer, a) 87 | -> WaiExpectation 88 | shouldRespondWithJson req (expectedStatus, expectedValue) = 89 | let matcher = (fromInteger expectedStatus) 90 | { matchBody = Just $ encode expectedValue } 91 | in shouldRespondWith req matcher 92 | 93 | -- An example blog post to use in tests. 94 | testBlogPost :: BlogPost 95 | testBlogPost = BlogPost "title" "content" 96 | 97 | -- | This is almost identical to the 'defaultMain' defined in "Lib", except 98 | -- that is it running against "testing.sqlite" instead of 99 | -- "production.sqlite". 100 | main :: IO () 101 | main = 102 | runNoLoggingT $ withSqliteConn "testing.sqlite" $ \conn -> do 103 | liftIO $ runSqlConn (runMigration migrateAll) conn 104 | liftIO $ putStrLn "\napi running on port 8080..." 105 | liftIO $ hspec $ spec $ do 106 | -- Before running each test, we have to remove all of the 107 | -- existing blog posts from the database. This ensures that 108 | -- it doesn't matter which order the tests are run in. 109 | runSqlConn (deleteWhere [BlogPostId >=. toSqlKey 0]) conn 110 | return . serve blogPostApiProxy $ server conn 111 | 112 | -------------------------------------------------------------------------------- /with-db/in-memory-db/test/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | -- These are the tests for our api. The only real interesting part is the 3 | -- 'main' function, where we specific that the test database is in memory. 4 | 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE InstanceSigs #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE QuasiQuotes #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | 17 | module Main (main) where 18 | 19 | import Control.Monad.IO.Class (liftIO) 20 | import Control.Monad.Logger (NoLoggingT(..)) 21 | import Data.Aeson (ToJSON, encode) 22 | import Data.ByteString (ByteString) 23 | import Database.Persist ((>=.), deleteWhere) 24 | import Database.Persist.Sql (toSqlKey) 25 | import Database.Persist.Sqlite (runMigration, runSqlConn, withSqliteConn) 26 | import Network.HTTP.Types.Method (methodPost, methodPut) 27 | import Network.Wai (Application) 28 | import Network.Wai.Test (SResponse) 29 | import Servant.Server (serve) 30 | import Test.Hspec (Spec, describe, hspec, it) 31 | import Test.Hspec.Wai 32 | ( WaiExpectation, WaiSession, delete, get, matchBody, request 33 | , shouldRespondWith, with ) 34 | 35 | import Lib (BlogPost(..), EntityField(..), blogPostApiProxy, migrateAll, server) 36 | 37 | -- | These are our actual unit tests. They should be relatively 38 | -- straightforward. 39 | -- 40 | -- This function is using 'app', which in turn accesses our in-memory 41 | -- database. 42 | spec :: IO Application -> Spec 43 | spec app = with app $ do 44 | describe "GET blogpost" $ do 45 | 46 | it "responds with 200 after inserting something" $ do 47 | postJson "/create" testBlogPost `shouldRespondWith` 201 48 | get "/read/1" `shouldRespondWithJson` (200, testBlogPost) 49 | it "responds with 404 because nothing has been inserted" $ do 50 | get "/read/1" `shouldRespondWith` 404 51 | 52 | describe "PUT blogpost" $ do 53 | it "responds with 204 even when key doesn't exist in DB" $ do 54 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 55 | 56 | it "can't GET after PUT" $ do 57 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 58 | get "/read/1" `shouldRespondWith` 404 59 | 60 | describe "DELETE blogpost" $ do 61 | it "responds with 204 even when key doesn't exist in DB" $ do 62 | delete "/delete/1" `shouldRespondWith` 204 63 | 64 | it "GET after DELETE returns 404" $ do 65 | postJson "/create" testBlogPost `shouldRespondWith` 201 66 | get "/read/1" `shouldRespondWith` 200 67 | delete "/delete/1" `shouldRespondWith` 204 68 | get "/read/1" `shouldRespondWith` 404 69 | where 70 | -- Send a type that can be turned into JSON (@a@) to the Wai 71 | -- 'Application' at the 'ByteString' url. This returns a 'SResponse' 72 | -- in the 'WaiSession' monad. This is similar to the 'post' function. 73 | postJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 74 | postJson path = 75 | request methodPost path [("Content-Type", "application/json")] . encode 76 | 77 | -- Similar to 'postJson'. 78 | putJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 79 | putJson path = 80 | request methodPut path [("Content-Type", "application/json")] . encode 81 | 82 | -- Similar to 'shouldRespondWith', but converts the second argument to 83 | -- JSON before it compares with the 'SResponse'. 84 | shouldRespondWithJson :: (ToJSON a) 85 | => WaiSession SResponse 86 | -> (Integer, a) 87 | -> WaiExpectation 88 | shouldRespondWithJson req (expectedStatus, expectedValue) = 89 | let matcher = (fromInteger expectedStatus) 90 | { matchBody = Just $ encode expectedValue } 91 | in shouldRespondWith req matcher 92 | 93 | -- An example blog post to use in tests. 94 | testBlogPost :: BlogPost 95 | testBlogPost = BlogPost "title" "content" 96 | 97 | -- | This is almost identical to the 'defaultMain' defined in "Lib", except 98 | -- that is it running against an in-memory database (specified as 99 | -- @:memory:@), instead of @production.sqlite@. 100 | main :: IO () 101 | main = 102 | runNoLoggingT $ withSqliteConn ":memory:" $ \conn -> do 103 | liftIO $ runSqlConn (runMigration migrateAll) conn 104 | liftIO $ putStrLn "\napi running on port 8080..." 105 | liftIO $ hspec $ spec $ do 106 | -- Before running each test, we have to remove all of the 107 | -- existing blog posts from the database. This ensures that 108 | -- it doesn't matter which order the tests are run in. 109 | runSqlConn (deleteWhere [BlogPostId >=. toSqlKey 0]) conn 110 | return . serve blogPostApiProxy $ server conn 111 | 112 | -------------------------------------------------------------------------------- /without-db/datatype/test/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | -- These are the tests for our api. The only real interesting parts are 3 | -- the 'testDB' function for creating our 'DBAccess' type, and the 'app' function. 4 | 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE InstanceSigs #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE QuasiQuotes #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | 16 | module Main (main) where 17 | 18 | import Control.Monad (when) 19 | import Control.Monad.Catch (MonadThrow, catch) 20 | import Control.Monad.Error.Class (throwError) 21 | import Control.Monad.IO.Class (MonadIO, liftIO) 22 | import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) 23 | import Control.Monad.Trans.Either (EitherT) 24 | import Data.Aeson (ToJSON, encode) 25 | import Data.ByteString (ByteString) 26 | import Data.IntMap.Lazy (IntMap) 27 | import qualified Data.IntMap.Lazy as IntMap 28 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 29 | import Database.Persist (Key) 30 | import Database.Persist.Sql (fromSqlKey, toSqlKey) 31 | import Network.HTTP.Types.Method (methodPost, methodPut) 32 | import Network.Wai (Application) 33 | import Network.Wai.Test (SResponse) 34 | import Servant.Server (ServantErr(..), serve) 35 | import Test.Hspec (Spec, describe, hspec, it) 36 | import Test.Hspec.Wai 37 | ( WaiExpectation, WaiSession, delete, get, matchBody, request 38 | , shouldRespondWith, with ) 39 | 40 | import Lib (BlogPost(..), DBAccess(..), blogPostApiProxy, server) 41 | 42 | -- | This is very similar to the instance for the 'DBAccess' typeclass in the "typeclass" 43 | -- example test code. Look there for an explanation. 44 | 45 | newtype DBIORef = DBIORef { unDBIORef :: IORef (IntMap BlogPost, Int) } 46 | 47 | newtype DB m a = DB (ReaderT DBIORef m a) 48 | deriving (Functor, Applicative, Monad, MonadIO, MonadReader DBIORef, MonadThrow) 49 | 50 | testDB :: DBIORef -> DBAccess (DB IO) 51 | testDB config = DBAccess { runDb = runDb' config 52 | , getDb = getDb' 53 | , insertDb = insertDb' 54 | , deleteDb = deleteDb' 55 | , updateDb = updateDb' 56 | } 57 | where 58 | runDb' :: DBIORef -> DB IO a -> EitherT ServantErr IO a 59 | runDb' dbIORef (DB readerT) = 60 | liftIO (runReaderT readerT dbIORef) 61 | `catch` \(err::ServantErr) -> throwError err 62 | 63 | getDb' :: Key BlogPost -> DB IO (Maybe BlogPost) 64 | getDb' key = do 65 | (intMap, _) <- liftIO . readIORef . unDBIORef =<< ask 66 | return $ IntMap.lookup (sqlKeyToInt key) intMap 67 | 68 | insertDb' :: BlogPost -> DB IO (Key BlogPost) 69 | insertDb' blogPost = do 70 | (DBIORef dbRef) <- ask 71 | (intMap, idCounter) <- liftIO $ readIORef dbRef 72 | let newIntMap = IntMap.insert idCounter blogPost intMap 73 | newCounter = idCounter + 1 74 | liftIO $ writeIORef dbRef (newIntMap, newCounter) 75 | return $ intToSqlKey idCounter 76 | 77 | deleteDb' :: Key BlogPost -> DB IO () 78 | deleteDb' key = do 79 | (DBIORef dbRef) <- ask 80 | (intMap, counter) <- liftIO $ readIORef dbRef 81 | let newIntMap = IntMap.delete (sqlKeyToInt key) intMap 82 | liftIO $ writeIORef dbRef (newIntMap, counter) 83 | 84 | updateDb' :: Key BlogPost -> BlogPost -> DB IO () 85 | updateDb' key blogPost = do 86 | (DBIORef dbRef) <- ask 87 | (intMap, counter) <- liftIO $ readIORef dbRef 88 | when (sqlKeyToInt key `IntMap.member` intMap) $ do 89 | let newIntMap = IntMap.insert (sqlKeyToInt key) blogPost intMap 90 | liftIO $ writeIORef dbRef (newIntMap, counter) 91 | 92 | -- | Turn a 'Key' 'BlogPost' into an 'Int'. This is for storing a 'Key' 93 | -- 'BlogPost' in our 'IntMap'. 94 | sqlKeyToInt :: Key BlogPost -> Int 95 | sqlKeyToInt key = fromInteger . toInteger $ fromSqlKey key 96 | 97 | -- | Opposite of 'sqlKeyToInt'. 98 | intToSqlKey :: Int -> Key BlogPost 99 | intToSqlKey int = toSqlKey . fromInteger $ toInteger int 100 | 101 | -- | This creates a Wai 'Application'. 102 | -- 103 | -- It just creates a new 'IORef' to our 'IntMap', and passes it to 104 | -- 'server'. It then uses the 'serve' function to create a Wai 105 | -- 'Application'. 106 | app :: IO Application 107 | app = do 108 | -- Create an 'IORef' that references a tuple of an 'IntMap' and 'Int'. 109 | -- The 'IntMap' will be our database. The 'Int' will be a count 110 | -- holding the highest id in the database. 111 | dbRef <- newIORef (IntMap.empty, 1) 112 | return . serve blogPostApiProxy . server . testDB $ DBIORef dbRef 113 | 114 | -- | These are our actual unit tests. They should be relatively 115 | -- straightforward. 116 | -- 117 | -- This function is using 'app', which in turn uses our 'DBAccess' 118 | -- datatype. 119 | spec :: Spec 120 | spec = with app $ do 121 | describe "GET blogpost" $ do 122 | it "responds with 200 after inserting something" $ do 123 | postJson "/create" testBlogPost `shouldRespondWith` 201 124 | get "/read/1" `shouldRespondWithJson` (200, testBlogPost) 125 | 126 | it "responds with 404 because nothing has been inserted" $ do 127 | get "/read/1" `shouldRespondWith` 404 128 | 129 | describe "PUT blogpost" $ do 130 | it "responds with 204 even when key doesn't exist in DB" $ do 131 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 132 | 133 | it "can't GET after PUT" $ do 134 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 135 | get "/read/1" `shouldRespondWith` 404 136 | 137 | describe "DELETE blogpost" $ do 138 | it "responds with 204 even when key doesn't exist in DB" $ do 139 | delete "/delete/1" `shouldRespondWith` 204 140 | 141 | it "GET after DELETE returns 404" $ do 142 | postJson "/create" testBlogPost `shouldRespondWith` 201 143 | get "/read/1" `shouldRespondWith` 200 144 | delete "/delete/1" `shouldRespondWith` 204 145 | get "/read/1" `shouldRespondWith` 404 146 | where 147 | -- Send a type that can be turned into JSON (@a@) to the Wai 148 | -- 'Application' at the 'ByteString' url. This returns a 'SResponse' 149 | -- in the 'WaiSession' monad. This is similar to the 'post' function. 150 | postJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 151 | postJson path = 152 | request methodPost path [("Content-Type", "application/json")] . encode 153 | 154 | -- Similar to 'postJson'. 155 | putJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 156 | putJson path = 157 | request methodPut path [("Content-Type", "application/json")] . encode 158 | 159 | -- Similar to 'shouldRespondWith', but converts the second argument to 160 | -- JSON before it compares with the 'SResponse'. 161 | shouldRespondWithJson :: (ToJSON a) 162 | => WaiSession SResponse 163 | -> (Integer, a) 164 | -> WaiExpectation 165 | shouldRespondWithJson req (expectedStatus, expectedValue) = 166 | let matcher = (fromInteger expectedStatus) 167 | { matchBody = Just $ encode expectedValue } 168 | in shouldRespondWith req matcher 169 | 170 | -- An example blog post to use in tests. 171 | testBlogPost :: BlogPost 172 | testBlogPost = BlogPost "title" "content" 173 | 174 | main :: IO () 175 | main = hspec spec 176 | 177 | -------------------------------------------------------------------------------- /without-db/free-monad/test/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | -- These are the tests for our api. The only real interesting parts are 3 | -- the 'testDbDSLInServant' and 'app' functions. 4 | 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | module Main (main) where 12 | 13 | import Control.Monad (when) 14 | import Control.Monad.Error.Class (throwError) 15 | import Control.Monad.IO.Class (liftIO) 16 | import Control.Monad.Operational (ProgramViewT(..), view) 17 | import Control.Monad.Trans.Either (EitherT) 18 | import Data.Aeson (ToJSON, encode) 19 | import Data.ByteString (ByteString) 20 | import Data.IntMap.Lazy (IntMap) 21 | import qualified Data.IntMap.Lazy as IntMap 22 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 23 | import Database.Persist (Key) 24 | import Database.Persist.Sql (fromSqlKey, toSqlKey) 25 | import Network.HTTP.Types.Method (methodPost, methodPut) 26 | import Network.Wai (Application) 27 | import Network.Wai.Test (SResponse) 28 | import Servant.Server (ServantErr(..), serve) 29 | import Test.Hspec (Spec, describe, hspec, it) 30 | import Test.Hspec.Wai 31 | ( WaiExpectation, WaiSession, delete, get, matchBody, request 32 | , shouldRespondWith, with ) 33 | 34 | import Lib (BlogPost(..), DbAction(..), DbDSL, blogPostApiProxy, server) 35 | 36 | -- | This is our dsl interpreter for these unit tests. It's very similar 37 | -- to 'Lib.runDbDSLInServant', except that it doesn't actually access 38 | -- a database. Instead, it just uses an 'IntMap' to simulate a database. 39 | 40 | -- It's similar to 'runDbDSLInServant' in that if you curry the 'IORef' 41 | -- argument, then you get a function @'DbDSL' a -> 'EitherT' 'ServantErr' 42 | -- IO a@. It takes a 'DbDSL' and evaluates it in a Servant context (e.g. 43 | -- the @'EitherT' 'ServantErrr' IO@ monad). 44 | -- 45 | -- It's using an 'IORef' to hold a tuple of the the 'IntMap' and 'Int' 46 | -- corresponding to the id count for simplicity, but it could easily be 47 | -- rewritten to use something like a 'State' monad. 48 | -- 49 | -- The 'Int' corresponding to the id count is simply the highest id of 50 | -- something in the database. Everytime we insert something we increase 51 | -- it by 1. 52 | testDbDSLInServant :: IORef (IntMap BlogPost, Int) 53 | -> DbDSL a 54 | -> EitherT ServantErr IO a 55 | testDbDSLInServant dbRef dbDSL = do 56 | case view dbDSL of 57 | Return a -> return a 58 | -- This evaluates a 'GetDb' request to actually get 59 | -- a 'BlogPost' from the hashmap. 60 | (GetDb key) :>>= nextStep -> do 61 | -- Get the 'IntMap' from the 'IORef'. 62 | (intMap, _) <- liftIO $ readIORef dbRef 63 | -- Lookup the key of the 'BlogPost' in the 'IntMap'. 64 | let maybeBlogPost = IntMap.lookup (sqlKeyToInt key) intMap 65 | -- Run the next step of the dsl, passing it the 'BlogPost'. 66 | testDbDSLInServant dbRef $ nextStep maybeBlogPost 67 | -- Evaluate a 'InsertDb' request to insert a 'BlogPost' in to the 68 | -- hashmap. 69 | (InsertDb blogPost) :>>= nextStep -> do 70 | (intMap, idCounter) <- liftIO $ readIORef dbRef 71 | let newIntMap = IntMap.insert idCounter blogPost intMap 72 | newCounter = idCounter + 1 73 | liftIO $ writeIORef dbRef (newIntMap, newCounter) 74 | testDbDSLInServant dbRef . nextStep $ intToSqlKey idCounter 75 | -- Evaluate a 'DelDb' request to delete a 'BlogPost' from the 76 | -- hashmap. 77 | (DelDb key) :>>= nextStep -> do 78 | (intMap, counter) <- liftIO $ readIORef dbRef 79 | let newIntMap = IntMap.delete (sqlKeyToInt key) intMap 80 | liftIO $ writeIORef dbRef (newIntMap, counter) 81 | testDbDSLInServant dbRef $ nextStep () 82 | -- Evaluate an 'UpdateDb' request to update a 'BlogPost' in the 83 | -- hashmap. 84 | (UpdateDb key blogPost) :>>= nextStep -> do 85 | (intMap, counter) <- liftIO $ readIORef dbRef 86 | let newIntMap = IntMap.insert (sqlKeyToInt key) blogPost intMap 87 | when (sqlKeyToInt key `IntMap.member` intMap) $ 88 | liftIO $ writeIORef dbRef (newIntMap, counter) 89 | testDbDSLInServant dbRef $ nextStep () 90 | -- Throw an error to indicate that something went wrong. 91 | (ThrowDb servantErr) :>>= _ -> 92 | throwError servantErr 93 | where 94 | -- | Turn a 'Key' 'BlogPost' into an 'Int'. This is for storing a 'Key' 95 | -- 'BlogPost' in our 'IntMap'. 96 | sqlKeyToInt :: Key BlogPost -> Int 97 | sqlKeyToInt key = fromInteger . toInteger $ fromSqlKey key 98 | 99 | -- | Opposite of 'sqlKeyToInt'. 100 | intToSqlKey :: Int -> Key BlogPost 101 | intToSqlKey int = toSqlKey . fromInteger $ toInteger int 102 | 103 | -- | This creates a Wai 'Application'. 104 | -- 105 | -- It just creates a new 'IORef' to our 'IntMap', and passes it to 106 | -- 'testDbDSLInServant'. It then uses the 'serve' function to create a Wai 107 | -- 'Application'. 108 | app :: IO Application 109 | app = do 110 | -- Create an 'IORef' to a tuple of an 'IntMap' and 'Int'. 111 | -- The 'IntMap' will be our database. The 'Int' will be a count 112 | -- holding the highest id in the database. 113 | dbRef <- newIORef (IntMap.empty, 1) 114 | return . serve blogPostApiProxy $ server (testDbDSLInServant dbRef) 115 | 116 | -- | These are our actual unit tests. They should be relatively 117 | -- straightforward. 118 | -- 119 | -- This function is using 'app', which in turn uses our test dsl interpreter 120 | -- ('testDbDSLInServant'). 121 | spec :: Spec 122 | spec = with app $ do 123 | describe "GET blogpost" $ do 124 | it "responds with 200 after inserting something" $ do 125 | postJson "/create" testBlogPost `shouldRespondWith` 201 126 | get "/read/1" `shouldRespondWithJson` (200, testBlogPost) 127 | 128 | it "responds with 404 because nothing has been inserted" $ do 129 | get "/read/1" `shouldRespondWith` 404 130 | 131 | describe "PUT blogpost" $ do 132 | it "responds with 204 even when key doesn't exist in DB" $ do 133 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 134 | 135 | it "can't GET after PUT" $ do 136 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 137 | get "/read/1" `shouldRespondWith` 404 138 | 139 | describe "DELETE blogpost" $ do 140 | it "responds with 204 even when key doesn't exist in DB" $ do 141 | delete "/delete/1" `shouldRespondWith` 204 142 | 143 | it "GET after DELETE returns 404" $ do 144 | postJson "/create" testBlogPost `shouldRespondWith` 201 145 | get "/read/1" `shouldRespondWith` 200 146 | delete "/delete/1" `shouldRespondWith` 204 147 | get "/read/1" `shouldRespondWith` 404 148 | where 149 | -- Send a type that can be turned into JSON (@a@) to the Wai 150 | -- 'Application' at the 'ByteString' url. This returns a 'SResponse' 151 | -- in the 'WaiSession' monad. This is similar to the 'post' function. 152 | postJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 153 | postJson path = 154 | request methodPost path [("Content-Type", "application/json")] . encode 155 | 156 | -- Similar to 'postJson'. 157 | putJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 158 | putJson path = 159 | request methodPut path [("Content-Type", "application/json")] . encode 160 | 161 | -- Similar to 'shouldRespondWith', but converts the second argument to 162 | -- JSON before it compares with the 'SResponse'. 163 | shouldRespondWithJson :: (ToJSON a) 164 | => WaiSession SResponse 165 | -> (Integer, a) 166 | -> WaiExpectation 167 | shouldRespondWithJson req (expectedStatus, expectedValue) = 168 | let matcher = (fromInteger expectedStatus) 169 | { matchBody = Just $ encode expectedValue } 170 | in shouldRespondWith req matcher 171 | 172 | -- An example blog post to use in tests. 173 | testBlogPost :: BlogPost 174 | testBlogPost = BlogPost "title" "content" 175 | 176 | main :: IO () 177 | main = hspec spec 178 | 179 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # 5 Ways to Test Application Code that Accesses a Database in Haskell 3 | 4 | This repository contains 5 separate Haskell projects. Each project 5 | demonstrates a different way of testing application code that accesses a 6 | database. 7 | 8 | These five Haskell projects were created for the [blog post 9 | here](http://functor.tokyo/blog/2015-11-20-testing-db-access), which explains 10 | the pros and cons of each approach. Please see the blog post for more 11 | information. Please see below for more information about the application in 12 | question. 13 | 14 | The five projects are separated into two groups. Two of the projects are in 15 | the 16 | [`with-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/with-db) 17 | directory, and the other three projects are in the 18 | [`without-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db) 19 | directory. 20 | 21 | The two projects in the 22 | [`with-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/with-db) 23 | directory access a database in the tests. The three projects in the 24 | [`without-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db) 25 | directory do not access a database in the tests. 26 | 27 | ## [`with-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/with-db) directory 28 | 29 | There are two projects in the 30 | [`with-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/with-db) 31 | directory. These two projects connect to an actual database even in the tests. 32 | 33 | - [`with-db/test-database/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/with-db/test-database) 34 | - This approach uses two separate databases. There is a production 35 | database and a test database. When unit tests are run, they are only 36 | accessing the test database. When code is run in production, it is only 37 | accessing the production database. 38 | - [`with-db/in-memory-database/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/with-db/in-memory-database) 39 | - This approach is similar to the previous one, except an in-memory 40 | database is used for the test database. 41 | 42 | ## [`without-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db) directory 43 | 44 | There are three projects in the 45 | [`without-db/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db) 46 | directory. These three projects do not connect to an actual database in the 47 | tests. This has the benefit of making the tests not dependent on a database. 48 | 49 | The three projects are as follows: 50 | 51 | - [`without-db/typeclass/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db/typeclass) 52 | - This approach abstracts out database access using a typeclass. In 53 | production, there is an instance of the typeclass that accesses the 54 | database. For testing, there is an instance of the typeclass that 55 | simulates a database with a hashmap. 56 | - [`without-db/datatype/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db/datatype) 57 | - This is similar to the typeclass approach, but instead of using a 58 | typeclass, it just has a datatype that represents methods to access a 59 | database. In production the datatype is filled in with methods that 60 | access a database, while in tests the datatype is filled in with methods 61 | that simulate accessing a database by using a hashmap. 62 | - [`without-db/free-monad/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db/free-monad) 63 | - This approach uses a free-monad to make a DSL to describe database 64 | access. Two separate interpreters for the DSL are created. One 65 | interpreter is used in production and one interpreter is used for tests. 66 | The interpreter used in production actually interacts with the database 67 | (e.g. putting data into the database and getting data out of the 68 | database). The interpreter used for tests simulates a database using a 69 | hashmap. 70 | 71 | ## Explanation of the Application 72 | 73 | All 5 projects implement a similar application. The application is a simple 74 | REST API. It uses [servant](https://hackage.haskell.org/package/servant) to 75 | define the API. 76 | 77 | The API allows the user to operate on blog posts. The API has 4 endpoints that 78 | correspond to 79 | [CRUD](https://en.wikipedia.org/wiki/Create,_read,_update_and_delete) 80 | operations on blog posts. 81 | 82 | ### API 83 | 84 | - Create 85 | - This lets you create a new blog post on the server. 86 | - METHOD: POST 87 | - URL: http://localhost:8080/create 88 | - BODY: blog post JSON 89 | - EXAMPLE: `{"title": "example title", "content": "example content"}` 90 | - RETURNS: id of new blog post 91 | - Read 92 | - This lets you query a blog post based on id. 93 | - METHOD: GET 94 | - URL: http://localhost:8080/read/ 95 | - BODY: empty 96 | - RETURNS: json of blog post 97 | - Update 98 | - This lets you update an existing blog post. 99 | - METHOD: PUT 100 | - URL: http://localhost:8080/update/ 101 | - BODY: blog post JSON 102 | - EXAMPLE: `{"title": "updated title", "content": "updated content"}` 103 | - RETURNS: nothing 104 | - Delete 105 | - This lets you delete an existing blog post. 106 | - METHOD: DELETE 107 | - URL: http://localhost:8080/delete/ 108 | - BODY: empty 109 | - RETURNS: nothing 110 | 111 | ### Run the API 112 | 113 | The following shows how to build and run the API on the command line. It is 114 | similar for all projects. The 115 | [`without-db/free-monad/`](https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/tree/master/without-db/free-monad) 116 | project is used below as an example. 117 | 118 | The following uses the [stack](https://github.com/commercialhaskell/stack) 119 | build tool. You must have `stack` installed. 120 | 121 | #### Build the API 122 | 123 | ```bash 124 | $ cd without-db/free-monad/ 125 | $ stack build 126 | ``` 127 | 128 | #### Run Unit Tests 129 | 130 | ```bash 131 | $ stack test 132 | ``` 133 | 134 | #### Run the API 135 | 136 | ```bash 137 | $ stack exec free-monad-exe 138 | 139 | api running on port 8080... 140 | ``` 141 | 142 | #### Test the API from the Command Line 143 | 144 | You can test a REST API easily with cURL. First, run `stack exec 145 | free-monad-exe` in one terminal, then in another terminal use cURL like below: 146 | 147 | ```bash 148 | # create a new blog post 149 | $ curl -D - -H "Content-Type: application/json" -X POST -d '{"title": "example title", "content": "example content"}' http://localhost:8080/create 150 | 151 | HTTP/1.1 201 Created 152 | Transfer-Encoding: chunked 153 | Date: Sat, 17 Oct 2015 23:37:32 GMT 154 | Server: Warp/3.1.3.1 155 | Content-Type: application/json 156 | 157 | 1 158 | 159 | # read the blog post we just created 160 | $ curl -D - -H "Content-Type: application/json" -X GET http://localhost:8080/read/1 161 | HTTP/1.1 200 OK 162 | 163 | Transfer-Encoding: chunked 164 | Date: Sat, 17 Oct 2015 23:38:53 GMT 165 | Server: Warp/3.1.3.1 166 | Content-Type: application/json 167 | 168 | {"content":"example content","title":"example title"} 169 | 170 | # update the blog post to change the content 171 | $ curl -D - -H "Content-Type: application/json" -X PUT -d '{"title": "example title", "content": "new content"}' http://localhost:8080/update/1 172 | 173 | HTTP/1.1 204 No Content 174 | Date: Sat, 17 Oct 2015 23:40:24 GMT 175 | Server: Warp/3.1.3.1 176 | 177 | # read the updated blog post 178 | $ curl -D - -H "Content-Type: application/json" -X GET http://localhost:8080/read/1 179 | HTTP/1.1 200 OK 180 | 181 | Transfer-Encoding: chunked 182 | Date: Sat, 17 Oct 2015 23:38:53 GMT 183 | Server: Warp/3.1.3.1 184 | Content-Type: application/json 185 | 186 | {"content":"new content","title":"example title"} 187 | 188 | # delete the blog post 189 | $ curl -D - -H "Content-Type: application/json" -X DELETE http://localhost:8080/delete/1 190 | 191 | HTTP/1.1 204 No Content 192 | Date: Sat, 17 Oct 2015 23:42:07 GMT 193 | Server: Warp/3.1.3.1 194 | 195 | $ 196 | ``` 197 | -------------------------------------------------------------------------------- /with-db/testing-db/src/Lib.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This approach is very straightforward. We just use two separate 3 | -- databases. We have one database for production, called 4 | -- "production.sqlite", and one database for testing, called 5 | -- "testing.sqlite". The database name is specified in the 'main' 6 | -- function. 7 | 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE DeriveGeneric #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE FunctionalDependencies #-} 14 | {-# LANGUAGE GADTs #-} 15 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 16 | {-# LANGUAGE InstanceSigs #-} 17 | {-# LANGUAGE MultiParamTypeClasses #-} 18 | {-# LANGUAGE OverloadedStrings #-} 19 | {-# LANGUAGE PolyKinds #-} 20 | {-# LANGUAGE QuasiQuotes #-} 21 | {-# LANGUAGE RankNTypes #-} 22 | {-# LANGUAGE ScopedTypeVariables #-} 23 | {-# LANGUAGE TemplateHaskell #-} 24 | {-# LANGUAGE TypeFamilies #-} 25 | {-# LANGUAGE TypeOperators #-} 26 | 27 | -- This is an unfortunate hack. Used to make the code slightly easier to 28 | -- follow. See below for how we could fix it. 29 | {-# LANGUAGE UndecidableInstances #-} 30 | 31 | -- This is another unfortunate hack to make the code simpler and easier to 32 | -- understand. Described at the end of this file. 33 | {-# OPTIONS_GHC -fno-warn-orphans #-} 34 | 35 | module Lib (module Lib, EntityField(..)) where 36 | 37 | import Control.Exception (Exception) 38 | import Control.Monad.Catch (catch, throwM) 39 | import Control.Monad.Error.Class (throwError) 40 | import Control.Monad.IO.Class (liftIO) 41 | import Control.Monad.Logger (runStderrLoggingT) 42 | import Control.Monad.Trans.Either (EitherT) 43 | import Data.Proxy (Proxy(..)) 44 | import Database.Persist 45 | ( Key, EntityField, ToBackendKey, delete, get, insert, replace ) 46 | import Database.Persist.Sqlite 47 | ( SqlBackend, SqlPersistT, runMigration, runSqlConn, toSqlKey 48 | , withSqliteConn ) 49 | import Database.Persist.TH 50 | ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings ) 51 | import Data.Text (Text) 52 | import Network.Wai.Handler.Warp (run) 53 | import Servant 54 | ( (:<|>)(..), (:>), Capture, Delete, FromText(..), Get, JSON, Post, Put 55 | , ReqBody, ServantErr(..), Server, err404, serve ) 56 | 57 | ---------------------------------- 58 | ---------------------------------- 59 | -- Persistent model definitions -- 60 | ---------------------------------- 61 | ---------------------------------- 62 | 63 | -- This uses Persistent (a database library) to define a BlogPost data 64 | -- type as well as it's corresponding database table. 65 | -- 66 | -- If you've never used Persistent, you can think of it as defining the 67 | -- following data types and sql statement. This is a vast simplification of 68 | -- what it is actually doing, but it's good for a start: 69 | -- 70 | -- data BlogPost = BlogPost { blogPostTitle :: Text 71 | -- , blogPostContent :: Text 72 | -- } 73 | -- 74 | -- type Key BlogPost = Int 75 | -- 76 | -- CREATE TABLE "blog_post" ("id" PRIMARY KEY,"title" VARCHAR,"content" VARCHAR) 77 | -- 78 | -- It also defines some helper functions to query the "blog_post" table. 79 | share [ mkPersist sqlSettings, mkMigrate "migrateAll"] 80 | [persistLowerCase| 81 | BlogPost json 82 | title Text 83 | content Text 84 | deriving Show 85 | |] 86 | 87 | 88 | ----------------- 89 | ----------------- 90 | -- servant api -- 91 | ----------------- 92 | ----------------- 93 | 94 | -- | This defines a type which represents the API. A description of the 95 | -- API is given in the README.md. If you read the README.md, this should 96 | -- be very understandable. 97 | type BlogPostApi = "create" :> ReqBody '[JSON] BlogPost 98 | :> Post '[JSON] (Key BlogPost) 99 | 100 | :<|> "read" :> Capture "id" (Key BlogPost) 101 | :> Get '[JSON] BlogPost 102 | 103 | :<|> "update" :> Capture "id" (Key BlogPost) 104 | :> ReqBody '[JSON] BlogPost 105 | :> Put '[JSON] () 106 | 107 | :<|> "delete" :> Capture "id" (Key BlogPost) 108 | :> Delete '[JSON] () 109 | 110 | -- | This defines handlers for our API. This 'server' function is 111 | -- Servant-specfic and not too interesting. If you want to learn more 112 | -- about it, see the Servant tutorial. 113 | -- 114 | -- However, there is one interesting things here. The first is the 115 | -- 'createBlogPost', 'readBlogPost', 'updateBlogPost', and 'deleteBlogPost' 116 | -- functions. See their documentation for an explanation of what they are 117 | -- doing. 118 | 119 | -- In production, the 'SqlBackend' argument will contain connection 120 | -- information to access the production database, while in testing, the 121 | -- 'SqlBackend' argument will contain connection information to access 122 | -- a testing database. 123 | server :: SqlBackend -> Server BlogPostApi 124 | server conn = createBlogPost 125 | :<|> readBlogPost 126 | :<|> updateBlogPost 127 | :<|> deleteBlogPost 128 | where 129 | -- This is the handler for the API call that creates a blog post. 130 | -- 131 | -- Looking at the type, you can see that we get a 'BlogPost' object as 132 | -- input, and we need to return a 'Key' 'BlogPost' (which you can think 133 | -- of as an integer that corresponds to a database id). 134 | -- 135 | -- -- We use the 'runDb' function defined below. 136 | createBlogPost :: BlogPost -> EitherT ServantErr IO (Key BlogPost) 137 | createBlogPost blogPost = runDb $ insert blogPost 138 | 139 | -- This is the handler for the API call that fetches a blog post from 140 | -- the database. Return a 404 if the blog post can't be found. 141 | readBlogPost :: Key BlogPost -> EitherT ServantErr IO BlogPost 142 | readBlogPost key = runDb $ do 143 | maybeVal <- get key 144 | case maybeVal of 145 | Just blogPost -> return blogPost 146 | Nothing -> throwM err404 147 | 148 | -- Similar to 'createBlogPost'. 149 | updateBlogPost :: Key BlogPost -> BlogPost -> EitherT ServantErr IO () 150 | updateBlogPost key val = runDb $ replace key val 151 | 152 | -- Similar to 'createBlogPost'. 153 | deleteBlogPost :: Key BlogPost -> EitherT ServantErr IO () 154 | deleteBlogPost key = runDb $ delete key 155 | 156 | -- This is a small helper function for running a Persistent database 157 | -- action. This is used in the four handlers above. 158 | runDb :: SqlPersistT IO a -> EitherT ServantErr IO a 159 | runDb query = 160 | liftIO (runSqlConn query conn) 161 | `catch` \(err::ServantErr) -> throwError err 162 | 163 | -- | This is another artifact of Servant. See the Servant tutorial or this 164 | -- article I wrote about Servant for an overview of what this is: 165 | -- 166 | blogPostApiProxy :: Proxy BlogPostApi 167 | blogPostApiProxy = Proxy 168 | 169 | ---------- 170 | ---------- 171 | -- main -- 172 | ---------- 173 | ---------- 174 | 175 | -- This is the main function. It basically does three things. 176 | -- 177 | -- 1. Open up a connection to the sqlite database "production.sqlite". In 178 | -- production this would probably be something like Postgres, MongoDB, 179 | -- AWS's DynamoDB, etc. 180 | -- 2. Perform migration. This creates the "blog_post" table in the 181 | -- database if it doesn't exist. 182 | -- 3. Run our 'server' function, which effectively runs the api. 183 | defaultMain :: IO () 184 | defaultMain = 185 | runStderrLoggingT $ withSqliteConn "production.sqlite" $ \conn -> do 186 | liftIO $ runSqlConn (runMigration migrateAll) conn 187 | liftIO $ putStrLn "\napi running on port 8080..." 188 | liftIO . run 8080 . serve blogPostApiProxy $ server conn 189 | 190 | ----------------- 191 | ----------------- 192 | -- other stuff -- 193 | ----------------- 194 | ----------------- 195 | 196 | --- | XXX: Hack. 197 | -- 198 | -- Read the comment at the bottom of Lib.hs in the free-monad 199 | -- implementation to find out more about this. 200 | instance Exception ServantErr 201 | 202 | -- | XXX: Hack. 203 | -- 204 | -- Read the comment at the bottom of Lib.hs in the free-monad 205 | -- implementation to find out more about this. 206 | instance (ToBackendKey SqlBackend a) => FromText (Key a) where 207 | fromText :: Text -> Maybe (Key a) 208 | fromText text = toSqlKey <$> fromText text 209 | 210 | -------------------------------------------------------------------------------- /with-db/in-memory-db/src/Lib.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This approach is very straightforward. We use a normal database for 3 | -- production, and then for testing we just use an in memory database. 4 | -- 5 | -- The code here is identical to the code for @testing-db@, so if you want 6 | -- to learn how the following code works, see the file 7 | -- @testing-db/src/Lib.hs@. 8 | 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveGeneric #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE FunctionalDependencies #-} 15 | {-# LANGUAGE GADTs #-} 16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 17 | {-# LANGUAGE InstanceSigs #-} 18 | {-# LANGUAGE MultiParamTypeClasses #-} 19 | {-# LANGUAGE OverloadedStrings #-} 20 | {-# LANGUAGE PolyKinds #-} 21 | {-# LANGUAGE QuasiQuotes #-} 22 | {-# LANGUAGE RankNTypes #-} 23 | {-# LANGUAGE ScopedTypeVariables #-} 24 | {-# LANGUAGE TemplateHaskell #-} 25 | {-# LANGUAGE TypeFamilies #-} 26 | {-# LANGUAGE TypeOperators #-} 27 | 28 | -- This is an unfortunate hack. Used to make the code slightly easier to 29 | -- follow. See below for how we could fix it. 30 | {-# LANGUAGE UndecidableInstances #-} 31 | 32 | -- This is another unfortunate hack to make the code simpler and easier to 33 | -- understand. Described at the end of this file. 34 | {-# OPTIONS_GHC -fno-warn-orphans #-} 35 | 36 | module Lib (module Lib, EntityField(..)) where 37 | 38 | import Control.Exception (Exception) 39 | import Control.Monad.Catch (catch, throwM) 40 | import Control.Monad.Error.Class (throwError) 41 | import Control.Monad.IO.Class (liftIO) 42 | import Control.Monad.Logger (runStderrLoggingT) 43 | import Control.Monad.Trans.Either (EitherT) 44 | import Data.Proxy (Proxy(..)) 45 | import Database.Persist 46 | ( Key, EntityField, ToBackendKey, delete, get, insert, replace ) 47 | import Database.Persist.Sqlite 48 | ( SqlBackend, SqlPersistT, runMigration, runSqlConn, toSqlKey 49 | , withSqliteConn ) 50 | import Database.Persist.TH 51 | ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings ) 52 | import Data.Text (Text) 53 | import Network.Wai.Handler.Warp (run) 54 | import Servant 55 | ( (:<|>)(..), (:>), Capture, Delete, FromText(..), Get, JSON, Post, Put 56 | , ReqBody, ServantErr(..), Server, err404, serve ) 57 | 58 | ---------------------------------- 59 | ---------------------------------- 60 | -- Persistent model definitions -- 61 | ---------------------------------- 62 | ---------------------------------- 63 | 64 | -- This uses Persistent (a database library) to define a BlogPost data 65 | -- type as well as it's corresponding database table. 66 | -- 67 | -- If you've never used Persistent, you can think of it as defining the 68 | -- following data types and sql statement. This is a vast simplification of 69 | -- what it is actually doing, but it's good for a start: 70 | -- 71 | -- data BlogPost = BlogPost { blogPostTitle :: Text 72 | -- , blogPostContent :: Text 73 | -- } 74 | -- 75 | -- type Key BlogPost = Int 76 | -- 77 | -- CREATE TABLE "blog_post" ("id" PRIMARY KEY,"title" VARCHAR,"content" VARCHAR) 78 | -- 79 | -- It also defines some helper functions to query the "blog_post" table. 80 | share [ mkPersist sqlSettings, mkMigrate "migrateAll"] 81 | [persistLowerCase| 82 | BlogPost json 83 | title Text 84 | content Text 85 | deriving Show 86 | |] 87 | 88 | 89 | ----------------- 90 | ----------------- 91 | -- servant api -- 92 | ----------------- 93 | ----------------- 94 | 95 | -- | This defines a type which represents the API. A description of the 96 | -- API is given in the README.md. If you read the README.md, this should 97 | -- be very understandable. 98 | type BlogPostApi = "create" :> ReqBody '[JSON] BlogPost 99 | :> Post '[JSON] (Key BlogPost) 100 | 101 | :<|> "read" :> Capture "id" (Key BlogPost) 102 | :> Get '[JSON] BlogPost 103 | 104 | :<|> "update" :> Capture "id" (Key BlogPost) 105 | :> ReqBody '[JSON] BlogPost 106 | :> Put '[JSON] () 107 | 108 | :<|> "delete" :> Capture "id" (Key BlogPost) 109 | :> Delete '[JSON] () 110 | 111 | -- | This defines handlers for our API. This 'server' function is 112 | -- Servant-specfic and not too interesting. If you want to learn more 113 | -- about it, see the Servant tutorial. 114 | -- 115 | -- However, there is one interesting things here. The first is the 116 | -- 'createBlogPost', 'readBlogPost', 'updateBlogPost', and 'deleteBlogPost' 117 | -- functions. See their documentation for an explanation of what they are 118 | -- doing. 119 | 120 | -- In production, the 'SqlBackend' argument will contain connection 121 | -- information to access the production database, while in testing, the 122 | -- 'SqlBackend' argument will contain connection information to access 123 | -- an in-memory database. 124 | server :: SqlBackend -> Server BlogPostApi 125 | server conn = createBlogPost 126 | :<|> readBlogPost 127 | :<|> updateBlogPost 128 | :<|> deleteBlogPost 129 | where 130 | -- This is the handler for the API call that creates a blog post. 131 | -- 132 | -- Looking at the type, you can see that we get a 'BlogPost' object as 133 | -- input, and we need to return a 'Key' 'BlogPost' (which you can think 134 | -- of as an integer that corresponds to a database id). 135 | -- 136 | -- -- We use the 'runDb' function defined below. 137 | createBlogPost :: BlogPost -> EitherT ServantErr IO (Key BlogPost) 138 | createBlogPost blogPost = runDb $ insert blogPost 139 | 140 | -- This is the handler for the API call that fetches a blog post from 141 | -- the database. Return a 404 if the blog post can't be found. 142 | readBlogPost :: Key BlogPost -> EitherT ServantErr IO BlogPost 143 | readBlogPost key = runDb $ do 144 | maybeVal <- get key 145 | case maybeVal of 146 | Just blogPost -> return blogPost 147 | Nothing -> throwM err404 148 | 149 | -- Similar to 'createBlogPost'. 150 | updateBlogPost :: Key BlogPost -> BlogPost -> EitherT ServantErr IO () 151 | updateBlogPost key val = runDb $ replace key val 152 | 153 | -- Similar to 'createBlogPost'. 154 | deleteBlogPost :: Key BlogPost -> EitherT ServantErr IO () 155 | deleteBlogPost key = runDb $ delete key 156 | 157 | -- This is a small helper function for running a Persistent database 158 | -- action. This is used in the four handlers above. 159 | runDb :: SqlPersistT IO a -> EitherT ServantErr IO a 160 | runDb query = 161 | liftIO (runSqlConn query conn) 162 | `catch` \(err::ServantErr) -> throwError err 163 | 164 | -- | This is another artifact of Servant. See the Servant tutorial or this 165 | -- article I wrote about Servant for an overview of what this is: 166 | -- 167 | blogPostApiProxy :: Proxy BlogPostApi 168 | blogPostApiProxy = Proxy 169 | 170 | ---------- 171 | ---------- 172 | -- main -- 173 | ---------- 174 | ---------- 175 | 176 | -- This is the main function. It basically does three things. 177 | -- 178 | -- 1. Open up a connection to the sqlite database "production.sqlite". In 179 | -- production this would probably be something like Postgres, MongoDB, 180 | -- AWS's DynamoDB, etc. 181 | -- 2. Perform migration. This creates the "blog_post" table in the 182 | -- database if it doesn't exist. 183 | -- 3. Run our 'server' function, which effectively runs the api. 184 | defaultMain :: IO () 185 | defaultMain = 186 | runStderrLoggingT $ withSqliteConn "production.sqlite" $ \conn -> do 187 | liftIO $ runSqlConn (runMigration migrateAll) conn 188 | liftIO $ putStrLn "\napi running on port 8080..." 189 | liftIO . run 8080 . serve blogPostApiProxy $ server conn 190 | 191 | ----------------- 192 | ----------------- 193 | -- other stuff -- 194 | ----------------- 195 | ----------------- 196 | 197 | --- | XXX: Hack. 198 | -- 199 | -- Read the comment at the bottom of Lib.hs in the free-monad 200 | -- implementation to find out more about this. 201 | instance Exception ServantErr 202 | 203 | -- | XXX: Hack. 204 | -- 205 | -- Read the comment at the bottom of Lib.hs in the free-monad 206 | -- implementation to find out more about this. 207 | instance (ToBackendKey SqlBackend a) => FromText (Key a) where 208 | fromText :: Text -> Maybe (Key a) 209 | fromText text = toSqlKey <$> fromText text 210 | 211 | -------------------------------------------------------------------------------- /without-db/typeclass/test/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | -- These are the tests for our api. The only real interesting parts are 3 | -- the 'DBAccess' instance and 'app' function. 4 | 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE InstanceSigs #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE QuasiQuotes #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | 16 | module Main (main) where 17 | 18 | import Control.Monad (when) 19 | import Control.Monad.Catch (MonadThrow, catch) 20 | import Control.Monad.Error.Class (throwError) 21 | import Control.Monad.IO.Class (MonadIO, liftIO) 22 | import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) 23 | import Control.Monad.Trans.Either (EitherT) 24 | import Data.Aeson (ToJSON, encode) 25 | import Data.ByteString (ByteString) 26 | import Data.IntMap.Lazy (IntMap) 27 | import qualified Data.IntMap.Lazy as IntMap 28 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 29 | import Database.Persist (Key) 30 | import Database.Persist.Sql (fromSqlKey, toSqlKey) 31 | import Network.HTTP.Types.Method (methodPost, methodPut) 32 | import Network.Wai (Application) 33 | import Network.Wai.Test (SResponse) 34 | import Servant.Server (ServantErr(..), serve) 35 | import Test.Hspec (Spec, describe, hspec, it) 36 | import Test.Hspec.Wai 37 | ( WaiExpectation, WaiSession, delete, get, matchBody, request 38 | , shouldRespondWith, with ) 39 | 40 | import Lib (BlogPost(..), DBAccess(..), blogPostApiProxy, server) 41 | 42 | -- | This is our 'DBAccess' instance for these unit tests. It's very similar 43 | -- to the 'DBAccess' instance in "Lib", except that it doesn't actually access 44 | -- a database. Instead, it just uses an 'IntMap' to simulate a database. 45 | 46 | -- The 'runDb' method takes an 'IORef' that references an 'IntMap' and our 47 | -- 'DB' monad, and evaluates it in a Servant context (e.g. the @'EitherT' 48 | -- 'ServantErrr' IO@ monad). 49 | -- 50 | -- It's using an 'IORef' to hold a tuple of the the 'IntMap' and 'Int' 51 | -- (corresponding to the id count) for simplicity, but it could easily be 52 | -- rewritten to use something like a 'State' monad instead of an IORef. 53 | -- 54 | -- The 'Int' (corresponding to the id count) is simply the highest id of 55 | -- something in the database. Everytime we insert something we increase 56 | -- it by 1. 57 | 58 | -- | This is just a simple newtype wrapper for our 'IORef'. 59 | newtype DBIORef = DBIORef { unDBIORef :: IORef (IntMap BlogPost, Int) } 60 | 61 | -- | This is also a simple newtype wrapper for our DB Monad. This is very 62 | -- similar to Persistent's 'SqlPersistT' type. 63 | newtype DB m a = DB (ReaderT DBIORef m a) 64 | deriving (Functor, Applicative, Monad, MonadIO, MonadReader DBIORef, MonadThrow) 65 | 66 | instance DBAccess (DB IO) DBIORef where 67 | 68 | -- | Evaluate our 'DB' moonad in a Servant context (e.g. the 69 | -- @'EitherT' 'ServantErrr' IO@ monad). 70 | runDb :: DBIORef 71 | -> DB IO a 72 | -> EitherT ServantErr IO a 73 | runDb dbIORef (DB readerT) = 74 | liftIO (runReaderT readerT dbIORef) 75 | `catch` \(err::ServantErr) -> throwError err 76 | 77 | -- | Get a 'BlogPost' from the hashmap given the key.' 78 | getDb :: Key BlogPost -> DB IO (Maybe BlogPost) 79 | getDb key = do 80 | -- Get the 'IntMap' from the 'IORef'. 81 | (intMap, _) <- liftIO . readIORef . unDBIORef =<< ask 82 | -- Lookup the key of the 'BlogPost' in the 'IntMap' and return it. 83 | return $ IntMap.lookup (sqlKeyToInt key) intMap 84 | 85 | -- | Put a 'BlogPost' into the hashmap and return the 'Key'. 86 | insertDb :: BlogPost -> DB IO (Key BlogPost) 87 | insertDb blogPost = do 88 | (DBIORef dbRef) <- ask 89 | (intMap, idCounter) <- liftIO $ readIORef dbRef 90 | let newIntMap = IntMap.insert idCounter blogPost intMap 91 | newCounter = idCounter + 1 92 | liftIO $ writeIORef dbRef (newIntMap, newCounter) 93 | return $ intToSqlKey idCounter 94 | 95 | -- | Delete a 'BlogPost' from the hashmap. 96 | deleteDb :: Key BlogPost -> DB IO () 97 | deleteDb key = do 98 | (DBIORef dbRef) <- ask 99 | (intMap, counter) <- liftIO $ readIORef dbRef 100 | let newIntMap = IntMap.delete (sqlKeyToInt key) intMap 101 | liftIO $ writeIORef dbRef (newIntMap, counter) 102 | 103 | -- | Overwrite a 'BlogPost' from the hashmap with a new value. 104 | updateDb :: Key BlogPost -> BlogPost -> DB IO () 105 | updateDb key blogPost = do 106 | (DBIORef dbRef) <- ask 107 | (intMap, counter) <- liftIO $ readIORef dbRef 108 | when (sqlKeyToInt key `IntMap.member` intMap) $ do 109 | let newIntMap = IntMap.insert (sqlKeyToInt key) blogPost intMap 110 | liftIO $ writeIORef dbRef (newIntMap, counter) 111 | 112 | -- | Turn a 'Key' 'BlogPost' into an 'Int'. This is for storing a 'Key' 113 | -- 'BlogPost' in our 'IntMap'. 114 | sqlKeyToInt :: Key BlogPost -> Int 115 | sqlKeyToInt key = fromInteger . toInteger $ fromSqlKey key 116 | 117 | -- | Opposite of 'sqlKeyToInt'. 118 | intToSqlKey :: Int -> Key BlogPost 119 | intToSqlKey int = toSqlKey . fromInteger $ toInteger int 120 | 121 | -- | This creates a Wai 'Application'. 122 | -- 123 | -- It just creates a new 'IORef' to our 'IntMap', and passes it to 124 | -- 'server'. It then uses the 'serve' function to create a Wai 125 | -- 'Application'. 126 | app :: IO Application 127 | app = do 128 | -- Create an 'IORef' that references a tuple of an 'IntMap' and 'Int'. 129 | -- The 'IntMap' will be our database. The 'Int' will be a count 130 | -- holding the highest id in the database. 131 | dbRef <- newIORef (IntMap.empty, 1) 132 | return . serve blogPostApiProxy . server $ DBIORef dbRef 133 | 134 | -- | These are our actual unit tests. They should be relatively 135 | -- straightforward. 136 | -- 137 | -- This function is using 'app', which in turn uses our testing instance of 138 | -- 'DBAccess'. 139 | spec :: Spec 140 | spec = with app $ do 141 | describe "GET blogpost" $ do 142 | it "responds with 200 after inserting something" $ do 143 | postJson "/create" testBlogPost `shouldRespondWith` 201 144 | get "/read/1" `shouldRespondWithJson` (200, testBlogPost) 145 | 146 | it "responds with 404 because nothing has been inserted" $ do 147 | get "/read/1" `shouldRespondWith` 404 148 | 149 | describe "PUT blogpost" $ do 150 | it "responds with 204 even when key doesn't exist in DB" $ do 151 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 152 | 153 | it "can't GET after PUT" $ do 154 | putJson "/update/1" testBlogPost `shouldRespondWith` 204 155 | get "/read/1" `shouldRespondWith` 404 156 | 157 | describe "DELETE blogpost" $ do 158 | it "responds with 204 even when key doesn't exist in DB" $ do 159 | delete "/delete/1" `shouldRespondWith` 204 160 | 161 | it "GET after DELETE returns 404" $ do 162 | postJson "/create" testBlogPost `shouldRespondWith` 201 163 | get "/read/1" `shouldRespondWith` 200 164 | delete "/delete/1" `shouldRespondWith` 204 165 | get "/read/1" `shouldRespondWith` 404 166 | where 167 | -- Send a type that can be turned into JSON (@a@) to the Wai 168 | -- 'Application' at the 'ByteString' url. This returns a 'SResponse' 169 | -- in the 'WaiSession' monad. This is similar to the 'post' function. 170 | postJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 171 | postJson path = 172 | request methodPost path [("Content-Type", "application/json")] . encode 173 | 174 | -- Similar to 'postJson'. 175 | putJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse 176 | putJson path = 177 | request methodPut path [("Content-Type", "application/json")] . encode 178 | 179 | -- Similar to 'shouldRespondWith', but converts the second argument to 180 | -- JSON before it compares with the 'SResponse'. 181 | shouldRespondWithJson :: (ToJSON a) 182 | => WaiSession SResponse 183 | -> (Integer, a) 184 | -> WaiExpectation 185 | shouldRespondWithJson req (expectedStatus, expectedValue) = 186 | let matcher = (fromInteger expectedStatus) 187 | { matchBody = Just $ encode expectedValue } 188 | in shouldRespondWith req matcher 189 | 190 | -- An example blog post to use in tests. 191 | testBlogPost :: BlogPost 192 | testBlogPost = BlogPost "title" "content" 193 | 194 | main :: IO () 195 | main = hspec spec 196 | 197 | -------------------------------------------------------------------------------- /without-db/datatype/src/Lib.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This approach is very similar to the typeclass approach. It directly 3 | -- wraps the DB access functions inside a datatype. 4 | -- 5 | -- This is so similar to the typeclass approach that I didn't comment the 6 | -- code very well. If you can understand the typeclass approach, this 7 | -- datatype approach should be easily understandable. 8 | 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveGeneric #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE FunctionalDependencies #-} 15 | {-# LANGUAGE GADTs #-} 16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 17 | {-# LANGUAGE InstanceSigs #-} 18 | {-# LANGUAGE MultiParamTypeClasses #-} 19 | {-# LANGUAGE OverloadedStrings #-} 20 | {-# LANGUAGE PolyKinds #-} 21 | {-# LANGUAGE QuasiQuotes #-} 22 | {-# LANGUAGE RankNTypes #-} 23 | {-# LANGUAGE ScopedTypeVariables #-} 24 | {-# LANGUAGE TemplateHaskell #-} 25 | {-# LANGUAGE TypeFamilies #-} 26 | {-# LANGUAGE TypeOperators #-} 27 | 28 | -- This is an unfortunate hack. Used to make the code slightly easier to 29 | -- follow. See below for how we could fix it. 30 | {-# LANGUAGE UndecidableInstances #-} 31 | 32 | -- This is another unfortunate hack to make the code simpler and easier to 33 | -- understand. Described at the end of this file. 34 | {-# OPTIONS_GHC -fno-warn-orphans #-} 35 | 36 | module Lib where 37 | 38 | import Control.Exception (Exception) 39 | import Control.Monad.Catch (MonadThrow, catch, throwM) 40 | import Control.Monad.Error.Class (throwError) 41 | import Control.Monad.IO.Class (liftIO) 42 | import Control.Monad.Logger (runStderrLoggingT) 43 | import Control.Monad.Trans.Either (EitherT) 44 | import Data.Proxy (Proxy(..)) 45 | import Database.Persist 46 | ( Key, ToBackendKey, delete, get, insert, replace ) 47 | import Database.Persist.Sqlite 48 | ( SqlBackend, SqlPersistT, runMigration, runSqlConn, toSqlKey 49 | , withSqliteConn ) 50 | import Database.Persist.TH 51 | ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings ) 52 | import Data.Text (Text) 53 | import Network.Wai.Handler.Warp (run) 54 | import Servant 55 | ( (:<|>)(..), (:>), Capture, Delete, FromText(..), Get, JSON, Post, Put 56 | , ReqBody, ServantErr(..), Server, err404, serve ) 57 | 58 | ---------------------------------- 59 | ---------------------------------- 60 | -- Persistent model definitions -- 61 | ---------------------------------- 62 | ---------------------------------- 63 | 64 | -- This uses Persistent (a database library) to define a BlogPost data 65 | -- type as well as it's corresponding database table. 66 | -- 67 | -- If you've never used Persistent, you can think of it as defining the 68 | -- following data types and sql statement. This is a vast simplification of 69 | -- what it is actually doing, but it's good for a start: 70 | -- 71 | -- data BlogPost = BlogPost { blogPostTitle :: Text 72 | -- , blogPostContent :: Text 73 | -- } 74 | -- 75 | -- type Key BlogPost = Int 76 | -- 77 | -- CREATE TABLE "blog_post" ("id" PRIMARY KEY,"title" VARCHAR,"content" VARCHAR) 78 | -- 79 | -- It also defines some helper functions to query the "blog_post" table. 80 | share [ mkPersist sqlSettings, mkMigrate "migrateAll"] 81 | [persistLowerCase| 82 | BlogPost json 83 | title Text 84 | content Text 85 | deriving Show 86 | |] 87 | 88 | --------------------------------------- 89 | --------------------------------------- 90 | -- Datatype for accessing a database -- 91 | --------------------------------------- 92 | --------------------------------------- 93 | 94 | data DBAccess m = DBAccess { runDb :: forall a . m a -> EitherT ServantErr IO a 95 | , getDb :: Key BlogPost -> m (Maybe BlogPost) 96 | , insertDb :: BlogPost -> m (Key BlogPost) 97 | , deleteDb :: Key BlogPost -> m () 98 | , updateDb :: Key BlogPost -> BlogPost -> m () 99 | } 100 | 101 | -- | This tries to get a 'BlogPost' from our database, and throws an error 102 | -- if it can't. 103 | -- 104 | -- Helper functions like this can easily be written by passing in 105 | -- a 'DBAccess' datatype. 106 | getOr404Db :: MonadThrow m => DBAccess m -> Key BlogPost -> m BlogPost 107 | getOr404Db db key = do 108 | maybeVal <- getDb db key 109 | case maybeVal of 110 | Just blogPost -> return blogPost 111 | Nothing -> throwM err404 112 | 113 | ----------------- 114 | ----------------- 115 | -- servant api -- 116 | ----------------- 117 | ----------------- 118 | 119 | -- | This defines a type which represents the API. A description of the 120 | -- API is given in the README.md. If you read the README.md, this should 121 | -- be very understandable. 122 | type BlogPostApi = "create" :> ReqBody '[JSON] BlogPost 123 | :> Post '[JSON] (Key BlogPost) 124 | 125 | :<|> "read" :> Capture "id" (Key BlogPost) 126 | :> Get '[JSON] BlogPost 127 | 128 | :<|> "update" :> Capture "id" (Key BlogPost) 129 | :> ReqBody '[JSON] BlogPost 130 | :> Put '[JSON] () 131 | 132 | :<|> "delete" :> Capture "id" (Key BlogPost) 133 | :> Delete '[JSON] () 134 | 135 | -- | This defines handlers for our API. This 'server' function is 136 | -- Servant-specfic and not too interesting. If you want to learn more 137 | -- about it, see the Servant tutorial. 138 | -- 139 | -- However, there are two interesting things here. The first is the 140 | -- 'createBlogPost', 'readBlogPost', 'updateBlogPost', and 'deleteBlogPost' 141 | -- functions. See their documentation for an explanation of what they are 142 | -- doing. 143 | 144 | -- The second interesting thing is the 'DBAccess' arguement. We can use 145 | -- this to actually access the database. 146 | -- 147 | -- In production, this 'DBAccesss' will contain functions that access an 148 | -- SQLite database. In testing, an instance of 'DBAccess' that just uses 149 | -- a hashmap to simulate a database will be used. 150 | -- 151 | -- The cool thing is that this 'server' function doesn't have to change 152 | -- between production and testing. The only thing that will change is the 153 | -- 'DBAccess' that is in use. 154 | server :: MonadThrow m => DBAccess m -> Server BlogPostApi 155 | server db = createBlogPost 156 | :<|> readBlogPost 157 | :<|> updateBlogPost 158 | :<|> deleteBlogPost 159 | where 160 | -- This is the handler for the API call that creates a blog post. 161 | -- 162 | -- Looking at the type, you can see that we get a 'BlogPost' object as 163 | -- input, and we need to return a 'Key' 'BlogPost' (which you can think 164 | -- of as an integer that corresponds to a database id). 165 | -- 166 | -- -- We use the 'runDb' function from the 'DBAccess', @db@. 167 | createBlogPost :: BlogPost -> EitherT ServantErr IO (Key BlogPost) 168 | createBlogPost blogPost = runDb db $ insertDb db blogPost 169 | 170 | -- Similar to 'createBlogPost'. 171 | readBlogPost :: Key BlogPost -> EitherT ServantErr IO BlogPost 172 | readBlogPost key = runDb db $ getOr404Db db key 173 | 174 | -- Similar to 'createBlogPost'. 175 | updateBlogPost :: Key BlogPost -> BlogPost -> EitherT ServantErr IO () 176 | updateBlogPost key val = runDb db $ updateDb db key val 177 | 178 | -- Similar to 'createBlogPost'. 179 | deleteBlogPost :: Key BlogPost -> EitherT ServantErr IO () 180 | deleteBlogPost key = runDb db $ deleteDb db key 181 | 182 | -- | This is another artifact of Servant. See the Servant tutorial or this 183 | -- article I wrote about Servant for an overview of what this is: 184 | -- 185 | blogPostApiProxy :: Proxy BlogPostApi 186 | blogPostApiProxy = Proxy 187 | 188 | ----------------------- 189 | ----------------------- 190 | -- database instance -- 191 | ----------------------- 192 | ----------------------- 193 | 194 | -- | This function will produce a 'DBAccess' when passed an 'SqlBackend'. 195 | -- 196 | -- This is very similar how the 'DBAccess' instance works in the typeclass 197 | -- example, so you might want to look there for additional comments. 198 | prodDB :: SqlBackend -> DBAccess (SqlPersistT IO) 199 | prodDB config = DBAccess { runDb = runDb' config 200 | , getDb = getDb' 201 | , insertDb = insertDb' 202 | , deleteDb = deleteDb' 203 | , updateDb = updateDb' 204 | } 205 | where 206 | runDb' :: SqlBackend -> SqlPersistT IO a -> EitherT ServantErr IO a 207 | runDb' conn query = 208 | liftIO (runSqlConn query conn) 209 | `catch` \(err::ServantErr) -> throwError err 210 | 211 | getDb' :: Key BlogPost -> SqlPersistT IO (Maybe BlogPost) 212 | getDb' = get 213 | 214 | insertDb' :: BlogPost -> SqlPersistT IO (Key BlogPost) 215 | insertDb' = insert 216 | 217 | deleteDb' :: Key BlogPost -> SqlPersistT IO () 218 | deleteDb' = delete 219 | 220 | updateDb' :: Key BlogPost -> BlogPost -> SqlPersistT IO () 221 | updateDb' = replace 222 | 223 | 224 | ---------- 225 | ---------- 226 | -- main -- 227 | ---------- 228 | ---------- 229 | 230 | -- This is the main function. It basically does three things. 231 | -- 232 | -- 1. Open up a connection to the sqlite database "production.sqlite". In 233 | -- production this would probably be something like Postgres, MongoDB, 234 | -- AWS's DynamoDB, etc. 235 | -- 2. Perform migration. This creates the "blog_post" table in the 236 | -- database if it doesn't exist. 237 | -- 3. Run our 'server' function, which effectively runs the api. 238 | defaultMain :: IO () 239 | defaultMain = 240 | runStderrLoggingT $ withSqliteConn "production.sqlite" $ \conn -> do 241 | liftIO $ runSqlConn (runMigration migrateAll) conn 242 | liftIO $ putStrLn "\napi running on port 8080..." 243 | liftIO $ run 8080 $ serve blogPostApiProxy $ server $ prodDB conn 244 | 245 | 246 | ----------------- 247 | ----------------- 248 | -- other stuff -- 249 | ----------------- 250 | ----------------- 251 | 252 | --- | XXX: Hack. 253 | -- 254 | -- Read the comment at the bottom of Lib.hs in the free-monad 255 | -- implementation to find out more about this. 256 | instance Exception ServantErr 257 | 258 | -- | XXX: Hack. 259 | -- 260 | -- Read the comment at the bottom of Lib.hs in the free-monad 261 | -- implementation to find out more about this. 262 | instance (ToBackendKey SqlBackend a) => FromText (Key a) where 263 | fromText :: Text -> Maybe (Key a) 264 | fromText text = toSqlKey <$> fromText text 265 | 266 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | 203 | -------------------------------------------------------------------------------- /without-db/typeclass/src/Lib.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This approach uses a typeclass to describe database access. Two 3 | -- separate instances are created, one for production that actually 4 | -- accesses a database, and one for testing that simulates a database with 5 | -- a simple hashmap. 6 | -- 7 | -- This approach is similar to how Persistent works. 8 | 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveGeneric #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE FunctionalDependencies #-} 15 | {-# LANGUAGE GADTs #-} 16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 17 | {-# LANGUAGE InstanceSigs #-} 18 | {-# LANGUAGE MultiParamTypeClasses #-} 19 | {-# LANGUAGE OverloadedStrings #-} 20 | {-# LANGUAGE PolyKinds #-} 21 | {-# LANGUAGE QuasiQuotes #-} 22 | {-# LANGUAGE RankNTypes #-} 23 | {-# LANGUAGE ScopedTypeVariables #-} 24 | {-# LANGUAGE TemplateHaskell #-} 25 | {-# LANGUAGE TypeFamilies #-} 26 | {-# LANGUAGE TypeOperators #-} 27 | 28 | -- This is an unfortunate hack. Used to make the code slightly easier to 29 | -- follow. See below for how we could fix it. 30 | {-# LANGUAGE UndecidableInstances #-} 31 | 32 | -- This is another unfortunate hack to make the code simpler and easier to 33 | -- understand. Described at the end of this file. 34 | {-# OPTIONS_GHC -fno-warn-orphans #-} 35 | 36 | module Lib where 37 | 38 | import Control.Exception (Exception) 39 | import Control.Monad.Catch (MonadThrow, catch, throwM) 40 | import Control.Monad.Error.Class (throwError) 41 | import Control.Monad.IO.Class (liftIO) 42 | import Control.Monad.Logger (runStderrLoggingT) 43 | import Control.Monad.Trans.Either (EitherT) 44 | import Data.Proxy (Proxy(..)) 45 | import Database.Persist 46 | ( Key, ToBackendKey, delete, get, insert, replace ) 47 | import Database.Persist.Sqlite 48 | ( SqlBackend, SqlPersistT, runMigration, runSqlConn, toSqlKey 49 | , withSqliteConn ) 50 | import Database.Persist.TH 51 | ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings ) 52 | import Data.Text (Text) 53 | import Network.Wai.Handler.Warp (run) 54 | import Servant 55 | ( (:<|>)(..), (:>), Capture, Delete, FromText(..), Get, JSON, Post, Put 56 | , ReqBody, ServantErr(..), Server, err404, serve ) 57 | 58 | ---------------------------------- 59 | ---------------------------------- 60 | -- Persistent model definitions -- 61 | ---------------------------------- 62 | ---------------------------------- 63 | 64 | -- This uses Persistent (a database library) to define a BlogPost data 65 | -- type as well as it's corresponding database table. 66 | -- 67 | -- If you've never used Persistent, you can think of it as defining the 68 | -- following data types and sql statement. This is a vast simplification of 69 | -- what it is actually doing, but it's good for a start: 70 | -- 71 | -- data BlogPost = BlogPost { blogPostTitle :: Text 72 | -- , blogPostContent :: Text 73 | -- } 74 | -- 75 | -- type Key BlogPost = Int 76 | -- 77 | -- CREATE TABLE "blog_post" ("id" PRIMARY KEY,"title" VARCHAR,"content" VARCHAR) 78 | -- 79 | -- It also defines some helper functions to query the "blog_post" table. 80 | share [ mkPersist sqlSettings, mkMigrate "migrateAll"] 81 | [persistLowerCase| 82 | BlogPost json 83 | title Text 84 | content Text 85 | deriving Show 86 | |] 87 | 88 | ---------------------------------------- 89 | ---------------------------------------- 90 | -- Typeclass for accessing a database -- 91 | ---------------------------------------- 92 | ---------------------------------------- 93 | 94 | -- | The whole point of this "typeclass" example is the next couple of 95 | -- lines. We are defining a typeclass that represents actions that can be 96 | -- performed on a database. 97 | -- 98 | -- 'DBAccess' is our typeclass. It represents types can be used to access 99 | -- a DB (whether on disk, in memory, etc). It takes two parameters, @m@ 100 | -- and @d@. 101 | -- 102 | -- @m@ is the monad that we will be running in. If you're doing something 103 | -- like accessing a database, this might be 'IO'. If you're using 104 | -- Persistent it might be something like 'SqlPersistT' 'IO'. 105 | -- 106 | -- @d@ is some data that needs to be passed in to actually run the database 107 | -- requests. If we are using persistent, it will probably be 'SqlBackend'. 108 | -- 109 | -- 'getDb' is a function that lets us get a specific 'BlogPost' from the 110 | -- database. It is running in our @m@ monad. The other functions are 111 | -- similar. 112 | -- 113 | -- 'runDb' actually lets us run our @m@ in a Servant context. 114 | -- 115 | -- Later on in this file, we will define an instance of 'DBAccess' that 116 | -- will allow us to access a Persistent database. Then, in testing, we 117 | -- will define a different instance of 'DBAccess' that allows us to access 118 | -- a fake database modeled as a simple Hashmap. 119 | -- 120 | -- (PROTIP1: Check out the argument to 'getDb': 'Key'. 'Key' is defined in 121 | -- Persistent. Ideally, this dsl would have no dependency on Persistent at 122 | -- all. I made the decision to have this dsl be dependent on Persistent in 123 | -- order to simply the code and make it easier to understand.) 124 | 125 | -- (PROTIP2: Modeling database access as a typeclass is very similar to how 126 | -- Persistent itself works.) 127 | class (MonadThrow m, Monad m) => DBAccess m d | m -> d, d -> m where 128 | 129 | runDb :: d -> m a -> EitherT ServantErr IO a 130 | 131 | getDb :: Key BlogPost -> m (Maybe BlogPost) 132 | 133 | insertDb :: BlogPost -> m (Key BlogPost) 134 | 135 | deleteDb :: Key BlogPost -> m () 136 | 137 | updateDb :: Key BlogPost -> BlogPost -> m () 138 | 139 | -- | This tries to get a 'BlogPost' from our database, and throws an error 140 | -- if it can't. 141 | -- 142 | -- Helper functions like this can easily be written by using the 'DBAccess' 143 | -- constraint. The functions in 'DBAcesss' can be combined arbitrarily. 144 | getOr404Db :: DBAccess m d => Key BlogPost -> m BlogPost 145 | getOr404Db key = do 146 | maybeVal <- getDb key 147 | case maybeVal of 148 | Just blogPost -> return blogPost 149 | Nothing -> throwM err404 150 | 151 | ----------------- 152 | ----------------- 153 | -- servant api -- 154 | ----------------- 155 | ----------------- 156 | 157 | -- | This defines a type which represents the API. A description of the 158 | -- API is given in the README.md. If you read the README.md, this should 159 | -- be very understandable. 160 | type BlogPostApi = "create" :> ReqBody '[JSON] BlogPost 161 | :> Post '[JSON] (Key BlogPost) 162 | 163 | :<|> "read" :> Capture "id" (Key BlogPost) 164 | :> Get '[JSON] BlogPost 165 | 166 | :<|> "update" :> Capture "id" (Key BlogPost) 167 | :> ReqBody '[JSON] BlogPost 168 | :> Put '[JSON] () 169 | 170 | :<|> "delete" :> Capture "id" (Key BlogPost) 171 | :> Delete '[JSON] () 172 | 173 | -- | This defines handlers for our API. This 'server' function is 174 | -- Servant-specfic and not too interesting. If you want to learn more 175 | -- about it, see the Servant tutorial. 176 | -- 177 | -- However, there are two interesting things here. The first is the 178 | -- 'createBlogPost', 'readBlogPost', 'updateBlogPost', and 'deleteBlogPost' 179 | -- functions. See their documentation for an explanation of what they are 180 | -- doing. 181 | 182 | -- The second interesting thing is the 'DBAccess' constraint. This 183 | -- constraint tells us that by using the @d@ argument, we will be able to 184 | -- access a database as long as there is an instance of 'DBAccess' in the 185 | -- environment. 186 | -- 187 | -- In production, an instance of 'DBAccess' that actually accesses an 188 | -- SQLite database will be used. In testing, an instance of 'DBAccess' that 189 | -- just uses a hashmap to simulate a database will be used. 190 | -- 191 | -- The cool thing is that this 'server' function doesn't have to change 192 | -- between production and testing. The only thing that will change is the 193 | -- 'DBAccess' that is in use. 194 | server :: DBAccess m d => d -> Server BlogPostApi 195 | server conn = createBlogPost 196 | :<|> readBlogPost 197 | :<|> updateBlogPost 198 | :<|> deleteBlogPost 199 | where 200 | -- This is the handler for the API call that creates a blog post. 201 | -- 202 | -- Looking at the type, you can see that we get a 'BlogPost' object as 203 | -- input, and we need to return a 'Key' 'BlogPost' (which you can think 204 | -- of as an integer that corresponds to a database id). 205 | -- 206 | -- -- We use 'runDb' and @conn@ from the 'DBAccess' constaint. 207 | createBlogPost :: BlogPost -> EitherT ServantErr IO (Key BlogPost) 208 | createBlogPost blogPost = runDb conn $ insertDb blogPost 209 | 210 | -- Similar to 'createBlogPost'. 211 | readBlogPost :: Key BlogPost -> EitherT ServantErr IO BlogPost 212 | readBlogPost key = runDb conn $ getOr404Db key 213 | 214 | -- Similar to 'createBlogPost'. 215 | updateBlogPost :: Key BlogPost -> BlogPost -> EitherT ServantErr IO () 216 | updateBlogPost key val = runDb conn $ updateDb key val 217 | 218 | -- Similar to 'createBlogPost'. 219 | deleteBlogPost :: Key BlogPost -> EitherT ServantErr IO () 220 | deleteBlogPost key = runDb conn $ deleteDb key 221 | 222 | -- | This is another artifact of Servant. See the Servant tutorial or this 223 | -- article I wrote about Servant for an overview of what this is: 224 | -- 225 | blogPostApiProxy :: Proxy BlogPostApi 226 | blogPostApiProxy = Proxy 227 | 228 | ------------------------------ 229 | ------------------------------ 230 | -- database typeclass instance -- 231 | ------------------------------ 232 | ------------------------------ 233 | 234 | -- | Here is our instance of 'DBAccess' for accessing the database in 235 | -- production. It pretty much just directly wraps the calls to Persistent. 236 | instance DBAccess (SqlPersistT IO) SqlBackend where 237 | 238 | runDb :: SqlBackend -> SqlPersistT IO a -> EitherT ServantErr IO a 239 | runDb conn query = 240 | liftIO (runSqlConn query conn) 241 | `catch` \(err::ServantErr) -> throwError err 242 | 243 | getDb :: Key BlogPost -> SqlPersistT IO (Maybe BlogPost) 244 | getDb = get 245 | 246 | insertDb :: BlogPost -> SqlPersistT IO (Key BlogPost) 247 | insertDb = insert 248 | 249 | deleteDb :: Key BlogPost -> SqlPersistT IO () 250 | deleteDb = delete 251 | 252 | updateDb :: Key BlogPost -> BlogPost -> SqlPersistT IO () 253 | updateDb = replace 254 | 255 | ---------- 256 | ---------- 257 | -- main -- 258 | ---------- 259 | ---------- 260 | 261 | -- This is the main function. It basically does three things. 262 | -- 263 | -- 1. Open up a connection to the sqlite database "production.sqlite". In 264 | -- production this would probably be something like Postgres, MongoDB, 265 | -- AWS's DynamoDB, etc. 266 | -- 2. Perform migration. This creates the "blog_post" table in the 267 | -- database if it doesn't exist. 268 | -- 3. Run our 'server' function, which effectively runs the api. 269 | defaultMain :: IO () 270 | defaultMain = 271 | runStderrLoggingT $ withSqliteConn "production.sqlite" $ \conn -> do 272 | liftIO $ runSqlConn (runMigration migrateAll) conn 273 | liftIO $ putStrLn "\napi running on port 8080..." 274 | liftIO $ run 8080 $ serve blogPostApiProxy $ server conn 275 | 276 | 277 | ----------------- 278 | ----------------- 279 | -- other stuff -- 280 | ----------------- 281 | ----------------- 282 | 283 | --- | XXX: Hack. 284 | -- 285 | -- Read the comment at the bottom of Lib.hs in the free-monad 286 | -- implementation to find out more about this. 287 | instance Exception ServantErr 288 | 289 | -- | XXX: Hack. 290 | -- 291 | -- Read the comment at the bottom of Lib.hs in the free-monad 292 | -- implementation to find out more about this. 293 | instance (ToBackendKey SqlBackend a) => FromText (Key a) where 294 | fromText :: Text -> Maybe (Key a) 295 | fromText text = toSqlKey <$> fromText text 296 | 297 | -------------------------------------------------------------------------------- /without-db/free-monad/src/Lib.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This approach uses a free-monad to make a DSL to describe database 3 | -- access. Two separate interpreters for the DSL are created. One 4 | -- interpreter is used in production and one interpreter is used for tests. 5 | -- The interpreter used in production actually interacts with the database 6 | -- (e.g. putting data into the database and getting data out of the 7 | -- database). The interpreter used for tests simulates a database using a 8 | -- hashmap. 9 | -- 10 | -- This is heavily inspired by 11 | -- https://hbtvl.wordpress.com/2015/06/28/servant-persistent-and-dsls. 12 | 13 | {-# LANGUAGE ConstraintKinds #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE DeriveGeneric #-} 16 | {-# LANGUAGE FlexibleContexts #-} 17 | {-# LANGUAGE FlexibleInstances #-} 18 | {-# LANGUAGE GADTs #-} 19 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 20 | {-# LANGUAGE InstanceSigs #-} 21 | {-# LANGUAGE MultiParamTypeClasses #-} 22 | {-# LANGUAGE OverloadedStrings #-} 23 | {-# LANGUAGE PolyKinds #-} 24 | {-# LANGUAGE QuasiQuotes #-} 25 | {-# LANGUAGE RankNTypes #-} 26 | {-# LANGUAGE ScopedTypeVariables #-} 27 | {-# LANGUAGE TemplateHaskell #-} 28 | {-# LANGUAGE TypeFamilies #-} 29 | {-# LANGUAGE TypeOperators #-} 30 | 31 | -- This is an unfortunate hack. Used to make the code slightly easier to 32 | -- follow. See below for how we could fix it. 33 | {-# LANGUAGE UndecidableInstances #-} 34 | 35 | -- This is another unfortunate hack to make the code simpler and easier to 36 | -- understand. Described at the end of this file. 37 | {-# OPTIONS_GHC -fno-warn-orphans #-} 38 | 39 | module Lib where 40 | 41 | import Control.Exception (Exception) 42 | import Control.Monad.Catch (catch, throwM) 43 | import Control.Monad.Error.Class (throwError) 44 | import Control.Monad.IO.Class (liftIO) 45 | import Control.Monad.Logger (runStderrLoggingT) 46 | import Control.Monad.Operational (Program, ProgramViewT(..), singleton, view) 47 | import Control.Monad.Trans.Either (EitherT) 48 | import Data.Proxy (Proxy(..)) 49 | import Database.Persist 50 | ( Key, ToBackendKey, delete, get, insert, replace ) 51 | import Database.Persist.Sqlite 52 | ( SqlBackend, SqlPersistT, runMigration, runSqlConn, toSqlKey 53 | , withSqliteConn ) 54 | import Database.Persist.TH 55 | ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings ) 56 | import Data.Text (Text) 57 | import Network.Wai.Handler.Warp (run) 58 | import Servant 59 | ( (:<|>)(..), (:>), Capture, Delete, FromText(..), Get, JSON, Post, Put 60 | , ReqBody, ServantErr(..), Server, err404, serve ) 61 | 62 | ---------------------------------- 63 | ---------------------------------- 64 | -- Persistent model definitions -- 65 | ---------------------------------- 66 | ---------------------------------- 67 | 68 | -- This uses Persistent (a database library) to define a BlogPost data 69 | -- type as well as it's corresponding database table. 70 | -- 71 | -- If you've never used Persistent, you can think of it as defining the 72 | -- following data types and sql statement. This is a vast simplification of 73 | -- what it is actually doing, but it's good for a start: 74 | -- 75 | -- data BlogPost = BlogPost { blogPostTitle :: Text 76 | -- , blogPostContent :: Text 77 | -- } 78 | -- 79 | -- type Key BlogPost = Int 80 | -- 81 | -- CREATE TABLE "blog_post" ("id" PRIMARY KEY,"title" VARCHAR,"content" VARCHAR) 82 | -- 83 | -- It also defines some helper functions to query the "blog_post" table. 84 | share [ mkPersist sqlSettings, mkMigrate "migrateAll"] 85 | [persistLowerCase| 86 | BlogPost json 87 | title Text 88 | content Text 89 | deriving Show 90 | |] 91 | 92 | ---------------------------------- 93 | ---------------------------------- 94 | -- DSL for accessing a database -- 95 | ---------------------------------- 96 | ---------------------------------- 97 | 98 | -- | The whole point of this "free-monad" example is the next couple of 99 | -- lines. We are defining a DSL that represents actions that can be 100 | -- performed on a database. 101 | -- 102 | -- A 'DbAction' is the /type/ of an action that can be performed on 103 | -- a database. For example, 'GetDb' is a data constructor that represents 104 | -- getting a row of data from the database. 'InsertDb' is a data 105 | -- constructor that represents putting a row of data into the database. 106 | -- 107 | -- 'DbDSL' represents a sequence of 'DbAction's. The magic starts to 108 | -- happen later in this file. We will construct an /interpreter/ that 109 | -- takes a 'DbDSL' and actually performs the actions against a real 110 | -- database. Then, in testing, we will write a /different interpreter/ 111 | -- that just operates on a hashmap in memory. It never actually operates 112 | -- on a real database. 113 | -- 114 | -- (PROTIP: The following is not actually a free-monad, but is instead using 115 | -- the operational monad. In practice, it's not a huge difference, but it 116 | -- is something to be aware of.) 117 | -- 118 | -- (PROTIP2: Check out the argument to 'GetDb': 'Key'. 'Key' is defined in 119 | -- Persistent. Ideally, this dsl would have no dependency on Persistent at 120 | -- all. I made the decision to have this dsl be dependent on Persistent in 121 | -- order to simply the code and make it easier to understand.) 122 | type DbDSL = Program DbAction 123 | data DbAction a where 124 | ThrowDb :: ServantErr -> DbAction a 125 | GetDb :: Key BlogPost -> DbAction (Maybe BlogPost) 126 | InsertDb :: BlogPost -> DbAction (Key BlogPost) 127 | UpdateDb :: Key BlogPost -> BlogPost -> DbAction () 128 | DelDb :: Key BlogPost -> DbAction () 129 | 130 | -- The following helper functions make it easy to create a 'DbDSL'. The 131 | -- most interesting one is 'getOr404Db', which combines both 'getDb' and 132 | -- 'throwDb' into one 'DbDSL'. 133 | 134 | -- | Throws an error. 135 | throwDb :: ServantErr -> DbDSL a 136 | throwDb err = singleton (ThrowDb err) 137 | 138 | -- | Get a 'BlogPost' from the database. 139 | getDb :: Key BlogPost -> DbDSL (Maybe BlogPost) 140 | getDb key = singleton (GetDb key) 141 | 142 | -- | Insert a 'BlogPost' into the database and return its id. 143 | insertDb :: BlogPost -> DbDSL (Key BlogPost) 144 | insertDb blogPost = singleton (InsertDb blogPost) 145 | 146 | -- | Update a 'BlogPost' that already exists in the database. 147 | updateDb :: Key BlogPost -> BlogPost -> DbDSL () 148 | updateDb key blogPost = singleton (UpdateDb key blogPost) 149 | 150 | -- | Delete a 'BlogPost' from the database. 151 | deleteDb :: Key BlogPost -> DbDSL () 152 | deleteDb key = singleton (DelDb key) 153 | 154 | -- | Try to get a 'BlogPost' from the database. If it doesn't exist, throw 155 | -- an error. 156 | getOr404Db :: Key BlogPost -> DbDSL BlogPost 157 | getOr404Db key = do 158 | maybeVal <- getDb key 159 | case maybeVal of 160 | Just blogPost -> return blogPost 161 | Nothing -> throwDb err404 162 | 163 | ----------------- 164 | ----------------- 165 | -- servant api -- 166 | ----------------- 167 | ----------------- 168 | 169 | -- | This defines a type which represents the API. A description of the 170 | -- API is given in the README.md. If you read the README.md, this should 171 | -- be very understandable. 172 | type BlogPostApi = "create" :> ReqBody '[JSON] BlogPost 173 | :> Post '[JSON] (Key BlogPost) 174 | 175 | :<|> "read" :> Capture "id" (Key BlogPost) 176 | :> Get '[JSON] BlogPost 177 | 178 | :<|> "update" :> Capture "id" (Key BlogPost) 179 | :> ReqBody '[JSON] BlogPost 180 | :> Put '[JSON] () 181 | 182 | :<|> "delete" :> Capture "id" (Key BlogPost) 183 | :> Delete '[JSON] () 184 | 185 | -- | This defines handlers for our API. This 'server' function is 186 | -- Servant-specfic and not too interesting. If you want to learn more 187 | -- about it, see the Servant tutorial. 188 | -- 189 | -- However, there are two interesting things here. The first is the 190 | -- 'createBlogPost', 'readBlogPost', 'updateBlogPost', and 'deleteBlogPost' 191 | -- functions. See their documentation for an explanation of what they are 192 | -- doing. 193 | -- 194 | -- The second interesting thing is the 'interpreter' arguement. The 195 | -- 'interpreter' is a function that takes a 'DbDSL' and runs it in 196 | -- a Servant context (that is, inside a @'EitherT' 'ServantErr' IO@ monad). 197 | -- 198 | -- This is what is actually evaluating the dsl. In production the 199 | -- 'interpreter' will actually access the database. It will put new 200 | -- 'BlogPost's in the database and read existing 'BlogPost's from the 201 | -- database. In testing, the 'interpreter' will just use a Hashmap in 202 | -- memory to simulate database access. 203 | -- 204 | -- The cool thing is that this 'server' function doesn't have to change 205 | -- between production and testing. The only thing that will change is the 206 | -- 'interpreter' function. 207 | server :: (forall a . DbDSL a -> EitherT ServantErr IO a) -> Server BlogPostApi 208 | server interpreter = createBlogPost 209 | :<|> readBlogPost 210 | :<|> updateBlogPost 211 | :<|> deleteBlogPost 212 | where 213 | -- This is the handler for the API call that creates a blog post. 214 | -- 215 | -- Looking at the type, you can see that we get a 'BlogPost' object as 216 | -- input, and we need to return a 'Key' 'BlogPost' (which you can think 217 | -- of as an integer that corresponds to a database id). 218 | -- 219 | -- We use 'interpreter' and pass it the dsl @'insertDb' blogPost@. 220 | -- This dsl corresponds to inserting a 'BlogPost'. The 'interpreter' 221 | -- will execute this dsl in the Servant context (@'EitherT' 222 | -- 'ServantErr' IO@). 223 | createBlogPost :: BlogPost -> EitherT ServantErr IO (Key BlogPost) 224 | createBlogPost blogPost = interpreter $ insertDb blogPost 225 | 226 | -- Similar to 'createBlogPost'. 227 | readBlogPost :: Key BlogPost -> EitherT ServantErr IO BlogPost 228 | readBlogPost key = interpreter $ getOr404Db key 229 | 230 | -- Similar to 'createBlogPost'. 231 | updateBlogPost :: Key BlogPost -> BlogPost -> EitherT ServantErr IO () 232 | updateBlogPost key val = interpreter $ updateDb key val 233 | 234 | -- Similar to 'createBlogPost'. 235 | deleteBlogPost :: Key BlogPost -> EitherT ServantErr IO () 236 | deleteBlogPost key = interpreter $ deleteDb key 237 | 238 | -- | This is another artifact of Servant. See the Servant tutorial or this 239 | -- article I wrote about Servant for an overview of what this is: 240 | -- 241 | blogPostApiProxy :: Proxy BlogPostApi 242 | blogPostApiProxy = Proxy 243 | 244 | ------------------------------ 245 | ------------------------------ 246 | -- database dsl interpreter -- 247 | ------------------------------ 248 | ------------------------------ 249 | 250 | -- | Remember the @interpreter@ argument for the 'server' function? That's 251 | -- basically what this function is. 252 | -- 253 | -- If you curry the 'SqlBackend' argument, then you get a function @'DbDSL' 254 | -- a -> 'EitherT' 'ServantErr' IO a@. It takes a 'DbDSL' and evaluates it 255 | -- in a Servant context (e.g. the @'EitherT' 'ServantErrr' IO@ monad). 256 | -- 257 | -- The real interesting part is the 'runDbDSLInPersistent' helper 258 | -- function. It runs a 'DbDSL' in a persistent context (e.g. the 259 | -- @'SqlPersistT' ('EitherT' 'ServantErr' IO)@ monad). It actually 260 | -- accesses the database. It uses functions provided by the Persistent 261 | -- library, for example, 'get', 'insert', 'replace'. 262 | runDbDSLInServant :: SqlBackend 263 | -> DbDSL a 264 | -> EitherT ServantErr IO a 265 | runDbDSLInServant conn dbDSL = 266 | -- 'runSqlConn' takes sql connection info ('SqlBackend') and uses it to 267 | -- run an 'SqlPersistT' against a real database. We catch 'ServantErr' 268 | -- and re-throw them in the @'EitherT' 'ServantErr'@ monad. 269 | runSqlConn (runDbDSLInPersistent dbDSL) conn 270 | `catch` \(err::ServantErr) -> throwError err 271 | where 272 | -- | This takes a 'DbDSL' and runs it in a persistent context (e.g. the 273 | -- @'SqlPersistT' ('EitherT' 'ServantErr' IO)@ monad). It actually 274 | -- accesses the database. 275 | -- 276 | -- It works by pattern-matching on the dsl, using some machinery from 277 | -- the "Control.Monad.Operational" module. Check out that module for 278 | -- an explanation of how it works. 279 | -- 280 | -- Everything other than 'ThrowDb' calls 'runDbDSLInPersistent' 281 | -- recursively with the next step of the dsl. 282 | runDbDSLInPersistent :: DbDSL b -> SqlPersistT (EitherT ServantErr IO) b 283 | runDbDSLInPersistent dbDSL' = 284 | case view dbDSL' of 285 | Return a -> return a 286 | -- This evaluates a 'GetDb' request to actually get 287 | -- a 'BlogPost' from the database. 288 | (GetDb key) :>>= nextStep -> do 289 | -- 'get' is a function from Persistent that gets 290 | -- a 'BlogPost' from the database given a key. 291 | maybeVal <- get key 292 | runDbDSLInPersistent $ nextStep maybeVal 293 | -- Evaluate a 'InsertDb' request to insert a 'BlogPost' in to the 294 | -- database. 295 | (InsertDb blogPost) :>>= nextStep -> do 296 | key <- insert blogPost 297 | runDbDSLInPersistent $ nextStep key 298 | -- Evaluate a 'DelDb' request to delete a 'BlogPost' from the 299 | -- database. 300 | (DelDb key) :>>= nextStep -> do 301 | delete key 302 | runDbDSLInPersistent $ nextStep () 303 | -- Evaluate a 'UpdateDb request to update a 'BlogPost' in the 304 | -- database. 305 | (UpdateDb key blogPost) :>>= nextStep -> do 306 | replace key blogPost 307 | runDbDSLInPersistent $ nextStep () 308 | -- Throw an error to indicate that something went wrong. 309 | (ThrowDb servantErr) :>>= _ -> 310 | -- In actual usage, you may need to rollback the database 311 | -- transaction here. It doesn't matter for this simple 312 | -- demonstration, but in production you'll probably want to roll 313 | -- back the current transaction when you use 'Throw'. 314 | -- conn <- ask 315 | -- liftIO $ connRollback conn (getStmtConn conn) 316 | throwM servantErr 317 | 318 | ---------- 319 | ---------- 320 | -- main -- 321 | ---------- 322 | ---------- 323 | 324 | -- This is the main function. It basically does three things. 325 | -- 326 | -- 1. Open up a connection to the sqlite database "production.sqlite". In 327 | -- production this would probably be something like Postgres, MongoDB, 328 | -- AWS's DynamoDB, etc. 329 | -- 2. Perform migration. This creates the "blog_post" table in the 330 | -- database if it doesn't exist. 331 | -- 3. Run our 'server' function, which effectively runs the api. 332 | defaultMain :: IO () 333 | defaultMain = 334 | runStderrLoggingT $ withSqliteConn "production.sqlite" $ \conn -> do 335 | liftIO $ runSqlConn (runMigration migrateAll) conn 336 | liftIO $ putStrLn "\napi running on port 8080..." 337 | liftIO $ run 8080 $ serve blogPostApiProxy $ server $ runDbDSLInServant conn 338 | 339 | 340 | ----------------- 341 | ----------------- 342 | -- other stuff -- 343 | ----------------- 344 | ----------------- 345 | 346 | --- | XXX: Hack. 347 | -- 348 | -- In the dsl interpreter, we @'throwM' 'ServantErr'@. In order to use 349 | -- 'ServantErr' with 'throwM', 'ServantErr' needs to be an instance of 350 | -- 'Exception'. In production code you probably don't want to do this. It 351 | -- makes this example code slightly simpler, but in actual code you 352 | -- probably want to create your own exception type. 353 | -- 354 | -- If you reuse 'ServantErr' like this you're creating an 355 | -- . 356 | instance Exception ServantErr 357 | 358 | -- | XXX: Hack. 359 | -- 360 | -- We need this to be able to read @'Key' 'BlogPost'@ from our api (for 361 | -- example, in the "delete" api). This instance gives us the ability to 362 | -- create a @'Key' a@ from 'Text'. 363 | -- 364 | -- This isn't bad, per se, but it needs UndecidableInstances to be able to 365 | -- compile. You can see 366 | -- on how to do something similar without having to use 368 | -- UndecidableInstances. 369 | instance (ToBackendKey SqlBackend a) => FromText (Key a) where 370 | fromText :: Text -> Maybe (Key a) 371 | fromText text = toSqlKey <$> fromText text 372 | 373 | --------------------------------------------------------------------------------