{-# LANGUAGE OverloadedStrings #-} module Main ( main ) where import Control.Lens ((^..), (^?)) import Control.Monad (replicateM_) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger (NoLoggingT, runNoLoggingT) import Data.Aeson.Lens (_Array, _Number, _String, key) import Data.ByteString.Lazy (ByteString) import Data.Foldable (traverse_) import Data.List (find) import Data.Maybe (fromMaybe) import Data.Scientific (Scientific) import Data.String (IsString(..)) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8) import Data.Time (getCurrentTime) import Database.Persist (Filter, deleteWhere, insert) import Database.Persist.Sql (SqlPersistT, insertMany_, runMigration) import GHC.Stack (HasCallStack) import Network.HTTP.Link.Compat import Network.HTTP.Types.Header (HeaderName) import Network.Wai.Test (simpleBody, simpleHeaders) import Test.Hspec (Spec, SpecWith, beforeAll, before_, describe, hspec, it) import Test.Hspec.Expectations.Lifted (shouldBe, shouldReturn) import TestApp import Yesod.Core (RedirectUrl, Yesod) import Yesod.Test main :: IO () main = hspec spec spec :: Spec spec = withApp $ do describe "Cursor" $ do it "responds with a useful message on invalid limit" $ do getPaginated SomeR [("teacherId", "1"), ("limit", "-1")] statusIs 400 bodyContains "must be a positive natural number" it "returns no cursor when there are no items" $ do getPaginated SomeR [("teacherId", "1")] mayLink "next" `shouldReturn` Nothing it "traverses a list with a next Cursor" $ do runDB $ insertAssignments 12 getPaginated SomeR [("teacherId", "1"), ("limit", "4")] assertDataKeys [1, 2, 3, 4] get =<< getLink "next" assertDataKeys [5, 6, 7, 8] get =<< getLink "next" assertDataKeys [9, 10, 11, 12] it "traverses a list to next and previous" $ do runDB $ insertAssignments 12 getPaginated SomeR [("teacherId", "1"), ("limit", "4")] assertDataKeys [1, 2, 3, 4] get =<< getLink "next" assertDataKeys [5, 6, 7, 8] get =<< getLink "previous" assertDataKeys [1, 2, 3, 4] it "correctly handles incomplete pages" $ do runDB $ insertAssignments 3 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] assertDataKeys [1, 2] get =<< getLink "next" assertDataKeys [3] get =<< getLink "previous" assertDataKeys [1, 2] it "finds a null next when no items are left" $ do runDB $ insertAssignments 2 getPaginated SomeR [("teacherId", "1"), ("limit", "3")] assertDataKeys [1, 2] mayLink "next" `shouldReturn` Nothing it "finds a null next even with limit defaulted" $ do runDB $ insertAssignments 2 getPaginated SomeR [("teacherId", "1")] mayLink "next" `shouldReturn` Nothing it "finds a null next even with page-aligned data" $ do runDB $ insertAssignments 2 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] mayLink "next" `shouldReturn` Nothing it "finds a null next on the last page" $ do runDB $ insertAssignments 2 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] get =<< getLink "last" mayLink "next" `shouldReturn` Nothing it "finds a null previous on the first page" $ do runDB $ insertAssignments 2 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] mayLink "previous" `shouldReturn` Nothing it "returns the same response for the same cursor" $ do runDB $ insertAssignments 5 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] assertDataKeys [1, 2] next <- getLink "next" let go = do get next assertDataKeys [3, 4] getBody response1 <- go response2 <- go response1 `shouldBe` response2 it "limits are optional" $ do runDB $ insertAssignments 5 getPaginated SomeR [("teacherId", "1")] _next <- getLink "next" assertDataKeys [1, 2, 3, 4, 5] it "parses optional params" $ do now <- liftIO getCurrentTime runDB $ do _ <- insert $ SomeAssignment 1 3 now replicateM_ 5 . insert $ SomeAssignment 1 2 now getPaginated SomeR [("teacherId", "1"), ("courseId", "3")] _next <- getLink "next" assertDataKeys [1] it "can link to first" $ do runDB $ insertAssignments 6 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] assertDataKeys [1, 2] get =<< getLink "next" assertDataKeys [3, 4] get =<< getLink "next" assertDataKeys [5, 6] get =<< getLink "first" assertDataKeys [1, 2] it "can link to last" $ do runDB $ insertAssignments 6 getPaginated SomeR [("teacherId", "1"), ("limit", "2")] assertDataKeys [1, 2] get =<< getLink "last" assertDataKeys [5, 6] get =<< getLink "previous" assertDataKeys [3, 4] get =<< getLink "previous" assertDataKeys [1, 2] it "can traverse via Link" $ do runDB $ insertAssignments 6 getPaginated SomeLinkR [("teacherId", "1"), ("limit", "2")] assertKeys [1, 2] get =<< getLinkViaHeader "next" assertKeys [3, 4] get =<< getLinkViaHeader "next" assertKeys [5, 6] get =<< getLinkViaHeader "first" assertKeys [1, 2] get =<< getLinkViaHeader "last" assertKeys [5, 6] get =<< getLinkViaHeader "previous" assertKeys [3, 4] get =<< getLinkViaHeader "previous" assertKeys [1, 2] withApp :: SpecWith (TestApp Simple) -> Spec withApp = beforeAll (testApp Simple id <$ setupDB) . before_ wipeDB setupDB :: IO () setupDB = liftIO $ runDB $ runMigration migrateAll wipeDB :: IO () wipeDB = liftIO $ runDB deleteAssignments runDB :: MonadUnliftIO m => SqlPersistT (NoLoggingT m) a -> m a runDB = runNoLoggingT . runDB' deleteAssignments :: MonadIO m => SqlPersistT m () deleteAssignments = deleteWhere ([] :: [Filter SomeAssignment]) insertAssignments :: MonadIO m => Int -> SqlPersistT m () insertAssignments n = do now <- liftIO getCurrentTime insertMany_ $ replicate n $ SomeAssignment 1 2 now getPaginated :: (Yesod site, RedirectUrl site url) => url -> [(Text, Text)] -> YesodExample site () getPaginated url params = request $ do setUrl url traverse_ (uncurry addGetParam) params assertDataKeys :: HasCallStack => [Scientific] -> YesodExample site () assertDataKeys expectedKeys = do statusIs 200 body <- getBody body ^.. key "data" . _Array . traverse . key "key" . _Number `shouldBe` expectedKeys assertKeys :: HasCallStack => [Scientific] -> YesodExample site () assertKeys expectedKeys = do statusIs 200 body <- getBody body ^.. _Array . traverse . key "key" . _Number `shouldBe` expectedKeys getLink :: HasCallStack => String -> YesodExample site Text getLink rel = fromMaybe (error $ "no " <> rel <> " in JSON response") <$> mayLink rel mayLink :: String -> YesodExample site (Maybe Text) mayLink rel = do body <- getBody -- Using fromString so we can deal with aeson-2.0 without CPP. fromString will -- give us a Text (aeson-1.x) or a Key (aeson-2.0) as appropriate. pure $ body ^? key (fromString rel) . _String getLinkViaHeader :: HasCallStack => Text -> YesodExample site Text getLinkViaHeader rel = fromMaybe (error $ "no " <> unpack rel <> " in Link header") <$> mayLinkViaHeader rel mayLinkViaHeader :: Text -> YesodExample site (Maybe Text) mayLinkViaHeader rel = do mHeader <- getHeader "Link" pure $ do header <- mHeader parsed <- either (const Nothing) Just $ parseLinkURI header link <- find (((Rel, rel) `elem`) . linkParams) parsed pure $ pack $ show $ href link getBody :: YesodExample site ByteString getBody = withResponse $ pure . simpleBody getHeader :: HeaderName -> YesodExample site (Maybe Text) getHeader h = withResponse $ pure . fmap decodeUtf8 . lookup h . simpleHeaders