qfpl/applied-fp-course
1
1
Fork 0
mirror of https://github.com/qfpl/applied-fp-course.git synced 2024-11-22 02:55:57 +03:00
Code Issues Projects Releases Wiki Activity

the bonnet is up and we're on bricks. Fix it. (#71)

Browse Source 
* Add shell.nix that includes sqlite.

previous shell environment didn't include an application that was necessary for
developing the application. Whoops.

This new shell.nix lets students add their own development tools if they want
to try something out. `ghcid` for example.

* Overhaul: New techniques, new exercises.

Remove hspec-wai dependencies, add waargonaut.

The aeson dependency has been replaced with waargonaut, and the exercises have
been updated to match. Some exercises have been removed.

Add the use of `finally` as a demonstration and reminder that we should be
cleaning up things like connections when an app is done.

Explain the purpose of the `runDB` function so that implementation makes more
sense to students as an exercise.

Add exercise to generalise the error type that is used in the `AppM` transformer
that they implement. This flows onto a later exercise where they reuse this type
to simplify a function that is not part of the core application. This also
allows for an easier introduction of `ExceptT` as an exercise later in the
course when `AppM` is no longer usable.

Add a startup error constructor as making the students add it isn't informative
when compared to the rest of the exercise.

* Remove all duplicate tests. Rebuild Level03.

Level03 has been changed entirely to be centered on writing tests for student
code. The tests are then to be updated by the students as they progress through
the course. There are no duplicated tests and there is a bit more incentive for
students to get in and get their hands dirty with respect to testing their own
work.

Still not sure what to do with doctests just yet. More documentation is required
for that.

* Remove Level03 exe and modules.

* Feedback driven development

* Add tighter bounds for lens.
* Add bounds for old-locale and contravariant.
* Realign some imports.
* Rename 'AppM'' to 'AppM' and 'AppM' to 'App'.
* Clean up an utterly misleading and out of date comment regarding configuration
  package choices. Revert to unremarkable statement about it being JSON.
* Remove redundant import of `Level02.Types` from `tests/Test.hs`.
* Add waargonaut to extra-deps in stack.yaml.
* Bump LTS in stack.yaml to 12.14.
* Fix typos.
* Improve wording, restructure some comments.

* Revert LTS bump, increase contravariant upper bound for GHC 8.6.1

* Try updated stack.yaml

* Update travis.yml:

Bump patch versions of GHC:

* 8.4.3 -> 8.4.4
* 8.6.1 -> 8.6.2

Drop Stack LTS:

6, 9, 10

Add Stack LTS:

11, 12

* Add fixes to help stack nightly builds on travis. Remove some comments in cabal file

* Remove LTS-11, add in-memory db notes to level04

* add workshop levels document for expansion

* Proofread changes.

* Try to use cached GHC downloads for stack on travis

* Remove install ghc flag from stack commands

* Last try to stop stack downloading its own GHC

* Revert stack travis changes. Attempt to pin appar version for 7.10.3.

* Drop support for GHC 7.10.3
This commit is contained in:
Sean Chalmers 2018-12-07 10:16:13 +10:00 committed by GitHub
parent 95f268c504
commit b8921cd1aa
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
58 changed files with 1096 additions and 1939 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
.travis.yml
View File

@ -30,10 +30,10 @@ before_cache:
matrix:
include:
- env: BUILD=cabal
compiler: "ghc-7.10.3"
# - env: BUILD=cabal
# compiler: "ghc-7.10.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}}
# addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}}
- env: BUILD=cabal
compiler: "ghc-8.0.2"
@ -46,13 +46,13 @@ matrix:
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}}
- env: BUILD=cabal
compiler: "ghc-8.4.3"
compiler: "ghc-8.4.4"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.3], sources: [hvr-ghc]}}
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}
- env: BUILD=cabal
compiler: "ghc-8.6.1"
compiler: "ghc-8.6.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.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.
@ -60,16 +60,8 @@ matrix:
compiler: ": #stack default"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-6"
compiler: ": #stack 7.10.3"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-10"
compiler: ": #stack 8.2.2"
- env: BUILD=stack ARGS="--resolver lts-12"
compiler: ": #stack 8.4.4"
addons: {apt: {packages: [libgmp-dev]}}
# Nightly builds are allowed to fail
@ -82,17 +74,8 @@ matrix:
compiler: ": #stack default osx"
os: osx
# Travis includes an macOS which is incompatible with GHC 7.8.4
- env: BUILD=stack ARGS="--resolver lts-6"
compiler: ": #stack 7.10.3 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-10"
compiler: ": #stack 8.2.2 osx"
- env: BUILD=stack ARGS="--resolver lts-12"
compiler: ": #stack 8.4.4 osx"
os: osx
- env: BUILD=stack ARGS="--resolver nightly"
@ -100,7 +83,6 @@ matrix:
os: osx
allow_failures:
#- env: BUILD=stack ARGS="--resolver lts-6"
- env: BUILD=stack ARGS="--resolver nightly"
before_install:
@ -134,13 +116,15 @@ install:
- |
case "$BUILD" in
stack)
cabal --version
ghc --version
# 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 --install-ghc build --bench --dry-run || ( \
stack --no-terminal $ARGS --install-ghc build cabal-install && \
stack --no-terminal $ARGS solver --update-config)
# Build the dependencies
stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies
stack --no-terminal $ARGS test --bench --only-dependencies
;;
cabal)
cabal --version

10
README.md
View File

@ -4,9 +4,9 @@
<img src="https://i.imgur.com/0h9dFhl.png" height="200" width="320" />
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.
This is a 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.
This course is designed to be run in a class room with instructors, but we
would like to make it suitable for self-study as well. Although undertaking
@ -123,8 +123,8 @@ instructions about what the goal is for that specific level.
* Level 06 : Add some flexible configuration
* Level 07 : ReaderT & refactoring
-- Coming Soon...
* Level 08 : (Bonus Round) Lenses & Refactoring
-- In Development...
* Level 08 : Lenses & "classy mtl" monad transformers
-- Maybe...
* Level 09 : Add session controls (login, logout) and a protected route. So we

56
applied-fp-course.cabal
View File

@ -48,7 +48,6 @@ tested-with: GHC==8.6.1
, GHC==8.4.3
, GHC==8.2.2
, GHC==8.0.2
, GHC==7.10.3
source-repository head
type: git
@ -60,8 +59,6 @@ library
Level01.Core
, Level02.Core
, Level02.Types
, Level03.Core
, Level03.Types
, Level04.Conf
, Level04.DB
, Level04.DB.Types
@ -118,13 +115,17 @@ library
, bytestring == 0.10.*
, text == 1.2.*
, optparse-applicative >= 0.13 && < 0.15
, aeson == 1.*
, mtl == 2.2.*
, time >= 1.4 && < 1.10
, old-locale >= 1.0 && < 1.5
, contravariant >= 1.4 && < 1.6
, sqlite-simple == 0.4.*
, sqlite-simple-errors == 0.6.*
, semigroups == 0.18.*
, transformers >= 0.4 && < 0.6
, lens >= 4.15 && < 4.18
, waargonaut >= 0.4.2 && < 0.5
, attoparsec >= 0.13 && < 0.15
-- Directories containing source files.
hs-source-dirs: src
@ -139,14 +140,6 @@ test-suite app-fp-tests
hs-source-dirs: tests
main-is: Test.hs
other-modules: Level03Tests
, Level04Tests
, Level05Tests
, Level06Tests
, Level07Tests
, Helpers
build-depends: base >= 4.8 && <4.13
, applied-fp-course
, wai == 3.2.*
@ -154,44 +147,28 @@ test-suite app-fp-tests
, http-types >= 0.9 && < 0.13
, tasty >= 0.8 && < 1.2
, tasty-hunit >= 0.9 && < 0.11
, hspec >= 2.2 && < 3.0
, hspec-wai >= 0.6 && < 0.10
, tasty-wai >= 0.1 && < 0.2
, bytestring == 0.10.*
, text == 1.2.*
, mtl == 2.2.*
, semigroups == 0.18.*
, transformers >= 0.4 && < 0.6
, mmorph
-- [Challenge] Packages
, hedgehog >= 0.6 && < 0.7
, tasty-hedgehog >= 0.2 && < 0.3
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
, Helpers
ghc-options: -threaded
main-is: doctests.hs
hs-source-dirs: tests
build-depends: base >= 4.8 && <4.13
, applied-fp-course
, mtl == 2.2.*
, hspec >= 2.2 && < 3.0
, hspec-wai >= 0.6 && < 0.10
, doctest >= 0.11 && < 0.17
, semigroups == 0.18.*
, tasty >= 0.8 && < 1.2
, tasty-hunit >= 0.9 && < 0.11
, bytestring == 0.10.*
, wai == 3.2.*
, wai-extra == 3.0.*
, http-types >= 0.9 && < 0.13
, transformers >= 0.4 && < 0.6
, mmorph
, applied-fp-course
-- Level Executables
executable level01-exe
@ -216,17 +193,6 @@ executable level02-exe
-- 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.13
, 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

21
applied-fp-course.nix
View File

@ -1,7 +1,9 @@
{ mkDerivation, aeson, base, bytestring, doctest, hspec, hspec-wai
, http-types, mtl, optparse-applicative, semigroups, sqlite-simple
, sqlite-simple-errors, stdenv, tasty, tasty-hunit, text, time
, transformers, wai, wai-extra, warp, mmorph
{ mkDerivation, attoparsec, base, bytestring, contravariant
, doctest, hedgehog, http-types, lens, mtl, old-locale
, optparse-applicative, semigroups, sqlite-simple
, sqlite-simple-errors, stdenv, tasty, tasty-hedgehog, tasty-hunit
, tasty-wai, text, time, transformers, waargonaut, wai, wai-extra
, warp
}:
mkDerivation {
pname = "applied-fp-course";
@ -10,14 +12,15 @@ mkDerivation {
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson base bytestring http-types mtl optparse-applicative
semigroups sqlite-simple sqlite-simple-errors text time
transformers wai warp
attoparsec base bytestring contravariant http-types lens mtl
old-locale optparse-applicative semigroups sqlite-simple
sqlite-simple-errors text time transformers waargonaut wai warp
];
executableHaskellDepends = [ base ];
testHaskellDepends = [
base bytestring doctest hspec hspec-wai http-types mtl tasty
tasty-hunit text wai wai-extra mmorph
base bytestring doctest hedgehog http-types mtl semigroups tasty
tasty-hedgehog tasty-hunit tasty-wai text transformers wai
wai-extra
];
description = "Simplest of web apps for educational purposes";
license = stdenv.lib.licenses.bsd3;

20
default.nix
View File

@ -8,7 +8,23 @@ let
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler};
drv = haskellPackages.callPackage ./applied-fp-course.nix {};
sources = {
tasty-wai = import ./nix/tasty-wai.nix;
waarg = import ./nix/waargonaut.nix;
};
waarg-deps = import "${sources.waarg}/waargonaut-deps.nix";
modifiedHaskellPackages = haskellPackages.override (old: {
overrides = pkgs.lib.composeExtensions
(old.overrides or (_: _: {}))
(self: super: (waarg-deps pkgs self super) // {
tasty-wai = self.callCabal2nix "tasty-wai" sources.tasty-wai {};
waargonaut = self.callCabal2nix "waargonaut" sources.waarg {};
});
});
drv = modifiedHaskellPackages.callPackage ./applied-fp-course.nix {};
in
if pkgs.lib.inNixShell then drv.env else drv
drv

9
exe/Level03.hs
View File

@ -1,9 +0,0 @@
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

2
exe/Level06.hs
View File

@ -6,4 +6,4 @@ import qualified Level06.Core as Core
-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable
-- affair.
main :: IO ()
main = Core.runApp
main = Core.runApplication

2
exe/Level07.hs
View File

@ -6,4 +6,4 @@ import qualified Level07.Core as Core
-- executable. So our ``exe/Main.hs`` is a straightforward and unremarkable
-- affair.
main :: IO ()
main = Core.runApp
main = Core.runApplication

7
nix/tasty-wai.json Normal file
View File

@ -0,0 +1,7 @@
{
"url": "https://github.com/qfpl/tasty-wai",
"rev": "17ae906f318a222eb30a22b6b334399a0ca436a9",
"date": "2018-12-04T14:31:04+10:00",
"sha256": "16j3qbpwxbl4n2pvck91k6gz2541pkfdpxn4l47nf1s9jx9yaa7f",
"fetchSubmodules": true
}

13
nix/tasty-wai.nix Normal file
View File

@ -0,0 +1,13 @@
let
initialNixpkgs = import <nixpkgs> {};
sources = rec {
tasty-wai-pinned = initialNixpkgs.pkgs.lib.importJSON ./tasty-wai.json;
tasty-wai = initialNixpkgs.pkgs.fetchFromGitHub {
owner = "qfpl";
repo = "tasty-wai";
inherit (tasty-wai-pinned) rev sha256;
};
};
in
sources.tasty-wai

7
nix/waargonaut.json Normal file
View File

@ -0,0 +1,7 @@
{
"url": "https://github.com/qfpl/waargonaut",
"rev": "7d868c5ca568797345cee762a499488227238b1f",
"date": "2018-11-29T12:55:15+10:00",
"sha256": "1hr0iyzcamgknsx4830rzvfxy6ykslnalfvbxb6k7h8ywkd2zzc2",
"fetchSubmodules": true
}

13
nix/waargonaut.nix Normal file
View File

@ -0,0 +1,13 @@
let
initialNixpkgs = import <nixpkgs> {};
sources = rec {
waargonaut-pinned = initialNixpkgs.pkgs.lib.importJSON ./waargonaut.json;
waargonaut = initialNixpkgs.pkgs.fetchFromGitHub {
owner = "qfpl";
repo = "waargonaut";
inherit (waargonaut-pinned) rev sha256;
};
};
in
sources.waargonaut

25
shell.nix Normal file
View File

@ -0,0 +1,25 @@
{ nixpkgs ? import <nixpkgs> {}
, compiler ? "default"
}:
let
inherit (nixpkgs) pkgs;
# Grab our course derivation
course = import ./. { inherit nixpkgs compiler; };
# Override the basic derivation so we can have a more fully feature
# environment for hacking on the course material
courseDevEnv = (pkgs.haskell.lib.addBuildTools course
[ # Include the SQLite Database application
nixpkgs.sqlite
# 'ghcid' auto reloading tool
nixpkgs.haskellPackages.ghcid
]
# We don't want nix to build the thing, we want the environment so we can
# build the thing.
).env;
in
# Fly, my pretties!
courseDevEnv

37
src/Level02/Core.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Level02.Core (runApp) where
module Level02.Core (runApp, app) where
import Network.Wai (Application, Request, Response,
pathInfo, requestMethod, responseLBS,
@ -16,13 +16,13 @@ import Data.Either (either)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Level02.Types (ContentType, Error, RqType,
import Level02.Types (ContentType, Error, RqType,
mkCommentText, mkTopic,
renderContentType)
-- --------------------------------------------
-- - Don't start here, go to Level02.Types! -
-- --------------------------------------------
-- |-------------------------------------------|
-- |- Don't start here, go to Level02.Types! -|
-- |-------------------------------------------|
-- | Some helper functions to make our lives a little more DRY.
mkResponse
@ -54,8 +54,16 @@ resp400
resp400 =
error "resp400 not implemented"
-- These next few functions will take raw request information and construct one
-- of our types.
-- |----------------------------------------------------------------------------------
-- These next few functions will take raw request information and construct --
-- one of our types. --
-- --
-- By breaking out these smaller functions, we're able to isolate our --
-- validation requirements into smaller components that are simpler to maintain --
-- and verify. It also allows for greater reuse and it also means that --
-- validation is not duplicated across the application, maybe incorrectly. --
--------------------------------------------------------------------------------------
mkAddRequest
:: Text
-> LBS.ByteString
@ -67,10 +75,6 @@ mkAddRequest =
lazyByteStringToStrictText =
decodeUtf8 . LBS.toStrict
-- This has a number of benefits, we're able to isolate our validation
-- requirements into smaller components that are simpler to maintain and verify.
-- It also allows for greater reuse and it also means that validation is not
-- duplicated across the application, maybe incorrectly.
mkViewRequest
:: Text
-> Either Error RqType
@ -82,13 +86,17 @@ mkListRequest
mkListRequest =
error "mkListRequest not implemented"
-- |----------------------------------
-- end of RqType creation functions --
--------------------------------------
mkErrorResponse
:: Error
-> Response
mkErrorResponse =
error "mkErrorResponse not implemented"
-- Use our ``RqType`` helpers to write a function that will take the input
-- | Use our ``RqType`` helpers to write a function that will take the input
-- ``Request`` from the Wai library and turn it into something our application
-- cares about.
mkRequest
@ -99,7 +107,7 @@ mkRequest =
-- specification in this function.
error "mkRequest not implemented"
-- If we find that we need more information to handle a request, or we have a
-- | If we find that we need more information to handle a request, or we have a
-- new type of request that we'd like to handle then we update the ``RqType``
-- structure and the compiler will let us know which parts of our application
-- are affected.
@ -116,8 +124,7 @@ handleRequest
handleRequest =
error "handleRequest not implemented"
-- Reimplement this function using the new functions and ``RqType`` constructors
-- as a guide.
-- | Reimplement this function using the new functions and ``RqType`` constructors as a guide.
app
:: Application
app =

121
src/Level03/Core.hs
View File

@ -1,121 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level03.Core (runApp, app) where
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)
import qualified Data.ByteString.Lazy as LBS
import Data.Either (either)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Level03.Types (ContentType (PlainText), Error (EmptyCommentText, EmptyTopic, UnknownRoute),
RqType (AddRq, ListRq, ViewRq),
mkCommentText, mkTopic,
renderContentType)
runApp :: IO ()
runApp = run 3000 app
-- | 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
-- |
app :: Application
app rq cb = mkRequest rq
>>= fmap handleRespErr . pure . handleRErr
>>= cb
where
-- Does this seem clunky to you?
handleRespErr :: Either Error Response -> Response
handleRespErr = either mkErrorResponse id
-- Because it is clunky, and we have a better solution, later.
handleRErr :: Either Error RqType -> Either Error Response
handleRErr = either Left handleRequest
handleRequest
:: RqType
-> Either Error Response
handleRequest (AddRq _ _) =
Right $ resp200 PlainText "Hello there!"
handleRequest (ViewRq _) =
Right $ resp200 PlainText "View Request not implemented"
handleRequest ListRq =
Right $ resp200 PlainText "List Request not implemented"
mkRequest
:: Request
-> IO ( Either Error RqType )
mkRequest rq =
case ( pathInfo rq, requestMethod rq ) of
-- Commenting on a given topic
( [t, "add"], "POST" ) -> 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 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 =
resp404 PlainText "Unknown Route"
mkErrorResponse EmptyCommentText =
resp400 PlainText "Empty Comment"
mkErrorResponse EmptyTopic =
resp400 PlainText "Empty Topic"

72
src/Level03/README.md
View File

@ -4,19 +4,64 @@ In this exercise we're going to add some tests to our application. Because types
are awesome, and tests are pretty good. But types AND tests is pretty much
perfect.
These tests will not be awe inspiring, this exercise is primarily to introduce
you to adding tests to your Haskell application. The setup of the Cabal file is
already completed for you, but will be covered.
This exercise is to introduce you to testing your Haskell application. The setup
of the Cabal file is already completed for you, but will be covered.
As is to be expected, there are multiple testing frameworks and packages
available but we will only cover one here. We will use the [HSpec] framework,
with the [hspec-wai] package to make our lives a bit easier.
As might be expected, there are multiple testing frameworks and packages
available. We will use the [tasty] framework, it is an established framework
that has widespread use. There are also several packages that extend [tasty]
with additional functionality, such as:
### Including Test Library Dependencies and Running the Tests
* `tasty-hunit` — for unit tests (based on HUnit)
* `tasty-golden` — for golden tests, which are unit tests whose results are kept in files
* `tasty-hedgehog` — for randomized property-based testing (based on Hedgehog)
To run the tests we first need to uncomment the required functions in
`test/Test.hs` otherwise nothing will be run! We do this so you don't have to
worry about tests you haven't written yet.
We will be using the [tasty-wai] package to test our `Application`, as it takes
care of constructing the `Request`s. As well as providing a collection of
assertion functions we will use to verify our expectations.
For testing individual functions, there is the [tasty-hunit] package. It
provides functions for creating test cases and for checking your assertions
## NB: UNLIKE OTHER LEVELS
This level is not an isolated module to complete. This level exists as one
module: `tests/Test.hs`, into which you are to import your most recently
completed `Application`.
As you progress through the course, you are encouraged to return to this
`tests/Test.hs` and update it so you're able to be confident that your
application will behave as you expect. You may also write your tests before you
write your functions, this can be useful when trying to think through a problem.
For example, we will assume that you have just completed `Level04`. In order to
test it you will need to update the imports in `tests/Test.hs`:
```haskell
-- FROM:
import qualified Level02.Core as Core
-- TO:
import qualified Level04.Core as Core
```
#### Property-Based Testing [Optional]
For more advanced testing, there is the [hedgehog] property-based testing
package, and the [tasty] integration component [tasty-hedgehog].
Property based testing is a technique of testing whereby you specify the
properties that your function satisfies. Hedgehog then generates random input to
verify that your properties hold.
If there are inputs that cause your properties to _not_ hold, then Hedgehog will
attempt to shrink down the size of the inputs that broke your test, to try to
find the 'minimum' input required.
Property based testing is immensely effective at locating bugs and unexpected
behaviour and has lead to the notion of "property driven development".
#### Running the Tests
For a cabal sandbox:
@ -58,8 +103,9 @@ in the REPL:
*Main> :main
```
Start in ``tests/Level03Tests.hs``.
Start in ``tests/Test.hs``.
[HSpec]: (http://hspec.github.io/)
[hspec-wai]: (https://hackage.haskell.org/package/hspec-wai)
[tasty]: (https://hackage.haskell.org/package/tasty)
[tasty-wai]: (https://hackage.haskell.org/package/tasty-wai)
[doctest]: (https://hackage.haskell.org/package/doctest)

86
src/Level03/Types.hs
View File

@ -1,86 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level03.Types
( Error (..)
, RqType (..)
, ContentType (..)
, Topic
, CommentText
, mkTopic
, getTopic
, mkCommentText
, getCommentText
, renderContentType
) where
import Data.ByteString (ByteString)
import Data.Text (Text)
newtype Topic = Topic Text
deriving Show
newtype CommentText = CommentText Text
deriving Show
nonEmptyText
:: (Text -> a)
-> Error
-> Text
-> Either Error a
nonEmptyText _ e "" = Left e
nonEmptyText c _ tx = Right (c tx)
mkTopic
:: Text
-> Either Error Topic
mkTopic =
nonEmptyText Topic EmptyTopic
getTopic
:: Topic
-> Text
getTopic (Topic t) =
t
mkCommentText
:: Text
-> Either Error CommentText
mkCommentText =
nonEmptyText CommentText EmptyCommentText
getCommentText
:: CommentText
-> Text
getCommentText (CommentText t) =
t
data RqType
= AddRq Topic CommentText
| ViewRq Topic
| ListRq
-- Not everything goes according to plan, but it's important that our types
-- reflect when errors can be introduced into our program. Additionally it's
-- useful to be able to be descriptive about what went wrong.
-- So lets think about some of the basic things that can wrong with our program
-- and create some values to represent that.
data Error
= UnknownRoute
| EmptyCommentText
| EmptyTopic
deriving Show
-- 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.
data ContentType
= PlainText
| JSON
-- The ContentType description for a header doesn't match our data definition so
-- we write a little helper function to pattern match on our ContentType value
-- and provide the correct header value.
renderContentType
:: ContentType
-> ByteString
renderContentType PlainText = "text/plain"
renderContentType JSON = "application/json"

23
src/Level04/Core.hs
View File

@ -27,11 +27,11 @@ import Data.Semigroup ((<>))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Aeson (ToJSON)
import qualified Data.Aeson as A
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Waargonaut.Encode (Encoder')
import qualified Waargonaut.Encode as E
import Level04.Conf (Conf, firstAppConfig)
import qualified Level04.DB as DB
import Level04.Types (ContentType (JSON, PlainText),
@ -101,11 +101,12 @@ resp500 =
mkResponse status500
resp200Json
:: ToJSON a
=> a
:: Encoder' a
-> a
-> Response
resp200Json =
mkResponse status200 JSON . A.encode
resp200Json e =
mkResponse status200 JSON .
E.simplePureEncodeNoSpaces e
-- |
app
@ -124,6 +125,14 @@ app db rq cb = do
handleRErr :: Either Error RqType -> IO (Either Error Response)
handleRErr = either ( pure . Left ) ( handleRequest db )
-- | Handle each of the different types of request. See how the types have helped narrow our focus
-- to only those types of request that we care about. Along with ensuring that once the data has
-- reached this point, we don't have to continually check if it is valid or usable. The types and
-- data structures that we created have taken care of that for us at an earlier stage, simplifying
-- this function.
--
-- For both the 'ViewRq' and 'ListRq' functions, we'll need to pass the correct 'Encoder' to the
-- 'resp200Json' function.
handleRequest
:: DB.FirstAppDB
-> RqType

131
src/Level04/DB/PostgreSQL.hs
View File

@ -1,131 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- This is an example module if you wanted to use PostgreSQL with the
-- 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 Level04.DB.PostgreSQL where
-- import GHC.Int (Int64)
-- import Data.Text (Text)
-- import Data.Time (getCurrentTime)
-- import Database.PostgreSQL.Simple (Connection, FromRow, Query,
-- ToRow)
-- import Database.PostgreSQL.Simple.Types (Identifier (..))
-- import qualified Database.PostgreSQL.Simple as PG
-- import Level04.Types
-- newtype Table = Table
-- { getTableName :: Text }
-- deriving Show
-- -- This is a bit more configuration available to the PostgreSQL package so we
-- -- have a bit more work to do.
-- newtype DBName = DBName
-- { getDBName :: String }
-- deriving Show
-- newtype UserName = UserName
-- { getUserName :: String }
-- deriving Show
-- data FirstAppDB = FirstAppDB
-- { dbConn :: Connection
-- }
-- closeDB
-- :: FirstAppDB
-- -> IO ()
-- closeDB =
-- PG.close . dbConn
-- initDB
-- :: UserName
-- -> DBName
-- -> IO FirstAppDB
-- initDB un dbN tab = do
-- -- The ConnectInfo type from PostgreSQL has extra configuration options if your local setup is a bit different
-- -- https://hackage.haskell.org/package/postgresql-simple-0.5.3.0/docs/Database-PostgreSQL-Simple.html#v:defaultConnectInfo
-- --
-- -- Use the info to adjust the default connection options.
-- let info = PG.defaultConnectInfo
-- { PG.connectUser = getUserName un
-- , PG.connectDatabase = getDBName dbN
-- }
-- -- Initialise the connection to the DB...
-- -- - What could go wrong here?
-- -- - What haven't we been told in the types?
-- con <- PG.connect info
-- -- Initialise our one table, if it's not there already
-- _ <- PG.execute con createTableQ
-- -- Wrap it up and hand it back.
-- pure $ FirstAppDB con tab
-- createTableQ
-- :: PG.Query
-- createTableQ =
-- -- Query has a IsString instance so you can write straight strings like this
-- -- and it will convert them into a Query type, use '?' as placeholders for
-- -- ORDER DEPENDENT interpolation.
-- "CREATE TABLE IF NOT EXISTS ? (id SERIAL PRIMARY KEY, topic TEXT, comment TEXT, time TIMESTAMPTZ)"
-- -- Another way to express this query if you prefer being able to use line
-- -- breaks is to use the QuasiQuotes extension and write the following:
-- -- [sql| CREATE TABLE IF NOT EXISTS comments (
-- -- id SERIAL PRIMARY KEY,
-- -- topic TEXT,
-- -- comment TEXT,
-- -- time TIMESTAMPTZ
-- -- )
-- -- |]
-- getComments
-- :: FirstAppDB
-- -> Topic
-- -> IO (Either Error [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 = ?"
-- -- Run the query against our DB using our connection.
-- -- To build the replacements for the query placeholders, this package uses
-- -- tuples. Remember that the '?' are order dependent so if you get your input
-- -- parameters in the wrong order, the types won't save you here. More on that
-- -- sort of goodness later.
-- res <- PG.query (dbConn db) q (Only $ getTopic t)
-- -- To be doubly and triply sure we've no garbage in our response, we take care
-- -- to convert our DB storage type into something we're going to share with the
-- -- outside world. Checking again for things like empty Topic or CommentText
-- -- values.
-- pure $ traverse fromDBComment res
-- -- Note that because of the use of traverse, this function will fail at the
-- -- first record that is invalid and discard any successful values.
-- addCommentToTopic
-- :: FirstAppDB
-- -> Topic
-- -> CommentText
-- -> IO (Either Error ())
-- addCommentToTopic db t c = do
-- -- Record the time this comment was created.
-- nowish <- getCurrentTime
-- -- Note the triple, matching the number of values we're trying to insert, plus
-- -- one for the table name.
-- let q = "INSERT INTO comments (topic,comment,time) VALUES (?,?,?)"
-- -- We use the PG.execute function this time as we don't care about anything
-- -- that is returned. The execute function will still return the number of rows
-- -- affected by the query, which in our case should always be 1.
-- res <- PG.execute (dbConn db) q (getTopic t, getCommentText c, nowish)
-- -- An alternative is to write a returning query to get the Id of the DBComment
-- -- we've created. We're being pretty lazy right now so check we've
-- -- affected a single row and move on.
-- pure $ if res == 1 then Right ()
-- else Left (DBError "Comment Insert Failed")
-- getTopics
-- :: FirstAppDB
-- -> IO (Either Error [Topic])
-- getTopics db = do
-- let q = "SELECT DISTINCT topic FROM comments"
-- res <- PG.query_ (dbConn db) q
-- pure $ traverse ( mkTopic . PG.fromOnly ) res

101
src/Level04/README.md
View File

@ -1,5 +1,7 @@
# Level 04
#### Database Integration
We need a place to store our Comments/Topics, so we're going to add a database
to our application, specifically the SQLite database. We've chosen SQLite
because it was the simplest to have up and running for the purposes of the
@ -16,22 +18,105 @@ For reference, the packages we will use to talk to our database are:
You will also need the [SQLite](https://www.sqlite.org/) database application
installed and available on your system.
Also we will not necessarily provide all of the required imports any more, there
may be other things you have to bring into scope.
#### Testing with a database
When testing your application it is wise to use a database that is created
explicitly for testing. When using `sqlite-simple`, we can either specify a
different file path to the database file we want to use. Alternatively we can
use a purely "in-memory" database, that won't persist and will always be able to
be created for our tests.
To do this, provide the special file path `":memory:"`. The `sqlite-simple`
package will pass this to SQLite and it will create a table in memory. You may
also provide an empty string, although that is a bit ambiguous.
More information can be found at:
- [Hackage docs for open](https://hackage.haskell.org/package/sqlite-simple-0.4.16.0/docs/Database-SQLite-Simple.html#v:open)
- [SQLite Documentation](https://www.sqlite.org/inmemorydb.html)
This should suffice for our needs in the course, but when it comes to larger
applications that have tests that hit a database. You will want to more
explicitly manage a separate database that does persist. In case you want to
examine the data for debugging.
#### JSON Encoding
Now that we have a place to keep our `Topic`s and `Comment`s, we need to be able
to encode this data in a way that is acceptable for other systems to consume.
JSON is de rigueur so we won't buck the trend just yet.
We will be using the [waargonaut](https://hackage.haskell.org/package/waargonaut)
package to do the heavy lifting for us. You are required to write the encoder
functions necessary to describe our types to Waargonaut.
We will be building an `Encoder` for our `Topic`, `CommentText`, and `Comment`
types. The `Encoder` and `Decoder` functions can be combined to handle more
complicated structures built of smaller components. An `Encoder` for `Text` can
be combined with the `Encoder` for `[]` to create an `Encoder` for `[Text]`, for
example.
## NB: We will not necessarily provide all of the required imports!
There may be other things you have to bring into scope. So if you see a compiler
error of the sort: "X is not in scope." then you may need to import a type or
function into the module scope.
## Steps for this level:
The steps for this level:
1) ``src/Level04/DB/Types.hs``
2) ``src/Level04/Types.hs``
3) ``src/Level04/DB.hs``
4) ``src/Level04/Core.hs``
2) ``src/Level04/DB.hs``
3) ``src/Level04/Types/Topic.hs``
4) ``src/Level04/Types/CommentText.hs``
5) ``src/Level04/Types.hs``
6) ``src/Level04/Core.hs``
For the sake of simplicity, any configuration requirements will be hardcoded in
``Level04/Conf.hs`` for now. We will return to that in the next level.
NB: The PostgreSQL example module is in ``src/Level04/DB/PostgreSQL.hs``.
``Level04/Conf.hs`` for now. We will return to that in a future level.
# Useful Typeclasses
## [Contravariant](http://hackage.haskell.org/package/contravariant/docs/Data-Functor-Contravariant.html)
The `Contravariant` typeclass provides the following function:
```haskell
contramap :: Contravariant f => (a -> b) -> f b -> f a
```
This might seem super wild, but if you take a moment, follow the types, and
perhaps squint a bit. We're able to discern that:
1) If we provide:
* some way of going from an `a` to a `b`: `(a -> b)`
* and a `f b`
2) We're able to create `f a` by applying the `(a -> b)` to the `a` so that we
then have a `b`
We will work through a small example. Copied from the `Contravariant` documentation on Hackage:
https://hackage.haskell.org/package/contravariant-1.5/docs/Data-Functor-Contravariant.html#t:Contravariant.
As an example, consider the type of predicate functions a -> Bool. One such
predicate might be negative x = x < 0, which classifies integers as to whether
they are negative. However, given this predicate, we can re-use it in other
situations, providing we have a way to map values to integers. For instance, we
can use the negative predicate on a person's bank balance to work out if they
are currently overdrawn:
```haskell
newtype Predicate a = Predicate { getPredicate :: a -> Bool }
instance Contravariant Predicate where
contramap f (Predicate p) = Predicate (p . f)
| `- First, map the input...
`----- then apply the predicate.
overdrawn :: Predicate Person
overdrawn = contramap personBankBalance negative
```
## [Traversable](https://hackage.haskell.org/package/base/docs/Data-Traversable.html)
This typeclass provides a function called ``traverse``, which is for

94
src/Level04/Types.hs
View File

@ -16,81 +16,61 @@ module Level04.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, pack)
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.Functor.Contravariant ((>$<))
import Data.Time (UTCTime)
import Data.Time (UTCTime)
import qualified Data.Time.Format as TF
import Level04.DB.Types (DBComment)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
-- Notice how we've moved these types into their own modules. It's cheap and
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 Level04.Types.CommentText (CommentText, getCommentText,
mkCommentText)
import Level04.Types.Topic (Topic, getTopic, mkTopic)
import Level04.Types.Error (Error (EmptyCommentText, EmptyTopic, UnknownRoute))
-- 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`.
-- However notice that we've also derived the `Generic` type class instance as
-- 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)
deriving (Eq, Show)
-- | This is the `Comment` record that we will be sending to users, it's a
-- straightforward record type, containing an `Int`, `Topic`, `CommentText`, and
-- `UTCTime`.
data Comment = Comment
{ commentId :: CommentId
, commentTopic :: Topic
, commentBody :: CommentText
, commentTime :: UTCTime
}
deriving ( Show, Generic )
deriving Show
-- Strip the prefix, or fall back to the original label if prefix not present.
-- | We're going to write the JSON encoder for our `Comment` type. We'll need to
-- consult the documentation in the 'Waargonaut.Encode' module to find the
-- relevant functions and instructions on how to use them:
--
-- 'https://hackage.haskell.org/package/waargonaut/docs/Waargonaut-Encode.html'
--
encodeComment :: Applicative f => Encoder f Comment
encodeComment =
error "Comment JSON encoder not implemented"
-- Tip: Use the 'encodeISO8601DateTime' to handle the UTCTime for us.
-- | modFieldLabel
-- >>> modFieldLabel "commentId"
-- "id"
-- >>> modFieldLabel "topic"
-- "topic"
-- >>> modFieldLabel ""
-- ""
modFieldLabel
:: String
-> String
modFieldLabel =
error "modFieldLabel not implemented"
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 ask Aeson to construct it for us.
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`
-- | 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.
@ -114,3 +94,11 @@ renderContentType
-> ByteString
renderContentType PlainText = "text/plain"
renderContentType JSON = "application/json"
encodeISO8601DateTime :: Applicative f => Encoder f UTCTime
encodeISO8601DateTime = pack . TF.formatTime loc fmt >$< E.text
where
fmt = TF.iso8601DateFormat (Just "%H:%M:%S")
loc = TF.defaultTimeLocale { TF.knownTimeZones = [] }
-- | Move on to ``src/Level04/Core.hs`` next.

41
src/Level04/Types/CommentText.hs
View File

@ -1,17 +1,20 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level04.Types.CommentText
( CommentText
, mkCommentText
, getCommentText
) where
import Level04.Types.Error (Error (EmptyCommentText), nonEmptyText)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Data.Aeson (ToJSON)
import Data.Text (Text)
import Level04.Types.Error (Error (EmptyCommentText),
nonEmptyText)
import Data.Functor.Contravariant (contramap)
import Data.Text (Text)
newtype CommentText = CommentText Text
deriving (Show, ToJSON)
deriving Show
mkCommentText
:: Text
@ -24,3 +27,31 @@ getCommentText
-> Text
getCommentText (CommentText t) =
t
-- | We will use this function to describe how we would like our `CommentText`
-- type to be encoded into JSON.
--
-- Waargonaut knows how to encode a `Text` value, we need a way of telling it
-- how to unwrap our newtype to encode the `Text` value inside.
--
-- We _could_ write the code to unpack or pattern match on the `CommentText` and
-- then run the `Text` encoder using that value as input before returning that
-- as the result of our Encoder. Something like this:
--
-- @
-- encodeA $ \(CommentText t) -> runEncoder text t
-- @
--
-- But like many of the tasks that we've been completing in this course, the
-- plumbing for such a thing has already been written for us. Sometimes the
-- instances of the structure we're trying to create may provide a handy
-- shortcut.
--
-- In this case the `Encoder` type has an instance of `Contravariant`. That
-- typeclass has a function that comes in very handy when writing these
-- functions. There is a quick introduction to `Contravariant` in the `README`
-- for this level.
--
encodeCommentText :: Applicative f => Encoder f CommentText
encodeCommentText = -- Try using 'contramap' and 'E.text'.
error "CommentText JSON encoder not implemented"

48
src/Level04/Types/Topic.hs
View File

@ -1,17 +1,20 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level04.Types.Topic
( Topic
, mkTopic
, getTopic
, encodeTopic
) where
import Level04.Types.Error (Error (EmptyTopic), nonEmptyText)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Data.Aeson (ToJSON)
import Data.Text (Text)
import Data.Functor.Contravariant (contramap)
import Data.Text (Text)
import Level04.Types.Error (Error (EmptyTopic), nonEmptyText)
newtype Topic = Topic Text
deriving (Show, ToJSON)
deriving Show
mkTopic
:: Text
@ -24,3 +27,38 @@ getTopic
-> Text
getTopic (Topic t) =
t
-- | We will use this function to describe how we would like our `Topic`
-- type to be encoded into JSON.
--
-- Waargonaut knows how to encode a `Text` value, we need a way of telling it
-- how to unwrap our newtype to encode the `Text` value inside.
--
-- We _could_ write the code to unpack or pattern match on the `Topic` and
-- then run the `Text` encoder using that value as input before returning that
-- as the result of our Encoder. Something like this:
--
-- @
-- encodeA $ \(Topic t) -> runEncoder text t
-- @
--
-- But like many of the tasks that we've been completing in this course, the
-- plumbing for such a thing has already been written for us. Sometimes the
-- instances of the structure we're trying to create may provide a handy
-- shortcut.
--
-- In this case the `Encoder` type has an instance of `Contravariant`. Which has
-- the following function:
--
-- @
-- contramap :: Contravariant f => (a -> b) -> f b -> f a
-- @
--
-- In this case the `Encoder` type has an instance of `Contravariant`. That
-- typeclass has a function that comes in very handy when writing these
-- functions. There is a quick introduction to `Contravariant` in the `README`
-- for this level.
--
encodeTopic :: Applicative f => Encoder f Topic
encodeTopic = -- Try using 'contramap' and 'E.text'
error "topic JSON encoder not implemented"

33
src/Level05/Core.hs
View File

@ -6,6 +6,7 @@ module Level05.Core
, prepareAppReqs
) where
import qualified Control.Exception as Ex
import Control.Monad.IO.Class (liftIO)
import Network.Wai (Application, Request,
@ -26,10 +27,10 @@ import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Waargonaut.Encode (Encoder')
import qualified Waargonaut.Encode as E
import Data.Aeson (ToJSON)
import qualified Data.Aeson as A
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Level05.AppM (AppM, liftEither, runAppM)
import qualified Level05.Conf as Conf
@ -37,6 +38,7 @@ import qualified Level05.DB as DB
import Level05.Types (ContentType (..),
Error (..),
RqType (AddRq, ListRq, ViewRq),
encodeComment, encodeTopic,
mkCommentText, mkTopic,
renderContentType)
@ -53,8 +55,15 @@ runApp = do
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
Left err ->
-- We can't run our app at all! Display the message and exit the application.
undefined
Right cfg ->
-- We have a valid config! We can now complete the various pieces needed to run our
-- application. This function 'finally' will execute the first 'IO a', and then, even in the
-- case of that value throwing an exception, execute the second 'IO b'. We do this to ensure
-- that our DB connection will always be closed when the application finishes, or crashes.
Ex.finally (run undefined undefined) (DB.closeDB cfg)
-- We need to complete the following steps to prepare our app requirements:
--
@ -106,11 +115,13 @@ resp500 =
mkResponse status500
resp200Json
:: ToJSON a
=> a
:: Encoder' a
-> a
-> Response
resp200Json =
resp200 JSON . A.encode
resp200Json e =
resp200 JSON .
E.simplePureEncodeNoSpaces e
-- |
-- How has this implementation changed, now that we have an AppM to handle the
@ -130,8 +141,8 @@ handleRequest db rqType = case rqType of
-- 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
ViewRq t -> resp200Json (E.list encodeComment) <$> DB.getComments db t
ListRq -> resp200Json (E.list encodeTopic) <$> DB.getTopics db
mkRequest
:: Request

5
src/Level05/DB.hs
View File

@ -70,7 +70,12 @@ runDB
-> IO a
-> AppM b
runDB =
-- This function is intended to abstract away the running of DB functions and
-- the catching of any errors. As well as the process of running some
-- processing function over those results.
error "Write 'runDB' to match the type signature"
-- Move your use of DB.runDBAction to this function to avoid repeating
-- yourself in the various DB functions.
getComments
:: FirstAppDB

128
src/Level05/DB/PostgreSQL.hs
View File

@ -1,128 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- This is an example module if you wanted to use PostgreSQL with the
-- 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 Level05.DB.PostgreSQL where
import GHC.Int (Int64)
import Data.Text (Text)
import Data.Time (getCurrentTime)
import Database.PostgreSQL.Simple (Connection, FromRow, Query,
ToRow)
import Database.PostgreSQL.Simple.Types (Identifier (..))
import qualified Database.PostgreSQL.Simple as PG
import Level05.Types
-- This is a bit more configuration available to the PostgreSQL package so we
-- have a bit more work to do.
newtype DBName = DBName
{ getDBName :: String }
deriving Show
newtype UserName = UserName
{ getUserName :: String }
deriving Show
data FirstAppDB = FirstAppDB
{ dbConn :: Connection
}
closeDB
:: FirstAppDB
-> IO ()
closeDB =
PG.close . dbConn
initDB
:: UserName
-> DBName
-> Table
-> IO FirstAppDB
initDB un dbN tab = do
-- The ConnectInfo type from PostgreSQL has extra configuration options if your local setup is a bit different
-- https://hackage.haskell.org/package/postgresql-simple-0.5.3.0/docs/Database-PostgreSQL-Simple.html#v:defaultConnectInfo
--
-- Use the info to adjust the default connection options.
let info = PG.defaultConnectInfo
{ PG.connectUser = getUserName un
, PG.connectDatabase = getDBName dbN
}
-- Initialise the connection to the DB...
-- - What could go wrong here?
-- - What haven't we been told in the types?
con <- PG.connect info
-- Initialise our one table, if it's not there already
_ <- PG.execute_ con createTableQ
-- Wrap it up and hand it back.
pure $ FirstAppDB con tab
createTableQ
:: PG.Query
createTableQ =
-- Query has a IsString instance so you can write straight strings like this
-- and it will convert them into a Query type, use '?' as placeholders for
-- ORDER DEPENDENT interpolation.
"CREATE TABLE IF NOT EXISTS comments (id SERIAL PRIMARY KEY, topic TEXT, comment TEXT, time TIMESTAMPTZ)"
-- Another way to express this query if you prefer being able to use line
-- breaks is to use the QuasiQuotes extension and write the following:
-- [sql| CREATE TABLE IF NOT EXISTS comments (
-- id SERIAL PRIMARY KEY,
-- topic TEXT,
-- comment TEXT,
-- time TIMESTAMPTZ
-- )
-- |]
getComments
:: FirstAppDB
-> Topic
-> IO (Either Error [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 = ?"
-- Run the query against our DB using our connection.
-- To build the replacements for the query placeholders, this package uses
-- tuples. Remember that the '?' are order dependent so if you get your input
-- parameters in the wrong order, the types won't save you here. More on that
-- sort of goodness later.
res <- PG.query (dbConn db) q (PG.Only $ getTopic t)
-- To be doubly and triply sure we've no garbage in our response, we take care
-- to convert our DB storage type into something we're going to share with the
-- outside world. Checking again for things like empty Topic or CommentText
-- values.
pure $ traverse fromDBComment res
-- Note that because of the use of traverse, this function will fail at the
-- first record that is invalid and discard any successful values.
addCommentToTopic
:: FirstAppDB
-> Topic
-> CommentText
-> IO (Either Error ())
addCommentToTopic db t c = do
-- Record the time this comment was created.
nowish <- getCurrentTime
-- Note the triple, matching the number of values we're trying to insert, plus
-- one for the table name.
let q = "INSERT INTO comments (topic,comment,time) VALUES (?,?,?)"
-- We use the PG.execute function this time as we don't care about anything
-- that is returned. The execute function will still return the number of rows
-- affected by the query, which in our case should always be 1.
res <- PG.execute (dbConn db) q (getTopic t, getCommentText c, nowish)
-- An alternative is to write a returning query to get the Id of the DBComment
-- we've created. We're being pretty lazy right now so check we've
-- affected a single row and move on.
pure $ if res == 1 then Right ()
else Left (DBError "Comment Insert Failed")
getTopics
:: FirstAppDB
-> IO (Either Error [Topic])
getTopics db = do
let q = "SELECT DISTINCT topic FROM comments"
res <- PG.query_ (dbConn db) q
pure $ traverse ( mkTopic . PG.fromOnly ) res

70
src/Level05/Types.hs
View File

@ -15,16 +15,19 @@ module Level05.Types
, getCommentText
, renderContentType
, fromDBComment
, encodeComment
, encodeTopic
) where
import GHC.Generics (Generic)
import GHC.Word (Word16)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text (Text, pack)
import System.IO.Error (IOError)
import Data.Functor.Contravariant ((>$<))
import Data.Monoid (Last,
Monoid (mappend, mempty))
import Data.Semigroup (Semigroup ((<>)))
@ -32,21 +35,28 @@ 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 qualified Data.Time.Format as TF
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Level05.DB.Types (DBComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic))
import Level05.Types.CommentText (CommentText,
encodeCommentText,
getCommentText,
mkCommentText)
import Level05.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute))
import Level05.Types.Topic (Topic, getTopic, mkTopic)
import Level05.Types.Topic (Topic, encodeTopic,
getTopic, mkTopic)
newtype CommentId = CommentId Int
deriving (Show, ToJSON)
deriving (Show)
encodeCommentId :: Applicative f => Encoder f CommentId
encodeCommentId = (\(CommentId i) -> i) >$< E.int
data Comment = Comment
{ commentId :: CommentId
@ -54,42 +64,20 @@ data Comment = Comment
, commentText :: CommentText
, commentTime :: UTCTime
}
-- Generic has been added to our deriving list.
deriving ( Show, Generic )
deriving Show
-- 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.
encodeISO8601DateTime :: Applicative f => Encoder f UTCTime
encodeISO8601DateTime = pack . TF.formatTime tl fmt >$< E.text
where
fmt = TF.iso8601DateFormat (Just "%H:%M:%S")
tl = TF.defaultTimeLocale { TF.knownTimeZones = [] }
-- | 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
}
encodeComment :: Applicative f => Encoder f Comment
encodeComment = E.mapLikeObj $ \c ->
E.atKey' "id" encodeCommentId (commentId c) .
E.atKey' "topic" encodeTopic (commentTopic c) .
E.atKey' "text" encodeCommentText (commentText c) .
E.atKey' "time" encodeISO8601DateTime (commentTime c)
-- 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

17
src/Level05/Types/CommentText.hs
View File

@ -1,17 +1,24 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level05.Types.CommentText
( CommentText
, mkCommentText
, getCommentText
, encodeCommentText
) where
import Data.Aeson (ToJSON)
import Data.Text (Text)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Level05.Types.Error (Error (EmptyCommentText), nonEmptyText)
import Level05.Types.Error (Error (EmptyCommentText),
nonEmptyText)
import Data.Functor.Contravariant ((>$<))
import Data.Text (Text)
newtype CommentText = CommentText Text
deriving (Show, ToJSON)
deriving (Show)
encodeCommentText :: Applicative f => Encoder f CommentText
encodeCommentText = getCommentText >$< E.text
mkCommentText
:: Text

18
src/Level05/Types/Topic.hs
View File

@ -1,17 +1,23 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level05.Types.Topic
( Topic
(Topic
, mkTopic
, getTopic
, encodeTopic
) where
import Data.Aeson (ToJSON)
import Data.Text (Text)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Level05.Types.Error (Error (EmptyTopic), nonEmptyText)
import Level05.Types.Error (Error (EmptyTopic), nonEmptyText)
import Data.Functor.Contravariant ((>$<))
import Data.Text (Text)
newtype Topic = Topic Text
deriving (Show, ToJSON)
deriving Show
encodeTopic :: Applicative f => Encoder f Topic
encodeTopic = getTopic >$< E.text
mkTopic
:: Text

112
src/Level06/AppM.hs
View File

@ -6,90 +6,74 @@ module Level06.AppM where
import Control.Monad.Except (MonadError (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Text (Text)
import Level06.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.
-- | We're going to upgrade the capability of our AppM by generalising the type of the errors that
-- it handles. This means that we'll be able to reuse our 'AppM' in more places that maybe have an
-- overabundance of 'IO (Either e a)' types.
--
-- 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 new 'AppM'' will also use the record syntax to define our 'runAppM' function. This is a more
-- common definition of this kind of newtype.
--
-- This 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.
newtype AppM e a = AppM
{ runAppM :: IO (Either e a)
}
-- | Predominantly our application has only one error type: 'Error'. It would be tedious to have to
-- declare that on every signature. We're able to use a type _alias_ to avoid this problem. We can
-- define this type alias to make the error type variable concrete as 'Error'.
--
-- f <$> (Left e) = Left e
-- f <$> (Right a) = Right (f a)
type App = AppM Error
-- | We need to refactor the 'runAppM' function as now the name conflicts, and it needs to suit the
-- specialised 'App' type. The definition is even simpler than before. If someone near you is up to
-- the same section, try to explain to each other why this works.
--
-- (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.
runApp :: App a -> IO (Either Error a)
runApp = runAppM
newtype AppM a = AppM (IO (Either Error a))
-- | You may copy your previously completed AppM instances here and then refactor them to suit the
-- more generalised type of AppM.
runAppM
:: AppM a
-> IO (Either Error a)
runAppM (AppM m) =
m
-- | -----------------------------------------------------------------------------------------------
-- | Copy from previous level and refactor, or reimplement to practice. The choice is yours.
-- | -----------------------------------------------------------------------------------------------
instance Functor AppM where
fmap :: (a -> b) -> AppM a -> AppM b
fmap = error "fmap for AppM not implemented"
instance Functor (AppM e) where
fmap :: (a -> b) -> AppM e a -> AppM e b
fmap = error "fmap for (AppM e) not implemented"
instance Applicative AppM where
pure :: a -> AppM a
pure = error "pure for AppM not implemented"
instance Applicative (AppM e) where
pure :: a -> AppM e a
pure = error "pure for (AppM e) not implemented"
(<*>) :: AppM (a -> b) -> AppM a -> AppM b
(<*>) = error "ap for AppM not implemented"
(<*>) :: AppM e (a -> b) -> AppM e a -> AppM e b
(<*>) = error "spaceship for (AppM e) not implemented"
instance Monad AppM where
return :: a -> AppM a
return = error "return for AppM not implemented"
instance Monad (AppM e) where
return :: a -> AppM e a
return = error "return for (AppM e) not implemented"
(>>=) :: AppM a -> (a -> AppM b) -> AppM b
(>>=) = error "bind for AppM not implemented"
(>>=) :: AppM e a -> (a -> AppM e b) -> AppM e b
(>>=) = error "bind for (AppM e) not implemented"
instance MonadIO AppM where
liftIO :: IO a -> AppM a
liftIO = error "liftIO for AppM not implemented"
instance MonadIO (AppM e) where
liftIO :: IO a -> AppM e a
liftIO = error "liftIO for (AppM e) not implemented"
instance MonadError Error AppM where
throwError :: Error -> AppM a
throwError = error "throwError for AppM not implemented"
instance MonadError e (AppM e) where
throwError :: e -> AppM e a
throwError = error "throwError for (AppM e) not implemented"
catchError :: AppM a -> (Error -> AppM a) -> AppM a
catchError = error "catchError for AppM not implemented"
catchError :: AppM e a -> (e -> AppM e a) -> AppM e a
catchError = error "catchError for (AppM e) not implemented"
-- This is a helper function that will `lift` an Either value into our new AppM
-- 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 "liftEither not implemented"
liftEither :: Either e a -> AppM e a
liftEither = error "throwLeft not implemented"

9
src/Level06/Conf.hs
View File

@ -9,6 +9,7 @@ import GHC.Word (Word16)
import Data.Bifunctor (first)
import Data.Monoid ((<>))
import Level06.AppM (AppM)
import Level06.Types (Conf, ConfigError,
DBFilePath (DBFilePath), PartialConf,
Port (Port))
@ -16,7 +17,7 @@ import Level06.Types (Conf, ConfigError,
import Level06.Conf.CommandLine (commandLineParser)
import Level06.Conf.File (parseJSONConfigFile)
-- For the purposes of this application we will encode some default values to
-- | 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
-- configuration values from either the file or command line inputs.
defaultConf
@ -24,7 +25,7 @@ defaultConf
defaultConf =
error "defaultConf not implemented"
-- We need something that will take our PartialConf and see if can finally build
-- | 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 values by
-- providing the relevant error.
makeConfig
@ -33,10 +34,10 @@ makeConfig
makeConfig =
error "makeConfig not implemented"
-- This is the function we'll actually export for building our configuration.
-- | 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.
--
-- Remember that we want the command line configuration to take precedence over
-- the File configuration, so if we think about combining each of our ``Conf``
-- records. By now we should be able to write something like this:

37
src/Level06/Conf/File.hs
View File

@ -1,37 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
module Level06.Conf.File where
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text (Text, pack)
import Data.Bifunctor (first)
import Data.Monoid (Last (Last))
import Control.Exception (try)
import Data.Aeson (FromJSON, Object)
import qualified Data.Attoparsec.ByteString as AB
import qualified Data.Aeson as A
import Waargonaut (Json, parseWaargonaut)
import qualified Waargonaut.Decode as D
import Waargonaut.Decode.Error (DecodeError (ParseFailed))
import Level06.Types (ConfigError,
import Level06.Types (ConfigError (BadConfFile),
PartialConf (PartialConf))
-- Doctest setup section
-- $setup
-- >>> :set -XOverloadedStrings
-- | File Parsing
-- We're trying to avoid complications when selecting a configuration file
-- package from Hackage. We'll use an encoding that you are probably familiar
-- with, for better or worse, and write a small parser to pull out the bits we
-- need. The package we're using is the ``aeson`` package to parse some JSON and
-- we'll pick the bits off the Object.
-- | Update these tests when you've completed this function.
-- | The configuration file is in the JSON format, so we need to write a
-- 'waargonaut' 'Decoder' to go from JSON to our 'PartialConf'.
--
-- Update these tests when you've completed this function.
--
-- | readConfFile
-- >>> readConfFile "badFileName.no"
-- Left (undefined "badFileName.no: openBinaryFile: does not exist (No such file or directory)")
-- >>> readConfFile "files/test.json"
@ -39,16 +33,19 @@ import Level06.Types (ConfigError,
--
readConfFile
:: FilePath
-> IO ( Either ConfigError ByteString )
-> IO (Either ConfigError ByteString)
readConfFile =
error "readConfFile not implemented"
-- Construct the function that will take a ``FilePath``, read it in, decode it,
-- | Construct the function that will take a ``FilePath``, read it in, decode it,
-- and construct our ``PartialConf``.
parseJSONConfigFile
:: FilePath
-> IO ( Either ConfigError PartialConf )
-> IO (Either ConfigError PartialConf)
parseJSONConfigFile =
error "parseJSONConfigFile not implemented"
where
parseFunc :: ByteString -> Either DecodeError Json
parseFunc = first (ParseFailed . pack . show) . AB.parseOnly parseWaargonaut
-- Go to 'src/Level06/Conf.hs' next.

67
src/Level06/Core.hs
View File

@ -1,13 +1,16 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
module Level06.Core
( runApp
( runApplication
, app
, prepareAppReqs
) where
import qualified Control.Exception as Ex
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (catchError, throwError)
import Network.Wai (Application, Request,
Response, pathInfo,
requestMethod, responseLBS,
@ -20,6 +23,7 @@ import Network.HTTP.Types (Status, hContentType,
import qualified Data.ByteString.Lazy as LBS
import Data.Bifunctor (first)
import Data.Either (either)
import Data.Monoid ((<>))
@ -28,35 +32,33 @@ import Data.Text.Encoding (decodeUtf8)
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Data.Aeson (ToJSON)
import qualified Data.Aeson as A
import Waargonaut.Encode (Encoder')
import qualified Waargonaut.Encode as E
import Level06.AppM (AppM, liftEither, runAppM)
import Level06.AppM (App, AppM (..),
liftEither, runApp)
import qualified Level06.Conf as Conf
import qualified Level06.DB as DB
import Level06.Types (Conf, ContentType (..),
import Level06.Types (Conf, ConfigError,
ContentType (..),
Error (..),
RqType (AddRq, ListRq, ViewRq),
encodeComment, encodeTopic,
mkCommentText, mkTopic,
renderContentType)
-- Our start-up is becoming more complicated and could fail in new and
-- | 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
| ConfErr ConfigError
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
runApplication :: IO ()
runApplication = error "copy your previous 'runApp' implementation and refactor as needed"
-- We need to complete the following steps to prepare our app requirements:
-- | We need to complete the following steps to prepare our app requirements:
--
-- 1) Load the configuration.
-- 2) Attempt to initialise the database.
@ -64,10 +66,12 @@ runApp = do
--
-- The file path for our application config is: "files/appconfig.json"
--
prepareAppReqs
:: IO ( Either StartUpError ( Conf, DB.FirstAppDB ) )
prepareAppReqs =
error "copy your prepareAppReqs from the previous level."
-- The config loading process is starting to become unweildly. We will re-use
-- our generalised AppM to also remove the problem of handling errors on start
-- up!
--
prepareAppReqs :: AppM StartUpError (Conf, DB.FirstAppDB)
prepareAppReqs = error "copy your prepareAppReqs from the previous level."
-- | Some helper functions to make our lives a little more DRY.
mkResponse
@ -107,20 +111,20 @@ resp500 =
mkResponse status500
resp200Json
:: ToJSON a
=> a
:: Encoder' a
-> a
-> Response
resp200Json =
resp200 JSON . A.encode
-- |
resp200Json e =
resp200 JSON .
E.simplePureEncodeNoSpaces e
-- Now that we have our configuration, pass it where it needs to go.
-- | Now that we have our configuration, pass it where it needs to go.
app
:: Conf
-> DB.FirstAppDB
-> Application
app cfg db rq cb =
runAppM (handleRequest db =<< mkRequest rq) >>= cb . handleRespErr
runApp (handleRequest db =<< mkRequest rq) >>= cb . handleRespErr
where
handleRespErr :: Either Error Response -> Response
handleRespErr = either mkErrorResponse id
@ -128,17 +132,16 @@ app cfg db rq cb =
handleRequest
:: DB.FirstAppDB
-> RqType
-> AppM Response
-> App Response
handleRequest db rqType =
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 -> resp200Json <$> DB.getComments db t
ListRq -> resp200Json <$> DB.getTopics db
AddRq t c -> resp200 PlainText "Success" <$ DB.addCommentToTopic db t c
ViewRq t -> resp200Json (E.list encodeComment) <$> DB.getComments db t
ListRq -> resp200Json (E.list encodeTopic) <$> DB.getTopics db
mkRequest
:: Request
-> AppM RqType
-> App RqType
mkRequest rq =
liftEither =<< case ( pathInfo rq, requestMethod rq ) of
-- Commenting on a given topic

12
src/Level06/DB.hs
View File

@ -24,7 +24,7 @@ import qualified Database.SQLite.Simple as Sql
import qualified Database.SQLite.SimpleErrors as Sql
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Level06.AppM (AppM, liftEither)
import Level06.AppM (App, liftEither)
import Level06.Types (Comment, CommentText,
Error (DBError), Topic,
@ -68,7 +68,7 @@ initDB fp = Sql.runDBAction $ do
runDB
:: (a -> Either Error b)
-> IO a
-> AppM b
-> App b
runDB f a = do
r <- liftIO $ first DBError <$> Sql.runDBAction a
liftEither $ f =<< r
@ -76,7 +76,7 @@ runDB f a = do
getComments
:: FirstAppDB
-> Topic
-> AppM [Comment]
-> App [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 = ?"
@ -89,7 +89,7 @@ addCommentToTopic
:: FirstAppDB
-> Topic
-> CommentText
-> AppM ()
-> App ()
addCommentToTopic db t c = do
-- Record the time this comment was created.
nowish <- liftIO getCurrentTime
@ -109,7 +109,7 @@ addCommentToTopic db t c = do
getTopics
:: FirstAppDB
-> AppM [Topic]
-> App [Topic]
getTopics db =
let q = "SELECT DISTINCT topic FROM comments"
in
@ -118,7 +118,7 @@ getTopics db =
deleteTopic
:: FirstAppDB
-> Topic
-> AppM ()
-> App ()
deleteTopic db t =
let q = "DELETE FROM comments WHERE topic = ?"
in

128
src/Level06/DB/PostgreSQL.hs
View File

@ -1,128 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- This is an example module if you wanted to use PostgreSQL with the
-- 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 Level06.DB.PostgreSQL where
import GHC.Int (Int64)
import Data.Text (Text)
import Data.Time (getCurrentTime)
import Database.PostgreSQL.Simple (Connection, FromRow, Query,
ToRow)
import Database.PostgreSQL.Simple.Types (Identifier (..))
import qualified Database.PostgreSQL.Simple as PG
import Level06.Types
-- This is a bit more configuration available to the PostgreSQL package so we
-- have a bit more work to do.
newtype DBName = DBName
{ getDBName :: String }
deriving Show
newtype UserName = UserName
{ getUserName :: String }
deriving Show
data FirstAppDB = FirstAppDB
{ dbConn :: Connection
}
closeDB
:: FirstAppDB
-> IO ()
closeDB =
PG.close . dbConn
initDB
:: UserName
-> DBName
-> Table
-> IO FirstAppDB
initDB un dbN tab = do
-- The ConnectInfo type from PostgreSQL has extra configuration options if your local setup is a bit different
-- https://hackage.haskell.org/package/postgresql-simple-0.5.3.0/docs/Database-PostgreSQL-Simple.html#v:defaultConnectInfo
--
-- Use the info to adjust the default connection options.
let info = PG.defaultConnectInfo
{ PG.connectUser = getUserName un
, PG.connectDatabase = getDBName dbN
}
-- Initialise the connection to the DB...
-- - What could go wrong here?
-- - What haven't we been told in the types?
con <- PG.connect info
-- Initialise our one table, if it's not there already
_ <- PG.execute_ con createTableQ
-- Wrap it up and hand it back.
pure $ FirstAppDB con tab
createTableQ
:: PG.Query
createTableQ =
-- Query has a IsString instance so you can write straight strings like this
-- and it will convert them into a Query type, use '?' as placeholders for
-- ORDER DEPENDENT interpolation.
"CREATE TABLE IF NOT EXISTS comments (id SERIAL PRIMARY KEY, topic TEXT, comment TEXT, time TIMESTAMPTZ)"
-- Another way to express this query if you prefer being able to use line
-- breaks is to use the QuasiQuotes extension and write the following:
-- [sql| CREATE TABLE IF NOT EXISTS comments (
-- id SERIAL PRIMARY KEY,
-- topic TEXT,
-- comment TEXT,
-- time TIMESTAMPTZ
-- )
-- |]
getComments
:: FirstAppDB
-> Topic
-> IO (Either Error [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 = ?"
-- Run the query against our DB using our connection.
-- To build the replacements for the query placeholders, this package uses
-- tuples. Remember that the '?' are order dependent so if you get your input
-- parameters in the wrong order, the types won't save you here. More on that
-- sort of goodness later.
res <- PG.query (dbConn db) q (PG.Only $ getTopic t)
-- To be doubly and triply sure we've no garbage in our response, we take care
-- to convert our DB storage type into something we're going to share with the
-- outside world. Checking again for things like empty Topic or CommentText
-- values.
pure $ traverse fromDBComment res
-- Note that because of the use of traverse, this function will fail at the
-- first record that is invalid and discard any successful values.
addCommentToTopic
:: FirstAppDB
-> Topic
-> CommentText
-> IO (Either Error ())
addCommentToTopic db t c = do
-- Record the time this comment was created.
nowish <- getCurrentTime
-- Note the triple, matching the number of values we're trying to insert, plus
-- one for the table name.
let q = "INSERT INTO comments (topic,comment,time) VALUES (?,?,?)"
-- We use the PG.execute function this time as we don't care about anything
-- that is returned. The execute function will still return the number of rows
-- affected by the query, which in our case should always be 1.
res <- PG.execute (dbConn db) q (getTopic t, getCommentText c, nowish)
-- An alternative is to write a returning query to get the Id of the DBComment
-- we've created. We're being pretty lazy right now so check we've
-- affected a single row and move on.
pure $ if res == 1 then Right ()
else Left (DBError "Comment Insert Failed")
getTopics
:: FirstAppDB
-> IO (Either Error [Topic])
getTopics db = do
let q = "SELECT DISTINCT topic FROM comments"
res <- PG.query_ (dbConn db) q
pure $ traverse ( mkTopic . PG.fromOnly ) res

14
src/Level06/README.md
View File

@ -1,6 +1,7 @@
# Level 06
In this exercise we build some configuration capabilities into our application.
In this exercise we will expand the capabilities of our `AppM` transformer, and
use that to 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
@ -8,12 +9,13 @@ 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``
1) ``src/Level06/AppM.hs``
2) ``src/Level06/Types.hs``
3) ``src/Level06/Conf/File.hs``
4) ``src/Level06/Conf.hs``
5) ``src/Level06/Core.hs``
The packages we will use for this are:
- [Aeson](http://hackage.haskell.org/package/aeson)
- [Waargonaut](http://hackage.haskell.org/package/waargonaut)
- [Optparse Applicative](http://hackage.haskell.org/package/optparse-applicative)

106
src/Level06/Types.hs
View File

@ -1,7 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Level06.Types
( Error (..)
, ConfigError (..)
@ -16,43 +20,58 @@ module Level06.Types
, CommentText
, mkTopic
, getTopic
, encodeTopic
, mkCommentText
, getCommentText
, encodeComment
, renderContentType
, confPortToWai
, fromDBComment
) where
import GHC.Generics (Generic)
import GHC.Word (Word16)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text (Text, pack)
import System.IO.Error (IOError)
import Data.Monoid (Last,
import Data.Monoid (Last (..),
Monoid (mappend, mempty))
import Data.Semigroup (Semigroup ((<>)))
import Data.Functor.Contravariant ((>$<))
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Time (UTCTime)
import qualified Data.Time.Format as TF
import Data.Aeson (FromJSON (..), ToJSON)
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import System.Locale (defaultTimeLocale)
import Waargonaut.Decode (Decoder)
import qualified Waargonaut.Decode as D
import Waargonaut.Decode.Error (DecodeError)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Level06.DB.Types (DBComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic))
import Level06.DB.Types (DBComment (..))
import Level06.Types.CommentText (CommentText,
encodeCommentText,
getCommentText,
mkCommentText)
import Level06.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute))
import Level06.Types.Topic (Topic, getTopic, mkTopic)
import Level06.Types.Error (Error (..))
import Level06.Types.Topic (Topic, encodeTopic,
getTopic, mkTopic)
newtype CommentId = CommentId Int
deriving (Show, ToJSON)
deriving Show
encodeCommentId :: Applicative f => Encoder f CommentId
encodeCommentId = (\(CommentId i) -> i) >$< E.int
data Comment = Comment
{ commentId :: CommentId
@ -60,48 +79,25 @@ data Comment = Comment
, commentText :: CommentText
, commentTime :: UTCTime
}
-- Generic has been added to our deriving list.
deriving ( Show, Generic )
deriving (Show)
-- 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.
encodeISO8601DateTime :: Applicative f => Encoder f UTCTime
encodeISO8601DateTime = E.encodeA $ E.runEncoder E.text . pack . TF.formatTime tl fmt
where
fmt = TF.iso8601DateFormat (Just "%H:%M:%S")
tl = TF.defaultTimeLocale { TF.knownTimeZones = [] }
-- | 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
}
encodeComment :: Applicative f => Encoder f Comment
encodeComment = E.mapLikeObj $ \c ->
E.atKey' "id" encodeCommentId (commentId c) .
E.atKey' "topic" encodeTopic (commentTopic c) .
E.atKey' "text" encodeCommentText (commentText c) .
E.atKey' "time" encodeISO8601DateTime (commentTime c)
-- 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
@ -176,9 +172,10 @@ confPortToWai
confPortToWai =
error "confPortToWai not implemented"
-- Similar to when we were considering our application types, leave this empty
-- for now and add to it as you go.
data ConfigError = ConfigError
-- Similar to when we were considering our application types. We can add to this sum type as we
-- build our application and the compiler can help us out.
data ConfigError
= BadConfFile DecodeError
deriving Show
-- Our application will be able to load configuration from both a file and
@ -226,17 +223,16 @@ instance Monoid PartialConf where
mempty = PartialConf mempty mempty
mappend = (<>)
-- When it comes to reading the configuration options from the command-line, we
-- | 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
-- For reading the configuration from the file, we're going to use the Waargonaut
-- 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
-- have to tell waargonaut how to go about converting the JSON into our PartialConf
-- data structure.
instance FromJSON PartialConf where
parseJSON = error "parseJSON for PartialConf not implemented yet."
partialConfDecoder :: Monad f => Decoder f PartialConf
partialConfDecoder = error "PartialConf Decoder not implemented"
-- Go to 'src/Level06/Conf/File.hs' next

18
src/Level06/Types/CommentText.hs
View File

@ -1,18 +1,24 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level06.Types.CommentText
( CommentText
, mkCommentText
, getCommentText
, encodeCommentText
) where
import Level06.Types.Error (Error(EmptyCommentText), nonEmptyText)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Data.Text (Text)
import Data.Aeson (ToJSON)
import Level06.Types.Error (Error (EmptyCommentText),
nonEmptyText)
import Data.Functor.Contravariant ((>$<))
import Data.Text (Text)
newtype CommentText = CommentText Text
deriving (Show, ToJSON)
deriving (Show)
encodeCommentText :: Applicative f => Encoder f CommentText
encodeCommentText = getCommentText >$< E.text
mkCommentText
:: Text

21
src/Level06/Types/Topic.hs
View File

@ -1,14 +1,23 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level06.Types.Topic
( Topic
, mkTopic
, getTopic
, encodeTopic
) where
module Level06.Types.Topic (Topic, mkTopic, getTopic) where
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Level06.Types.Error (Error (EmptyTopic), nonEmptyText)
import Level06.Types.Error (Error (EmptyTopic), nonEmptyText)
import Data.Aeson (ToJSON)
import Data.Text (Text)
import Data.Functor.Contravariant ((>$<))
import Data.Text (Text)
newtype Topic = Topic Text
deriving (Show, ToJSON)
deriving Show
encodeTopic :: Applicative f => Encoder f Topic
encodeTopic = getTopic >$< E.text
mkTopic
:: Text

111
src/Level07/AppM.hs
View File

@ -13,25 +13,25 @@ import Data.Text (Text)
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
-- are values, we're able to pass them around and place them on records like any
-- other type.
-- | 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 are values, we're able to pass them around and place them on
-- records like any other type.
data Env = Env
-- We will add a function to take some 'Text' input and print it to the
-- | We will add a function to take some 'Text' input and print it to the
-- console as a crude form of logging. Construct a function that matches this
-- type so you can include it when you create the 'Env'.
{ envLoggingFn :: Text -> AppM ()
{ envLoggingFn :: Text -> App ()
-- We're able to nest records to keep things neat and tidy.
, envConfig :: Conf
, envDB :: FirstAppDB
}
-- It would be nice to remove the need to pass around our Env to every function
-- that needs it. Wouldn't it be great to have our functions run where we could
-- simply ask for the current Env?
-- | It would be nice to remove the need to pass around our Env to every
-- function that needs it. Wouldn't it be great to have our functions run where
-- we could simply ask for the current Env?
--
-- We can create this by wrapping a function in a newtype like so:
--
@ -39,67 +39,72 @@ data Env = Env
-- 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.
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
newtype AppM e a = AppM
{ runAppM :: Env -> IO (Either e 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.
-- | 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 (Either Error a)
runAppM =
error "runAppM not implemented"
type App = AppM Error
instance Applicative AppM where
pure :: a -> AppM a
pure = error "pure for AppM not implemented"
runApp :: App a -> Env -> IO (Either Error a)
runApp = error "runAppM not implemented"
(<*>) :: AppM (a -> b) -> AppM a -> AppM b
(<*>) = error "spaceship for AppM not implemented"
instance Applicative (AppM e) where
pure :: a -> AppM e a
pure = error "pure for AppM e not implemented"
instance Monad AppM where
return :: a -> AppM a
return = error "return for AppM not implemented"
(<*>) :: AppM e (a -> b) -> AppM e a -> AppM e b
(<*>) = error "spaceship for AppM e not implemented"
-- When it comes to running functions in AppM as a Monad, this will take care
-- of passing the Env from one function to the next.
(>>=) :: AppM a -> (a -> AppM b) -> AppM b
(>>=) = error "bind for AppM not implemented"
instance Monad (AppM e) where
return :: a -> AppM e a
return = error "return for AppM e not implemented"
instance MonadError Error AppM where
throwError :: Error -> AppM a
throwError = error "throwError for AppM not implemented"
-- | When it comes to running functions in (AppM e) as a Monad, this will take
-- care of passing the Env from one function to the next whilst preserving the
-- error handling behaviour.
(>>=) :: AppM e a -> (a -> AppM e b) -> AppM e b
(>>=) = error "bind for AppM e not implemented"
catchError :: AppM a -> (Error -> AppM a) -> AppM a
catchError = error "catchError for AppM not implemented"
instance MonadError Error (AppM e) where
throwError :: Error -> AppM e a
throwError = error "throwError for AppM e not implemented"
instance MonadReader Env AppM where
catchError :: AppM e a -> (Error -> AppM e a) -> AppM e a
catchError = error "catchError for AppM e not implemented"
instance MonadReader Env (AppM e) where
-- Return the current Env from the AppM.
ask :: AppM Env
ask = error "ask for AppM not implemented"
ask :: AppM e Env
ask = error "ask for AppM e not implemented"
-- Run a AppM inside of the current one using a modified Env value.
local :: (Env -> Env) -> AppM a -> AppM a
local = error "local for AppM not implemented"
-- Run a (AppM e) inside of the current one using a modified Env value.
local :: (Env -> Env) -> AppM e a -> AppM e a
local = error "local for AppM e not implemented"
-- This will run a function on the current Env and return the result.
reader :: (Env -> a) -> AppM a
reader = error "reader for AppM not implemented"
reader :: (Env -> a) -> AppM e a
reader = error "reader for AppM e not implemented"
instance MonadIO AppM where
-- Take a type of 'IO a' and lift it into our AppM.
liftIO :: IO a -> AppM a
instance MonadIO (AppM e) where
-- Take a type of 'IO a' and lift it into our (AppM e).
liftIO :: IO a -> AppM e a
liftIO = error "liftIO for AppM not implemented"
liftEither
:: Either Error a
-> AppM a
liftEither =
error "liftEither 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 e a -> AppM e a
liftEither = error "throwLeft not implemented"
-- Move on to ``src/Level07/DB.hs`` after this

29
src/Level07/Conf/File.hs
View File

@ -1,21 +1,21 @@
module Level07.Conf.File where
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as LBS
import Data.Text (Text)
import Data.Text (pack)
import Data.Bifunctor (first)
import Data.Monoid (Last (Last))
import qualified Data.Attoparsec.ByteString as AB
import Waargonaut (Json, parseWaargonaut)
import qualified Waargonaut.Decode as D
import Waargonaut.Decode.Error (DecodeError (ParseFailed))
import Control.Exception (try)
import Data.Aeson (FromJSON, Object, (.:))
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import Level07.Types (ConfigError (..), PartialConf)
import Level07.Types (ConfigError (..), PartialConf, partialConfDecoder)
-- Doctest setup section
-- $setup
@ -35,10 +35,15 @@ readConfFile
readConfFile fp =
first ConfigFileReadError <$> try (LBS.readFile fp)
-- Construct the function that will take a ``FilePath``, read it in, decode it,
-- | 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 . A.eitherDecode =<<) <$> readConfFile fp
(>>= first BadConfFile . doDecode) <$> readConfFile fp
where
doDecode = D.runPureDecode partialConfDecoder parseFunc . D.mkCursor
parseFunc :: ByteString -> Either DecodeError Json
parseFunc = first (ParseFailed . pack . show) . AB.parseOnly parseWaargonaut

67
src/Level07/Core.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
module Level07.Core
( runApp
( runApplication
, prepareAppReqs
, app
) where
import Control.Applicative (liftA2)
import qualified Control.Exception as Ex
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
@ -32,57 +33,63 @@ import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import System.IO (stderr)
import qualified Waargonaut.Encode as E
import qualified Level07.Conf as Conf
import qualified Level07.DB as DB
import qualified Level07.Responses as Res
import Level07.Types (Conf (dbFilePath),
ConfigError,
import Level07.Types (Conf, ConfigError,
ContentType (PlainText),
Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute),
RqType (AddRq, ListRq, ViewRq),
Error (..), RqType (..),
confPortToWai,
encodeComment, encodeTopic,
mkCommentText, mkTopic)
import Level07.AppM (AppM, Env (Env, envConfig, envDB, envLoggingFn),
liftEither)
import Level07.AppM (App, Env (..), liftEither,
runApp)
-- We're going to use the `mtl` ExceptT monad transformer to make the loading of our `Conf` a bit more straight-forward.
-- | 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
-- | 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
= ConfErr ConfigError
| DBInitErr SQLiteResponse
= DBInitErr SQLiteResponse
| ConfErr ConfigError
deriving Show
runApp :: IO ()
runApp = do
appE <- prepareAppReqs
runApplication :: IO ()
runApplication = do
appE <- runExceptT prepareAppReqs
either print runWithDBConn appE
where
runWithDBConn env =
appWithDB env >> DB.closeDB (envDB env)
appWithDB env =
run ( confPortToWai $ envConfig env ) (app env)
Ex.finally (run ( confPortToWai $ envConfig env ) (app env)) (DB.closeDB (envDB env))
-- Reimplement the `prepareAppReqs` function using the imported `ExceptT`
-- constructor to help eliminate the manual plumbing of the error values.
-- | Our AppM is no longer useful for implementing this function. Can you explain why?
--
-- 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 = runExceptT $
error "Copy your completed 'prepareAppReqs' from the previous level and refactor it here"
-- We will reimplement this function using `ExceptT`. It is from the 'mtl'
-- package and it's the very general form of the AppM we implemented previously.
-- It has all of the useful instances written for us, along with many utility
-- functions.
--
-- 'mtl' on Hackage: https://hackage.haskell.org/package/mtl
--
prepareAppReqs :: ExceptT StartUpError IO Env
prepareAppReqs = error "prepareAppReqs not reimplemented with ExceptT"
-- You may copy your previous implementation of this function and try refactoring it. On the
-- condition you have to explain to the person next to you what you've done and why it works.
-- 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
-- | Now that our request handling and response creating functions operate
-- within our App context, we need to run the App to get our IO action out
-- to be run and handed off to the callback function. We've already written
-- the function for this so include the 'runAppM' with the Env.
-- the function for this so include the 'runApp' with the Env.
app
:: Env
-> Application
@ -91,15 +98,15 @@ app =
handleRequest
:: RqType
-> AppM Response
-> App 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
ViewRq t -> Res.resp200Json (E.list encodeComment) <$> DB.getComments t
ListRq -> Res.resp200Json (E.list encodeTopic) <$> DB.getTopics
mkRequest
:: Request
-> AppM RqType
-> App RqType
mkRequest rq =
liftEither =<< case ( pathInfo rq, requestMethod rq ) of
-- Commenting on a given topic

14
src/Level07/DB.hs
View File

@ -25,7 +25,7 @@ import qualified Database.SQLite.Simple as Sql
import qualified Database.SQLite.SimpleErrors as Sql
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Level07.AppM (AppM, Env (envDB))
import Level07.AppM (App, Env (envDB))
import Level07.Types (Comment, CommentText,
DBFilePath (getDBFilePath),
@ -61,38 +61,38 @@ initDB fp = Sql.runDBAction $ do
"CREATE TABLE IF NOT EXISTS comments (id INTEGER PRIMARY KEY, topic TEXT, comment TEXT, time INTEGER)"
getDBConn
:: AppM Connection
:: App Connection
getDBConn =
error "getDBConn not implemented"
runDB
:: (a -> Either Error b)
-> (Connection -> IO a)
-> AppM b
-> App b
runDB =
error "runDB not re-implemented"
getComments
:: Topic
-> AppM [Comment]
-> App [Comment]
getComments =
error "Copy your completed 'getComments' and refactor to match the new type signature"
addCommentToTopic
:: Topic
-> CommentText
-> AppM ()
-> App ()
addCommentToTopic =
error "Copy your completed 'appCommentToTopic' and refactor to match the new type signature"
getTopics
:: AppM [Topic]
:: App [Topic]
getTopics =
error "Copy your completed 'getTopics' and refactor to match the new type signature"
deleteTopic
:: Topic
-> AppM ()
-> App ()
deleteTopic =
error "Copy your completed 'deleteTopic' and refactor to match the new type signature"

128
src/Level07/DB/PostgreSQL.hs
View File

@ -1,128 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- This is an example module if you wanted to use PostgreSQL with the
-- 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 Level07.DB.PostgreSQL where
import GHC.Int (Int64)
import Data.Text (Text)
import Data.Time (getCurrentTime)
import Database.PostgreSQL.Simple (Connection, FromRow, Query,
ToRow)
import Database.PostgreSQL.Simple.Types (Identifier (..))
import qualified Database.PostgreSQL.Simple as PG
import Level07.Types
-- This is a bit more configuration available to the PostgreSQL package so we
-- have a bit more work to do.
newtype DBName = DBName
{ getDBName :: String }
deriving Show
newtype UserName = UserName
{ getUserName :: String }
deriving Show
data FirstAppDB = FirstAppDB
{ dbConn :: Connection
}
closeDB
:: FirstAppDB
-> IO ()
closeDB =
PG.close . dbConn
initDB
:: UserName
-> DBName
-> Table
-> IO FirstAppDB
initDB un dbN tab = do
-- The ConnectInfo type from PostgreSQL has extra configuration options if your local setup is a bit different
-- https://hackage.haskell.org/package/postgresql-simple-0.5.3.0/docs/Database-PostgreSQL-Simple.html#v:defaultConnectInfo
--
-- Use the info to adjust the default connection options.
let info = PG.defaultConnectInfo
{ PG.connectUser = getUserName un
, PG.connectDatabase = getDBName dbN
}
-- Initialise the connection to the DB...
-- - What could go wrong here?
-- - What haven't we been told in the types?
con <- PG.connect info
-- Initialise our one table, if it's not there already
_ <- PG.execute_ con createTableQ
-- Wrap it up and hand it back.
pure $ FirstAppDB con tab
createTableQ
:: PG.Query
createTableQ =
-- Query has a IsString instance so you can write straight strings like this
-- and it will convert them into a Query type, use '?' as placeholders for
-- ORDER DEPENDENT interpolation.
"CREATE TABLE IF NOT EXISTS comments (id SERIAL PRIMARY KEY, topic TEXT, comment TEXT, time TIMESTAMPTZ)"
-- Another way to express this query if you prefer being able to use line
-- breaks is to use the QuasiQuotes extension and write the following:
-- [sql| CREATE TABLE IF NOT EXISTS comments (
-- id SERIAL PRIMARY KEY,
-- topic TEXT,
-- comment TEXT,
-- time TIMESTAMPTZ
-- )
-- |]
getComments
:: FirstAppDB
-> Topic
-> IO (Either Error [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 = ?"
-- Run the query against our DB using our connection.
-- To build the replacements for the query placeholders, this package uses
-- tuples. Remember that the '?' are order dependent so if you get your input
-- parameters in the wrong order, the types won't save you here. More on that
-- sort of goodness later.
res <- PG.query (dbConn db) q (PG.Only $ getTopic t)
-- To be doubly and triply sure we've no garbage in our response, we take care
-- to convert our DB storage type into something we're going to share with the
-- outside world. Checking again for things like empty Topic or CommentText
-- values.
pure $ traverse fromDBComment res
-- Note that because of the use of traverse, this function will fail at the
-- first record that is invalid and discard any successful values.
addCommentToTopic
:: FirstAppDB
-> Topic
-> CommentText
-> IO (Either Error ())
addCommentToTopic db t c = do
-- Record the time this comment was created.
nowish <- getCurrentTime
-- Note the triple, matching the number of values we're trying to insert, plus
-- one for the table name.
let q = "INSERT INTO comments (topic,comment,time) VALUES (?,?,?)"
-- We use the PG.execute function this time as we don't care about anything
-- that is returned. The execute function will still return the number of rows
-- affected by the query, which in our case should always be 1.
res <- PG.execute (dbConn db) q (getTopic t, getCommentText c, nowish)
-- An alternative is to write a returning query to get the Id of the DBComment
-- we've created. We're being pretty lazy right now so check we've
-- affected a single row and move on.
pure $ if res == 1 then Right ()
else Left (DBError "Comment Insert Failed")
getTopics
:: FirstAppDB
-> IO (Either Error [Topic])
getTopics db = do
let q = "SELECT DISTINCT topic FROM comments"
res <- PG.query_ (dbConn db) q
pure $ traverse ( mkTopic . PG.fromOnly ) res

16
src/Level07/Responses.hs
View File

@ -7,9 +7,10 @@ import Network.HTTP.Types (Status, hContentType, status200,
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Aeson (ToJSON)
import qualified Data.Aeson as A
import Level07.Types (ContentType (JSON),
import Waargonaut.Encode (Encoder')
import qualified Waargonaut.Encode as E
import Level07.Types (ContentType (JSON),
renderContentType)
mkResponse
@ -50,8 +51,9 @@ resp500 =
mkResponse status500
resp200Json
:: ToJSON a
=> a
:: Encoder' a
-> a
-> Response
resp200Json =
resp200 JSON . A.encode
resp200Json e =
resp200 JSON .
E.simplePureEncodeNoSpaces e

119
src/Level07/Types.hs
View File

@ -1,6 +1,4 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
module Level07.Types
( Error (..)
, ConfigError (..)
@ -14,6 +12,7 @@ module Level07.Types
, Comment (..)
, Topic
, CommentText
, partialConfDecoder
, mkTopic
, getTopic
, mkCommentText
@ -21,45 +20,51 @@ module Level07.Types
, renderContentType
, fromDBComment
, confPortToWai
, encodeComment
, encodeTopic
) where
import System.IO.Error (IOError)
import GHC.Generics (Generic)
import GHC.Word (Word16)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text (pack)
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Functor.Contravariant ((>$<))
import Data.Monoid (Last (Last))
import Data.Semigroup (Semigroup ((<>)))
import Data.Aeson (FromJSON (..), ToJSON,
(.:?))
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import Data.Time (UTCTime)
import qualified Data.Time.Format as TF
import Waargonaut.Decode (CursorHistory, Decoder)
import qualified Waargonaut.Decode as D
import Waargonaut.Decode.Error (DecodeError)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Database.SQLite.Simple (Connection)
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Level07.DB.Types (DBComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic))
import Level07.Types.Error (Error ( UnknownRoute
, EmptyCommentText
, EmptyTopic
, DBError
))
import Level07.Types.CommentText ( CommentText
, mkCommentText
, getCommentText
)
import Level07.Types.Topic (Topic, mkTopic, getTopic)
import Level07.DB.Types (DBComment (dbCommentComment, dbCommentId, dbCommentTime, dbCommentTopic))
import Level07.Types.Error (Error (DBError, EmptyCommentText, EmptyTopic, UnknownRoute))
import Level07.Types.CommentText (CommentText,
encodeCommentText,
getCommentText,
mkCommentText)
import Level07.Types.Topic (Topic, encodeTopic,
getTopic, mkTopic)
newtype CommentId = CommentId Int
deriving (Show, ToJSON)
deriving (Show)
encodeCommentId :: Applicative f => Encoder f CommentId
encodeCommentId = (\(CommentId i) -> i) >$< E.int
data Comment = Comment
{ commentId :: CommentId
@ -67,42 +72,20 @@ data Comment = Comment
, commentText :: CommentText
, commentTime :: UTCTime
}
-- Generic has been added to our deriving list.
deriving ( Show, Generic )
deriving Show
-- 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.
encodeISO8601DateTime :: Applicative f => Encoder f UTCTime
encodeISO8601DateTime = pack . TF.formatTime tl fmt >$< E.text
where
fmt = TF.iso8601DateFormat (Just "%H:%M:%S")
tl = TF.defaultTimeLocale { TF.knownTimeZones = [] }
-- | 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
}
encodeComment :: Applicative f => Encoder f Comment
encodeComment = E.mapLikeObj $ \c ->
E.atKey' "id" encodeCommentId (commentId c) .
E.atKey' "topic" encodeTopic (commentTopic c) .
E.atKey' "text" encodeCommentText (commentText c) .
E.atKey' "time" encodeISO8601DateTime (commentTime c)
-- 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
@ -172,7 +155,8 @@ confPortToWai =
-- Similar to when we were considering our application types, leave this empty
-- for now and add to it as you go.
data ConfigError
= MissingPort
= BadConfFile (DecodeError, CursorHistory)
| MissingPort
| MissingDBFilePath
| JSONDecodeError String
| ConfigFileReadError IOError
@ -228,17 +212,16 @@ instance Monoid PartialConf where
-- 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
-- For reading the configuration from the file, we're going to use the Waargonaut
-- 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
-- have to tell waargonaut 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
partialConfDecoder :: Monad f => Decoder f PartialConf
partialConfDecoder = PartialConf
<$> lastAt "port" D.integral Port
<*> lastAt "dbFilePath" D.string DBFilePath
where
lastAt k d c = Last . fmap c <$> D.atKeyOptional k d
-- 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

18
src/Level07/Types/CommentText.hs
View File

@ -1,18 +1,24 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level07.Types.CommentText
( CommentText
, mkCommentText
, getCommentText
, encodeCommentText
) where
import Level07.Types.Error (Error(EmptyCommentText), nonEmptyText)
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Data.Text (Text)
import Data.Aeson (ToJSON)
import Data.Functor.Contravariant ((>$<))
import Data.Text (Text)
import Level07.Types.Error (Error (EmptyCommentText),
nonEmptyText)
newtype CommentText = CommentText Text
deriving (Show, ToJSON)
deriving (Show)
encodeCommentText :: Applicative f => Encoder f CommentText
encodeCommentText = getCommentText >$< E.text
mkCommentText
:: Text

21
src/Level07/Types/Topic.hs
View File

@ -1,14 +1,23 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Level07.Types.Topic
( Topic
, mkTopic
, getTopic
, encodeTopic
) where
module Level07.Types.Topic (Topic, mkTopic, getTopic) where
import Waargonaut.Encode (Encoder)
import qualified Waargonaut.Encode as E
import Level07.Types.Error (Error(EmptyTopic), nonEmptyText)
import Data.Functor.Contravariant ((>$<))
import Data.Text (Text)
import Data.Text (Text)
import Data.Aeson (ToJSON)
import Level07.Types.Error (Error (EmptyTopic), nonEmptyText)
newtype Topic = Topic Text
deriving (Show, ToJSON)
deriving (Show)
encodeTopic :: Applicative f => Encoder f Topic
encodeTopic = getTopic >$< E.text
mkTopic
:: Text

105
src/Workshop/NextLevels.md Normal file
View File

@ -0,0 +1,105 @@
# [Workshop] Levels
This level is the start of the [Workshop] levels. These are levels that _are
still in development_ so they will not be as well structured or tested as
earlier levels.
You are invited to give them a go if you are ready for a challenge. But be
prepared that the instructions may not be as clearly defined as earlier levels.
There is also no code provided as the expectation is that you have a _completed_
Level07 `Application` that you will copy and refactor to meet the requirements.
## Level 08 [Workshop]
This exercise introduces the [lens](https://hackage.haskell.org/package/lens)
package. We will be writing some `Lens`es and `Prism`s for our various data
structures, then refactoring some of our code to take advantage of them.
Building up a solid theoretical foundation of what a `lens` is, is beyond the
scope of this level. We will be making use of a far too popular software
development technique of 'cargo-culting'.
This is not to imply that a solid theoretical foundation of lenses is beyond
you, far from it. But there is a more focused and in-depth course that deals
with this subject to a far more satisfying depth. You would be better served by
delving into the details there.
See [lets-lens](https://github.com/data61/lets-lens) for the juicy details.
We have two main goals:
A) Develop your _intuition_ of what a lens is
B) Crush any notion that lenses are super complicated things, used only by
wizened Haskellers and skittery mathematicians to write inscrutable code.
Our approach is to:
* Discuss some analogies
* Build some
* Use them
[lens intro examples](https://github.com/ekmett/lens/wiki/Examples)
[derivation of lenses](https://github.com/ekmett/lens/wiki/Derivation)
## Level 09 [Workshop]
Classy MTL
[a talk](https://www.youtube.com/watch?v=GZPup5Iuaqw)
[a slides](https://github.com/gwils/next-level-mtl-with-classy-optics)
[a blog](https://carlo-hamalainen.net/2015/07/20/classy-mtl/)
1) Reimplement AppM with ReaderT & ExceptT
You may use GeneralizedNewtypeDeriving to make this easier.
2) Define Prisms and 'AsError' typeclass for 'Error' type
import Control.Lens (Prism', prism')
class AsError s where
_Error :: Prism' s Error
_EmptyTopic :: Prism' s ()
_EmptyCommentText :: Prism' s ()
_DBError :: Prism' s SQLiteResponse
...
...
3) Define Lenses and 'HasEnv' typeclass for 'Env' type
- refer to 'Control.Lens.TH' for more info about these classes
class HasEnv t where
env :: Lens' t Env
class HasConf t where
port :: Lens' t Port
dbFilePath :: Lens' t DBFilePath
3b) Reimplement 'getDBConn' in DB.hs
4) Define 'AsAppM' constraint:
'type AsAppM m = ...'
You'll need 'ConstraintKinds' for this.
5) Begin refactoring function types to utilise these constraints:
'f :: AsAppM m => ... -> m a'
Only the top level should need to use concrete 'AppM' type.
We want to be able to write functions similar to:
f :: (AsError e, MonadError e m) => a -> m ()
# Level 10 [Workshop]
Reimplement routes using Servant, integrate with existing AppM
# Level 11 [Workshop]
Implement Hedgehog property tests
** Bonus points: Implement tests to prove your typeclasses satisfy the laws (hedgehog-fn package)
Add Hedgehog dependency
Add separate hedgehog test-suite

17
stack.yaml
View File

@ -1,7 +1,12 @@
resolver: lts-10.4
resolver: lts-12.21
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
- tasty-wai-0.1.0.1
- waargonaut-0.4.2.0
- digit-0.7
- hoist-error-0.2.1.0
- hw-json-0.9.0.1
- hw-parser-0.1.0.0
- natural-0.3.0.3
- tagged-0.8.6
- generics-sop-0.3.2.0
- witherable-0.2

118
tests/Helpers.hs
View File

@ -1,118 +0,0 @@
module Helpers
( -- * Test Monad
TestM
-- * Test Runner
, runTestsFor
-- * Request Builders
, get
, post
, put
-- * Response Assertions
, assertBody
, assertStatus
, assertContentType
-- * Internals
, RequestPath (..)
, rq
, rqWithBody
) where
import qualified System.Exit as Exit
import qualified Control.Exception as E
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT (..), ask, runReaderT)
import Control.Monad.State (StateT (..), evalStateT, lift,
runStateT)
import qualified Control.Monad.State as State
import Data.Semigroup ((<>))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Network.HTTP.Types as HTTP
import Network.Wai (Application, Request (..))
import Network.Wai.Test (Session, WaiTestFailure (..))
import qualified Network.Wai.Test as WT
import Network.Wai.Test.Internal (ClientState, initState)
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as MVar
import Control.Monad.Morph (hoist)
-- | This terrifying beast is the combination of the 'Session' transformer stack
-- from Wai.Test and the transformer stack required to keep track of the test
-- name, along with catching the exceptions so we don't just die with an awful
-- failure and no information.
type TestM = ReaderT Application (StateT ClientState (ExceptT WaiTestFailure (StateT String IO)))
-- | By leaning on some monad morphisms, we're able to insert a transformer
-- stack at an arbitrary point in a different transformer stack that we do not
-- control. This lets us extend it with new functionality that it may not have been
-- designed for.
manipulateTransStack :: WT.Session a -> TestM a
manipulateTransStack = hoist (hoist (hoist lift . ExceptT . E.try))
-- | Although not exported, this newtype helps us keep our strings in line.
newtype RequestPath = RequestPath
{ unRequestPath :: BS.ByteString
}
-- | Create an empty 'Request' using the given HTTP Method and route.
rq :: StdMethod -> RequestPath -> Request
rq mth rpath = flip WT.setPath (unRequestPath rpath) $ WT.defaultRequest
{ requestMethod = HTTP.renderStdMethod mth
}
-- | Create a 'Request' with a body.
rqWithBody
:: StdMethod
-> RequestPath
-> LBS.ByteString
-> WT.SRequest
rqWithBody mth rpath =
WT.SRequest (rq mth rpath)
-- | Run a single instance of the 'Application' for all of the tests given in the 'TestM'.
runTestsFor :: Application -> String -> TestM a -> IO a
runTestsFor app nm m = do
(e, testName) <- runStateT (runExceptT (evalStateT (runReaderT m app) initState)) nm
either (sad testName) pure e
where
sad test (WT.WaiTestFailure msg) = do
putStrLn $ "\tTest Failure For: " <> "[" <> test <> "]"
putStrLn $ "\t" <> msg
Exit.exitFailure
testRequest :: String -> WT.Session a -> TestM a
testRequest test r = do
lift . lift . State.put $ test
manipulateTransStack r
get :: String -> BS.ByteString -> TestM WT.SResponse
get test = testRequest test . WT.request . rq HTTP.GET . RequestPath
post :: String -> BS.ByteString -> LBS.ByteString -> TestM WT.SResponse
post test r = testRequest test . WT.srequest . rqWithBody HTTP.POST (RequestPath r)
put :: String -> BS.ByteString -> LBS.ByteString -> TestM WT.SResponse
put test r = testRequest test . WT.srequest . rqWithBody HTTP.PUT (RequestPath r)
assertBody :: LBS.ByteString -> WT.SResponse -> TestM ()
assertBody b = manipulateTransStack . WT.assertBody b
assertStatus :: HTTP.Status -> WT.SResponse -> TestM ()
assertStatus c = manipulateTransStack . WT.assertStatus (HTTP.statusCode c)
assertContentType :: BS.ByteString -> WT.SResponse -> TestM ()
assertContentType b = manipulateTransStack . WT.assertContentType b

34
tests/Level03Tests.hs
View File

@ -1,34 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level03Tests
( unitTests
) where
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.HUnit (testCase)
import Network.HTTP.Types as HTTP
import Helpers (assertBody, assertStatus, get, runTestsFor)
import qualified Level03.Core as Core
unitTests :: IO ()
unitTests = runTestsFor Core.app "Level 03 Tests" $ do
-- Using the functions from ``Helpers`` this actions a GET request on the
-- "/list" route and compares the response body and status code to our
-- expectations
get "GET list route" "/list" >>= \resp -> do
assertBody "List Request not implemented" resp
assertStatus HTTP.status200 resp
-- Write some more tests, below are some ideas to get you started:
-- Don't worry if you don't get all of these done. :)
-- 1) The '<topic>/add' route will respond with an error when given an empty comment
-- 2) The '<topic>/view' route will respond correctly when given a topic
-- 3) The '<topic>/view' route will respond with an error when given an empty topic
-- 4) A gibberish route will return a 404
-- After you're done here, you'll need to uncomment the use of these functions
-- in the `test/Test.hs` otherwise the tests won't run!

81
tests/Level04Tests.hs
View File

@ -1,81 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level04Tests
( unitTests
, doctests
) where
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import qualified System.Exit as Exit
import Data.Foldable (traverse_)
import Data.Semigroup ((<>))
import Network.HTTP.Types as HTTP
import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified Level04.Core as Core
import qualified Level04.DB as DB
import qualified Level04.Types as Types
-- Don't forget to uncomment these functions in @tests/Test.hs@ otherwise your
-- tests won't be run.
doctests :: [FilePath]
doctests =
[ "-isrc"
, "src/Level04/Conf.hs"
, "src/Level04/DB.hs"
, "src/Level04/Types.hs"
]
dieWith :: Show a => a -> IO ()
dieWith err = print err >> Exit.exitFailure
unitTests :: IO ()
unitTests = do
reqE <- Core.prepareAppReqs
case reqE of
Left err -> dieWith err
Right db -> runTestsFor (Core.app db) "Level 04 Tests" $ do
let
flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- 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 a test and then flush the db
test t = t >> flushTopic
topicR = "/fudge/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

93
tests/Level05Tests.hs
View File

@ -1,93 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level05Tests
( unitTests
, doctests
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, reader)
import Data.Foldable (traverse_)
import Data.Monoid ((<>))
import Data.String (IsString)
import Network.HTTP.Types as HTTP
import Test.Hspec
import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
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 -> runTestsFor (Core.app db) "Level 05 Tests" $ do
let
flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Include the runner to handle our new 'AppM'
AppM.runAppM .
-- 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 a test and then flush the db
test t = t >> flushTopic
topicR = "/fudge/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

88
tests/Level06Tests.hs
View File

@ -1,88 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level06Tests
( doctests
, unitTests
) where
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (traverse_)
import Data.Monoid ((<>))
import Data.String (IsString)
import Network.HTTP.Types as HTTP
import Test.Hspec
import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
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) -> runTestsFor (Core.app cfg db) "Level 06 Tests" $ do
let
flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Include the runner to handle our new 'AppM'
AppM.runAppM .
-- 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 a test and then flush the db
test t = t >> flushTopic
topicR = "/fudge/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"fudge\"]"

114
tests/Level07Tests.hs
View File

@ -1,114 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Level07Tests
( unitTests
, doctests
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, reader)
import Control.Monad (join)
import Data.Foldable (traverse_)
import Data.Monoid ((<>))
import Data.String (IsString)
import Test.Hspec
import Network.HTTP.Types as HTTP
import Helpers (TestM, assertBody, assertStatus, get,
post, runTestsFor)
import qualified System.Exit as Exit
import Level07.AppM (Env)
import qualified Level07.AppM as AppM
import qualified Level07.Core as Core
import qualified Level07.DB as DB
import qualified Level07.Types as Types
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
testTopic :: IsString s => s
testTopic = "fudge"
reqsE <- Core.prepareAppReqs
case reqsE of
Left err -> dieWith err
Right e -> runTestsFor (Core.app e) "Level 07 API Tests" $ do
let
flushTopic :: TestM ()
flushTopic = liftIO .
-- Clean up and yell about our errors
(traverse_ (either dieWith pure) =<<) .
-- Include the runner to handle our new 'AppM'
flip AppM.runAppM e .
-- Purge all of the comments for this topic for our tests
traverse DB.deleteTopic
-- 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 a test and then flush the db
test t = t >> flushTopic
topicR = "/fudge/"
addToTopic =
post "Add Topic" (topicR <> "add") "Fred"
-- AddRq Spec
-- it should return 200 with well formed request
test $ addToTopic >>= assertBody "Success"
-- it should 400 on empty input
test $ post "Empty Input" (topicR <> "add") ""
>>= assertStatus HTTP.status400
-- ViewRq Spec
-- it should return 200 with
test $ addToTopic
>> get "View topic" (topicR <> "view")
>>= assertStatus HTTP.status200
-- ListRq Spec
test $ addToTopic
>> get "List topics" "/list"
>>= assertBody "[\"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) == Right (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` Right (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` Right ()

67
tests/Test.hs
View File

@ -1,16 +1,59 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified Level03Tests
import qualified Level04Tests
import qualified Level05Tests
import qualified Level06Tests
import qualified Level07Tests
-- | **REMINDER**
-- This level is not an isolated module to complete. This level exists as one
-- starting module: `test/Test.hs`. Which you are to import your most recently
-- completed `Application` to be tested.
--
-- As you progress through the course, you are encouraged to return to this
-- `test/Test.hs` and update it so you're able to be confident that your
-- application will behave as you expect. You may also write your tests before
-- you write your functions, this can be useful when trying to think through a
-- problem.
-- | This is the only location for tests as you progress through the course.
-- | This module starts our very sparse. There are only the imports required to
-- have these initial tests work. Additional tests are for you to build. and may
-- require you to import other modules as you require.
--
-- As you progress through the levels, the initialisation of the 'app' will
-- become more complicated as more components are introduced. Part of the
-- exercise is to work out how to integrate your application with this testing
-- framework.
-- | 'tasty' takes care of managing all of our test cases, running them,
-- checking results and then providing us with a report.
import Test.Tasty (defaultMain, testGroup)
-- | 'tasty-wai' makes it easier to create requests to submit to our
-- application, and provides some helper functions for checking our assertions.
import Test.Tasty.Wai (assertBody, assertStatus', get, post,
testWai)
-- | For running unit tests for individual functions, we have included the
-- 'tasty-hunit' package. More information is available on the Hackage page:
-- https://hackage.haskell.org/package/tasty-hunit.
--
-- import qualified Test.Tasty.HUnit as HU
--
import Network.HTTP.Types as HTTP
-- | This import is provided for you so you can check your work from Level02. As
-- you move forward, come back and import your latest 'Application' so that you
-- can test your work as you progress.
import qualified Level02.Core as Core
main :: IO ()
main = do
putStrLn "No tests yet!"
-- Level03Tests.unitTests
-- Level04Tests.unitTests
-- Level05Tests.unitTests
-- Level06Tests.unitTests
-- Level07Tests.unitTests
main = defaultMain $ testGroup "Applied FP Course - Tests"
[ testWai Core.app "List Topics" $
get "fudge/view" >>= assertStatus' HTTP.status200
, testWai Core.app "Empty Input" $ do
resp <- post "fudge/add" ""
assertStatus' HTTP.status400 resp
assertBody "Empty Comment Text" resp
]

13
tests/doctests.hs
View File

@ -2,14 +2,7 @@ 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
main = doctest
[ -- No doctests yet!
]