From dd907523ba3401768b172aca2b9e73ed7f24fe93 Mon Sep 17 00:00:00 2001 From: Sean Chalmers Date: Tue, 8 May 2018 09:02:51 +1000 Subject: [PATCH] Full Course Layout Change with a shuffle. (#54) * Restructure entire course into a single library with multiple executable definitions. Makes working through the course a bit easier with respect to sandboxes, nix shells, and stack caching. Should be a side benefit of giving editor tooling a bit of an easier time. Lowers switch time between course levels. * Readme updates to suit new structure. Add comment to cabal file. * Syntax error in Travis yml file. Not sure where yet. * Applied some linting suggestions to travis file * Fixed missing comments in travis yml, removed duplicate executable entry in the cabal file * Added changelog file, vcs entry to cabal file * Fixing travis file, WIP. * Still trying * Added cabal.project file * Still trying (Travis) * Moved var declaration to higher level in travis.yml file. * Forgo the complexity of hvrs script and go low-tech. * Remove Haddocks from stack build. Add extra-deps because what was a working stack build is now failing for some reason, despite having the same version bounds and using the same LTS as before. * Added more deps to extra-deps to appease the stackbeast. * Updated base README * Readme tweaks, level 03 test updates * Moved Level07 to Level05, bumped other levels accordingly. * Moved 'Main' to 'Core'. Updated READMEs, first pass. Updated Cabal file. Updated Tests to handle change of Main to Core. * Proof read #3616 Lots of small fixes for file paths, wording, some additional exercises. Fixed up the tests to be more consistent as they've been reordered a few times and mostly left to rot. Readmes updated where needed. New exercise added to level07 for using the general `ExceptT` type. * Fix up some tests and avoid any more dynamic linking errors, I think * Fix up cabal config for doctests, missing packages and some exposed-modules * Removed use of Semigroup in tests to avoid CPP in cabal file for including semigroups package. Added bounds to base dependency for doctests test-suite --- .travis.yml | 228 +++++++--------- README.md | 63 +++-- applied-fp-course.cabal | 253 ++++++++++++++++++ applied-fp-course.nix | 23 ++ cabal-only-travis.yml | 132 --------- cabal.project | 9 +- changelog.md | 0 level04/default.nix => default.nix | 7 +- exe/Level01.hs | 9 + exe/Level02.hs | 9 + exe/Level03.hs | 9 + exe/Level04.hs | 9 + exe/Level05.hs | 9 + exe/Level06.hs | 9 + exe/Level07.hs | 9 + {level06 => files}/appconfig.json | 0 {level03 => files}/test.json | 0 level01/LICENCE | 31 --- level01/Setup.hs | 2 - level01/bin/Main.hs | 9 - level01/changelog.md | 5 - level01/default.nix | 13 - level01/level01.cabal | 93 ------- level01/level01.nix | 13 - level01/stack.yaml | 66 ----- level02/LICENCE | 31 --- level02/Setup.hs | 2 - level02/bin/Main.hs | 6 - level02/changelog.md | 5 - level02/default.nix | 13 - level02/level02.cabal | 97 ------- level02/level02.nix | 13 - level02/stack.yaml | 66 ----- level03/LICENCE | 31 --- level03/Setup.hs | 2 - level03/bin/Main.hs | 6 - level03/changelog.md | 5 - level03/default.nix | 13 - level03/level03.cabal | 113 -------- level03/level03.nix | 20 -- level03/stack.yaml | 66 ----- level03/tests/doctests.hs | 9 - level04/LICENCE | 31 --- level04/Setup.hs | 2 - level04/bin/Main.hs | 6 - level04/changelog.md | 5 - level04/level04.cabal | 132 --------- level04/level04.nix | 21 -- level04/stack.yaml | 66 ----- level04/test.json | 1 - level04/tests/doctests.hs | 11 - level05/LICENCE | 31 --- level05/README.md | 33 --- level05/Setup.hs | 2 - level05/appconfig.json | 3 - level05/bin/Main.hs | 6 - level05/changelog.md | 5 - level05/default.nix | 13 - level05/level05.cabal | 126 --------- level05/level05.nix | 21 -- level05/stack.yaml | 66 ----- level05/test.json | 3 - level05/tests/Test.hs | 58 ---- level05/tests/doctests.hs | 9 - level06/LICENCE | 31 --- level06/Setup.hs | 2 - level06/bin/Main.hs | 6 - level06/changelog.md | 5 - level06/default.nix | 13 - level06/level06.cabal | 136 ---------- level06/level06.nix | 23 -- level06/src/FirstApp/Conf.hs | 57 ---- level06/stack.yaml | 66 ----- level06/test.json | 1 - level06/tests/Test.hs | 89 ------ level06/tests/doctests.hs | 11 - level07/LICENCE | 31 --- level07/README.md | 8 - level07/Setup.hs | 2 - level07/appconfig.json | 6 - level07/bin/Main.hs | 6 - level07/changelog.md | 5 - level07/default.nix | 13 - level07/level07.cabal | 136 ---------- level07/level07.nix | 23 -- level07/src/FirstApp/Conf/CommandLine.hs | 61 ----- level07/src/FirstApp/Conf/File.hs | 39 --- level07/src/FirstApp/Main.hs | 176 ------------ level07/src/FirstApp/Responses.hs | 53 ---- level07/src/FirstApp/Types.hs | 248 ----------------- level07/stack.yaml | 66 ----- level07/test.json | 1 - level07/tests/doctests.hs | 11 - .../FirstApp/Main.hs => src/Level01/Core.hs | 3 +- {level01 => src/Level01}/README.md | 2 +- .../FirstApp/Main.hs => src/Level02/Core.hs | 6 +- {level02 => src/Level02}/README.md | 2 +- .../src/FirstApp => src/Level02}/Types.hs | 4 +- .../FirstApp/Main.hs => src/Level03/Core.hs | 16 +- {level03 => src/Level03}/README.md | 14 +- .../src/FirstApp => src/Level03}/Types.hs | 2 +- src/Level04/Conf.hs | 17 ++ .../FirstApp/Main.hs => src/Level04/Core.hs | 9 +- {level04/src/FirstApp => src/Level04}/DB.hs | 5 +- .../FirstApp => src/Level04}/DB/PostgreSQL.hs | 4 +- .../src/FirstApp => src/Level04}/DB/Types.hs | 4 +- {level04 => src/Level04}/README.md | 14 +- .../src/FirstApp => src/Level04}/Types.hs | 41 +-- .../Level04}/Types/CommentText.hs | 9 +- .../FirstApp => src/Level04}/Types/Error.hs | 8 +- .../FirstApp => src/Level04}/Types/Topic.hs | 13 +- src/Level05/AppM.hs | 109 ++++++++ {level04/src/FirstApp => src/Level05}/Conf.hs | 2 +- src/Level05/Core.hs | 179 +++++++++++++ {level07/src/FirstApp => src/Level05}/DB.hs | 59 ++-- .../FirstApp => src/Level05}/DB/PostgreSQL.hs | 4 +- .../src/FirstApp => src/Level05}/DB/Types.hs | 2 +- src/Level05/README.md | 7 + src/Level05/Types.hs | 131 +++++++++ .../Level05}/Types/CommentText.hs | 9 +- .../FirstApp => src/Level05}/Types/Error.hs | 10 +- .../FirstApp => src/Level05}/Types/Topic.hs | 13 +- {level07/src/FirstApp => src/Level06}/AppM.hs | 38 +-- {level05/src/FirstApp => src/Level06}/Conf.hs | 20 +- .../Level06}/Conf/CommandLine.hs | 4 +- .../src/FirstApp => src/Level06}/Conf/File.hs | 6 +- .../FirstApp/Main.hs => src/Level06/Core.hs | 41 ++- {level05/src/FirstApp => src/Level06}/DB.hs | 32 ++- .../FirstApp => src/Level06}/DB/PostgreSQL.hs | 4 +- .../src/FirstApp => src/Level06}/DB/Types.hs | 2 +- src/Level06/README.md | 19 ++ .../src/FirstApp => src/Level06}/Types.hs | 19 +- .../Level06}/Types/CommentText.hs | 4 +- .../FirstApp => src/Level06}/Types/Error.hs | 2 +- .../FirstApp => src/Level06}/Types/Topic.hs | 4 +- {level06/src/FirstApp => src/Level07}/AppM.hs | 56 ++-- {level07/src/FirstApp => src/Level07}/Conf.hs | 8 +- .../Level07}/Conf/CommandLine.hs | 4 +- .../src/FirstApp => src/Level07}/Conf/File.hs | 7 +- .../FirstApp/Main.hs => src/Level07/Core.hs | 86 ++---- {level06/src/FirstApp => src/Level07}/DB.hs | 16 +- .../FirstApp => src/Level07}/DB/PostgreSQL.hs | 4 +- .../src/FirstApp => src/Level07}/DB/Types.hs | 18 +- {level06 => src/Level07}/README.md | 5 +- .../src/FirstApp => src/Level07}/Responses.hs | 4 +- .../src/FirstApp => src/Level07}/Types.hs | 10 +- .../Level07}/Types/CommentText.hs | 4 +- .../FirstApp => src/Level07}/Types/Error.hs | 2 +- .../FirstApp => src/Level07}/Types/Topic.hs | 4 +- stack.yaml | 14 +- .../tests/Test.hs => tests/Level03Tests.hs | 13 +- .../tests/Test.hs => tests/Level04Tests.hs | 27 +- tests/Level05Tests.hs | 85 ++++++ tests/Level06Tests.hs | 74 +++++ .../tests/Test.hs => tests/Level07Tests.hs | 61 +++-- tests/Test.hs | 16 ++ tests/doctests.hs | 15 ++ 157 files changed, 1500 insertions(+), 3410 deletions(-) create mode 100644 applied-fp-course.cabal create mode 100644 applied-fp-course.nix delete mode 100644 cabal-only-travis.yml create mode 100644 changelog.md rename level04/default.nix => default.nix (66%) create mode 100644 exe/Level01.hs create mode 100644 exe/Level02.hs create mode 100644 exe/Level03.hs create mode 100644 exe/Level04.hs create mode 100644 exe/Level05.hs create mode 100644 exe/Level06.hs create mode 100644 exe/Level07.hs rename {level06 => files}/appconfig.json (100%) rename {level03 => files}/test.json (100%) delete mode 100644 level01/LICENCE delete mode 100644 level01/Setup.hs delete mode 100644 level01/bin/Main.hs delete mode 100644 level01/changelog.md delete mode 100644 level01/default.nix delete mode 100644 level01/level01.cabal delete mode 100644 level01/level01.nix delete mode 100644 level01/stack.yaml delete mode 100644 level02/LICENCE delete mode 100644 level02/Setup.hs delete mode 100644 level02/bin/Main.hs delete mode 100644 level02/changelog.md delete mode 100644 level02/default.nix delete mode 100644 level02/level02.cabal delete mode 100644 level02/level02.nix delete mode 100644 level02/stack.yaml delete mode 100644 level03/LICENCE delete mode 100644 level03/Setup.hs delete mode 100644 level03/bin/Main.hs delete mode 100644 level03/changelog.md delete mode 100644 level03/default.nix delete mode 100644 level03/level03.cabal delete mode 100644 level03/level03.nix delete mode 100644 level03/stack.yaml delete mode 100644 level03/tests/doctests.hs delete mode 100644 level04/LICENCE delete mode 100644 level04/Setup.hs delete mode 100644 level04/bin/Main.hs delete mode 100644 level04/changelog.md delete mode 100644 level04/level04.cabal delete mode 100644 level04/level04.nix delete mode 100644 level04/stack.yaml delete mode 100644 level04/test.json delete mode 100644 level04/tests/doctests.hs delete mode 100644 level05/LICENCE delete mode 100644 level05/README.md delete mode 100644 level05/Setup.hs delete mode 100644 level05/appconfig.json delete mode 100644 level05/bin/Main.hs delete mode 100644 level05/changelog.md delete mode 100644 level05/default.nix delete mode 100644 level05/level05.cabal delete mode 100644 level05/level05.nix delete mode 100644 level05/stack.yaml delete mode 100644 level05/test.json delete mode 100644 level05/tests/Test.hs delete mode 100644 level05/tests/doctests.hs delete mode 100644 level06/LICENCE delete mode 100644 level06/Setup.hs delete mode 100644 level06/bin/Main.hs delete mode 100644 level06/changelog.md delete mode 100644 level06/default.nix delete mode 100644 level06/level06.cabal delete mode 100644 level06/level06.nix delete mode 100644 level06/src/FirstApp/Conf.hs delete mode 100644 level06/stack.yaml delete mode 100644 level06/test.json delete mode 100644 level06/tests/Test.hs delete mode 100644 level06/tests/doctests.hs delete mode 100644 level07/LICENCE delete mode 100644 level07/README.md delete mode 100644 level07/Setup.hs delete mode 100644 level07/appconfig.json delete mode 100644 level07/bin/Main.hs delete mode 100644 level07/changelog.md delete mode 100644 level07/default.nix delete mode 100644 level07/level07.cabal delete mode 100644 level07/level07.nix delete mode 100644 level07/src/FirstApp/Conf/CommandLine.hs delete mode 100644 level07/src/FirstApp/Conf/File.hs delete mode 100644 level07/src/FirstApp/Main.hs delete mode 100644 level07/src/FirstApp/Responses.hs delete mode 100644 level07/src/FirstApp/Types.hs delete mode 100644 level07/stack.yaml delete mode 100644 level07/test.json delete mode 100644 level07/tests/doctests.hs rename level01/src/FirstApp/Main.hs => src/Level01/Core.hs (98%) rename {level01 => src/Level01}/README.md (91%) rename level02/src/FirstApp/Main.hs => src/Level02/Core.hs (95%) rename {level02 => src/Level02}/README.md (95%) rename {level02/src/FirstApp => src/Level02}/Types.hs (98%) rename level03/src/FirstApp/Main.hs => src/Level03/Core.hs (87%) rename {level03 => src/Level03}/README.md (78%) rename {level03/src/FirstApp => src/Level03}/Types.hs (98%) create mode 100644 src/Level04/Conf.hs rename level04/src/FirstApp/Main.hs => src/Level04/Core.hs (95%) rename {level04/src/FirstApp => src/Level04}/DB.hs (97%) rename {level04/src/FirstApp => src/Level04}/DB/PostgreSQL.hs (98%) rename {level04/src/FirstApp => src/Level04}/DB/Types.hs (94%) rename {level04 => src/Level04}/README.md (91%) rename {level04/src/FirstApp => src/Level04}/Types.hs (71%) rename {level07/src/FirstApp => src/Level04}/Types/CommentText.hs (64%) rename {level04/src/FirstApp => src/Level04}/Types/Error.hs (70%) rename {level04/src/FirstApp => src/Level04}/Types/Topic.hs (50%) create mode 100644 src/Level05/AppM.hs rename {level04/src/FirstApp => src/Level05}/Conf.hs (90%) create mode 100644 src/Level05/Core.hs rename {level07/src/FirstApp => src/Level05}/DB.hs (70%) rename {level06/src/FirstApp => src/Level05}/DB/PostgreSQL.hs (98%) rename {level05/src/FirstApp => src/Level05}/DB/Types.hs (97%) create mode 100644 src/Level05/README.md create mode 100644 src/Level05/Types.hs rename {level05/src/FirstApp => src/Level05}/Types/CommentText.hs (64%) rename {level07/src/FirstApp => src/Level05}/Types/Error.hs (59%) rename {level07/src/FirstApp => src/Level05}/Types/Topic.hs (50%) rename {level07/src/FirstApp => src/Level06}/AppM.hs (71%) rename {level05/src/FirstApp => src/Level06}/Conf.hs (72%) rename {level05/src/FirstApp => src/Level06}/Conf/CommandLine.hs (95%) rename {level05/src/FirstApp => src/Level06}/Conf/File.hs (92%) rename level05/src/FirstApp/Main.hs => src/Level06/Core.hs (82%) rename {level05/src/FirstApp => src/Level06}/DB.hs (86%) rename {level05/src/FirstApp => src/Level06}/DB/PostgreSQL.hs (98%) rename {level06/src/FirstApp => src/Level06}/DB/Types.hs (97%) create mode 100644 src/Level06/README.md rename {level05/src/FirstApp => src/Level06}/Types.hs (91%) rename {level04/src/FirstApp => src/Level06}/Types/CommentText.hs (80%) rename {level05/src/FirstApp => src/Level06}/Types/Error.hs (88%) rename {level05/src/FirstApp => src/Level06}/Types/Topic.hs (71%) rename {level06/src/FirstApp => src/Level07}/AppM.hs (69%) rename {level07/src/FirstApp => src/Level07}/Conf.hs (89%) rename {level06/src/FirstApp => src/Level07}/Conf/CommandLine.hs (95%) rename {level06/src/FirstApp => src/Level07}/Conf/File.hs (89%) rename level06/src/FirstApp/Main.hs => src/Level07/Core.hs (60%) rename {level06/src/FirstApp => src/Level07}/DB.hs (90%) rename {level07/src/FirstApp => src/Level07}/DB/PostgreSQL.hs (98%) rename {level07/src/FirstApp => src/Level07}/DB/Types.hs (68%) rename {level06 => src/Level07}/README.md (73%) rename {level06/src/FirstApp => src/Level07}/Responses.hs (92%) rename {level06/src/FirstApp => src/Level07}/Types.hs (96%) rename {level06/src/FirstApp => src/Level07}/Types/CommentText.hs (80%) rename {level06/src/FirstApp => src/Level07}/Types/Error.hs (87%) rename {level06/src/FirstApp => src/Level07}/Types/Topic.hs (70%) rename level03/tests/Test.hs => tests/Level03Tests.hs (92%) rename level04/tests/Test.hs => tests/Level04Tests.hs (79%) create mode 100644 tests/Level05Tests.hs create mode 100644 tests/Level06Tests.hs rename level07/tests/Test.hs => tests/Level07Tests.hs (59%) create mode 100644 tests/Test.hs create mode 100644 tests/doctests.hs diff --git a/.travis.yml b/.travis.yml index dfa753e..c400613 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,61 +1,56 @@ -# This is the complex Travis configuration, which is intended for use -# on open source libraries which need compatibility across multiple GHC -# versions, must work with cabal-install, and should be -# cross-platform. For more information and other options, see: +# This Travis job script has been generated by a script via # -# https://docs.haskellstack.org/en/stable/travis_ci/ +# runghc make_travis_yml_2.hs 'applied-fp-course.cabal' # -# Copy these contents into the root directory of your Github project in a file -# named .travis.yml - -# Use new container infrastructure to enable caching +# For more information, see https://github.com/hvr/multi-ghc-travis +# +language: c sudo: false -# Do not choose a language; we provide our own build tools. -language: generic +git: + submodules: false # whether to recursively clone submodules -# Caching so the next build will be fast too. cache: directories: - - $HOME/.ghc - - $HOME/.cabal - - $HOME/.stack + - $HOME/.cabal/packages + - $HOME/.cabal/store + - $HOME/.ghc + - $HOME/.stack + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $HOME/.cabal/packages/head.hackage -# The different configurations we want to test. We have BUILD=cabal which uses -# cabal-install, and BUILD=stack which uses Stack. More documentation on each -# of those below. -# -# We set the compiler values here to tell Travis to use a different -# cache file per set of arguments. -# -# If you need to have different apt packages for each combination in the -# matrix, you can use a line such as: -# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} matrix: include: - # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: - # https://github.com/hvr/multi-ghc-travis - - env: BUILD=cabal GHCVER=7.10.3 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-2.0,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.0.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.0.2" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.2.2" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.4.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.4.1" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal + compiler: "ghc-7.10.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}} - # Build with the newest GHC and cabal-install. This is an accepted failure, - # see below. - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC HEAD" - addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal + compiler: "ghc-8.0.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} - # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS - # variable, such as using --stack-yaml to point to a different file. + - env: BUILD=cabal + compiler: "ghc-8.2.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} + + - env: BUILD=cabal + compiler: "ghc-8.4.1" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}} + + # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS + # variable, such as using --stack-yaml to point to a different file. - env: BUILD=stack ARGS="" compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} @@ -100,102 +95,63 @@ matrix: os: osx allow_failures: - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + #- env: BUILD=stack ARGS="--resolver lts-6" - env: BUILD=stack ARGS="--resolver nightly" before_install: -# Using compiler above sets CC to an invalid value, so unset it -- unset CC - -# Store the list of levels -- LEVELS=$(ls -1d level*) - -# We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" -- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi - -# Download and unpack the stack executable -- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH -- mkdir -p ~/.local/bin -- | - if [ `uname` = "Darwin" ] - then - travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin - else - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - fi - - # Use the more reliable S3 mirror of Hackage - mkdir -p $HOME/.cabal - echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - - if [ "$CABALVER" != "1.16" ] - then - echo 'jobs: $ncpus' >> $HOME/.cabal/config - fi + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - ROOTDIR=$(pwd) + - mkdir -p $HOME/.local/bin + - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" + - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - echo $HCNUMVER + # Download and unpack the stack executable + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH + - mkdir -p ~/.local/bin + - | + if [ `uname` = "Darwin" ] + then + travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin + else + travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + fi install: -- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" -- if [ -f configure.ac ]; then autoreconf -i; fi -- | - set -x - case "$BUILD" in - stack) - # Add in extra-deps for older snapshots, as necessary - stack --no-terminal --install-ghc $ARGS build --bench --dry-run || ( \ - stack --no-terminal $ARGS build cabal-install && \ - stack --no-terminal $ARGS solver --update-config) + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - HADDOCK=${HADDOCK-true} + - INSTALLED=${INSTALLED-true} + - GHCHEAD=${GHCHEAD-false} + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + - | + case "$BUILD" in + stack) + # Add in extra-deps for older snapshots, as necessary + stack --no-terminal --install-ghc $ARGS build --bench --dry-run || ( \ + stack --no-terminal $ARGS build cabal-install && \ + stack --no-terminal $ARGS solver --update-config) - # Build the dependencies - stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies - ;; - cabal) - cabal --version - travis_retry cabal update - - # Get the list of packages from the stack.yaml file. Note that - # this will also implicitly run hpack as necessary to generate - # the .cabal files needed by cabal-install. - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - - ;; - esac - set +ex + # Build the dependencies + stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies + ;; + cabal) + cabal --version + travis_retry cabal update -v + ;; + esac +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. script: -- | - set -ex - case "$BUILD" in - stack) - stack --no-terminal $ARGS build --no-run-benchmarks --haddock --no-haddock-deps - ;; - cabal) + # Build with stack + - if [[ "$BUILD" == "stack" ]]; then stack --no-terminal $ARGS build --no-run-benchmarks; fi + # Build with cabal, using individual commands so we can see which part failed. + - if [[ "$BUILD" == "cabal" ]]; then cabal new-configure -w ${HC} --enable-tests --ghc-options -O0; fi + - if [[ "$BUILD" == "cabal" ]]; then cabal new-build -w ${HC} all; fi + - if [[ "$BUILD" == "cabal" ]]; then rm -rf ./dist-newstyle; fi - ORIGDIR=$(pwd) - - if [ $CABALVER != "2.0" ] - then - - cabal sandbox init - - for dir in $PACKAGES - do - cd $dir - echo "Processing $dir" - travis_retry cabal update - PKGVER=$(cabal info . | awk '{print $2;exit}') - - cabal install --only-dependencies --enable-tests - cabal configure --enable-tests --ghc-options -O0 - cabal build - - cd $ORIGDIR - done - else - cabal new-configure --project-file="cabal.project" --enable-tests --ghc-options -O0 - cabal new-build --project-file="cabal.project" all - fi - ;; - esac - set +ex +# REGENDATA ["applied-fp-course.cabal"] +# EOF diff --git a/README.md b/README.md index 7bcbef6..1efea87 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ [![Build Status](https://travis-ci.org/qfpl/applied-fp-course.svg?branch=master)](https://travis-ci.org/qfpl/applied-fp-course) - + This is a brand new course, so there are going to be rough edges. We invite you to submit issues or pull requests if you find errors or have suggestions on how to improve it. @@ -21,6 +21,7 @@ IRC on [Freenode](https://freenode.net/) in #qfpl or #fp-course. * Have a few months self-study to your name. * Want to know how to build larger applications with statically typed FP. * Are willing to accept that a web application is a sufficient choice. +* Can write the canonical function of type: ``Applicative f => [f a] -> f [a]`` ### We: @@ -39,30 +40,45 @@ IRC on [Freenode](https://freenode.net/) in #qfpl or #fp-course. ### Setup build tools: -Each level is a self-contained Haskell application, containing incomplete, or as -yet undefined, data types and functions. There is a Cabal and Nix file for each -level, so you can use either cabal sandboxes or a ``nix-shell``, depending on -your preference. +Each level is a self-contained Haskell module, containing incomplete, or as yet +undefined, data types and functions. + +We recommend using either a cabal sandbox, or a ``nix-shell``, depending on your +preference. To use a sandbox: + ```bash -$ cd +$ cd path/to/applied-fp-course $ cabal sandbox init -$ cabal install --only-dependencies +$ cabal install --only-dependencies --enable-tests $ cabal build $ $EDITOR README.md ``` -The normal cabal build commands should then work as expected. We do recommend -using cabal sandboxes as they provide a contained Haskell environment for a -given project. Easy to clean up, and package versions won't conflict with any -other sandboxed project you may be working on. + +We do recommend using cabal sandboxes as they provide a contained Haskell +environment for a given project. Easy to clean up, and package versions won't +conflict with any other sandboxed project you may be working on. + +If you're using a version of Cabal that is >=2.0 (use ``cabal --version`` to +find out), then you can use the ``new-*`` commands and you don't need a sandbox: + +```bash +$ cd path/to/applied-fp-course +$ cabal new-configure --enable-tests +$ cabal new-build -exe +$ $EDITOR src//README.md +``` + +The normal cabal build commands should then work as expected. To use the Nix Shell: ```bash -$ cd +$ cd path/to/applied-fp-course $ nix-shell -$ cabal build -$ $EDITOR README.md +$ cabal new-build -exe +$ $EDITOR src//README.md + ``` Once that completes you will be in a ``nix-shell`` environment with all the tools required to build the application for that level. Note that the @@ -70,7 +86,13 @@ levels build on each other, so you can go to the highest level and enter a nix-shell there, you will then have all the required tools for every level. The ``shell.nix`` is not provided, so if you have a different work-flow you can -utilise the derivation from the respective ``levelN.nix``. +utilise the derivation from the ``applied-fp-course.nix``. + +##### Stack + +Stack yaml configuration is provided and checked by our CI system for successful +builds. However the authors do not use stack, so we cannot promise to be able to +resolve stack related issues that may arise. Though we will do our best. :) ##### Please note... @@ -83,16 +105,16 @@ free [WebChat client](https://webchat.freenode.net). #### Subsequent lessons may contain spoilers, don't cheat yourself out of the experience! -There is a ``README.md`` file in each Level project that will provide instructions about -what the goal is for that specific level. +There is a ``README.md`` file in each Level module folder that will provide +instructions about what the goal is for that specific level. * Level 01 : Simple Hello World web app. * Level 02 : Define our application spec with types! * Level 03 : Testing & Tools (hspec & ghcid) * Level 04 : Database layer (sqlite-simple) -* Level 05 : Add some flexible configuration -* Level 06 : ReaderT & Refactoring -* Level 07 : ExceptT & Refactoring +* Level 05 : Better Error Handling Through ExceptT +* Level 06 : Add some flexible configuration +* Level 07 : ReaderT & Refactoring -- Coming Soon... * Level 08 : (Bonus Round) Lenses & Refactoring @@ -101,4 +123,3 @@ what the goal is for that specific level. * Level 09 : Add session controls (login, logout) and a protected route. So we can have something that resembles application state. For the purposes of modelling the state machine and implementing some property based tests. - diff --git a/applied-fp-course.cabal b/applied-fp-course.cabal new file mode 100644 index 0000000..f1e5e11 --- /dev/null +++ b/applied-fp-course.cabal @@ -0,0 +1,253 @@ +-- Initial level01.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: applied-fp-course + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://wiki.haskell.org/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Simplest of web apps for educational purposes. + +-- A longer description of the package. +description: Haskell course for people looking to start building larger applications. + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENCE + +-- The package author(s). +author: QFPL @ Data61 + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: sean.chalmers@data61.csiro.au + +-- A copyright notice. +copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) + +category: Education + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a README. +extra-source-files: changelog.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +tested-with: GHC==8.4.1 + , GHC==8.2.2 + , GHC==8.0.2 + , GHC==7.10.3 + +source-repository head + type: git + location: https://github.com/qfpl/applied-fp-course + +library + -- Modules included in this executable, other than Main. + exposed-modules: + Level01.Core + , Level02.Core + , Level02.Types + , Level03.Core + , Level03.Types + , Level04.Conf + , Level04.DB + , Level04.DB.Types + , Level04.Core + , Level04.Types + , Level04.Types.CommentText + , Level04.Types.Error + , Level04.Types.Topic + , Level05.AppM + , Level05.Conf + , Level05.DB + , Level05.DB.Types + , Level05.Core + , Level05.Types + , Level05.Types.CommentText + , Level05.Types.Error + , Level05.Types.Topic + , Level06.AppM + , Level06.Conf + , Level06.Conf.CommandLine + , Level06.Conf.File + , Level06.DB + , Level06.DB.Types + , Level06.Core + , Level06.Types + , Level06.Types.CommentText + , Level06.Types.Error + , Level06.Types.Topic + , Level07.AppM + , Level07.Conf + , Level07.Conf.CommandLine + , Level07.Conf.File + , Level07.DB + , Level07.DB.Types + , Level07.Core + , Level07.Responses + , Level07.Types + , Level07.Types.CommentText + , Level07.Types.Error + , Level07.Types.Topic + + ghc-options: -Wall + -fno-warn-unused-binds + -fno-warn-unused-do-bind + -fno-warn-unused-imports + -fno-warn-type-defaults + -ferror-spans + + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , wai == 3.2.* + , warp == 3.2.* + , http-types >= 0.9 && < 0.13 + , bytestring == 0.10.* + , text == 1.2.* + , optparse-applicative >= 0.13 && < 0.15 + , aeson == 1.* + , mtl == 2.2.* + , time >= 1.4 && < 1.10 + , sqlite-simple == 0.4.* + , sqlite-simple-errors == 0.6.* + , semigroups == 0.18.* + , transformers >= 0.4 && < 0.6 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + +test-suite app-fp-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + + hs-source-dirs: tests + main-is: Test.hs + + other-modules: Level03Tests + , Level04Tests + , Level05Tests + , Level06Tests + , Level07Tests + + build-depends: base >= 4.8 && <4.12 + , applied-fp-course + , wai == 3.2.* + , wai-extra == 3.0.* + , hspec >= 2.2 && < 3.0 + , hspec-wai >= 0.6 && < 0.10 + , bytestring == 0.10.* + , text == 1.2.* + , mtl == 2.2.* + +test-suite doctests + -- Base language which the package is written in. + default-language: Haskell2010 + type: exitcode-stdio-1.0 + + other-modules: Level04Tests + , Level05Tests + , Level06Tests + , Level07Tests + + ghc-options: -threaded + main-is: doctests.hs + hs-source-dirs: tests + build-depends: base >= 4.8 && <4.12 + , applied-fp-course + , mtl == 2.2.* + , hspec >= 2.2 && < 3.0 + , hspec-wai >= 0.6 && < 0.10 + , doctest >= 0.11 && < 0.16 + +-- Level Executables +executable level01-exe + -- .hs or .lhs file containing the Main module. + main-is: Level01.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 + +executable level02-exe + -- .hs or .lhs file containing the Main module. + main-is: Level02.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 + +executable level03-exe + -- .hs or .lhs file containing the Main module. + main-is: Level03.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 + +executable level04-exe + -- .hs or .lhs file containing the Main module. + main-is: Level04.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 + +executable level05-exe + -- .hs or .lhs file containing the Main module. + main-is: Level05.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 + +executable level06-exe + -- .hs or .lhs file containing the Main module. + main-is: Level06.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 + +executable level07-exe + -- .hs or .lhs file containing the Main module. + main-is: Level07.hs + -- Directories containing source files. + hs-source-dirs: exe + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.12 + , applied-fp-course + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/applied-fp-course.nix b/applied-fp-course.nix new file mode 100644 index 0000000..a44fb7e --- /dev/null +++ b/applied-fp-course.nix @@ -0,0 +1,23 @@ +{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai +, http-types, mtl, optparse-applicative, semigroups, sqlite-simple +, sqlite-simple-errors, stdenv, text, time, transformers, wai +, wai-extra, warp +}: +mkDerivation { + pname = "applied-fp-course"; + version = "0.1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson base bytestring http-types mtl optparse-applicative + semigroups sqlite-simple sqlite-simple-errors text time + transformers wai warp + ]; + executableHaskellDepends = [ base ]; + testHaskellDepends = [ + base bytestring doctest hspec hspec-wai mtl text wai wai-extra + ]; + description = "Simplest of web apps for educational purposes"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/cabal-only-travis.yml b/cabal-only-travis.yml deleted file mode 100644 index 48f2735..0000000 --- a/cabal-only-travis.yml +++ /dev/null @@ -1,132 +0,0 @@ -# This Travis job script has been generated by a script via -# -# runghc make_travis_yml_2.hs 'cabal.project' -# -# For more information, see https://github.com/hvr/multi-ghc-travis -# -language: c -sudo: false - -git: - submodules: false # whether to recursively clone submodules - -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - -before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - - - rm -rfv $HOME/.cabal/packages/head.hackage - -matrix: - include: - - compiler: "ghc-7.10.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} - -before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - -install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - INSTALLED=${INSTALLED-true} - - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project cabal.project.local - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \"level01\" \"level02\" \"level03\" \"level04\" \"level05\" \"level06\" \"level07\"\\n' > cabal.project" - - cat cabal.project - - if [ -f "level01/configure.ac" ]; then - (cd "level01" && autoreconf -i); - fi - - if [ -f "level02/configure.ac" ]; then - (cd "level02" && autoreconf -i); - fi - - if [ -f "level03/configure.ac" ]; then - (cd "level03" && autoreconf -i); - fi - - if [ -f "level04/configure.ac" ]; then - (cd "level04" && autoreconf -i); - fi - - if [ -f "level05/configure.ac" ]; then - (cd "level05" && autoreconf -i); - fi - - if [ -f "level06/configure.ac" ]; then - (cd "level06" && autoreconf -i); - fi - - if [ -f "level07/configure.ac" ]; then - (cd "level07" && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all - - rm -rf "level01"/.ghc.environment.* "level02"/.ghc.environment.* "level03"/.ghc.environment.* "level04"/.ghc.environment.* "level05"/.ghc.environment.* "level06"/.ghc.environment.* "level07"/.ghc.environment.* "level01"/dist "level02"/dist "level03"/dist "level04"/dist "level05"/dist "level06"/dist "level07"/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. -script: - # test that source-distributions can be generated - # - (cd "level01" && cabal sdist) - # - (cd "level02" && cabal sdist) - # - (cd "level03" && cabal sdist) - # - (cd "level04" && cabal sdist) - # - (cd "level05" && cabal sdist) - # - (cd "level06" && cabal sdist) - # - (cd "level07" && cabal sdist) - # - mv "level01"/dist/level01-*.tar.gz "level02"/dist/level02-*.tar.gz "level03"/dist/level03-*.tar.gz "level04"/dist/level04-*.tar.gz "level05"/dist/level05-*.tar.gz "level06"/dist/level06-*.tar.gz "level07"/dist/level07-*.tar.gz ${DISTDIR}/ - # - cd ${DISTDIR} || false - # - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: level01/level01.cabal level02/level02.cabal level03/level03.cabal level04/level04.cabal level05/level05.cabal level06/level06.cabal level07/level07.cabal\\n' > cabal.project" - - cat cabal.project - # this builds all libraries and executables (without tests/benchmarks) - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all - - # Build with installed constraints for packages in global-db - - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi - - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - # - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - - # cabal check - # - (cd level01 && cabal check) - # - (cd level02 && cabal check) - # - (cd level03 && cabal check) - # - (cd level04 && cabal check) - # - (cd level05 && cabal check) - # - (cd level06 && cabal check) - # - (cd level07 && cabal check) - - # haddock - - rm -rf ./dist-newstyle - - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi - -# REGENDATA ["cabal.project"] -# EOF diff --git a/cabal.project b/cabal.project index 74b4211..5356e76 100644 --- a/cabal.project +++ b/cabal.project @@ -1,8 +1 @@ -packages: - level01/ - level02/ - level03/ - level04/ - level05/ - level06/ - level07/ \ No newline at end of file +packages: . \ No newline at end of file diff --git a/changelog.md b/changelog.md new file mode 100644 index 0000000..e69de29 diff --git a/level04/default.nix b/default.nix similarity index 66% rename from level04/default.nix rename to default.nix index a265973..e3bacb6 100644 --- a/level04/default.nix +++ b/default.nix @@ -1,5 +1,6 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - +{ nixpkgs ? import {} +, compiler ? "default" +}: let inherit (nixpkgs) pkgs; @@ -7,7 +8,7 @@ let then pkgs.haskellPackages else pkgs.haskell.packages.${compiler}; - drv = haskellPackages.callPackage ./level04.nix {}; + drv = haskellPackages.callPackage ./applied-fp-course.nix {}; in if pkgs.lib.inNixShell then drv.env else drv diff --git a/exe/Level01.hs b/exe/Level01.hs new file mode 100644 index 0000000..eb9dad2 --- /dev/null +++ b/exe/Level01.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level01.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/exe/Level02.hs b/exe/Level02.hs new file mode 100644 index 0000000..0d182a3 --- /dev/null +++ b/exe/Level02.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level02.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/exe/Level03.hs b/exe/Level03.hs new file mode 100644 index 0000000..ba914aa --- /dev/null +++ b/exe/Level03.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level03.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/exe/Level04.hs b/exe/Level04.hs new file mode 100644 index 0000000..b9edccc --- /dev/null +++ b/exe/Level04.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level04.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Level04.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/exe/Level05.hs b/exe/Level05.hs new file mode 100644 index 0000000..8fe51ed --- /dev/null +++ b/exe/Level05.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level05.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Level05.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/exe/Level06.hs b/exe/Level06.hs new file mode 100644 index 0000000..6849ba0 --- /dev/null +++ b/exe/Level06.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level06.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/exe/Level07.hs b/exe/Level07.hs new file mode 100644 index 0000000..5fd8bfc --- /dev/null +++ b/exe/Level07.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Level07.Core as Core + +-- Our application will be built as a library that will be included in an +-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable +-- affair. +main :: IO () +main = Core.runApp diff --git a/level06/appconfig.json b/files/appconfig.json similarity index 100% rename from level06/appconfig.json rename to files/appconfig.json diff --git a/level03/test.json b/files/test.json similarity index 100% rename from level03/test.json rename to files/test.json diff --git a/level01/LICENCE b/level01/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level01/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level01/Setup.hs b/level01/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level01/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level01/bin/Main.hs b/level01/bin/Main.hs deleted file mode 100644 index fea5e5d..0000000 --- a/level01/bin/Main.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import qualified FirstApp.Main as Main - --- Our application will be built as a library that will be included in an --- executable. So our ``bin/Main.hs`` is a straightforward and unremarkable --- affair. We won't be updating this file. -main :: IO () -main = Main.runApp diff --git a/level01/changelog.md b/level01/changelog.md deleted file mode 100644 index 33b3947..0000000 --- a/level01/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level01 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level01/default.nix b/level01/default.nix deleted file mode 100644 index 9a4746b..0000000 --- a/level01/default.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage ./level01.nix {}; - -in - if pkgs.lib.inNixShell then drv.env else drv diff --git a/level01/level01.cabal b/level01/level01.cabal deleted file mode 100644 index 0a23cfa..0000000 --- a/level01/level01.cabal +++ /dev/null @@ -1,93 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level01 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 - -library - exposed-modules: FirstApp.Main - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable level01-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level01 - - -- Directories containing source files. - hs-source-dirs: bin - - -- Base language which the package is written in. - default-language: Haskell2010 - diff --git a/level01/level01.nix b/level01/level01.nix deleted file mode 100644 index 2475191..0000000 --- a/level01/level01.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ mkDerivation, stdenv, base, wai, warp, http-types }: - -mkDerivation { - pname = "level01"; - src = ./.; - version = "0.1.0.0"; - sha256 = "0"; - isLibrary = false; - isExecutable = true; - executableHaskellDepends = [ base wai warp http-types ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level01/stack.yaml b/level01/stack.yaml deleted file mode 100644 index 97a175f..0000000 --- a/level01/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/level02/LICENCE b/level02/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level02/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level02/Setup.hs b/level02/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level02/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level02/bin/Main.hs b/level02/bin/Main.hs deleted file mode 100644 index 88d8f08..0000000 --- a/level02/bin/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified FirstApp.Main as Main - -main :: IO () -main = Main.runApp diff --git a/level02/changelog.md b/level02/changelog.md deleted file mode 100644 index df9efa4..0000000 --- a/level02/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level02 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level02/default.nix b/level02/default.nix deleted file mode 100644 index 97098c4..0000000 --- a/level02/default.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage ./level02.nix {}; - -in - if pkgs.lib.inNixShell then drv.env else drv diff --git a/level02/level02.cabal b/level02/level02.cabal deleted file mode 100644 index 82daee8..0000000 --- a/level02/level02.cabal +++ /dev/null @@ -1,97 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level02 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 -library - exposed-modules: FirstApp.Types - , FirstApp.Main - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -fwarn-missing-import-lists - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - , bytestring == 0.10.* - , text == 1.2.* - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - - -executable level02-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level02 - - -- Directories containing source files. - hs-source-dirs: bin - - -- Base language which the package is written in. - default-language: Haskell2010 - diff --git a/level02/level02.nix b/level02/level02.nix deleted file mode 100644 index e9dac17..0000000 --- a/level02/level02.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ mkDerivation, base, wai, warp, http-types, stdenv }: -mkDerivation { - pname = "level02"; - version = "0.1.0.0"; - src = ./.; - isLibrary = false; - isExecutable = true; - executableHaskellDepends = [ - base wai warp http-types - ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level02/stack.yaml b/level02/stack.yaml deleted file mode 100644 index 90a6cee..0000000 --- a/level02/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/level03/LICENCE b/level03/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level03/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level03/Setup.hs b/level03/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level03/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level03/bin/Main.hs b/level03/bin/Main.hs deleted file mode 100644 index 323f840..0000000 --- a/level03/bin/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified FirstApp.Main as M - -main :: IO () -main = M.runApp diff --git a/level03/changelog.md b/level03/changelog.md deleted file mode 100644 index 25db4fe..0000000 --- a/level03/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level03 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level03/default.nix b/level03/default.nix deleted file mode 100644 index 7c34ccc..0000000 --- a/level03/default.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage ./level03.nix {}; - -in - if pkgs.lib.inNixShell then drv.env else drv diff --git a/level03/level03.cabal b/level03/level03.cabal deleted file mode 100644 index 73c206a..0000000 --- a/level03/level03.cabal +++ /dev/null @@ -1,113 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level03 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 - -library - -- Modules included in this executable, other than Main. - exposed-modules: FirstApp.Types - , FirstApp.Main - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -fwarn-missing-import-lists - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - , bytestring == 0.10.* - , text == 1.2.* - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable level03-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level03 - - -- Directories containing source files. - hs-source-dirs: bin - - -- Base language which the package is written in. - default-language: Haskell2010 - --- This is the declaration of a test-suite for your application. You may have --- multiple test suites in a single application, provided they are named --- differently. -test-suite level03-tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Test.hs - build-depends: base >= 4.8 && <4.12 - , level03 - , wai == 3.2.* - , wai-extra == 3.0.* - , hspec >= 2.2 && < 3.0 - , hspec-wai >= 0.6 && < 0.10 - , bytestring == 0.10.* diff --git a/level03/level03.nix b/level03/level03.nix deleted file mode 100644 index f0a33bc..0000000 --- a/level03/level03.nix +++ /dev/null @@ -1,20 +0,0 @@ -{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai -, http-types, optparse-applicative, stdenv, text, wai, wai-extra -, warp -}: -mkDerivation { - pname = "level03"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson base bytestring http-types optparse-applicative text wai warp - ]; - executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring doctest hspec hspec-wai wai wai-extra - ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level03/stack.yaml b/level03/stack.yaml deleted file mode 100644 index 97a175f..0000000 --- a/level03/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/level03/tests/doctests.hs b/level03/tests/doctests.hs deleted file mode 100644 index 4e2ee55..0000000 --- a/level03/tests/doctests.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Test.DocTest (doctest) - -main :: IO () -main = doctest - [ "-isrc" - , "src/FirstApp/Conf.hs" - ] diff --git a/level04/LICENCE b/level04/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level04/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level04/Setup.hs b/level04/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level04/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level04/bin/Main.hs b/level04/bin/Main.hs deleted file mode 100644 index 323f840..0000000 --- a/level04/bin/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified FirstApp.Main as M - -main :: IO () -main = M.runApp diff --git a/level04/changelog.md b/level04/changelog.md deleted file mode 100644 index e0041b6..0000000 --- a/level04/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level04 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level04/level04.cabal b/level04/level04.cabal deleted file mode 100644 index fb2f3ae..0000000 --- a/level04/level04.cabal +++ /dev/null @@ -1,132 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level04 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 - -library - -- Modules included in this executable, other than Main. - exposed-modules: FirstApp.Conf - , FirstApp.DB - , FirstApp.DB.Types - , FirstApp.Main - , FirstApp.Types - , FirstApp.Types.CommentText - , FirstApp.Types.Error - , FirstApp.Types.Topic - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -fwarn-missing-import-lists - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - , bytestring == 0.10.* - , text == 1.2.* - , optparse-applicative >= 0.13 && < 0.15 - , aeson == 1.* - , mtl == 2.2.* - , time >= 1.4 && < 1.10 - , sqlite-simple == 0.4.* - , sqlite-simple-errors == 0.6.* - , semigroups == 0.18.* - - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable level04-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Directories containing source files. - hs-source-dirs: bin - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level04 - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite level04-tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Test.hs - build-depends: base >= 4.8 && <4.12 - , level04 - , wai == 3.2.* - , wai-extra == 3.0.* - , hspec >= 2.2 && < 3.0 - , hspec-wai >= 0.6 && < 0.10 - , bytestring == 0.10.* - -test-suite doctests - -- Base language which the package is written in. - default-language: Haskell2010 - type: exitcode-stdio-1.0 - ghc-options: -threaded - main-is: doctests.hs - hs-source-dirs: tests - build-depends: base - , doctest >= 0.11 && < 0.16 - , semigroups == 0.18.* diff --git a/level04/level04.nix b/level04/level04.nix deleted file mode 100644 index f872279..0000000 --- a/level04/level04.nix +++ /dev/null @@ -1,21 +0,0 @@ -{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai -, http-types, mtl, optparse-applicative, sqlite-simple, semigroups -, sqlite-simple-errors, stdenv, text, time, wai, wai-extra, warp -}: -mkDerivation { - pname = "level04"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson base bytestring http-types mtl optparse-applicative - sqlite-simple sqlite-simple-errors text time wai warp semigroups - ]; - executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring doctest hspec hspec-wai wai wai-extra - ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level04/stack.yaml b/level04/stack.yaml deleted file mode 100644 index 97a175f..0000000 --- a/level04/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/level04/test.json b/level04/test.json deleted file mode 100644 index 0725d49..0000000 --- a/level04/test.json +++ /dev/null @@ -1 +0,0 @@ -{"foo":33} diff --git a/level04/tests/doctests.hs b/level04/tests/doctests.hs deleted file mode 100644 index 2774511..0000000 --- a/level04/tests/doctests.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Test.DocTest (doctest) - -main :: IO () -main = doctest - [ "-isrc" - , "src/FirstApp/Conf.hs" - , "src/FirstApp/DB.hs" - , "src/FirstApp/Types.hs" - ] diff --git a/level05/LICENCE b/level05/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level05/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level05/README.md b/level05/README.md deleted file mode 100644 index 6f99c47..0000000 --- a/level05/README.md +++ /dev/null @@ -1,33 +0,0 @@ -# Level 05 - -In this exercise we build some configuration capabilities into our application. - -This exercise will require a combination of building the right types to guide -your development, plus consulting plenty of documentation to leverage the chosen -packages. There may also be, depending on your level of interest, some external -reading for later as well. - -The steps for this level: -1) ``src/FirstApp/Types.hs`` -2) ``src/FirstApp/Conf/File.hs`` -3) ``src/FirstApp/Conf.hs`` -4) ``src/FirstApp/Main.hs`` - -The packages we will use for this are: - -- [Aeson](http://hackage.haskell.org/package/aeson) -- [Optparse Applicative](http://hackage.haskell.org/package/optparse-applicative) - -#### Aside: Tool Introduction - doctest - -This level utilises the [doctest](https://hackage.haskell.org/package/doctest) -tool to help us ensure our functions comply with some quick tests that are -written as comments in the source file. This is a port of the same technology -that exists in Python. - -You can see the new entry in the Cabal file as another ``test-suite``. The -``doctests.hs`` lists the files that have doctests that we want to run. The -``src/FirstApp/Conf/File.hs`` file contains some tests that you need to update -as part of the level. - -For details on running and writing doctests, refer to the documentation. diff --git a/level05/Setup.hs b/level05/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level05/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level05/appconfig.json b/level05/appconfig.json deleted file mode 100644 index 84482a7..0000000 --- a/level05/appconfig.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "dbFileName": "app_db.db" -} diff --git a/level05/bin/Main.hs b/level05/bin/Main.hs deleted file mode 100644 index 88d8f08..0000000 --- a/level05/bin/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified FirstApp.Main as Main - -main :: IO () -main = Main.runApp diff --git a/level05/changelog.md b/level05/changelog.md deleted file mode 100644 index 714644e..0000000 --- a/level05/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level05 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level05/default.nix b/level05/default.nix deleted file mode 100644 index ea9136f..0000000 --- a/level05/default.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage ./level05.nix {}; - -in - if pkgs.lib.inNixShell then drv.env else drv diff --git a/level05/level05.cabal b/level05/level05.cabal deleted file mode 100644 index a6d7dbb..0000000 --- a/level05/level05.cabal +++ /dev/null @@ -1,126 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level05 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 - -library - exposed-modules: FirstApp.Conf - , FirstApp.Conf.CommandLine - , FirstApp.Conf.File - , FirstApp.DB - , FirstApp.DB.Types - , FirstApp.Main - , FirstApp.Types - , FirstApp.Types.CommentText - , FirstApp.Types.Error - , FirstApp.Types.Topic - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - , bytestring == 0.10.* - , text == 1.2.* - , optparse-applicative >= 0.13 && < 0.15 - , aeson == 1.* - , time >= 1.4 && < 1.10 - , sqlite-simple == 0.4.* - , sqlite-simple-errors == 0.6.* - , semigroups == 0.18.* - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable level05-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level05 - - -- Directories containing source files. - hs-source-dirs: bin - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite level05-tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Test.hs - build-depends: base >= 4.8 && <4.12 - , level05 - , wai == 3.2.* - , wai-extra == 3.0.* - , hspec >= 2.2 && < 3.0 - , hspec-wai >= 0.6 && < 0.10 - , bytestring == 0.10.* -test-suite doctests - -- Base language which the package is written in. - default-language: Haskell2010 - type: exitcode-stdio-1.0 - ghc-options: -threaded - main-is: doctests.hs - hs-source-dirs: tests - build-depends: base - , level05 - , doctest >= 0.11 && < 0.16 diff --git a/level05/level05.nix b/level05/level05.nix deleted file mode 100644 index 4458f05..0000000 --- a/level05/level05.nix +++ /dev/null @@ -1,21 +0,0 @@ -{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai -, http-types, mtl, optparse-applicative, sqlite-simple, semigroups -, sqlite-simple-errors, stdenv, text, time, wai, wai-extra, warp -}: -mkDerivation { - pname = "level05"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson base bytestring http-types mtl optparse-applicative - sqlite-simple sqlite-simple-errors text time wai warp semigroups - ]; - executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring doctest hspec hspec-wai wai wai-extra - ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level05/stack.yaml b/level05/stack.yaml deleted file mode 100644 index 97a175f..0000000 --- a/level05/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/level05/test.json b/level05/test.json deleted file mode 100644 index 7cb871c..0000000 --- a/level05/test.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "foo": 33 -} diff --git a/level05/tests/Test.hs b/level05/tests/Test.hs deleted file mode 100644 index 837deb0..0000000 --- a/level05/tests/Test.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Monad (join) - -import Test.Hspec -import Test.Hspec.Wai - -import qualified System.Exit as Exit - -import qualified FirstApp.DB as DB -import qualified FirstApp.Main as Main -import qualified FirstApp.Types as Types - -main :: IO () -main = do - let dieWith m = print m >> Exit.exitFailure - - reqsE <- Main.prepareAppReqs - case reqsE of - - Left err -> dieWith err - - Right ( cfg, db ) -> do - let app' = pure ( Main.app cfg db ) - - flushTopic = - -- Clean up and yell about our errors - fmap ( either dieWith pure . join ) . - -- Purge all of the comments for this topic for our tests - traverse ( DB.deleteTopic db ) - -- We don't export the constructor so even for known values we have - -- to play by the rules. There is no - "Oh just this one time.", do it right. - $ Types.mkTopic "fudge" - - -- Run the tests with a DB topic flush between each spec - hspec . with ( flushTopic >> app' ) $ do - - -- AddRq Spec - describe "POST /topic/add" $ do - - it "Should return 200 with well formed request" $ do - post "/fudge/add" "Fred" `shouldRespondWith` "Success" - - it "Should 400 on empty input" $ - post "/fudge/add" "" `shouldRespondWith` 400 - - -- ViewRq Spec - describe "GET /topic/view" $ do - it "Should return 200 with content" $ do - post "/fudge/add" "Is super tasty." - get "/fudge/view" `shouldRespondWith` 200 - - -- ListRq Spec - describe "GET /list" $ do - it "Should return 200 with content" $ do - post "/fudge/add" "Is super tasty." - get "/list" `shouldRespondWith` "[\"fudge\"]" diff --git a/level05/tests/doctests.hs b/level05/tests/doctests.hs deleted file mode 100644 index 4e2ee55..0000000 --- a/level05/tests/doctests.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Test.DocTest (doctest) - -main :: IO () -main = doctest - [ "-isrc" - , "src/FirstApp/Conf.hs" - ] diff --git a/level06/LICENCE b/level06/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level06/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level06/Setup.hs b/level06/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level06/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level06/bin/Main.hs b/level06/bin/Main.hs deleted file mode 100644 index 323f840..0000000 --- a/level06/bin/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified FirstApp.Main as M - -main :: IO () -main = M.runApp diff --git a/level06/changelog.md b/level06/changelog.md deleted file mode 100644 index c9fb6db..0000000 --- a/level06/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level06 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level06/default.nix b/level06/default.nix deleted file mode 100644 index 6bf89e2..0000000 --- a/level06/default.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage ./level06.nix {}; - -in - if pkgs.lib.inNixShell then drv.env else drv diff --git a/level06/level06.cabal b/level06/level06.cabal deleted file mode 100644 index 3613014..0000000 --- a/level06/level06.cabal +++ /dev/null @@ -1,136 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level06 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 - -library - -- Modules included in this executable, other than Main. - exposed-modules: FirstApp.AppM - , FirstApp.Conf - , FirstApp.Conf.CommandLine - , FirstApp.Conf.File - , FirstApp.DB - , FirstApp.DB.Types - , FirstApp.Main - , FirstApp.Responses - , FirstApp.Types - , FirstApp.Types.CommentText - , FirstApp.Types.Error - , FirstApp.Types.Topic - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - , bytestring == 0.10.* - , text == 1.2.* - , optparse-applicative >= 0.13 && < 0.15 - , aeson == 1.* - , mtl == 2.2.* - , time >= 1.4 && < 1.10 - , sqlite-simple == 0.4.* - , sqlite-simple-errors == 0.6.* - , semigroups == 0.18.* - , transformers >= 0.4 && < 0.6 - - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable level06-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Directories containing source files. - hs-source-dirs: bin - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level06 - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite level06-tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Test.hs - build-depends: base >= 4.8 && <4.12 - , level06 - , mtl == 2.2.* - , wai == 3.2.* - , wai-extra == 3.0.* - , hspec >= 2.2 && < 3.0 - , hspec-wai >= 0.6 && < 0.10 - , bytestring == 0.10.* - -test-suite doctests - -- Base language which the package is written in. - default-language: Haskell2010 - type: exitcode-stdio-1.0 - ghc-options: -threaded - main-is: doctests.hs - hs-source-dirs: tests - build-depends: base - , doctest >= 0.11 && < 0.16 diff --git a/level06/level06.nix b/level06/level06.nix deleted file mode 100644 index 5ec0e7b..0000000 --- a/level06/level06.nix +++ /dev/null @@ -1,23 +0,0 @@ -{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai -, http-types, mtl, optparse-applicative, sqlite-simple, semigroups -, sqlite-simple-errors, stdenv, text, time, wai, wai-extra, warp -, transformers -}: -mkDerivation { - pname = "level06"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson base bytestring http-types mtl optparse-applicative - sqlite-simple sqlite-simple-errors text time wai warp semigroups - transformers - ]; - executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring doctest hspec hspec-wai wai wai-extra - ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level06/src/FirstApp/Conf.hs b/level06/src/FirstApp/Conf.hs deleted file mode 100644 index 5da08f6..0000000 --- a/level06/src/FirstApp/Conf.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-missing-methods #-} -module FirstApp.Conf - ( parseOptions - ) where - -import GHC.Word (Word16) - -import Data.Bifunctor (first) -import Data.Monoid (Last (..), (<>)) - -import FirstApp.Types (Conf (..), ConfigError (..), - DBFilePath (DBFilePath), - PartialConf (..), Port (Port)) - -import FirstApp.Conf.CommandLine (commandLineParser) -import FirstApp.Conf.File (parseJSONConfigFile) - --- We have some sane defaults that we can always rely on, so define them using --- our PartialConf. -defaultConf - :: PartialConf -defaultConf = PartialConf - (pure (Port 3000)) - (pure (DBFilePath "app_db.db")) - --- We need something that will take our PartialConf and see if can finally build --- a complete Conf record. Also we need to highlight any missing config values --- by providing the relevant error. -makeConfig - :: PartialConf - -> Either ConfigError Conf -makeConfig pc = Conf - <$> lastToEither MissingPort pcPort - <*> lastToEither MissingDBFilePath pcDBFilePath - where - -- You don't need to provide type signatures for most functions in where/let - -- sections. Sometimes the compiler might need a bit of help, or you would - -- like to be explicit in your intentions. - lastToEither - :: ConfigError - -> (PartialConf -> Last b) - -> Either ConfigError b - lastToEither e g = - (maybe (Left e) Right . getLast . g) pc - --- This is the function we'll actually export for building our configuration. --- Since it wraps all our efforts to read information from the command line, and --- the file, before combining it all and returning the required information. -parseOptions - :: FilePath - -> IO (Either ConfigError Conf) -parseOptions fp = - let mkCfg cli file = makeConfig (defaultConf <> file <> cli) - in do - cli' <- commandLineParser - ( >>= mkCfg cli' ) <$> parseJSONConfigFile fp diff --git a/level06/stack.yaml b/level06/stack.yaml deleted file mode 100644 index 97a175f..0000000 --- a/level06/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/level06/test.json b/level06/test.json deleted file mode 100644 index 0725d49..0000000 --- a/level06/test.json +++ /dev/null @@ -1 +0,0 @@ -{"foo":33} diff --git a/level06/tests/Test.hs b/level06/tests/Test.hs deleted file mode 100644 index 8a8d0d0..0000000 --- a/level06/tests/Test.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Monad.Reader (ask, reader) - -import Control.Monad (join) - -import Test.Hspec -import Test.Hspec.Wai - -import qualified System.Exit as Exit - -import FirstApp.AppM (Env) -import qualified FirstApp.AppM as AppM - -import qualified FirstApp.DB as DB -import qualified FirstApp.Main as Main -import qualified FirstApp.Types as Types - -main :: IO () -main = do - let dieWith m = print m >> Exit.exitFailure - - -- Keeping everything in sync with out larger application changes. - reqsE <- Main.prepareAppReqs - case reqsE of - - Left err -> dieWith err - - Right env -> do - let app' = pure ( Main.app env ) - - flushTopic :: IO () - flushTopic = AppM.runAppM (do - r <- traverse DB.deleteTopic ( Types.mkTopic "fudge" ) - either ( liftIO . dieWith ) pure $ join r - ) env - - -- We can't run the tests for our AppM in the same stage as our - -- application, because of the use of the 'with' function. As it expects - -- to be able to execute our tests by applying it to our 'Application'. - hspec $ appMTests env - - -- Run the tests with a DB topic flush between each spec - hspec . with ( flushTopic >> app' ) $ do - - -- AddRq Spec - describe "POST /topic/add" $ do - - it "Should return 200 with well formed request" $ - post "/fudge/add" "Fred" `shouldRespondWith` "Success" - - it "Should 400 on empty input" $ - post "/fudge/add" "" `shouldRespondWith` 400 - - -- ViewRq Spec - describe "GET /topic/view" $ - it "Should return 200 with content" $ do - post "/fudge/add" "Is super tasty." - get "/fudge/view" `shouldRespondWith` 200 - - -- ListRq Spec - describe "GET /list" $ - it "Should return 200 with content" $ do - post "/fudge/add" "Is super tasty." - get "/list" `shouldRespondWith` "[\"fudge\"]" - - --- These tests ensure that our AppM will do we want it to, with respect to the --- behaviour of 'ask', 'reader', and use in a Monad. -appMTests :: Env -> Spec -appMTests env = describe "AppM Tests" $ do - - it "ask should retrieve the Env" $ do - r <- AppM.runAppM ask env - ( AppM.envConfig r == AppM.envConfig env ) `shouldBe` True - - it "reader should run a function on the Env" $ do - let getDBfilepath = Types.dbFilePath . AppM.envConfig - - r <- AppM.runAppM ( reader getDBfilepath ) env - r `shouldBe` (getDBfilepath env) - - it "should let us run IO functions" $ do - let fn = do - e <- ask - AppM.envLoggingFn e "In a test!" - r <- AppM.runAppM fn env - r `shouldBe` () diff --git a/level06/tests/doctests.hs b/level06/tests/doctests.hs deleted file mode 100644 index 2774511..0000000 --- a/level06/tests/doctests.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Test.DocTest (doctest) - -main :: IO () -main = doctest - [ "-isrc" - , "src/FirstApp/Conf.hs" - , "src/FirstApp/DB.hs" - , "src/FirstApp/Types.hs" - ] diff --git a/level07/LICENCE b/level07/LICENCE deleted file mode 100644 index 9dd6055..0000000 --- a/level07/LICENCE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation -(CSIRO) ABN 41 687 119 230. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of QFPL nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/level07/README.md b/level07/README.md deleted file mode 100644 index b684cf5..0000000 --- a/level07/README.md +++ /dev/null @@ -1,8 +0,0 @@ -# Level 07 - -Handling those `Either` values everywhere is a bit awkward, this exercise -introduces another monad transformer, ``ExceptT``. As well as the concept of a -'transformer stack' and what benefits it can provide. - -Start in ``src/FirstApp/AppM.hs``. - diff --git a/level07/Setup.hs b/level07/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/level07/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/level07/appconfig.json b/level07/appconfig.json deleted file mode 100644 index 1d200fd..0000000 --- a/level07/appconfig.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "port": 3000, - "helloMsg": "Functional Programming is neat.", - "tableName": "comments", - "dbName": "firstapp" -} diff --git a/level07/bin/Main.hs b/level07/bin/Main.hs deleted file mode 100644 index 323f840..0000000 --- a/level07/bin/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified FirstApp.Main as M - -main :: IO () -main = M.runApp diff --git a/level07/changelog.md b/level07/changelog.md deleted file mode 100644 index 3db9ce6..0000000 --- a/level07/changelog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for level07 - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/level07/default.nix b/level07/default.nix deleted file mode 100644 index 72d9e6b..0000000 --- a/level07/default.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default" }: - -let - inherit (nixpkgs) pkgs; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage ./level07.nix {}; - -in - if pkgs.lib.inNixShell then drv.env else drv diff --git a/level07/level07.cabal b/level07/level07.cabal deleted file mode 100644 index 867091a..0000000 --- a/level07/level07.cabal +++ /dev/null @@ -1,136 +0,0 @@ --- Initial level01.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: level07 - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- https://wiki.haskell.org/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: Simplest of web apps - --- A longer description of the package. --- description: - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENCE - --- The package author(s). -author: QFPL @ Data61 - --- An email address to which users can send suggestions, bug reports, and --- patches. -maintainer: sean.chalmers@data61.csiro.au - --- A copyright notice. -copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) - -category: Education - -build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: ChangeLog.md - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - -tested-with: GHC==8.2.2 - , GHC==8.0.2 - , GHC==7.10.3 - -library - -- Modules included in this executable, other than Main. - exposed-modules: FirstApp.AppM - , FirstApp.Conf - , FirstApp.Conf.CommandLine - , FirstApp.Conf.File - , FirstApp.DB - , FirstApp.DB.Types - , FirstApp.Main - , FirstApp.Responses - , FirstApp.Types - , FirstApp.Types.CommentText - , FirstApp.Types.Error - , FirstApp.Types.Topic - - ghc-options: -Wall - -fno-warn-unused-binds - -fno-warn-unused-do-bind - -fno-warn-unused-imports - -fno-warn-type-defaults - -ferror-spans - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , wai == 3.2.* - , warp == 3.2.* - , http-types >= 0.9 && < 0.13 - , bytestring == 0.10.* - , text == 1.2.* - , optparse-applicative >= 0.13 && < 0.15 - , aeson == 1.* - , mtl == 2.2.* - , time >= 1.4 && < 1.10 - , sqlite-simple == 0.4.* - , sqlite-simple-errors == 0.6.* - , semigroups == 0.18.* - , transformers >= 0.4 && < 0.6 - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 - -executable level07-exe - -- .hs or .lhs file containing the Main module. - main-is: Main.hs - - -- Directories containing source files. - hs-source-dirs: bin - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.12 - , level07 - - -- Base language which the package is written in. - default-language: Haskell2010 - -test-suite level07-tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Test.hs - build-depends: base >= 4.8 && <4.12 - , level07 - , wai == 3.2.* - , wai-extra == 3.0.* - , hspec >= 2.2 && < 3.0 - , hspec-wai >= 0.6 && < 0.10 - , bytestring == 0.10.* - , text == 1.2.* - , mtl == 2.2.* - -test-suite doctests - -- Base language which the package is written in. - default-language: Haskell2010 - type: exitcode-stdio-1.0 - ghc-options: -threaded - main-is: doctests.hs - hs-source-dirs: tests - build-depends: base - , doctest >= 0.11 && < 0.16 diff --git a/level07/level07.nix b/level07/level07.nix deleted file mode 100644 index 50c1905..0000000 --- a/level07/level07.nix +++ /dev/null @@ -1,23 +0,0 @@ -{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai -, http-types, mtl, optparse-applicative, sqlite-simple, semigroups -, sqlite-simple-errors, stdenv, text, time, wai, wai-extra, warp -, transformers -}: -mkDerivation { - pname = "level07"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson base bytestring http-types mtl optparse-applicative - sqlite-simple sqlite-simple-errors text time wai warp semigroups - transformers - ]; - executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base bytestring doctest hspec hspec-wai text wai wai-extra - ]; - description = "Simplest of web apps"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/level07/src/FirstApp/Conf/CommandLine.hs b/level07/src/FirstApp/Conf/CommandLine.hs deleted file mode 100644 index 8887719..0000000 --- a/level07/src/FirstApp/Conf/CommandLine.hs +++ /dev/null @@ -1,61 +0,0 @@ -module FirstApp.Conf.CommandLine - ( commandLineParser - ) where - -import Data.Monoid (Last (Last), (<>)) - -import Options.Applicative (Parser, eitherReader, execParser, - fullDesc, header, help, helper, info, - long, metavar, option, optional, progDesc, - short, strOption) - -import Text.Read (readEither) - -import FirstApp.Types (DBFilePath (DBFilePath), - PartialConf (PartialConf), Port (Port)) - --- | Command Line Parsing - --- This is an example of using the ``optparse-applicative`` package to build our command line --- parser. As this particular problem is fraught with silly dangers and we appreciate someone else --- having eaten this gremlin on our behalf. -commandLineParser - :: IO PartialConf -commandLineParser = - let mods = fullDesc - <> progDesc "Manage comments for something" - <> header "Your first Haskell app!" - in - execParser $ info (helper <*> partialConfParser) mods - --- Combine the smaller parsers into our larger ``PartialConf`` type. -partialConfParser - :: Parser PartialConf -partialConfParser = - PartialConf <$> portParser <*> dbFilePathParser - --- Parse the Port value off the command line args and into a Last wrapper. -portParser - :: Parser (Last Port) -portParser = - let - mods = long "port" - <> short 'p' - <> metavar "PORT" - <> help "TCP Port to accept requests on" - -- A custom parser to turn a String into a Word16, before putting it into a Port - portReader = eitherReader (fmap Port . readEither) - in - Last <$> optional (option portReader mods) - --- Parse the DBFilePath from the input string into our type and into a Last wrapper. -dbFilePathParser - :: Parser (Last DBFilePath) -dbFilePathParser = - let - mods = long "db-filepath" - <> short 'd' - <> metavar "DBFILEPATH" - <> help "File path for our SQLite Database file." - in - Last <$> optional (DBFilePath <$> strOption mods) diff --git a/level07/src/FirstApp/Conf/File.hs b/level07/src/FirstApp/Conf/File.hs deleted file mode 100644 index c835fd7..0000000 --- a/level07/src/FirstApp/Conf/File.hs +++ /dev/null @@ -1,39 +0,0 @@ -module FirstApp.Conf.File where - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS - -import Data.Bifunctor (first) - -import Control.Exception (try) - -import qualified Data.Aeson as Aeson - -import FirstApp.Types (ConfigError (..), PartialConf) - --- Doctest setup section --- $setup --- >>> :set -XOverloadedStrings - --- | Update these tests when you've completed this function. --- --- | readConfFile --- >>> readConfFile "badFileName.no" --- Left (ConfigFileReadError badFileName.no: openBinaryFile: does not exist (No such file or directory)) --- >>> readConfFile "test.json" --- Right "{\"foo\":33}\n" --- -readConfFile - :: FilePath - -> IO ( Either ConfigError ByteString ) -readConfFile fp = - first ConfigFileReadError <$> try (LBS.readFile fp) - --- Construct the function that will take a ``FilePath``, read it in, decode it, --- and construct our ``PartialConf``. -parseJSONConfigFile - :: FilePath - -> IO ( Either ConfigError PartialConf ) -parseJSONConfigFile fp = - (first JSONDecodeError . Aeson.eitherDecode =<<) <$> readConfFile fp - diff --git a/level07/src/FirstApp/Main.hs b/level07/src/FirstApp/Main.hs deleted file mode 100644 index 4513551..0000000 --- a/level07/src/FirstApp/Main.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module FirstApp.Main - ( runApp - , prepareAppReqs - , app - ) where - -import Control.Monad.Except (ExceptT (ExceptT), - runExceptT) -import Control.Monad.IO.Class (liftIO) - -import Network.Wai (Application, Request, - Response, pathInfo, - requestMethod, - strictRequestBody) -import Network.Wai.Handler.Warp (run) - -import Data.Bifunctor (first) -import Data.Either (Either (Left, Right), - either) - -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8) -import Data.Text.IO (hPutStrLn) - -import qualified Data.ByteString.Lazy.Char8 as LBS - -import Database.SQLite.SimpleErrors.Types (SQLiteResponse) - -import System.IO (stderr) - -import qualified FirstApp.DB as DB - -import qualified FirstApp.Conf as Conf -import qualified FirstApp.Responses as Res -import FirstApp.Types (Conf (..), - ConfigError (..), - Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute), - RqType (AddRq, ListRq, ViewRq), - confPortToWai, - mkCommentText, mkTopic) - -import FirstApp.AppM (AppM, - Env (Env, envConfig, envDB), - runAppM, liftEither) - --- Our start-up process is becoming more complicated and could fail in new and --- interesting ways. But we also want to be able to capture these errors in a --- single type so that we can deal with the entire start-up process as a whole. -data StartUpError - = ConfErr ConfigError - | DbInitErr SQLiteResponse - deriving Show - -runApp - :: IO () -runApp = do - appE <- prepareAppReqs - either print runWithDbConn appE - where - runWithDbConn env = - appWithDb env >> DB.closeDB (envDB env) - - appWithDb env = - run ( confPortToWai $ envConfig env ) (app env) - --- Monad transformers can be used without needing to write the newtype. The --- constructor for ExceptT has a type of :: m (Either e a). So if you have --- multiple functions that match that pattern and you don't want to have to --- thread the error handling needle yourself. You can apply the constructor to --- the functions and work directly on the values, knowing that the error --- handling will work as expected. Then you `runExceptT` and produce the final --- Either value. -prepareAppReqs - :: IO (Either StartUpError Env) -prepareAppReqs = - error "Copy your completed 'prepareAppReqs' and refactor to match the new type signature" - where - logToErr :: Text -> AppM () - logToErr = liftIO . hPutStrLn stderr - - toStartUpErr :: (a -> StartUpError) -> IO (Either a c) -> ExceptT StartUpError IO c - toStartUpErr = error "toStartUpErr not reimplemented" - - -- Take our possibly failing configuration/db functions with their unique - -- error types and turn them into a consistently typed ExceptT. We can then - -- use them in a `do` block as if the Either isn't there. Extracting the - -- final result before returning. - initConf :: ExceptT StartUpError IO Conf - initConf = toStartUpErr ConfErr $ Conf.parseOptions "appconfig.json" - - initDB :: Conf -> ExceptT StartUpError IO DB.FirstAppDB - initDB cfg = toStartUpErr DbInitErr $ DB.initDB (dbFilePath cfg) - -app - :: Env - -> Application -app env rq cb = do - e <- requestToResponse - resp <- either handleError pure e - cb resp - where - logToErr :: Text -> IO () - logToErr = liftIO . hPutStrLn stderr - - requestToResponse :: IO (Either Error Response) - requestToResponse = runAppM ( mkRequest rq >>= handleRequest ) env - - handleError :: Error -> IO Response - handleError e = mkErrorResponse e <$ ( logToErr . Text.pack . show ) e - --- This function has changed quite a bit since we changed our DB functions to be --- part of AppM. We no longer have to deal with the extra layer of the returned --- Either and these functions share the same Monad, AppM. -handleRequest - :: RqType - -> AppM Response -handleRequest ( AddRq t c ) = - -- We've cleaned this branch up a bit more by dropping our use of `const` as - -- we can use the Functor operator that ignores the result on the right hand - -- side and returns the result of the function on the left. - Res.resp200 "Success" <$ DB.addCommentToTopic t c -handleRequest ( ViewRq t ) = - Res.resp200Json <$> DB.getComments t -handleRequest ListRq = - Res.resp200Json <$> DB.getTopics - -mkRequest - :: Request - -> AppM RqType -mkRequest rq = - liftEither =<< case ( pathInfo rq, requestMethod rq ) of - -- Commenting on a given topic - ( [t, "add"], "POST" ) -> - liftIO $ mkAddRequest t <$> strictRequestBody rq - -- View the comments on a given topic - ( [t, "view"], "GET" ) -> - pure ( mkViewRequest t ) - -- List the current topics - ( ["list"], "GET" ) -> - pure mkListRequest - -- We don't care about any other requests so throw your hands in the air - _ -> - pure ( Left UnknownRoute ) - -mkAddRequest - :: Text - -> LBS.ByteString - -> Either Error RqType -mkAddRequest ti c = AddRq - <$> mkTopic ti - <*> (mkCommentText . decodeUtf8 . LBS.toStrict) c - -mkViewRequest - :: Text - -> Either Error RqType -mkViewRequest = - fmap ViewRq . mkTopic - -mkListRequest - :: Either Error RqType -mkListRequest = - Right ListRq - -mkErrorResponse - :: Error - -> Response -mkErrorResponse UnknownRoute = - Res.resp404 "Unknown Route" -mkErrorResponse EmptyCommentText = - Res.resp400 "Empty Comment" -mkErrorResponse EmptyTopic = - Res.resp400 "Empty Topic" -mkErrorResponse ( DBError _ ) = - Res.resp500 "OH NOES" diff --git a/level07/src/FirstApp/Responses.hs b/level07/src/FirstApp/Responses.hs deleted file mode 100644 index 9e2b216..0000000 --- a/level07/src/FirstApp/Responses.hs +++ /dev/null @@ -1,53 +0,0 @@ -module FirstApp.Responses where - -import Network.Wai (Response, responseLBS) - -import Network.HTTP.Types (Status, hContentType, status200, - status400, status404, status500) - -import qualified Data.ByteString.Lazy.Char8 as LBS - -import Data.Aeson (ToJSON) -import qualified Data.Aeson as A -import FirstApp.Types (ContentType (JSON, PlainText), - renderContentType) - -mkResponse - :: Status - -> ContentType - -> LBS.ByteString - -> Response -mkResponse sts ct msg = - responseLBS sts [(hContentType, renderContentType ct)] msg - -resp200 - :: LBS.ByteString - -> Response -resp200 = - mkResponse status200 PlainText - -resp404 - :: LBS.ByteString - -> Response -resp404 = - mkResponse status404 PlainText - -resp400 - :: LBS.ByteString - -> Response -resp400 = - mkResponse status400 PlainText - --- Some new helpers for different statuses and content types -resp500 - :: LBS.ByteString - -> Response -resp500 = - mkResponse status500 PlainText - -resp200Json - :: ToJSON a - => a - -> Response -resp200Json = - mkResponse status200 JSON . A.encode diff --git a/level07/src/FirstApp/Types.hs b/level07/src/FirstApp/Types.hs deleted file mode 100644 index 4d42221..0000000 --- a/level07/src/FirstApp/Types.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -module FirstApp.Types - ( Error (..) - , ConfigError (..) - , PartialConf (..) - , Port (..) - , DBFilePath (..) - , Conf (..) - , FirstAppDB (..) - , RqType (..) - , ContentType (..) - , Comment (..) - , Topic - , CommentText - , mkTopic - , getTopic - , mkCommentText - , getCommentText - , renderContentType - , fromDbComment - , confPortToWai - ) where - -import System.IO.Error (IOError) - -import GHC.Generics (Generic) -import GHC.Word (Word16) - -import Data.ByteString (ByteString) -import Data.Text (Text) - -import Data.List (stripPrefix) -import Data.Maybe (fromMaybe) -import Data.Monoid (Last (..)) -import Data.Semigroup (Semigroup ((<>))) - -import Data.Aeson (ToJSON, FromJSON (..), (.:?)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A - -import Data.Time (UTCTime) - -import Database.SQLite.Simple (Connection) -import Database.SQLite.SimpleErrors.Types (SQLiteResponse) - -import FirstApp.DB.Types (DbComment (..)) -import FirstApp.Types.Error (Error ( UnknownRoute - , EmptyCommentText - , EmptyTopic - , DBError - )) -import FirstApp.Types.CommentText ( CommentText - , mkCommentText - , getCommentText - ) -import FirstApp.Types.Topic (Topic, mkTopic, getTopic) - -newtype CommentId = CommentId Int - deriving (Show, ToJSON) - -data Comment = Comment - { commentId :: CommentId - , commentTopic :: Topic - , commentText :: CommentText - , commentTime :: UTCTime - } - -- Generic has been added to our deriving list. - deriving ( Show, Generic ) - --- Strip the prefix (which may fail if the prefix isn't present), fall --- back to the original label if need be, then camel-case the name. - --- | modFieldLabel --- >>> modFieldLabel "commentId" --- "id" --- >>> modFieldLabel "topic" --- "topic" --- >>> modFieldLabel "" --- "" -modFieldLabel - :: String - -> String -modFieldLabel l = - A.camelTo2 '_' - . fromMaybe l - $ stripPrefix "comment" l - -instance ToJSON Comment where - -- This is one place where we can take advantage of our Generic instance. Aeson - -- already has the encoding functions written for anything that implements the - -- Generic typeclass. So we don't have to write our encoding, we tell Aeson to - -- build it. - toEncoding = A.genericToEncoding opts - where - -- These options let us make some minor adjustments to how Aeson treats - -- our type. Our only adjustment is to alter the field names a little, to - -- remove the 'comment' prefix and use an Aeson function to handle the - -- rest of the name. This accepts any 'String -> String' function but it's - -- wise to keep the modifications simple. - opts = A.defaultOptions - { A.fieldLabelModifier = modFieldLabel - } - --- For safety we take our stored DbComment and try to construct a Comment that --- we would be okay with showing someone. However unlikely it may be, this is a --- nice method for separating out the back and front end of a web app and --- providing greater guarantees about data cleanliness. -fromDbComment - :: DbComment - -> Either Error Comment -fromDbComment dbc = - Comment (CommentId $ dbCommentId dbc) - <$> (mkTopic $ dbCommentTopic dbc) - <*> (mkCommentText $ dbCommentComment dbc) - <*> (pure $ dbCommentTime dbc) - -data RqType - = AddRq Topic CommentText - | ViewRq Topic - | ListRq - --- Provide a type to list our response content types so we don't try to --- do the wrong thing with what we meant to be used as text or JSON etc. -data ContentType - = PlainText - | JSON - -renderContentType - :: ContentType - -> ByteString -renderContentType PlainText = "text/plain" -renderContentType JSON = "application/json" - ------------------ --- Config Types ------------------ - --- This is an alternative way of defining a `newtype`. You define it as a simple --- record and this lets you specify an unwrapping function at the same time. Which --- technique you choose is a matter for your specific needs and preference. --- -newtype Port = Port - { getPort :: Word16 } - deriving (Eq, Show) - -newtype DBFilePath = DBFilePath - { getDBFilePath :: FilePath } - deriving (Eq, Show) - --- The ``Conf`` type will need: --- - A customisable port number: ``Port`` --- - A filepath for our SQLite database: ``DBFilePath`` -data Conf = Conf - { port :: Port - , dbFilePath :: DBFilePath - } - deriving Eq - --- We're storing our Port as a Word16 to be more precise and prevent invalid --- values from being used in our application. However Wai is not so stringent. --- To accommodate this and make our lives a bit easier, we will write this --- helper function to take ``Conf`` value and convert it to an ``Int``. -confPortToWai - :: Conf - -> Int -confPortToWai = - fromIntegral . getPort . port - --- Similar to when we were considering our application types, leave this empty --- for now and add to it as you go. -data ConfigError - = MissingPort - | MissingDBFilePath - | JSONDecodeError String - | ConfigFileReadError IOError - deriving Show - --- Our application will be able to load configuration from both a file and --- command line input. We want to be able to use the command line to temporarily --- override the configuration from our file. How do we combine the different --- inputs to enable this property? - --- We want the command line configuration to take precedence over the File --- configuration, so if we think about combining each of our ``Conf`` records, --- we want to be able to write something like this: - --- ``defaults <> file <> commandLine`` - --- We can use the ``Monoid`` typeclass to handle combining the ``Conf`` records --- together, and the ``Last`` type to wrap up our values to handle the desired --- precedence. The ``Last`` type is a wrapper for Maybe that when used with its --- ``Monoid`` instance will always preference the last ``Just`` value that it --- has: - --- Last (Just 3) <> Last (Just 1) = Last (Just 1) --- Last Nothing <> Last (Just 1) = Last (Just 1) --- Last (Just 1) <> Last Nothing = Last (Just 1) - --- To make this easier, we'll make a new type ``PartialConf`` that will have our --- ``Last`` wrapped values. We can then define a ``Monoid`` instance for it and --- have our ``Conf`` be a known good configuration. -data PartialConf = PartialConf - { pcPort :: Last Port - , pcDBFilePath :: Last DBFilePath - } - --- Before we can define our ``Monoid`` instance for ``PartialConf``, we'll have --- to define a Semigroup instance. We define our ``(<>)`` function to lean --- on the ``Semigroup`` instance for Last to always get the last value. -instance Semigroup PartialConf where - _a <> _b = PartialConf - { pcPort = error "pcPort (<>) not implemented" - , pcDBFilePath = error "pcDBFilePath (<>) not implemented" - } - --- We now define our ``Monoid`` instance for ``PartialConf``. Allowing us to --- define our always empty configuration, which would always fail our --- requirements. We just define `mappend` to be an alias of ``(<>)`` -instance Monoid PartialConf where - mempty = PartialConf mempty mempty - mappend = (<>) - --- When it comes to reading the configuration options from the command-line, we --- use the 'optparse-applicative' package. This part of the exercise has already --- been completed for you, feel free to have a look through the 'CommandLine' --- module and see how it works. --- --- For reading the configuration from the file, we're going to use the aeson --- library to handle the parsing and decoding for us. In order to do this, we --- have to tell aeson how to go about converting the JSON into our PartialConf --- data structure. -instance FromJSON PartialConf where - parseJSON = A.withObject "PartialConf" $ \o -> PartialConf - <$> parseToLast "port" Port o - <*> parseToLast "dbFilePath" DBFilePath o - where - parseToLast k c o = - Last . fmap c <$> o .:? k - --- We have a data type to simplify passing around the information we need to run --- our database queries. This also allows things to change over time without --- having to rewrite all of the functions that need to interact with DB related --- things in different ways. -newtype FirstAppDB = FirstAppDB - { dbConn :: Connection - } diff --git a/level07/stack.yaml b/level07/stack.yaml deleted file mode 100644 index 97a175f..0000000 --- a/level07/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.4 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/level07/test.json b/level07/test.json deleted file mode 100644 index 0725d49..0000000 --- a/level07/test.json +++ /dev/null @@ -1 +0,0 @@ -{"foo":33} diff --git a/level07/tests/doctests.hs b/level07/tests/doctests.hs deleted file mode 100644 index 2774511..0000000 --- a/level07/tests/doctests.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Test.DocTest (doctest) - -main :: IO () -main = doctest - [ "-isrc" - , "src/FirstApp/Conf.hs" - , "src/FirstApp/DB.hs" - , "src/FirstApp/Types.hs" - ] diff --git a/level01/src/FirstApp/Main.hs b/src/Level01/Core.hs similarity index 98% rename from level01/src/FirstApp/Main.hs rename to src/Level01/Core.hs index a775b6d..3b3f659 100644 --- a/level01/src/FirstApp/Main.hs +++ b/src/Level01/Core.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -module FirstApp.Main (runApp) where +module Level01.Core (runApp) where import Network.Wai (Application, Request, Response, ResponseReceived, responseLBS) @@ -42,4 +42,3 @@ app _ cb = -- executable Main.hs. runApp :: IO () runApp = run undefined undefined - diff --git a/level01/README.md b/src/Level01/README.md similarity index 91% rename from level01/README.md rename to src/Level01/README.md index f90d062..7c8cb8b 100644 --- a/level01/README.md +++ b/src/Level01/README.md @@ -2,7 +2,7 @@ The purpose of this exercise is to whet our appetite by creating a basic web app. The focus will be on reading the [Hackage] documentation for the [Wai] -framework. Consult the ``src/FirstApp/Main.hs`` to find the parts that are +framework. Consult the ``src/Level01/Core.hs`` to find the parts that are missing and what we need from the [Wai] package to build our "Hello, World!" application. diff --git a/level02/src/FirstApp/Main.hs b/src/Level02/Core.hs similarity index 95% rename from level02/src/FirstApp/Main.hs rename to src/Level02/Core.hs index 771e360..150c714 100644 --- a/level02/src/FirstApp/Main.hs +++ b/src/Level02/Core.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Main (runApp) where +module Level02.Core (runApp) where import Network.Wai (Application, Request, Response, pathInfo, requestMethod, responseLBS, @@ -16,12 +16,12 @@ import Data.Either (either) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) -import FirstApp.Types (ContentType, Error, RqType, +import Level02.Types (ContentType, Error, RqType, mkCommentText, mkTopic, renderContentType) -- -------------------------------------------- --- - Don't start here, go to FirstApp.Types! - +-- - Don't start here, go to Level02.Types! - -- -------------------------------------------- -- | Some helper functions to make our lives a little more DRY. diff --git a/level02/README.md b/src/Level02/README.md similarity index 95% rename from level02/README.md rename to src/Level02/README.md index 93a40ab..c3c2d23 100644 --- a/level02/README.md +++ b/src/Level02/README.md @@ -38,7 +38,7 @@ GET //view GET /list ``` -The starting point for this exercise is the ``src/FirstApp/Types.hs``. +The starting point for this exercise is the ``src/Level02/Types.hs``. ### Running the program: diff --git a/level02/src/FirstApp/Types.hs b/src/Level02/Types.hs similarity index 98% rename from level02/src/FirstApp/Types.hs rename to src/Level02/Types.hs index b4f1088..6e531f7 100644 --- a/level02/src/FirstApp/Types.hs +++ b/src/Level02/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-dodgy-exports #-} -module FirstApp.Types +module Level02.Types ( Topic , CommentText , ContentType (..) @@ -122,3 +122,5 @@ getCommentText -> Text getCommentText = error "getCommentText not implemented" + +---- Go to `src/Level02/Core.hs` next diff --git a/level03/src/FirstApp/Main.hs b/src/Level03/Core.hs similarity index 87% rename from level03/src/FirstApp/Main.hs rename to src/Level03/Core.hs index 2400f96..acf3100 100644 --- a/level03/src/FirstApp/Main.hs +++ b/src/Level03/Core.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Main (runApp, app) where +module Level03.Core (runApp, app) where import Network.Wai (Application, Request, Response, pathInfo, requestMethod, responseLBS, @@ -16,7 +16,7 @@ import Data.Either (either) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) -import FirstApp.Types (ContentType (PlainText), Error (EmptyCommentText, EmptyTopic, UnknownRoute), +import Level03.Types (ContentType (PlainText), Error (EmptyCommentText, EmptyTopic, UnknownRoute), RqType (AddRq, ListRq, ViewRq), mkCommentText, mkTopic, renderContentType) @@ -83,17 +83,13 @@ mkRequest mkRequest rq = case ( pathInfo rq, requestMethod rq ) of -- Commenting on a given topic - ( [t, "add"], "POST" ) -> - mkAddRequest t <$> strictRequestBody rq + ( [t, "add"], "POST" ) -> mkAddRequest t <$> strictRequestBody rq -- View the comments on a given topic - ( [t, "view"], "GET" ) -> - pure ( mkViewRequest t ) + ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) -- List the current topics - ( ["list"], "GET" ) -> - pure mkListRequest + ( ["list"], "GET" ) -> pure mkListRequest -- Finally we don't care about any other requests so throw your hands in the air - _ -> - pure ( Left UnknownRoute ) + _ -> pure ( Left UnknownRoute ) mkAddRequest :: Text diff --git a/level03/README.md b/src/Level03/README.md similarity index 78% rename from level03/README.md rename to src/Level03/README.md index bd2d1ad..9bae819 100644 --- a/level03/README.md +++ b/src/Level03/README.md @@ -23,6 +23,14 @@ $ cabal configure --enable-tests $ cabal test ``` +If you're using Cabal 2.0 or greater (You can check your cabal version with `$ cabal --version`): + +```shell +$ cabal new-configure --enable-tests +$ cabal new-build --enable-tests +$ cabal new-test +``` + For a stack environment: ```shell @@ -33,10 +41,10 @@ To load the tests in the REPL: ```shell # Cabal -$ cabal repl level03-tests +$ cabal new-repl app-fp-tests # Stack -$ stack ghci level03:test:level03-tests +$ stack ghci applied-fp-course:test:app-fp-tests ``` To run the tests in the repl: @@ -45,7 +53,7 @@ To run the tests in the repl: *Main> :main ``` -Start in ``tests/Test.hs``. +Start in ``tests/Level03Tests.hs``. [HSpec]: (http://hspec.github.io/) [hspec-wai]: (https://hackage.haskell.org/package/hspec-wai) diff --git a/level03/src/FirstApp/Types.hs b/src/Level03/Types.hs similarity index 98% rename from level03/src/FirstApp/Types.hs rename to src/Level03/Types.hs index 221d275..bd9fb59 100644 --- a/level03/src/FirstApp/Types.hs +++ b/src/Level03/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Types +module Level03.Types ( Error (..) , RqType (..) , ContentType (..) diff --git a/src/Level04/Conf.hs b/src/Level04/Conf.hs new file mode 100644 index 0000000..6bc340b --- /dev/null +++ b/src/Level04/Conf.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +module Level04.Conf + ( Conf (..) + , firstAppConfig + ) where + +-- We'll do more with this later, but we can easily stub it to keep things +-- rolling and come back to refactor it later. +data Conf = Conf + { dbFilePath :: FilePath + } + +-- A aimple default that we could just inline this right where we need it. But +-- types are so cheap that we can easily prepare ourselves for "doing the right +-- thing". +firstAppConfig :: Conf +firstAppConfig = Conf "app_db.db" diff --git a/level04/src/FirstApp/Main.hs b/src/Level04/Core.hs similarity index 95% rename from level04/src/FirstApp/Main.hs rename to src/Level04/Core.hs index 9a527e1..1814108 100644 --- a/level04/src/FirstApp/Main.hs +++ b/src/Level04/Core.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Main +module Level04.Core ( runApp , prepareAppReqs , app @@ -32,9 +32,9 @@ import qualified Data.Aeson as A import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.Conf (Conf, firstAppConfig) -import qualified FirstApp.DB as DB -import FirstApp.Types (ContentType (JSON, PlainText), +import Level04.Conf (Conf, firstAppConfig) +import qualified Level04.DB as DB +import Level04.Types (ContentType (JSON, PlainText), Error (EmptyCommentText, EmptyTopic, UnknownRoute), RqType (AddRq, ListRq, ViewRq), mkCommentText, mkTopic, @@ -54,7 +54,6 @@ runApp = error "runApp needs re-implementing" -- -- 1) Load the configuration. -- 2) Attempt to initialise the database. --- 3) Combine the results into a tuple -- -- Our application configuration is defined in Conf.hs -- diff --git a/level04/src/FirstApp/DB.hs b/src/Level04/DB.hs similarity index 97% rename from level04/src/FirstApp/DB.hs rename to src/Level04/DB.hs index a49ce72..1e09543 100644 --- a/level04/src/FirstApp/DB.hs +++ b/src/Level04/DB.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -module FirstApp.DB +module Level04.DB ( FirstAppDB (FirstAppDB) , initDB , closeDB @@ -21,7 +21,7 @@ import qualified Database.SQLite.Simple as Sql import qualified Database.SQLite.SimpleErrors as Sql import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.Types (Comment, CommentText, +import Level04.Types (Comment, CommentText, Error, Topic) -- ------------------------------------------------------------------------| @@ -95,7 +95,6 @@ addCommentToTopic = in error "addCommentToTopic not implemented" - getTopics :: FirstAppDB -> IO (Either Error [Topic]) diff --git a/level04/src/FirstApp/DB/PostgreSQL.hs b/src/Level04/DB/PostgreSQL.hs similarity index 98% rename from level04/src/FirstApp/DB/PostgreSQL.hs rename to src/Level04/DB/PostgreSQL.hs index f22d00b..8d788ab 100644 --- a/level04/src/FirstApp/DB/PostgreSQL.hs +++ b/src/Level04/DB/PostgreSQL.hs @@ -3,7 +3,7 @@ -- postgresql-simple package. It is missing the very helpful error handling of -- the sqlite-simple-errors package. The postgresql-simple package is littered -- with exceptions which are not visible in the types, so be wary. -module FirstApp.DB.PostgreSQL where +module Level04.DB.PostgreSQL where -- import GHC.Int (Int64) @@ -15,7 +15,7 @@ module FirstApp.DB.PostgreSQL where -- import Database.PostgreSQL.Simple.Types (Identifier (..)) -- import qualified Database.PostgreSQL.Simple as PG --- import FirstApp.Types +-- import Level04.Types -- newtype Table = Table -- { getTableName :: Text } diff --git a/level04/src/FirstApp/DB/Types.hs b/src/Level04/DB/Types.hs similarity index 94% rename from level04/src/FirstApp/DB/Types.hs rename to src/Level04/DB/Types.hs index 1d3bbcc..681f237 100644 --- a/level04/src/FirstApp/DB/Types.hs +++ b/src/Level04/DB/Types.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-methods #-} -module FirstApp.DB.Types where +module Level04.DB.Types where import Data.Text (Text) import Data.Time (UTCTime) @@ -25,4 +25,4 @@ data DBComment = DBComment instance FromRow DBComment where fromRow = error "FromRow DBComment instance not implemented" --- Now move to ``src/FirstApp/Types.hs`` +-- Now move to ``src/Level04/Types.hs`` diff --git a/level04/README.md b/src/Level04/README.md similarity index 91% rename from level04/README.md rename to src/Level04/README.md index de6323e..dcc9901 100644 --- a/level04/README.md +++ b/src/Level04/README.md @@ -20,15 +20,15 @@ Also we will not necessarily provide all of the required imports any more, there may be other things you have to bring into scope. The steps for this level: -1) ``src/FirstApp/DB/Types.hs`` -2) ``src/FirstApp/Types.hs`` -3) ``src/FirstApp/DB.hs`` -4) ``src/FirstApp/Main.hs`` +1) ``src/Level04/DB/Types.hs`` +2) ``src/Level04/Types.hs`` +3) ``src/Level04/DB.hs`` +4) ``src/Level04/Core.hs`` For the sake of simplicity, any configuration requirements will be hardcoded in -``FirstApp/Conf.hs`` for now. We will return to that in the next level. +``Level04/Conf.hs`` for now. We will return to that in the next level. -NB: The PostgreSQL example module is in ``src/FirstApp/DB/PostgreSQL.hs``. +NB: The PostgreSQL example module is in ``src/Level04/DB/PostgreSQL.hs``. # Useful Typeclasses @@ -44,7 +44,7 @@ traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b) This is very useful when you want to perform an action on every element of a list, but that action will return the new result in a some ``Applicative`` -context. +context. To help build some intuition for how this function can be useful, write out the type signature for ``traverse``, but replace the ``f`` with ``Either e``, diff --git a/level04/src/FirstApp/Types.hs b/src/Level04/Types.hs similarity index 71% rename from level04/src/FirstApp/Types.hs rename to src/Level04/Types.hs index abb0318..39349b4 100644 --- a/level04/src/FirstApp/Types.hs +++ b/src/Level04/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Types +module Level04.Types ( Error (..) , RqType (..) , ContentType (..) @@ -16,29 +16,31 @@ module FirstApp.Types , fromDbComment ) where -import GHC.Generics (Generic) +import GHC.Generics (Generic) -import Data.ByteString (ByteString) -import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Text (Text) -import Data.List (stripPrefix) -import Data.Maybe (fromMaybe) +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) -import Data.Aeson (ToJSON (toJSON)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A +import Data.Aeson (ToJSON (toJSON)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A -import Data.Time (UTCTime) +import Data.Time (UTCTime) + +import Level04.DB.Types (DBComment) + +-- Notice how we've moved these types into their own modules. It's cheap and +-- easy to add modules to carve out components in a Haskell application. So +-- whenever you think that a module is too big, covers more than one piece of +-- distinct functionality, or you want to carve out a particular piece of code, +-- just spin up another module. +import Level04.Types.CommentText (CommentText, getCommentText, mkCommentText) +import Level04.Types.Error (Error (EmptyCommentText, EmptyTopic, UnknownRoute)) +import Level04.Types.Topic (Topic, getTopic, mkTopic) -import FirstApp.DB.Types (DBComment) -import FirstApp.Types.CommentText (CommentText, mkCommentText - , getCommentText) -import FirstApp.Types.Error (Error( UnknownRoute - , EmptyCommentText - , EmptyTopic - ) - ) -import FirstApp.Types.Topic (Topic, mkTopic, getTopic) -- This is the `Comment` record that we will be sending to users, it's a simple -- record type, containing an `Int`, `Topic`, `CommentText`, and `UTCTime`. @@ -46,7 +48,6 @@ import FirstApp.Types.Topic (Topic, mkTopic, getTopic) -- well. This saves us some effort when it comes to creating encoding/decoding -- instances. Since our types are all simple types at the end of the day, we're -- able to let GHC do the work. - newtype CommentId = CommentId Int deriving (Eq, Show, ToJSON) diff --git a/level07/src/FirstApp/Types/CommentText.hs b/src/Level04/Types/CommentText.hs similarity index 64% rename from level07/src/FirstApp/Types/CommentText.hs rename to src/Level04/Types/CommentText.hs index c52f31a..a2c8c96 100644 --- a/level07/src/FirstApp/Types/CommentText.hs +++ b/src/Level04/Types/CommentText.hs @@ -1,15 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module FirstApp.Types.CommentText +module Level04.Types.CommentText ( CommentText , mkCommentText , getCommentText ) where -import FirstApp.Types.Error (Error(EmptyCommentText), nonEmptyText) +import Level04.Types.Error (Error (EmptyCommentText), nonEmptyText) -import Data.Text (Text) -import Data.Aeson (ToJSON) +import Data.Aeson (ToJSON) +import Data.Text (Text) newtype CommentText = CommentText Text deriving (Show, ToJSON) diff --git a/level04/src/FirstApp/Types/Error.hs b/src/Level04/Types/Error.hs similarity index 70% rename from level04/src/FirstApp/Types/Error.hs rename to src/Level04/Types/Error.hs index 1c23cb7..58ef447 100644 --- a/level04/src/FirstApp/Types/Error.hs +++ b/src/Level04/Types/Error.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} - -module FirstApp.Types.Error (Error(..), nonEmptyText) where +module Level04.Types.Error + ( Error(..) + , nonEmptyText + ) where import Data.Text (Text) @@ -8,7 +10,7 @@ data Error = UnknownRoute | EmptyCommentText | EmptyTopic - -- We need another constructor for our DB error types. + -- Add another constructor for our DB error types. deriving (Eq, Show) nonEmptyText diff --git a/level04/src/FirstApp/Types/Topic.hs b/src/Level04/Types/Topic.hs similarity index 50% rename from level04/src/FirstApp/Types/Topic.hs rename to src/Level04/Types/Topic.hs index f18fe10..dfe5750 100644 --- a/level04/src/FirstApp/Types/Topic.hs +++ b/src/Level04/Types/Topic.hs @@ -1,11 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Level04.Types.Topic + ( Topic + , mkTopic + , getTopic + ) where -module FirstApp.Types.Topic (Topic, mkTopic, getTopic) where +import Level04.Types.Error (Error (EmptyTopic), nonEmptyText) -import FirstApp.Types.Error (Error(EmptyTopic), nonEmptyText) - -import Data.Text (Text) -import Data.Aeson (ToJSON) +import Data.Aeson (ToJSON) +import Data.Text (Text) newtype Topic = Topic Text deriving (Show, ToJSON) diff --git a/src/Level05/AppM.hs b/src/Level05/AppM.hs new file mode 100644 index 0000000..0a76739 --- /dev/null +++ b/src/Level05/AppM.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Level05.AppM where + +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) + +import Data.Text (Text) + +import Level05.Types (Error) + +import Data.Bifunctor (first) + +-- We're going to add a very useful abstraction to our application. We'll +-- automate away the explicit error handling and inspection of our Either values +-- while preserving the type-level information that tells us what can go wrong. +-- +-- To do this we will create a newtype `AppM` that is a shorthand way of +-- describing the return type of a function that may contain an error. +-- +-- Our `AppM` type will work in the same manner as the Functor/Applicative/Monad +-- instances for Either, with functions being applied to the Right value and +-- everything been ignored if a Left value is encountered, returning that Left +-- value. With the added bonus of allowing us to perform `IO` actions! +-- +-- f <$> (Left e) = Left e +-- f <$> (Right a) = Right (f a) +-- +-- (Left e) >>= f = Left e +-- (Right a) >>= f = f a +-- +-- This means when we have a function doing this sort of shuffling: +-- +-- foo :: IO (Either Error Value) +-- foo = do +-- aE <- mightFail +-- either (pure . Left) needsAButMightFail aE +-- where +-- mightFail :: IO (Either Error Int) +-- alsoMightFail :: Int -> IO (Either Error Value) +-- +-- We can wrap our functions with AppM and we can work directly with the +-- values we expect to appear on the happy path, knowing that if the sad path is +-- encountered, the structure of our AppM will automatically handle it for us. + +newtype AppM a = AppM (IO (Either Error a)) +-- This structure allows us to start writing our functions in terms of +-- constraints. As an example, if we wanted to abstract over IO and indicate +-- that instead of the concrete type we wanted a constraint that allows for IO +-- actions. Our AppM would look more like this: +-- +-- AppM m a = AppM ( m (Either Error a) ) +-- +-- Then our functions would look like: +-- +-- foo :: MonadIO m => Int -> AppM m a +-- +-- Or we could not use a concrete type for Error +-- +-- AppM e m a = AppM ( m (Either e a) ) + +runAppM + :: AppM a + -> IO (Either Error a) +runAppM (AppM m) = + m + +instance Functor AppM where + fmap :: (a -> b) -> AppM a -> AppM b + fmap = error "fmap for AppM not implemented" + +instance Applicative AppM where + pure :: a -> AppM a + pure = error "pure for AppM not implemented" + + (<*>) :: AppM (a -> b) -> AppM a -> AppM b + (<*>) = error "spaceship for AppM not implemented" + +instance Monad AppM where + return :: a -> AppM a + return = error "return for AppM not implemented" + + (>>=) :: AppM a -> (a -> AppM b) -> AppM b + (>>=) = error "bind for AppM not implemented" + +instance MonadIO AppM where + liftIO :: IO a -> AppM a + liftIO = error "liftIO for AppM not implemented" + +instance MonadError Error AppM where + throwError :: Error -> AppM a + throwError = error "throwError for AppM not implemented" + + catchError :: AppM a -> (Error -> AppM a) -> AppM a + catchError = error "catchError for AppM not implemented" + +-- This is a helper function that will `lift` an Either value into our new AppM +-- by applying `throwError` to the Left value, and using `pure` to lift the +-- Right value into the AppM. +-- +-- throwError :: MonadError e m => e -> m a +-- pure :: Applicative m => a -> m a +-- +liftEither + :: Either Error a + -> AppM a +liftEither = + error "throwLeft not implemented" diff --git a/level04/src/FirstApp/Conf.hs b/src/Level05/Conf.hs similarity index 90% rename from level04/src/FirstApp/Conf.hs rename to src/Level05/Conf.hs index 0e91449..f3b33ed 100644 --- a/level04/src/FirstApp/Conf.hs +++ b/src/Level05/Conf.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Conf +module Level05.Conf ( Conf (..) , firstAppConfig ) where diff --git a/src/Level05/Core.hs b/src/Level05/Core.hs new file mode 100644 index 0000000..0c1c9b2 --- /dev/null +++ b/src/Level05/Core.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +module Level05.Core + ( runApp + , app + , prepareAppReqs + ) where + +import Control.Monad.IO.Class (liftIO) + +import Network.Wai (Application, Request, + Response, pathInfo, + requestMethod, responseLBS, + strictRequestBody) +import Network.Wai.Handler.Warp (run) + +import Network.HTTP.Types (Status, hContentType, + status200, status400, + status404, status500) + +import qualified Data.ByteString.Lazy as LBS + +import Data.Either (either) +import Data.Monoid ((<>)) + +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) + +import Database.SQLite.SimpleErrors.Types (SQLiteResponse) + +import Data.Aeson (ToJSON) +import qualified Data.Aeson as A + +import Level05.AppM (AppM, liftEither, runAppM) +import qualified Level05.Conf as Conf +import qualified Level05.DB as DB +import Level05.Types (ContentType (..), + Error (..), + RqType (AddRq, ListRq, ViewRq), + mkCommentText, mkTopic, + renderContentType) + +-- Our start-up is becoming more complicated and could fail in new and +-- interesting ways. But we also want to be able to capture these errors in a +-- single type so that we can deal with the entire start-up process as a whole. +data StartUpError + = DbInitErr SQLiteResponse + deriving Show + +runApp :: IO () +runApp = do + -- Load our configuration + cfgE <- prepareAppReqs + -- Loading the configuration can fail, so we have to take that into account now. + case cfgE of + Left err -> undefined + Right _cfg -> run undefined undefined + +-- We need to complete the following steps to prepare our app requirements: +-- +-- 1) Load the configuration. +-- 2) Attempt to initialise the database. +-- +-- Our application configuration is defined in Conf.hs +-- +prepareAppReqs + :: IO ( Either StartUpError DB.FirstAppDB ) +prepareAppReqs = + error "copy your prepareAppReqs from the previous level." + +-- | Some helper functions to make our lives a little more DRY. +mkResponse + :: Status + -> ContentType + -> LBS.ByteString + -> Response +mkResponse sts ct = + responseLBS sts [(hContentType, renderContentType ct)] + +resp200 + :: ContentType + -> LBS.ByteString + -> Response +resp200 = + mkResponse status200 + +resp404 + :: ContentType + -> LBS.ByteString + -> Response +resp404 = + mkResponse status404 + +resp400 + :: ContentType + -> LBS.ByteString + -> Response +resp400 = + mkResponse status400 + +resp500 + :: ContentType + -> LBS.ByteString + -> Response +resp500 = + mkResponse status500 + +resp200Json + :: ToJSON a + => a + -> Response +resp200Json = + resp200 JSON . A.encode +-- | + +-- How has this implementation changed, now that we have an AppM to handle the +-- errors for our application? Could it be simplified? Can it be changed at all? +app + :: DB.FirstAppDB + -> Application +app db rq cb = + error "app not reimplemented" + +handleRequest + :: DB.FirstAppDB + -> RqType + -> AppM Response +handleRequest db rqType = case rqType of + -- Notice that we've been able to remove a layer of `fmap` because our `AppM` + -- handles all of that for us. Such is the pleasant nature of these + -- abstractions. + AddRq t c -> resp200 PlainText "Success" <$ DB.addCommentToTopic db t c + ViewRq t -> resp200Json <$> DB.getComments db t + ListRq -> resp200Json <$> DB.getTopics db + +mkRequest + :: Request + -> AppM RqType +mkRequest rq = + liftEither =<< case ( pathInfo rq, requestMethod rq ) of + -- Commenting on a given topic + ( [t, "add"], "POST" ) -> liftIO $ mkAddRequest t <$> strictRequestBody rq + -- View the comments on a given topic + ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) + -- List the current topics + ( ["list"], "GET" ) -> pure mkListRequest + -- Finally we don't care about any other requests so build an Error response + _ -> pure ( Left UnknownRoute ) + +mkAddRequest + :: Text + -> LBS.ByteString + -> Either Error RqType +mkAddRequest ti c = AddRq + <$> mkTopic ti + <*> (mkCommentText . decodeUtf8 . LBS.toStrict) c + +mkViewRequest + :: Text + -> Either Error RqType +mkViewRequest = + fmap ViewRq . mkTopic + +mkListRequest + :: Either Error RqType +mkListRequest = + Right ListRq + +mkErrorResponse + :: Error + -> Response +mkErrorResponse UnknownRoute = + resp404 PlainText "Unknown Route" +mkErrorResponse EmptyCommentText = + resp400 PlainText "Empty Comment" +mkErrorResponse EmptyTopic = + resp400 PlainText "Empty Topic" +mkErrorResponse ( DBError _ ) = + resp500 PlainText "Oh noes" diff --git a/level07/src/FirstApp/DB.hs b/src/Level05/DB.hs similarity index 70% rename from level07/src/FirstApp/DB.hs rename to src/Level05/DB.hs index e67381e..fa74270 100644 --- a/level07/src/FirstApp/DB.hs +++ b/src/Level05/DB.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.DB - ( Table (..) - , FirstAppDB (FirstAppDB) +module Level05.DB + ( FirstAppDB (FirstAppDB) , initDB , closeDB , addCommentToTopic @@ -11,31 +10,35 @@ module FirstApp.DB ) where import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) - -import Data.Bifunctor (first) +import Data.Text (Text) import qualified Data.Text as Text +import Data.Bifunctor (first) import Data.Time (getCurrentTime) -import Database.SQLite.Simple (Connection, FromRow, - Query (fromQuery), ToRow) +import Database.SQLite.Simple (Connection, + Query (fromQuery)) import qualified Database.SQLite.Simple as Sql import qualified Database.SQLite.SimpleErrors as Sql import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.DB.Types (FirstAppDB (FirstAppDB, dbConn), - Table (Table, getTableName)) -import FirstApp.Types (Comment, CommentText, - DBFilePath (getDBFilePath), - Error (DBError), - Topic, fromDbComment, +import Level05.Types (Comment, CommentText, + Error (DBError), Topic, + fromDbComment, getCommentText, getTopic, mkTopic) -import FirstApp.AppM (AppM, envDB, liftEither) +import Level05.AppM (AppM) + +-- We have a data type to simplify passing around the information we need to run +-- our database queries. This also allows things to change over time without +-- having to rewrite all of the functions that need to interact with DB related +-- things in different ways. +newtype FirstAppDB = FirstAppDB + { dbConn :: Connection + } -- Quick helper to pull the connection and close it down. closeDB @@ -45,13 +48,13 @@ closeDB = Sql.close . dbConn initDB - :: DBFilePath + :: FilePath -> IO ( Either SQLiteResponse FirstAppDB ) initDB fp = Sql.runDBAction $ do -- Initialise the connection to the DB... -- - What could go wrong here? -- - What haven't we be told in the types? - con <- Sql.open ( getDBFilePath fp ) + con <- Sql.open fp -- Initialise our one table, if it's not there already _ <- Sql.execute_ con createTableQ pure $ FirstAppDB con @@ -59,40 +62,40 @@ initDB fp = Sql.runDBAction $ do -- Query has an `IsString` instance so string literals like this can be -- converted into a `Query` type when the `OverloadedStrings` language -- extension is enabled. - createTableQ = "CREATE TABLE IF NOT EXISTS comments (id INTEGER PRIMARY KEY, topic TEXT, comment TEXT, time INTEGER)" - -getDBConn - :: AppM Connection -getDBConn = - asks (dbConn . envDB) + createTableQ = + "CREATE TABLE IF NOT EXISTS comments (id INTEGER PRIMARY KEY, topic TEXT, comment TEXT, time INTEGER)" runDB :: (a -> Either Error b) - -> (Connection -> IO a) + -> IO a -> AppM b runDB = error "Copy your completed 'runDB' and refactor to match the new type signature" getComments - :: Topic + :: FirstAppDB + -> Topic -> AppM [Comment] getComments = error "Copy your completed 'getComments' and refactor to match the new type signature" addCommentToTopic - :: Topic + :: FirstAppDB + -> Topic -> CommentText -> AppM () addCommentToTopic = error "Copy your completed 'appCommentToTopic' and refactor to match the new type signature" getTopics - :: AppM [Topic] + :: FirstAppDB + -> AppM [Topic] getTopics = error "Copy your completed 'getTopics' and refactor to match the new type signature" deleteTopic - :: Topic + :: FirstAppDB + -> Topic -> AppM () deleteTopic = error "Copy your completed 'deleteTopic' and refactor to match the new type signature" diff --git a/level06/src/FirstApp/DB/PostgreSQL.hs b/src/Level05/DB/PostgreSQL.hs similarity index 98% rename from level06/src/FirstApp/DB/PostgreSQL.hs rename to src/Level05/DB/PostgreSQL.hs index f7f2ca3..90a3ef2 100644 --- a/level06/src/FirstApp/DB/PostgreSQL.hs +++ b/src/Level05/DB/PostgreSQL.hs @@ -3,7 +3,7 @@ -- postgresql-simple package. It is missing the very helpful error handling of -- the sqlite-simple-errors package. The postgresql-simple package is littered -- with exceptions which are not visible in the types, so be wary. -module FirstApp.DB.PostgreSQL where +module Level05.DB.PostgreSQL where import GHC.Int (Int64) @@ -15,7 +15,7 @@ import Database.PostgreSQL.Simple (Connection, FromRow, Query, import Database.PostgreSQL.Simple.Types (Identifier (..)) import qualified Database.PostgreSQL.Simple as PG -import FirstApp.Types +import Level05.Types -- This is a bit more configuration available to the PostgreSQL package so we -- have a bit more work to do. diff --git a/level05/src/FirstApp/DB/Types.hs b/src/Level05/DB/Types.hs similarity index 97% rename from level05/src/FirstApp/DB/Types.hs rename to src/Level05/DB/Types.hs index fa3fb8b..91e849d 100644 --- a/level05/src/FirstApp/DB/Types.hs +++ b/src/Level05/DB/Types.hs @@ -1,4 +1,4 @@ -module FirstApp.DB.Types where +module Level05.DB.Types where import Data.Text (Text) import Data.Time (UTCTime) diff --git a/src/Level05/README.md b/src/Level05/README.md new file mode 100644 index 0000000..1287e3b --- /dev/null +++ b/src/Level05/README.md @@ -0,0 +1,7 @@ +# Level 05 + +Handling those `Either` values everywhere is a bit awkward, this exercise +introduces our first monad transformer, ``ExceptT``. Further along, we will add +the concept of a 'transformer stack' and what benefits it can provide. + +Start in ``src/Level05/AppM.hs``. diff --git a/src/Level05/Types.hs b/src/Level05/Types.hs new file mode 100644 index 0000000..f5bf2b9 --- /dev/null +++ b/src/Level05/Types.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Level05.Types + ( Error (..) + , RqType (..) + , ContentType (..) + , Comment (..) + , Topic + , CommentText + , mkTopic + , getTopic + , mkCommentText + , getCommentText + , renderContentType + , fromDbComment + ) where + +import GHC.Generics (Generic) +import GHC.Word (Word16) + +import Data.ByteString (ByteString) +import Data.Text (Text) + +import System.IO.Error (IOError) + +import Data.Monoid (Last, + Monoid (mappend, mempty)) +import Data.Semigroup (Semigroup ((<>))) + +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime) + +import Data.Aeson (FromJSON (..), ToJSON) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A + +import Database.SQLite.SimpleErrors.Types (SQLiteResponse) +import Level05.DB.Types (DbComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic)) +import Level05.Types.CommentText (CommentText, + getCommentText, + mkCommentText) +import Level05.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute)) +import Level05.Types.Topic (Topic, getTopic, mkTopic) + +newtype CommentId = CommentId Int + deriving (Show, ToJSON) + +data Comment = Comment + { commentId :: CommentId + , commentTopic :: Topic + , commentText :: CommentText + , commentTime :: UTCTime + } + -- Generic has been added to our deriving list. + deriving ( Show, Generic ) + +-- Strip the prefix (which may fail if the prefix isn't present), fall +-- back to the original label if need be, then camel-case the name. + +-- | modFieldLabel +-- >>> modFieldLabel "commentId" +-- "id" +-- >>> modFieldLabel "topic" +-- "topic" +-- >>> modFieldLabel "" +-- "" +modFieldLabel + :: String + -> String +modFieldLabel l = + A.camelTo2 '_' + . fromMaybe l + $ stripPrefix "comment" l + +instance ToJSON Comment where + -- This is one place where we can take advantage of our Generic instance. Aeson + -- already has the encoding functions written for anything that implements the + -- Generic typeclass. So we don't have to write our encoding, we tell Aeson to + -- build it. + toEncoding = A.genericToEncoding opts + where + -- These options let us make some minor adjustments to how Aeson treats + -- our type. Our only adjustment is to alter the field names a little, to + -- remove the 'comment' prefix and use an Aeson function to handle the + -- rest of the name. This accepts any 'String -> String' function but it's + -- wise to keep the modifications simple. + opts = A.defaultOptions + { A.fieldLabelModifier = modFieldLabel + } + +-- For safety we take our stored DbComment and try to construct a Comment that +-- we would be okay with showing someone. However unlikely it may be, this is a +-- nice method for separating out the back and front end of a web app and +-- providing greater guarantees about data cleanliness. + +fromDbComment + :: DbComment + -> Either Error Comment +fromDbComment dbc = + Comment (CommentId $ dbCommentId dbc) + <$> (mkTopic $ dbCommentTopic dbc) + <*> (mkCommentText $ dbCommentComment dbc) + <*> (pure $ dbCommentTime dbc) + +-- We have to be able to: +-- - Comment on a given topic +-- - View a topic and its comments +-- - List the current topics +-- +-- To that end, we have the following types: +-- +-- AddRq : Which needs to the target topic, and the body of the comment. +-- ViewRq : Which needs the topic being requested. +-- ListRq : Which lists all of the current topics. +data RqType + = AddRq Topic CommentText + | ViewRq Topic + | ListRq + +data ContentType + = PlainText + | JSON + +renderContentType + :: ContentType + -> ByteString +renderContentType PlainText = "text/plain" +renderContentType JSON = "application/json" diff --git a/level05/src/FirstApp/Types/CommentText.hs b/src/Level05/Types/CommentText.hs similarity index 64% rename from level05/src/FirstApp/Types/CommentText.hs rename to src/Level05/Types/CommentText.hs index c52f31a..5ae2679 100644 --- a/level05/src/FirstApp/Types/CommentText.hs +++ b/src/Level05/Types/CommentText.hs @@ -1,15 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module FirstApp.Types.CommentText +module Level05.Types.CommentText ( CommentText , mkCommentText , getCommentText ) where -import FirstApp.Types.Error (Error(EmptyCommentText), nonEmptyText) +import Data.Aeson (ToJSON) +import Data.Text (Text) -import Data.Text (Text) -import Data.Aeson (ToJSON) +import Level05.Types.Error (Error (EmptyCommentText), nonEmptyText) newtype CommentText = CommentText Text deriving (Show, ToJSON) diff --git a/level07/src/FirstApp/Types/Error.hs b/src/Level05/Types/Error.hs similarity index 59% rename from level07/src/FirstApp/Types/Error.hs rename to src/Level05/Types/Error.hs index b359aca..237175e 100644 --- a/level07/src/FirstApp/Types/Error.hs +++ b/src/Level05/Types/Error.hs @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +module Level05.Types.Error + ( Error(..) + , nonEmptyText + ) where -module FirstApp.Types.Error (Error(..), nonEmptyText) where - -import Data.Text (Text) -import Database.SQLite.SimpleErrors.Types (SQLiteResponse) +import Data.Text (Text) +import Database.SQLite.SimpleErrors.Types (SQLiteResponse) data Error = UnknownRoute diff --git a/level07/src/FirstApp/Types/Topic.hs b/src/Level05/Types/Topic.hs similarity index 50% rename from level07/src/FirstApp/Types/Topic.hs rename to src/Level05/Types/Topic.hs index f18fe10..57dfe91 100644 --- a/level07/src/FirstApp/Types/Topic.hs +++ b/src/Level05/Types/Topic.hs @@ -1,11 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Level05.Types.Topic + ( Topic + , mkTopic + , getTopic + ) where -module FirstApp.Types.Topic (Topic, mkTopic, getTopic) where +import Data.Aeson (ToJSON) +import Data.Text (Text) -import FirstApp.Types.Error (Error(EmptyTopic), nonEmptyText) - -import Data.Text (Text) -import Data.Aeson (ToJSON) +import Level05.Types.Error (Error (EmptyTopic), nonEmptyText) newtype Topic = Topic Text deriving (Show, ToJSON) diff --git a/level07/src/FirstApp/AppM.hs b/src/Level06/AppM.hs similarity index 71% rename from level07/src/FirstApp/AppM.hs rename to src/Level06/AppM.hs index 59a89f0..19eb713 100644 --- a/level07/src/FirstApp/AppM.hs +++ b/src/Level06/AppM.hs @@ -1,33 +1,23 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveFunctor #-} -module FirstApp.AppM where +module Level06.AppM where import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader (MonadReader (..)) import Data.Text (Text) -import FirstApp.DB.Types (FirstAppDB) -import FirstApp.Types (Conf, Error) +import Level06.Types (Error) import Data.Bifunctor (first) -data Env = Env - { envLoggingFn :: Text -> AppM () - , envConfig :: Conf - , envDB :: FirstAppDB - } - -- We're going to add a very useful abstraction to our application. We'll -- automate away the explicit error handling and inspection of our Either values -- while preserving the type-level information that tells us what can go wrong. -- --- To do this we will expand the capabilities of our AppM by including the --- Either type in our definition. We will also rework our Monad instance to stop --- processing when it encounters a Left value. +-- To do this we will create a newtype `AppM` that is a shorthand way of +-- describing the return type of a function that may contain an error. -- -- This will work in the same manner as the Functor/Applicative/Monad -- instances for Either, with functions being applied to the Right value and @@ -54,19 +44,17 @@ data Env = Env -- values we expect to appear on the happy path, knowing that if the sad path is -- encountered, the structure of our AppM will automatically handle it for us. -newtype AppM a = AppM (Env -> IO (Either Error a)) - deriving Functor +newtype AppM a = AppM (IO (Either Error a)) --- The runAppM function only needs to change the final return type as it has an --- 'Either Error' and not just the 'a'. runAppM :: AppM a - -> Env -> IO (Either Error a) runAppM (AppM m) = m --- Copy over your previously completed definitions. +instance Functor AppM where + fmap :: (a -> b) -> AppM a -> AppM b + fmap = error "fmap for AppM not implemented" instance Applicative AppM where pure :: a -> AppM a @@ -86,16 +74,6 @@ instance MonadIO AppM where liftIO :: IO a -> AppM a liftIO = error "liftIO for AppM not implemented" -instance MonadReader Env AppM where - ask :: AppM Env - ask = error "ask for AppM not implemented" - - local :: (Env -> Env) -> AppM a -> AppM a - local = error "local for AppM not implemented" - - reader :: (Env -> a) -> AppM a - reader = error "reader for AppM not implemented" - instance MonadError Error AppM where throwError :: Error -> AppM a throwError = error "throwError for AppM not implemented" diff --git a/level05/src/FirstApp/Conf.hs b/src/Level06/Conf.hs similarity index 72% rename from level05/src/FirstApp/Conf.hs rename to src/Level06/Conf.hs index 3498a29..d1824e0 100644 --- a/level05/src/FirstApp/Conf.hs +++ b/src/Level06/Conf.hs @@ -1,20 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} -module FirstApp.Conf +module Level06.Conf ( parseOptions ) where -import GHC.Word (Word16) +import GHC.Word (Word16) -import Data.Bifunctor (first) -import Data.Monoid ((<>)) +import Data.Bifunctor (first) +import Data.Monoid ((<>)) -import FirstApp.Types (Conf, ConfigError, - DBFilePath (DBFilePath), - PartialConf, Port (Port)) +import Level06.Types (Conf, ConfigError, + DBFilePath (DBFilePath), PartialConf, + Port (Port)) -import FirstApp.Conf.CommandLine (commandLineParser) -import FirstApp.Conf.File (parseJSONConfigFile) +import Level06.Conf.CommandLine (commandLineParser) +import Level06.Conf.File (parseJSONConfigFile) -- For the purposes of this application we will encode some default values to -- ensure that our application continues to function in the event of missing @@ -47,7 +47,7 @@ parseOptions :: FilePath -> IO (Either ConfigError Conf) parseOptions = - -- Parse the options from the config file: "appconfig.json" + -- Parse the options from the config file: "files/appconfig.json" -- Parse the options from the commandline using 'commandLineParser' -- Combine these with the default configuration 'defaultConf' -- Return the final configuration value diff --git a/level05/src/FirstApp/Conf/CommandLine.hs b/src/Level06/Conf/CommandLine.hs similarity index 95% rename from level05/src/FirstApp/Conf/CommandLine.hs rename to src/Level06/Conf/CommandLine.hs index d04d908..86218e1 100644 --- a/level05/src/FirstApp/Conf/CommandLine.hs +++ b/src/Level06/Conf/CommandLine.hs @@ -1,4 +1,4 @@ -module FirstApp.Conf.CommandLine +module Level06.Conf.CommandLine ( commandLineParser ) where @@ -11,7 +11,7 @@ import Options.Applicative (Parser, eitherReader, execParser, import Text.Read (readEither) -import FirstApp.Types (DBFilePath (DBFilePath), +import Level06.Types (DBFilePath (DBFilePath), PartialConf (PartialConf), Port (Port)) -- | Command Line Parsing diff --git a/level05/src/FirstApp/Conf/File.hs b/src/Level06/Conf/File.hs similarity index 92% rename from level05/src/FirstApp/Conf/File.hs rename to src/Level06/Conf/File.hs index 911b079..078199b 100644 --- a/level05/src/FirstApp/Conf/File.hs +++ b/src/Level06/Conf/File.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Conf.File where +module Level06.Conf.File where import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS @@ -15,7 +15,7 @@ import Data.Aeson (FromJSON, Object) import qualified Data.Aeson as Aeson -import FirstApp.Types (ConfigError, +import Level06.Types (ConfigError, PartialConf (PartialConf)) -- Doctest setup section -- $setup @@ -34,7 +34,7 @@ import FirstApp.Types (ConfigError, -- | readConfFile -- >>> readConfFile "badFileName.no" -- Left (undefined "badFileName.no: openBinaryFile: does not exist (No such file or directory)") --- >>> readConfFile "test.json" +-- >>> readConfFile "files/test.json" -- Right "{\n \"foo\": 33\n}\n" -- readConfFile diff --git a/level05/src/FirstApp/Main.hs b/src/Level06/Core.hs similarity index 82% rename from level05/src/FirstApp/Main.hs rename to src/Level06/Core.hs index 6c0a14f..0aef6e2 100644 --- a/level05/src/FirstApp/Main.hs +++ b/src/Level06/Core.hs @@ -1,11 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -module FirstApp.Main +module Level06.Core ( runApp , app , prepareAppReqs ) where +import Control.Monad.IO.Class (liftIO) + import Network.Wai (Application, Request, Response, pathInfo, requestMethod, responseLBS, @@ -29,9 +31,10 @@ import Database.SQLite.SimpleErrors.Types (SQLiteResponse) import Data.Aeson (ToJSON) import qualified Data.Aeson as A -import qualified FirstApp.Conf as Conf -import qualified FirstApp.DB as DB -import FirstApp.Types (Conf, ContentType (..), +import Level06.AppM (AppM, liftEither, runAppM) +import qualified Level06.Conf as Conf +import qualified Level06.DB as DB +import Level06.Types (Conf, ContentType (..), Error (..), RqType (AddRq, ListRq, ViewRq), mkCommentText, mkTopic, @@ -59,7 +62,7 @@ runApp = do -- 2) Attempt to initialise the database. -- 3) Combine the results into a tuple -- --- The filename for our application config is: "appconfig.json" +-- The file path for our application config is: "files/appconfig.json" -- prepareAppReqs :: IO ( Either StartUpError ( Conf, DB.FirstAppDB ) ) @@ -116,25 +119,16 @@ app :: Conf -> DB.FirstAppDB -> Application -app cfg db rq cb = do - rq' <- mkRequest rq - resp <- handleRespErr <$> handleRErr rq' - cb resp +app cfg db rq cb = + runAppM (handleRequest db =<< mkRequest rq) >>= cb . handleRespErr where handleRespErr :: Either Error Response -> Response handleRespErr = either mkErrorResponse id - -- We want to pass the Database through to the handleRequest so it's - -- available to all of our handlers. - handleRErr :: Either Error RqType -> IO (Either Error Response) - handleRErr = either ( pure . Left ) ( handleRequest db ) - --- Now we have some config, we can pull the ``helloMsg`` off it and use it in --- the response. handleRequest :: DB.FirstAppDB -> RqType - -> IO ( Either Error Response ) + -> AppM Response handleRequest db rqType = -- Now that we're operating within the context of our AppM, which is a -- ReaderT, we're able to access the values stored in the Env. @@ -151,17 +145,17 @@ handleRequest db rqType = -- > asks envDb :: AppM FirstAppDB case rqType of -- Exercise for later: Could this be generalised to clean up the repetition ? - AddRq t c -> (resp200 PlainText "Success" <$) <$> DB.addCommentToTopic db t c - ViewRq t -> fmap resp200Json <$> DB.getComments db t - ListRq -> fmap resp200Json <$> DB.getTopics db + AddRq t c -> resp200 PlainText "Success" <$ DB.addCommentToTopic db t c + ViewRq t -> resp200Json <$> DB.getComments db t + ListRq -> resp200Json <$> DB.getTopics db mkRequest :: Request - -> IO ( Either Error RqType ) + -> AppM RqType mkRequest rq = - case ( pathInfo rq, requestMethod rq ) of + liftEither =<< case ( pathInfo rq, requestMethod rq ) of -- Commenting on a given topic - ( [t, "add"], "POST" ) -> mkAddRequest t <$> strictRequestBody rq + ( [t, "add"], "POST" ) -> liftIO $ mkAddRequest t <$> strictRequestBody rq -- View the comments on a given topic ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) -- List the current topics @@ -199,4 +193,3 @@ mkErrorResponse EmptyTopic = resp400 PlainText "Empty Topic" mkErrorResponse ( DBError _ ) = resp500 PlainText "Oh noes" - diff --git a/level05/src/FirstApp/DB.hs b/src/Level06/DB.hs similarity index 86% rename from level05/src/FirstApp/DB.hs rename to src/Level06/DB.hs index 78402a0..437a789 100644 --- a/level05/src/FirstApp/DB.hs +++ b/src/Level06/DB.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.DB +module Level06.DB ( FirstAppDB (FirstAppDB) , initDB , closeDB @@ -9,6 +9,8 @@ module FirstApp.DB , deleteTopic ) where +import Control.Monad.IO.Class (liftIO) + import Data.Text (Text) import qualified Data.Text as Text @@ -22,7 +24,9 @@ import qualified Database.SQLite.Simple as Sql import qualified Database.SQLite.SimpleErrors as Sql import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.Types (Comment, CommentText, +import Level06.AppM (AppM, liftEither) + +import Level06.Types (Comment, CommentText, Error (DBError), Topic, fromDbComment, getCommentText, getTopic, @@ -64,21 +68,15 @@ initDB fp = Sql.runDBAction $ do runDB :: (a -> Either Error b) -> IO a - -> IO (Either Error b) -runDB f a = - (>>= f) . first DBError <$> Sql.runDBAction a - -- Choices, choices... - -- either (Left . DBError) f <$> Sql.runDBAction a - -- these two are pretty much the same. - -- Sql.runDBAction >=> pure . either (Left . DBError) f - -- this is because we noticed that our call to pure, which means we should - -- be able to fmap to victory. - -- fmap ( either (Left . DBError) f ) . Sql.runDBAction + -> AppM b +runDB f a = do + r <- liftIO $ first DBError <$> Sql.runDBAction a + liftEither $ f =<< r getComments :: FirstAppDB -> Topic - -> IO (Either Error [Comment]) + -> AppM [Comment] getComments db t = do -- Write the query with an icky string and remember your placeholders! let q = "SELECT id,topic,comment,time FROM comments WHERE topic = ?" @@ -91,10 +89,10 @@ addCommentToTopic :: FirstAppDB -> Topic -> CommentText - -> IO (Either Error ()) + -> AppM () addCommentToTopic db t c = do -- Record the time this comment was created. - nowish <- getCurrentTime + nowish <- liftIO getCurrentTime -- Note the triple, matching the number of values we're trying to insert, plus -- one for the table name. let q = @@ -111,7 +109,7 @@ addCommentToTopic db t c = do getTopics :: FirstAppDB - -> IO (Either Error [Topic]) + -> AppM [Topic] getTopics db = let q = "SELECT DISTINCT topic FROM comments" in @@ -120,7 +118,7 @@ getTopics db = deleteTopic :: FirstAppDB -> Topic - -> IO (Either Error ()) + -> AppM () deleteTopic db t = let q = "DELETE FROM comments WHERE topic = ?" in diff --git a/level05/src/FirstApp/DB/PostgreSQL.hs b/src/Level06/DB/PostgreSQL.hs similarity index 98% rename from level05/src/FirstApp/DB/PostgreSQL.hs rename to src/Level06/DB/PostgreSQL.hs index f7f2ca3..08778a4 100644 --- a/level05/src/FirstApp/DB/PostgreSQL.hs +++ b/src/Level06/DB/PostgreSQL.hs @@ -3,7 +3,7 @@ -- postgresql-simple package. It is missing the very helpful error handling of -- the sqlite-simple-errors package. The postgresql-simple package is littered -- with exceptions which are not visible in the types, so be wary. -module FirstApp.DB.PostgreSQL where +module Level06.DB.PostgreSQL where import GHC.Int (Int64) @@ -15,7 +15,7 @@ import Database.PostgreSQL.Simple (Connection, FromRow, Query, import Database.PostgreSQL.Simple.Types (Identifier (..)) import qualified Database.PostgreSQL.Simple as PG -import FirstApp.Types +import Level06.Types -- This is a bit more configuration available to the PostgreSQL package so we -- have a bit more work to do. diff --git a/level06/src/FirstApp/DB/Types.hs b/src/Level06/DB/Types.hs similarity index 97% rename from level06/src/FirstApp/DB/Types.hs rename to src/Level06/DB/Types.hs index fa3fb8b..c033aee 100644 --- a/level06/src/FirstApp/DB/Types.hs +++ b/src/Level06/DB/Types.hs @@ -1,4 +1,4 @@ -module FirstApp.DB.Types where +module Level06.DB.Types where import Data.Text (Text) import Data.Time (UTCTime) diff --git a/src/Level06/README.md b/src/Level06/README.md new file mode 100644 index 0000000..774d5a9 --- /dev/null +++ b/src/Level06/README.md @@ -0,0 +1,19 @@ +# Level 05 + +In this exercise we build some configuration capabilities into our application. + +This exercise will require a combination of building the right types to guide +your development, plus consulting plenty of documentation to leverage the chosen +packages. There may also be, depending on your level of interest, some external +reading for later as well. + +The steps for this level: +1) ``src/Level06/Types.hs`` +2) ``src/Level06/Conf/File.hs`` +3) ``src/Level06/Conf.hs`` +4) ``src/Level06/Core.hs`` + +The packages we will use for this are: + +- [Aeson](http://hackage.haskell.org/package/aeson) +- [Optparse Applicative](http://hackage.haskell.org/package/optparse-applicative) diff --git a/level05/src/FirstApp/Types.hs b/src/Level06/Types.hs similarity index 91% rename from level05/src/FirstApp/Types.hs rename to src/Level06/Types.hs index f2cda95..b556395 100644 --- a/level05/src/FirstApp/Types.hs +++ b/src/Level06/Types.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module FirstApp.Types +module Level06.Types ( Error (..) , ConfigError (..) , PartialConf (..) @@ -44,17 +44,12 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.DB.Types (DbComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic)) -import FirstApp.Types.Error (Error ( UnknownRoute - , EmptyCommentText - , EmptyTopic - , DBError - )) -import FirstApp.Types.CommentText ( CommentText - , mkCommentText - , getCommentText - ) -import FirstApp.Types.Topic (Topic, mkTopic, getTopic) +import Level06.DB.Types (DbComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic)) +import Level06.Types.CommentText (CommentText, + getCommentText, + mkCommentText) +import Level06.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute)) +import Level06.Types.Topic (Topic, getTopic, mkTopic) newtype CommentId = CommentId Int deriving (Show, ToJSON) diff --git a/level04/src/FirstApp/Types/CommentText.hs b/src/Level06/Types/CommentText.hs similarity index 80% rename from level04/src/FirstApp/Types/CommentText.hs rename to src/Level06/Types/CommentText.hs index c52f31a..5971182 100644 --- a/level04/src/FirstApp/Types/CommentText.hs +++ b/src/Level06/Types/CommentText.hs @@ -1,12 +1,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module FirstApp.Types.CommentText +module Level06.Types.CommentText ( CommentText , mkCommentText , getCommentText ) where -import FirstApp.Types.Error (Error(EmptyCommentText), nonEmptyText) +import Level06.Types.Error (Error(EmptyCommentText), nonEmptyText) import Data.Text (Text) import Data.Aeson (ToJSON) diff --git a/level05/src/FirstApp/Types/Error.hs b/src/Level06/Types/Error.hs similarity index 88% rename from level05/src/FirstApp/Types/Error.hs rename to src/Level06/Types/Error.hs index aaf3f18..2b561ca 100644 --- a/level05/src/FirstApp/Types/Error.hs +++ b/src/Level06/Types/Error.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Types.Error (Error(..), nonEmptyText) where +module Level06.Types.Error (Error(..), nonEmptyText) where import Data.Text (Text) import Database.SQLite.SimpleErrors.Types (SQLiteResponse) diff --git a/level05/src/FirstApp/Types/Topic.hs b/src/Level06/Types/Topic.hs similarity index 71% rename from level05/src/FirstApp/Types/Topic.hs rename to src/Level06/Types/Topic.hs index e0d6573..9202bfd 100644 --- a/level05/src/FirstApp/Types/Topic.hs +++ b/src/Level06/Types/Topic.hs @@ -1,8 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module FirstApp.Types.Topic (Topic, mkTopic, getTopic) where +module Level06.Types.Topic (Topic, mkTopic, getTopic) where -import FirstApp.Types.Error (Error (EmptyTopic), nonEmptyText) +import Level06.Types.Error (Error (EmptyTopic), nonEmptyText) import Data.Aeson (ToJSON) import Data.Text (Text) diff --git a/level06/src/FirstApp/AppM.hs b/src/Level07/AppM.hs similarity index 69% rename from level06/src/FirstApp/AppM.hs rename to src/Level07/AppM.hs index dc0a39b..4636b27 100644 --- a/level06/src/FirstApp/AppM.hs +++ b/src/Level07/AppM.hs @@ -1,14 +1,17 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -module FirstApp.AppM where +module Level07.AppM where +import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (MonadReader (..)) import Data.Text (Text) -import FirstApp.Types (Conf, FirstAppDB) +import Level07.Types (Conf, FirstAppDB) +import Level07.Types.Error (Error) -- First, let's clean up our (Conf,FirstAppDB) with an application Env type. We -- will add a general purpose logging function as well. Remember that functions @@ -25,41 +28,27 @@ data Env = Env -- simply ask for the current Env? -- -- We can create this by wrapping a function in a newtype like so: - -newtype AppM a = AppM ( Env -> IO a ) - +-- -- This gives us a type that declares this function has access to our Env, and -- will do something involving IO. It's another form of documentation and type -- safety. AppM only has one definition and so we can easily understand what it -- implies when used in our application. --- --- This structure allows us to start writing our functions in terms of --- constraints. As an example, if we wanted to abstract over IO and indicate --- that instead of the concrete type we wanted a constraint that allows for IO --- actions. Our AppM would look more like this: --- --- AppM m a = AppM ( Env -> m a ) --- --- Then our functions would look like: --- --- foo :: MonadIO m => Int -> AppM m a --- --- Or we could not use a concrete type for Env --- --- AppM e m a = AppM ( e -> m a ) --- +newtype AppM a = AppM ( Env -> IO (Either Error a) ) + -- Quite often, GHC is able to write the code for us. In this case we just + -- tell GHC that we want a Functor instance for our newtype, and it is able to + -- correctly derive what is needed. + deriving Functor + -- We could do this for the rest of these instances, but that would turn into + -- "magic" what is otherwise straight-forward implementations. You are here to + -- learn after all. runAppM :: AppM a -> Env - -> IO a + -> IO (Either Error a) runAppM = error "runAppM not implemented" -instance Functor AppM where - fmap :: (a -> b) -> AppM a -> AppM b - fmap = error "fmap for AppM not implemented" - instance Applicative AppM where pure :: a -> AppM a pure = error "pure for AppM not implemented" @@ -76,6 +65,13 @@ instance Monad AppM where (>>=) :: AppM a -> (a -> AppM b) -> AppM b (>>=) = error "bind for AppM not implemented" +instance MonadError Error AppM where + throwError :: Error -> AppM a + throwError = error "throwError for AppM not implemented" + + catchError :: AppM a -> (Error -> AppM a) -> AppM a + catchError = error "catchError for AppM not implemented" + instance MonadReader Env AppM where -- Return the current Env from the AppM. ask :: AppM Env @@ -94,4 +90,10 @@ instance MonadIO AppM where liftIO :: IO a -> AppM a liftIO = error "liftIO for AppM not implemented" --- Move on to ``src/FirstApp/DB.hs`` after this +-- Move on to ``src/Level07/DB.hs`` after this + +liftEither + :: Either Error a + -> AppM a +liftEither = + error "throwLeft not implemented" diff --git a/level07/src/FirstApp/Conf.hs b/src/Level07/Conf.hs similarity index 89% rename from level07/src/FirstApp/Conf.hs rename to src/Level07/Conf.hs index 5da08f6..560fe3b 100644 --- a/level07/src/FirstApp/Conf.hs +++ b/src/Level07/Conf.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} -module FirstApp.Conf +module Level07.Conf ( parseOptions ) where @@ -9,12 +9,12 @@ import GHC.Word (Word16) import Data.Bifunctor (first) import Data.Monoid (Last (..), (<>)) -import FirstApp.Types (Conf (..), ConfigError (..), +import Level07.Types (Conf (..), ConfigError (..), DBFilePath (DBFilePath), PartialConf (..), Port (Port)) -import FirstApp.Conf.CommandLine (commandLineParser) -import FirstApp.Conf.File (parseJSONConfigFile) +import Level07.Conf.CommandLine (commandLineParser) +import Level07.Conf.File (parseJSONConfigFile) -- We have some sane defaults that we can always rely on, so define them using -- our PartialConf. diff --git a/level06/src/FirstApp/Conf/CommandLine.hs b/src/Level07/Conf/CommandLine.hs similarity index 95% rename from level06/src/FirstApp/Conf/CommandLine.hs rename to src/Level07/Conf/CommandLine.hs index 8887719..f8be0d2 100644 --- a/level06/src/FirstApp/Conf/CommandLine.hs +++ b/src/Level07/Conf/CommandLine.hs @@ -1,4 +1,4 @@ -module FirstApp.Conf.CommandLine +module Level07.Conf.CommandLine ( commandLineParser ) where @@ -11,7 +11,7 @@ import Options.Applicative (Parser, eitherReader, execParser, import Text.Read (readEither) -import FirstApp.Types (DBFilePath (DBFilePath), +import Level07.Types (DBFilePath (DBFilePath), PartialConf (PartialConf), Port (Port)) -- | Command Line Parsing diff --git a/level06/src/FirstApp/Conf/File.hs b/src/Level07/Conf/File.hs similarity index 89% rename from level06/src/FirstApp/Conf/File.hs rename to src/Level07/Conf/File.hs index dada672..8061f43 100644 --- a/level06/src/FirstApp/Conf/File.hs +++ b/src/Level07/Conf/File.hs @@ -1,4 +1,4 @@ -module FirstApp.Conf.File where +module Level07.Conf.File where import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS @@ -15,7 +15,7 @@ import Data.Aeson (FromJSON, Object, (.:)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import FirstApp.Types (ConfigError (..), PartialConf) +import Level07.Types (ConfigError (..), PartialConf) -- Doctest setup section -- $setup @@ -26,7 +26,7 @@ import FirstApp.Types (ConfigError (..), PartialConf) -- | readConfFile -- >>> readConfFile "badFileName.no" -- Left (ConfigFileReadError badFileName.no: openBinaryFile: does not exist (No such file or directory)) --- >>> readConfFile "test.json" +-- >>> readConfFile "files/test.json" -- Right "{\"foo\":33}\n" -- readConfFile @@ -42,4 +42,3 @@ parseJSONConfigFile -> IO ( Either ConfigError PartialConf ) parseJSONConfigFile fp = (first JSONDecodeError . Aeson.eitherDecode =<<) <$> readConfFile fp - diff --git a/level06/src/FirstApp/Main.hs b/src/Level07/Core.hs similarity index 60% rename from level06/src/FirstApp/Main.hs rename to src/Level07/Core.hs index 60ef22b..5026d9e 100644 --- a/level06/src/FirstApp/Main.hs +++ b/src/Level07/Core.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Main +module Level07.Core ( runApp , prepareAppReqs , app @@ -32,11 +32,11 @@ import Database.SQLite.SimpleErrors.Types (SQLiteResponse) import System.IO (stderr) -import qualified FirstApp.Conf as Conf -import qualified FirstApp.DB as DB +import qualified Level07.Conf as Conf +import qualified Level07.DB as DB -import qualified FirstApp.Responses as Res -import FirstApp.Types (Conf (dbFilePath), +import qualified Level07.Responses as Res +import Level07.Types (Conf (dbFilePath), ConfigError, ContentType (PlainText), Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute), @@ -44,7 +44,11 @@ import FirstApp.Types (Conf (dbFilePath), confPortToWai, mkCommentText, mkTopic) -import FirstApp.AppM (AppM, Env (Env, envConfig, envDB, envLoggingFn)) +import Level07.AppM (AppM, Env (Env, envConfig, envDB, envLoggingFn), + liftEither) + +-- We're going to use the `mtl` ExceptT monad transformer to make the loading of our `Conf` a bit more straight-forward. +import Control.Monad.Except (ExceptT (..), runExceptT) -- Our start-up is becoming more complicated and could fail in new and -- interesting ways. But we also want to be able to capture these errors in a @@ -65,38 +69,15 @@ runApp = do appWithDb env = run ( confPortToWai $ envConfig env ) (app env) +-- Reimplement the `prepareAppReqs` function using the imported `ExceptT` +-- constructor to help eliminate the manual plumbing of the error values. +-- +-- We'll use the more general version of our error handling monad transformer to +-- demonstrate how easily it can be applied simplify error handling. prepareAppReqs :: IO (Either StartUpError Env) -prepareAppReqs = do - cfgE <- initConf - -- This is awkward because we need to initialise our DB using the config, - -- which might have failed to be created for some reason, but our DB start up - -- might have also failed for some reason. This is a bit clunky - dbE <- join <$> traverse initDB cfgE - - -- Wrap our values (if we have them) in our Env for use in other parts of our - -- application. We do it this way so we can have access to the bits we need - -- when starting up the full app or one for testing. - pure $ liftA2 ( Env logToErr ) cfgE dbE - where - logToErr = liftIO . hPutStrLn stderr - - -- This makes it a bit easier to take our individual initialisation - -- functions and ensure that they both conform to the StartUpError type - -- that we want them too. - -- - -- Fun for later: Play with composing 'fmap' and 'first' in ghci and - -- watch how the types specialise and change. - toStartUpErr :: (a -> b) -> IO (Either a c) -> IO (Either b c) - toStartUpErr = fmap . first - - -- Prepare the config - initConf :: IO (Either StartUpError Conf) - initConf = toStartUpErr ConfErr $ Conf.parseOptions "appconfig.json" - - -- Power up the tubes - initDB :: Conf -> IO (Either StartUpError DB.FirstAppDB) - initDB cfg = toStartUpErr DbInitErr $ DB.initDB (dbFilePath cfg) +prepareAppReqs = runExceptT $ + error "Copy your completed 'prepareAppReqs' from the previous level and refactor it here" -- Now that our request handling and response creating functions operate -- within our AppM context, we need to run the AppM to get our IO action out @@ -110,25 +91,19 @@ app = handleRequest :: RqType - -> AppM (Either Error Response) -handleRequest rqType = - case rqType of - -- Exercise: Could this be generalised to clean up the repetition ? - AddRq t c -> pure (Res.resp200 PlainText "Success") <$ DB.addCommentToTopic t c - ViewRq t -> fmap Res.resp200Json <$> DB.getComments t - ListRq -> fmap Res.resp200Json <$> DB.getTopics + -> AppM Response +handleRequest rqType = case rqType of + AddRq t c -> Res.resp200 PlainText "Success" <$ DB.addCommentToTopic t c + ViewRq t -> Res.resp200Json <$> DB.getComments t + ListRq -> Res.resp200Json <$> DB.getTopics mkRequest :: Request - -- We change this to be in our AppM context as well because when we're - -- constructing our RqType we might want to call on settings or other such - -- things, maybe. - -> AppM ( Either Error RqType ) + -> AppM RqType mkRequest rq = - case ( pathInfo rq, requestMethod rq ) of + liftEither =<< case ( pathInfo rq, requestMethod rq ) of -- Commenting on a given topic - ( [t, "add"], "POST" ) -> - liftIO (mkAddRequest t <$> strictRequestBody rq) + ( [t, "add"], "POST" ) -> liftIO (mkAddRequest t <$> strictRequestBody rq) -- View the comments on a given topic ( [t, "view"], "GET" ) -> pure ( mkViewRequest t ) -- List the current topics @@ -158,13 +133,10 @@ mkListRequest = mkErrorResponse :: Error -> AppM Response -mkErrorResponse UnknownRoute = - pure $ Res.resp404 PlainText "Unknown Route" -mkErrorResponse EmptyCommentText = - pure $ Res.resp400 PlainText "Empty Comment" -mkErrorResponse EmptyTopic = - pure $ Res.resp400 PlainText "Empty Topic" -mkErrorResponse ( DBError _e ) = do +mkErrorResponse UnknownRoute = pure $ Res.resp404 PlainText "Unknown Route" +mkErrorResponse EmptyCommentText = pure $ Res.resp400 PlainText "Empty Comment" +mkErrorResponse EmptyTopic = pure $ Res.resp400 PlainText "Empty Topic" +mkErrorResponse ( DBError _ ) = do -- As with our request for the FirstAppDB, we use the asks function from -- Control.Monad.Reader and pass the field accessors from the Env record. error "mkErrorResponse needs to 'log' our DB Errors to the console" diff --git a/level06/src/FirstApp/DB.hs b/src/Level07/DB.hs similarity index 90% rename from level06/src/FirstApp/DB.hs rename to src/Level07/DB.hs index 5ba36b0..a0914de 100644 --- a/level06/src/FirstApp/DB.hs +++ b/src/Level07/DB.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.DB +module Level07.DB ( FirstAppDB (FirstAppDB) , initDB , closeDB @@ -25,9 +25,9 @@ import qualified Database.SQLite.Simple as Sql import qualified Database.SQLite.SimpleErrors as Sql import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.AppM (AppM, Env (envDB)) +import Level07.AppM (AppM, Env (envDB)) -import FirstApp.Types (Comment, CommentText, +import Level07.Types (Comment, CommentText, DBFilePath (getDBFilePath), Error (DBError), FirstAppDB (FirstAppDB, dbConn), @@ -68,30 +68,30 @@ getDBConn = runDB :: (a -> Either Error b) -> (Connection -> IO a) - -> AppM (Either Error b) + -> AppM b runDB = error "runDB not re-implemented" getComments :: Topic - -> AppM (Either Error [Comment]) + -> AppM [Comment] getComments = error "Copy your completed 'getComments' and refactor to match the new type signature" addCommentToTopic :: Topic -> CommentText - -> AppM (Either Error ()) + -> AppM () addCommentToTopic = error "Copy your completed 'appCommentToTopic' and refactor to match the new type signature" getTopics - :: AppM (Either Error [Topic]) + :: AppM [Topic] getTopics = error "Copy your completed 'getTopics' and refactor to match the new type signature" deleteTopic :: Topic - -> AppM (Either Error ()) + -> AppM () deleteTopic = error "Copy your completed 'deleteTopic' and refactor to match the new type signature" diff --git a/level07/src/FirstApp/DB/PostgreSQL.hs b/src/Level07/DB/PostgreSQL.hs similarity index 98% rename from level07/src/FirstApp/DB/PostgreSQL.hs rename to src/Level07/DB/PostgreSQL.hs index f7f2ca3..d38d17e 100644 --- a/level07/src/FirstApp/DB/PostgreSQL.hs +++ b/src/Level07/DB/PostgreSQL.hs @@ -3,7 +3,7 @@ -- postgresql-simple package. It is missing the very helpful error handling of -- the sqlite-simple-errors package. The postgresql-simple package is littered -- with exceptions which are not visible in the types, so be wary. -module FirstApp.DB.PostgreSQL where +module Level07.DB.PostgreSQL where import GHC.Int (Int64) @@ -15,7 +15,7 @@ import Database.PostgreSQL.Simple (Connection, FromRow, Query, import Database.PostgreSQL.Simple.Types (Identifier (..)) import qualified Database.PostgreSQL.Simple as PG -import FirstApp.Types +import Level07.Types -- This is a bit more configuration available to the PostgreSQL package so we -- have a bit more work to do. diff --git a/level07/src/FirstApp/DB/Types.hs b/src/Level07/DB/Types.hs similarity index 68% rename from level07/src/FirstApp/DB/Types.hs rename to src/Level07/DB/Types.hs index fec9047..add3774 100644 --- a/level07/src/FirstApp/DB/Types.hs +++ b/src/Level07/DB/Types.hs @@ -1,24 +1,10 @@ -module FirstApp.DB.Types where - -import Data.Time (UTCTime) +module Level07.DB.Types where import Data.Text (Text) +import Data.Time (UTCTime) -import Database.SQLite.Simple (Connection) import Database.SQLite.Simple.FromRow (FromRow (fromRow), field) -newtype Table = Table - { getTableName :: Text } - deriving Show - --- We have a data type to simplify passing around the information we need to run --- our database queries. This also allows things to change over time without --- having to rewrite all of the functions that need to interact with DB related --- things in different ways. -data FirstAppDB = FirstAppDB - { dbConn :: Connection - } - -- To try to avoid leaking various types and expected functionality around the -- application, we create a stand alone type that will represent the data we -- store in the database. In this instance, it is the raw types that make up a diff --git a/level06/README.md b/src/Level07/README.md similarity index 73% rename from level06/README.md rename to src/Level07/README.md index 71f76b2..1aefbc3 100644 --- a/level06/README.md +++ b/src/Level07/README.md @@ -9,4 +9,7 @@ Since nearly any given request handler will likely require access to either the general application configuration or the database, it is tedious to have to pass the information in manually in every instance. -Start in ``src/FirstApp/AppM.hs``. +Since we already have an AppM type, we're extending with more functionality, +this is what is known as 'stacking' monad transformers. + +Start in ``src/Level07/AppM.hs``. diff --git a/level06/src/FirstApp/Responses.hs b/src/Level07/Responses.hs similarity index 92% rename from level06/src/FirstApp/Responses.hs rename to src/Level07/Responses.hs index 4c9cda0..3b32725 100644 --- a/level06/src/FirstApp/Responses.hs +++ b/src/Level07/Responses.hs @@ -1,4 +1,4 @@ -module FirstApp.Responses where +module Level07.Responses where import Network.Wai (Response, responseLBS) @@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Aeson (ToJSON) import qualified Data.Aeson as A -import FirstApp.Types (ContentType (JSON), +import Level07.Types (ContentType (JSON), renderContentType) mkResponse diff --git a/level06/src/FirstApp/Types.hs b/src/Level07/Types.hs similarity index 96% rename from level06/src/FirstApp/Types.hs rename to src/Level07/Types.hs index e677553..f6f4d45 100644 --- a/level06/src/FirstApp/Types.hs +++ b/src/Level07/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Types +module Level07.Types ( Error (..) , ConfigError (..) , PartialConf (..) @@ -46,17 +46,17 @@ import Data.Time (UTCTime) import Database.SQLite.Simple (Connection) import Database.SQLite.SimpleErrors.Types (SQLiteResponse) -import FirstApp.DB.Types (DbComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic)) -import FirstApp.Types.Error (Error ( UnknownRoute +import Level07.DB.Types (DbComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic)) +import Level07.Types.Error (Error ( UnknownRoute , EmptyCommentText , EmptyTopic , DBError )) -import FirstApp.Types.CommentText ( CommentText +import Level07.Types.CommentText ( CommentText , mkCommentText , getCommentText ) -import FirstApp.Types.Topic (Topic, mkTopic, getTopic) +import Level07.Types.Topic (Topic, mkTopic, getTopic) newtype CommentId = CommentId Int deriving (Show, ToJSON) diff --git a/level06/src/FirstApp/Types/CommentText.hs b/src/Level07/Types/CommentText.hs similarity index 80% rename from level06/src/FirstApp/Types/CommentText.hs rename to src/Level07/Types/CommentText.hs index c52f31a..626d8c3 100644 --- a/level06/src/FirstApp/Types/CommentText.hs +++ b/src/Level07/Types/CommentText.hs @@ -1,12 +1,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module FirstApp.Types.CommentText +module Level07.Types.CommentText ( CommentText , mkCommentText , getCommentText ) where -import FirstApp.Types.Error (Error(EmptyCommentText), nonEmptyText) +import Level07.Types.Error (Error(EmptyCommentText), nonEmptyText) import Data.Text (Text) import Data.Aeson (ToJSON) diff --git a/level06/src/FirstApp/Types/Error.hs b/src/Level07/Types/Error.hs similarity index 87% rename from level06/src/FirstApp/Types/Error.hs rename to src/Level07/Types/Error.hs index f26ccd2..3e9d86d 100644 --- a/level06/src/FirstApp/Types/Error.hs +++ b/src/Level07/Types/Error.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module FirstApp.Types.Error (Error(..), nonEmptyText) where +module Level07.Types.Error (Error(..), nonEmptyText) where import Data.Text (Text) import Database.SQLite.SimpleErrors.Types (SQLiteResponse) diff --git a/level06/src/FirstApp/Types/Topic.hs b/src/Level07/Types/Topic.hs similarity index 70% rename from level06/src/FirstApp/Types/Topic.hs rename to src/Level07/Types/Topic.hs index f18fe10..43a747d 100644 --- a/level06/src/FirstApp/Types/Topic.hs +++ b/src/Level07/Types/Topic.hs @@ -1,8 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module FirstApp.Types.Topic (Topic, mkTopic, getTopic) where +module Level07.Types.Topic (Topic, mkTopic, getTopic) where -import FirstApp.Types.Error (Error(EmptyTopic), nonEmptyText) +import Level07.Types.Error (Error(EmptyTopic), nonEmptyText) import Data.Text (Text) import Data.Aeson (ToJSON) diff --git a/stack.yaml b/stack.yaml index 6ecf0e5..04dfded 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,7 @@ resolver: lts-10.4 -packages: -- level01 -- level02 -- level03 -- level04 -- level05 -- level06 -- level07 +extra-deps: +- aeson-1.3.1.0 +- optparse-applicative-0.14.2.0 +- sqlite-simple-errors-0.6.1.0 +- text-1.2.3.0 +- th-abstraction-0.2.6.0 diff --git a/level03/tests/Test.hs b/tests/Level03Tests.hs similarity index 92% rename from level03/tests/Test.hs rename to tests/Level03Tests.hs index 4bc00b4..4472fda 100644 --- a/level03/tests/Test.hs +++ b/tests/Level03Tests.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where +module Level03Tests + ( unitTests + ) where import Test.Hspec import Test.Hspec.Wai @@ -10,12 +12,12 @@ import qualified System.Exit as Exit import qualified Data.ByteString.Lazy.Char8 as LBS8 -import qualified FirstApp.Main as Main +import qualified Level03.Core as Core -main :: IO () -main = do +unitTests :: IO () +unitTests = do -- We need to setup our Application. - let app' = pure Main.app + let app' = pure Core.app -- This sets up HSpec to use our application as the thing it executes before the tests are run hspec . with app' $ do @@ -44,4 +46,3 @@ main = do -- 2) The '/view' route will respond correctly when given a topic -- 3) The '/view' route will respond with an error when given an empty topic -- 4) A gibberish route will return a 404 - diff --git a/level04/tests/Test.hs b/tests/Level04Tests.hs similarity index 79% rename from level04/tests/Test.hs rename to tests/Level04Tests.hs index 3521684..2084315 100644 --- a/level04/tests/Test.hs +++ b/tests/Level04Tests.hs @@ -1,5 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where +module Level04Tests + ( unitTests + , doctests + ) where import Control.Monad (join) @@ -8,21 +11,29 @@ import Test.Hspec.Wai import qualified System.Exit as Exit -import qualified FirstApp.DB as DB -import qualified FirstApp.Main as Main -import qualified FirstApp.Types as Types +import qualified Level04.Core as Core +import qualified Level04.DB as DB +import qualified Level04.Types as Types -main :: IO () -main = do +doctests :: [FilePath] +doctests = + [ "-isrc" + , "src/Level04/Conf.hs" + , "src/Level04/DB.hs" + , "src/Level04/Types.hs" + ] + +unitTests :: IO () +unitTests = do let dieWith m = print m >> Exit.exitFailure - reqsE <- Main.prepareAppReqs + reqsE <- Core.prepareAppReqs case reqsE of Left err -> dieWith err Right db -> do - let app' = pure ( Main.app db ) + let app' = pure ( Core.app db ) flushTopic = -- Clean up and yell about our errors diff --git a/tests/Level05Tests.hs b/tests/Level05Tests.hs new file mode 100644 index 0000000..fd25117 --- /dev/null +++ b/tests/Level05Tests.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +module Level05Tests + ( unitTests + , doctests + ) where + +import Control.Monad.Reader (ask, reader) + +import Data.Monoid ((<>)) + +import Data.String (IsString) + +import Test.Hspec +import Test.Hspec.Wai + +import qualified System.Exit as Exit + +import qualified Level05.AppM as AppM + +import qualified Level05.Core as Core +import qualified Level05.DB as DB +import qualified Level05.Types as Types + +doctests :: [FilePath] +doctests = + [ "-isrc" + , "src/Level05/Conf.hs" + , "src/Level05/DB.hs" + , "src/Level05/Types.hs" + ] + +unitTests :: IO () +unitTests = do + let + dieWith :: Show a => a -> IO () + dieWith m = print m >> Exit.exitFailure + + -- This helps keep the string polymorphic so we can use it in both + -- ByteString and Text forms in this file, without having to run encoding + -- functions. The compiler takes care of it for us. + testTopic :: IsString s => s + testTopic = "fudge" + + reqsE <- Core.prepareAppReqs + case reqsE of + + Left err -> dieWith err + + Right db -> do + let app' = pure (Core.app db) + + flushTopic = + -- Clean up and yell about our errors + either dieWith pure =<< AppM.runAppM ( + -- We don't export the constructor so even for known values we have + -- to play by the rules. There is no - "Oh just this one time.", do it right. + AppM.liftEither (Types.mkTopic testTopic) + -- Purge all of the comments for this topic for our tests + >>= DB.deleteTopic db + ) + + -- Run the tests with a DB topic flush between each spec + hspec . with ( flushTopic >> app' ) $ do + -- Save us a bit of repetition + let pOST = post ( "/" <> testTopic <> "/add" ) + + -- AddRq Spec + describe "POST /topic/add" $ do + it "Should return 200 with well formed request" $ + pOST "Is super tasty." `shouldRespondWith` "Success" + + it "Should 400 on empty input" $ + pOST "" `shouldRespondWith` 400 + + -- ViewRq Spec + describe "GET /topic/view" $ + it "Should return 200 with content" $ do + _ <- pOST "Is super tasty." + get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200 + + -- ListRq Spec + describe "GET /list" $ + it "Should return 200 with content" $ do + _ <- pOST "Is super tasty." + get "/list" `shouldRespondWith` "[\"fudge\"]" diff --git a/tests/Level06Tests.hs b/tests/Level06Tests.hs new file mode 100644 index 0000000..1a2c0f8 --- /dev/null +++ b/tests/Level06Tests.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +module Level06Tests + ( doctests + , unitTests + ) where + +import Control.Monad (join) + +import Data.Monoid ((<>)) +import Data.String (IsString) + +import Test.Hspec +import Test.Hspec.Wai + +import qualified System.Exit as Exit + +import qualified Level06.AppM as AppM +import qualified Level06.Core as Core +import qualified Level06.DB as DB +import qualified Level06.Types as Types + +doctests :: [FilePath] +doctests = + [ "-isrc" + , "src/Level06/Conf.hs" + , "src/Level06/DB.hs" + , "src/Level06/Types.hs" + ] + +unitTests :: IO () +unitTests = do + let + dieWith :: Show a => a -> IO () + dieWith m = print m >> Exit.exitFailure + + testTopic :: IsString s => s + testTopic = "fudge" + + reqsE <- Core.prepareAppReqs + case reqsE of + + Left err -> dieWith err + + Right ( cfg, db ) -> do + let app' = pure (Core.app cfg db) + + flushTopic :: IO () + flushTopic = either dieWith pure =<< AppM.runAppM + (AppM.liftEither (Types.mkTopic testTopic) >>= DB.deleteTopic db) + + -- Run the tests with a DB topic flush between each spec + hspec . with ( flushTopic >> app' ) $ do + -- Save us a bit of repetition + let pOST = post ( "/" <> testTopic <> "/add" ) + + -- AddRq Spec + describe "POST /topic/add" $ do + it "Should return 200 with well formed request" $ + pOST "Is super tasty." `shouldRespondWith` "Success" + + it "Should 400 on empty input" $ + pOST "" `shouldRespondWith` 400 + + -- ViewRq Spec + describe "GET /topic/view" $ + it "Should return 200 with content" $ do + _ <- pOST "Is super tasty." + get ( "/" <> testTopic <> "/view" ) `shouldRespondWith` 200 + + -- ListRq Spec + describe "GET /list" $ + it "Should return 200 with content" $ do + _ <- pOST "Is super tasty." + get "/list" `shouldRespondWith` "[\"fudge\"]" diff --git a/level07/tests/Test.hs b/tests/Level07Tests.hs similarity index 59% rename from level07/tests/Test.hs rename to tests/Level07Tests.hs index 71ac0cb..baaa7bd 100644 --- a/level07/tests/Test.hs +++ b/tests/Level07Tests.hs @@ -1,52 +1,67 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where +module Level07Tests + ( unitTests + , doctests + ) where import Control.Monad.Reader (ask, reader) -import Data.Monoid ((<>)) +import Control.Monad (join) -import Data.String (IsString) +import Data.Monoid ((<>)) +import Data.String (IsString) import Test.Hspec import Test.Hspec.Wai -import qualified System.Exit as Exit +import qualified System.Exit as Exit -import FirstApp.AppM (Env) -import qualified FirstApp.AppM as AppM +import Level07.AppM (Env) +import qualified Level07.AppM as AppM -import qualified FirstApp.DB as DB -import qualified FirstApp.Main as Main -import qualified FirstApp.Types as Types +import qualified Level07.Core as Core +import qualified Level07.DB as DB +import qualified Level07.Types as Types -main :: IO () -main = do +doctests :: [FilePath] +doctests = + [ "-isrc" + , "src/Level07/Conf.hs" + , "src/Level07/DB.hs" + , "src/Level07/Types.hs" + ] + +unitTests :: IO () +unitTests = do let dieWith :: Show a => a -> IO () dieWith m = print m >> Exit.exitFailure - -- This helps keep the string polymorphic so we can use it in both - -- ByteString and Text forms in this file, without having to run encoding - -- functions. The compiler takes care of it for us. testTopic :: IsString s => s testTopic = "fudge" - reqsE <- Main.prepareAppReqs + -- Keeping everything in sync with out larger application changes. + reqsE <- Core.prepareAppReqs case reqsE of Left err -> dieWith err Right env -> do - let app' = pure ( Main.app env ) + let app' = pure ( Core.app env ) flushTopic :: IO () - flushTopic = (either dieWith pure =<<) - $ AppM.runAppM ( do - t <- AppM.liftEither $ Types.mkTopic "fudge" - DB.deleteTopic t ) env + flushTopic = either dieWith pure =<< AppM.runAppM + (AppM.liftEither =<< traverse DB.deleteTopic ( Types.mkTopic testTopic )) + env + + -- We can't run the tests for our AppM in the same stage as our + -- application, because of the use of the 'with' function. As it expects + -- to be able to execute our tests by applying it to our 'Application'. + hspec $ appMTests env -- Run the tests with a DB topic flush between each spec hspec . with ( flushTopic >> app' ) $ do + -- Save us a bit of repetition let pOST = post ( "/" <> testTopic <> "/add" ) @@ -70,6 +85,7 @@ main = do _ <- pOST "Is super tasty." get "/list" `shouldRespondWith` "[\"fudge\"]" + -- These tests ensure that our AppM will do we want it to, with respect to the -- behaviour of 'ask', 'reader', and use in a Monad. appMTests :: Env -> Spec @@ -77,8 +93,7 @@ appMTests env = describe "AppM Tests" $ do it "ask should retrieve the Env" $ do r <- AppM.runAppM ask env - let cfg = AppM.envConfig <$> r - ( cfg == ( Right $ AppM.envConfig env )) `shouldBe` True + ( (AppM.envConfig <$> r) == (Right $ AppM.envConfig env) ) `shouldBe` True it "reader should run a function on the Env" $ do let getDBfilepath = Types.dbFilePath . AppM.envConfig @@ -91,4 +106,4 @@ appMTests env = describe "AppM Tests" $ do e <- ask AppM.envLoggingFn e "In a test!" r <- AppM.runAppM fn env - r `shouldBe` ( Right () ) + r `shouldBe` Right () diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 index 0000000..47c96d1 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,16 @@ +module Main where + +import qualified Level03Tests +import qualified Level04Tests +import qualified Level05Tests +import qualified Level06Tests +import qualified Level07Tests + +main :: IO () +main = do + putStrLn "No tests yet!" + -- Level03Tests.unitTests + -- Level04Tests.unitTests + -- Level05Tests.unitTests + -- Level06Tests.unitTests + -- Level07Tests.unitTests diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 index 0000000..246323c --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,15 @@ +module Main where + +import Test.DocTest (doctest) + +import qualified Level04Tests +import qualified Level05Tests +import qualified Level06Tests +import qualified Level07Tests + +main :: IO () +main = doctest [] -- No doctests yet! + -- Level04Tests.doctests + -- Level05Tests.doctests + -- Level06Tests.doctests + -- Level07Tests.doctests