Permalink
Cannot retrieve contributors at this time
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
111 lines (95 sloc)
4.5 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- These are the tests for our api. The only real interesting part is the | |
-- 'main' function, where we specific that the test database is in memory. | |
{-# LANGUAGE DeriveFunctor #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE GADTs #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
{-# LANGUAGE InstanceSigs #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE QuasiQuotes #-} | |
{-# LANGUAGE RankNTypes #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TypeFamilies #-} | |
module Main (main) where | |
import Control.Monad.IO.Class (liftIO) | |
import Control.Monad.Logger (NoLoggingT(..)) | |
import Data.Aeson (ToJSON, encode) | |
import Data.ByteString (ByteString) | |
import Database.Persist ((>=.), deleteWhere) | |
import Database.Persist.Sql (toSqlKey) | |
import Database.Persist.Sqlite (runMigration, runSqlConn, withSqliteConn) | |
import Network.HTTP.Types.Method (methodPost, methodPut) | |
import Network.Wai (Application) | |
import Network.Wai.Test (SResponse) | |
import Servant.Server (serve) | |
import Test.Hspec (Spec, describe, hspec, it) | |
import Test.Hspec.Wai | |
( WaiExpectation, WaiSession, delete, get, matchBody, request | |
, shouldRespondWith, with ) | |
import Lib (BlogPost(..), EntityField(..), blogPostApiProxy, migrateAll, server) | |
-- | These are our actual unit tests. They should be relatively | |
-- straightforward. | |
-- | |
-- This function is using 'app', which in turn accesses our in-memory | |
-- database. | |
spec :: IO Application -> Spec | |
spec app = with app $ do | |
describe "GET blogpost" $ do | |
it "responds with 200 after inserting something" $ do | |
postJson "/create" testBlogPost `shouldRespondWith` 201 | |
get "/read/1" `shouldRespondWithJson` (200, testBlogPost) | |
it "responds with 404 because nothing has been inserted" $ do | |
get "/read/1" `shouldRespondWith` 404 | |
describe "PUT blogpost" $ do | |
it "responds with 204 even when key doesn't exist in DB" $ do | |
putJson "/update/1" testBlogPost `shouldRespondWith` 204 | |
it "can't GET after PUT" $ do | |
putJson "/update/1" testBlogPost `shouldRespondWith` 204 | |
get "/read/1" `shouldRespondWith` 404 | |
describe "DELETE blogpost" $ do | |
it "responds with 204 even when key doesn't exist in DB" $ do | |
delete "/delete/1" `shouldRespondWith` 204 | |
it "GET after DELETE returns 404" $ do | |
postJson "/create" testBlogPost `shouldRespondWith` 201 | |
get "/read/1" `shouldRespondWith` 200 | |
delete "/delete/1" `shouldRespondWith` 204 | |
get "/read/1" `shouldRespondWith` 404 | |
where | |
-- Send a type that can be turned into JSON (@a@) to the Wai | |
-- 'Application' at the 'ByteString' url. This returns a 'SResponse' | |
-- in the 'WaiSession' monad. This is similar to the 'post' function. | |
postJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse | |
postJson path = | |
request methodPost path [("Content-Type", "application/json")] . encode | |
-- Similar to 'postJson'. | |
putJson :: (ToJSON a) => ByteString -> a -> WaiSession SResponse | |
putJson path = | |
request methodPut path [("Content-Type", "application/json")] . encode | |
-- Similar to 'shouldRespondWith', but converts the second argument to | |
-- JSON before it compares with the 'SResponse'. | |
shouldRespondWithJson :: (ToJSON a) | |
=> WaiSession SResponse | |
-> (Integer, a) | |
-> WaiExpectation | |
shouldRespondWithJson req (expectedStatus, expectedValue) = | |
let matcher = (fromInteger expectedStatus) | |
{ matchBody = Just $ encode expectedValue } | |
in shouldRespondWith req matcher | |
-- An example blog post to use in tests. | |
testBlogPost :: BlogPost | |
testBlogPost = BlogPost "title" "content" | |
-- | This is almost identical to the 'defaultMain' defined in "Lib", except | |
-- that is it running against an in-memory database (specified as | |
-- @:memory:@), instead of @production.sqlite@. | |
main :: IO () | |
main = | |
runNoLoggingT $ withSqliteConn ":memory:" $ \conn -> do | |
liftIO $ runSqlConn (runMigration migrateAll) conn | |
liftIO $ putStrLn "\napi running on port 8080..." | |
liftIO $ hspec $ spec $ do | |
-- Before running each test, we have to remove all of the | |
-- existing blog posts from the database. This ensures that | |
-- it doesn't matter which order the tests are run in. | |
runSqlConn (deleteWhere [BlogPostId >=. toSqlKey 0]) conn | |
return . serve blogPostApiProxy $ server conn | |