git.gnu.io has moved to IP address 209.51.188.249 -- please double check where you are logging in.

Remove unused tests

The remaining tests fail and are scheduled for removal, but they at least
test "features" that still exist.
parent b5237770
......@@ -267,16 +267,11 @@ test-suite test
ghc-options: -Wall -O0 -fobject-code
other-modules:
BlogTest
CommentTest
DiscussionTest
NotifyTest
PPrint
TestHandler
TestImport
TimedYesodTest
UserTest
WikiTest
default-extensions: QuasiQuotes
TemplateHaskell
OverloadedStrings
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module BlogTest
( blogSpecs
) where
import TestImport
import Data.Text.Encoding
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML
blogSpecs :: Spec
blogSpecs = do
let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS
blogRoute = NewBlogPostR "snowdrift"
ydescribe "blog" $ do
yit "previews blog post" $ do
loginAs AdminUser
get200 $ ProjectBlogR "snowdrift"
htmlNoneContain ".blog-post" "Above fold."
htmlNoneContain ".blog-post" "Below fold."
get200 blogRoute
[ form ] <- htmlQuery "form"
withStatus 200 False $ request $ do
addToken
setMethod "POST"
maybe (setUrl blogRoute) setUrl $ M.lookup "action" $ getAttrs form
addPostParam "mode" "preview"
byLabel "Title for this blog post" "Test"
byLabel "Handle for the URL" "test"
byLabel "Content" "Above fold.\n***\nBelow fold."
bodyContains "Above fold."
bodyContains "Below fold."
yit "posts blog post" $ do
loginAs AdminUser
get200 $ ProjectBlogR "snowdrift"
htmlNoneContain ".blog-post" "Above fold."
htmlNoneContain ".blog-post" "Below fold."
get200 blogRoute
[ form ] <- htmlQuery "form"
withStatus 303 True $ request $ do
addToken
setMethod "POST"
let route' = maybe (Left blogRoute) Right $ M.lookup "action" $ getAttrs form
either setUrl setUrl route'
addPostParam "mode" "post"
byLabel "Title for this blog post" "Test"
byLabel "Handle for the URL" "test"
byLabel "Content" "Above fold.\n***\nBelow fold."
Just route <- extractLocation
get200 $ decodeUtf8 route
htmlAnyContain ".blog-post-top" "Above fold."
htmlNoneContain ".blog-post-top" "Below fold."
get $ BlogPostR "snowdrift" "test"
htmlAnyContain ".blog-post" "Above fold."
htmlAnyContain ".blog-post" "Below fold."
get200 $ ProjectBlogR "snowdrift"
htmlAnyContain ".blog-post-top" "Above fold."
htmlNoneContain ".blog-post-top" "Below fold."
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module CommentTest (commentSpecs) where
import TestImport hiding (get)
import Control.Monad (when, unless)
import Data.Foldable (forM_)
import Data.Monoid ((<>))
import Data.Text (Text)
import Database.Esqueleto
import Yesod (RedirectUrl, Route)
import Yesod.Default.Config (AppConfig (..), DefaultEnv (..))
import Yesod.Markdown (unMarkdown)
import qualified Data.Text as Text
import PPrint
commentSpecs :: AppConfig DefaultEnv a -> Spec
commentSpecs conf = do
tagSpecs conf
ticketSpecs conf
tagSpecs :: AppConfig DefaultEnv a -> Spec
tagSpecs AppConfig {..} = ydescribe "tags" $
yit "'tags:' syntax" $ do
-- Test that 'tags:' adds tags when a comment is created.
---------------------------------------------------------
-- Add a few tags.
loginAs user
let tags_line = tagsLine tags_post_comment
postComment (enRoute NewWikiDiscussionR "about") $
byLabel "New Topic" $
"Testing the 'tags:' syntax.\n" <>
tags_line <> "\n" <>
"One more line, just in case."
(comment_id, True) <- getLatestCommentId
let comment_route =
render appRoot $ enRoute EditWikiCommentR "about" comment_id
-- Check that the added tags are present in the database.
errorUnlessUniqueTags comment_id tags_post_comment
-- Check that the "tags:" line is stripped from the contents.
comment_text <- getCommentText comment_id
errorWhenInfixOf tags_line comment_text
-- Test that 'tags:' adds tags when a comment is edited.
--------------------------------------------------------
-- Add more tags.
editComment comment_route $
comment_text <> "\n" <>
tagsLine tags_edit_comment
-- Check that new tags are added.
errorUnlessUniqueTags comment_id tags_edit_comment
-- Check that old tags are not removed.
errorUnlessUniqueTags comment_id tags_post_comment
-- Check that the "tags:" line is stripped from the contents.
getCommentText comment_id >>= errorWhenInfixOf tags_line
-- Test that editing a comment does not remove tags.
----------------------------------------------------
-- Edit a comment without changing anything.
editComment comment_route comment_text
-- Check that the tags are still there.
errorUnlessUniqueTags comment_id $ tags_post_comment <> tags_edit_comment
where
user = Mary
foo = "foo"
bar = "bar"
baz = "baz"
qux = "qux"
quux = "quux"
tagsLine tags = "tags: " <> Text.intercalate ", " tags
tags_post_comment = [foo, bar, baz]
-- Duplicates are added intentionally, so the tests could check
-- that they are removed.
tags_edit_comment = [bar, qux, foo, quux, quux]
errorUnlessUniqueTags comment_id tags = do
user_id <- userId user
forM_ tags $ \tag_name ->
testDB $ errorUnlessUniqueTag comment_id user_id tag_name
errorWhenInfixOf subt t =
when (subt `Text.isInfixOf` t) $
error $ Text.unpack $ subt <> " appears in " <> t
getCommentText comment_id = fmap unMarkdown $ testDB $
get comment_id >>=
maybe (error $ "comment " <> pprint comment_id <> " not found")
(return . commentText)
errorUnlessUniqueTag :: CommentId -> UserId -> Text -> SqlPersistM ()
errorUnlessUniqueTag comment_id user_id tag_name = do
mtag_id <- fmap (fmap entityKey) $ getBy $ UniqueTag tag_name
maybe (error $ "tag name " <> pprint tag_name <> " not found")
(\tag_id -> do
mcomment_tag <- getBy $ UniqueCommentTag comment_id tag_id user_id
maybe (error $ "comment tag with"
<> " comment id " <> pprint comment_id
<> ", tag id " <> pprint tag_id
<> ", and user id " <> pprint user_id
<> " not found")
(\comment_tag ->
when (commentTagCount (entityVal comment_tag) /= 1) $
error $ "tag name "
<> pprint tag_name
<> " not unique")
mcomment_tag)
mtag_id
ticketSpecs :: AppConfig DefaultEnv a -> Spec
ticketSpecs conf = ydescribe "ticket" $
yit "'ticket:' syntax" $ do
testTicket conf Mary
(enRoute NewWikiDiscussionR "about")
(enRoute ReplyWikiCommentR "about")
(enRoute EditWikiCommentR "about")
mary_id <- userId Mary
testTicket conf Mary
(NewUserDiscussionR mary_id)
(ReplyUserCommentR mary_id)
(EditUserCommentR mary_id)
testTicket conf Mary
(NewProjectDiscussionR "snowdrift")
(ReplyProjectCommentR "snowdrift")
(EditProjectCommentR "snowdrift")
-- Depends on the blog test from 'NotifyTest'.
testTicket conf Mary
(NewBlogPostDiscussionR "snowdrift" "testing")
(ReplyBlogPostCommentR "snowdrift" "testing")
(EditBlogPostCommentR "snowdrift" "testing")
testTicket
:: (RedirectUrl App url1, RedirectUrl App url2, Login user)
=> AppConfig DefaultEnv a
-> user -> url1 -> (CommentId -> url2) -> (CommentId -> Route App)
-> Example ()
testTicket AppConfig {..} user new_route reply_route edit_route = do
-- Ticket number is not changed when ticket is edited.
------------------------------------------------------
-- Create a ticket.
loginAs user
let new_ticket_line = "ticket: this is a new ticket"
postComment new_route $
byLabel "New Topic" $
"Testing the 'ticket:' syntax.\n" <>
new_ticket_line <> "\n" <>
"One more line, just in case."
(new_comment_id, True) <- getLatestCommentId
mnew_ticket <- testDB $ getBy $ UniqueTicket new_comment_id
when (mnew_ticket == Nothing) $ error "new ticket not found"
-- Reply to it.
let reply_ticket_line = "ticket: this is a replied ticket"
postComment (reply_route new_comment_id) $
byLabel "Reply" $ "Replying\n" <> reply_ticket_line
(reply_comment_id, True) <- getLatestCommentId
mreply_ticket <- testDB $ getBy $ UniqueTicket reply_comment_id
let comment_route = render appRoot $ edit_route reply_comment_id
-- Edit the reply.
let edit_ticket_line = "ticket: this is an edited ticket"
editComment comment_route edit_ticket_line
medit_ticket <- testDB $ getBy $ UniqueTicket reply_comment_id
case (mreply_ticket, medit_ticket) of
(Just (Entity reply_ticket_id _), Just (Entity edit_ticket_id _)) ->
when (reply_ticket_id /= edit_ticket_id) $ error "ticket id changed"
_ -> error "ticket not found"
-- Removing the 'ticket:' line removes the ticket from the DB.
--------------------------------------------------------------
editComment comment_route "no tickets here"
medit_ticket2 <- testDB $ getBy $ UniqueTicket reply_comment_id
unless (medit_ticket2 == Nothing) $ error "ticket not deleted"
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module DiscussionTest
( discussionSpecs
) where
import TestImport
import Import (key)
import Control.Monad
import Network.Wai.Test (SResponse (..))
import Yesod (RedirectUrl)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Map as M
import qualified Data.Text as T
import Model.Language
discussionSpecs :: Spec
discussionSpecs =
forM_ [minBound..maxBound] $ \case
DiscussionTypeWikiPage ->
runDiscussionTest
"wiki page"
(WikiDiscussionR "snowdrift" LangEn "about")
(WikiCommentR "snowdrift" LangEn "about")
(NewWikiDiscussionR "snowdrift" LangEn "about")
(ReplyWikiCommentR "snowdrift" LangEn "about")
(RethreadWikiCommentR "snowdrift" LangEn "about")
DiscussionTypeBlogPost ->
runDiscussionTest
"blog post"
(BlogPostDiscussionR "snowdrift" "test")
(BlogPostCommentR "snowdrift" "test")
(NewBlogPostDiscussionR "snowdrift" "test")
(ReplyBlogPostCommentR "snowdrift" "test")
(RethreadBlogPostCommentR "snowdrift" "test")
DiscussionTypeProject ->
runDiscussionTest
"project"
(ProjectDiscussionR "snowdrift")
(ProjectCommentR "snowdrift")
(NewProjectDiscussionR "snowdrift")
(ReplyProjectCommentR "snowdrift")
(RethreadProjectCommentR "snowdrift")
DiscussionTypeUser ->
runDiscussionTest
"user"
(UserDiscussionR user_id)
(UserCommentR user_id)
(NewUserDiscussionR user_id)
(ReplyUserCommentR user_id)
(RethreadUserCommentR user_id)
where user_id = key $ PersistInt64 1
runDiscussionTest :: (Show url, RedirectUrl App url)
=> String
-> url
-> (CommentId -> url)
-> url
-> (CommentId -> url)
-> (CommentId -> url)
-> Spec
runDiscussionTest
label
discussion_page_url
comment_url
new_thread_url
comment_reply_url
comment_rethread_url = do
ydescribe (unwords ["discussion on", label]) $ do
yit "loads the discussion page" $ do
loginAs TestUser
get200 discussion_page_url
let postReply i = do
(comment_id, approved) <- getLatestCommentId
unless approved
(error $ "comment not approved: " ++ show comment_id)
postComment
(comment_reply_url comment_id)
(byLabel
"Reply"
(T.pack ("Thread 1 - reply " ++ show (i :: Integer))))
return (i, comment_id)
yit "posts and moves some comments" $ do
loginAs TestUser
postComment new_thread_url
(byLabel "New Topic" "Thread 1 - root message")
comment_map <- fmap M.fromList $ forM [1..10] postReply
let reply_comment = comment_map M.! 4
get200 $ comment_rethread_url reply_comment
withStatus 303 True $ request $ do
addToken
setMethod "POST"
setUrl $ comment_rethread_url reply_comment
byLabel "New Parent Url" "/p/snowdrift/w/en/about/d"
byLabel "Reason" "testing"
addPostParam "mode" "post"
ydescribe (unwords ["discussion on", label, "- rethreading"]) $ do
let createComments = do
postComment new_thread_url $ byLabel "New Topic" "First message"
(first_message, True) <- getLatestCommentId
postComment new_thread_url $ byLabel "New Topic" "Second message"
(second_message, True) <- getLatestCommentId
return (first_message, second_message)
testRethread first_message second_message = do
get200 $ comment_rethread_url first_message
withStatus 303 True $ request $ do
addToken
setMethod "POST"
setUrl $ comment_rethread_url first_message
byLabel
"New Parent Url"
(T.pack
("/p/snowdrift/w/en/about/c/"
++ (\(PersistInt64 i) -> show i)
(toPersistValue second_message)))
byLabel "Reason" "testing"
addPostParam "mode" "post"
get200 $ comment_url second_message
bodyContains "First message"
bodyContains "Second message"
yit "can move newer comments under older" $ do
loginAs TestUser
(first_message, second_message) <- createComments
testRethread first_message second_message
yit "can move older comments under newer" $ do
loginAs TestUser
(first_message, second_message) <- createComments
testRethread second_message first_message
yit "can rethread across pages and the redirect still works" $ do
loginAs TestUser
postComment new_thread_url $ byLabel "New Topic" "posting on about page"
(originalId, True) <- getLatestCommentId
get200 $ comment_rethread_url originalId
withStatus 303 True $ request $ do
addToken
setMethod "POST"
setUrl $ comment_rethread_url originalId
byLabel "New Parent Url" "/p/snowdrift/w/en/intro/d"
byLabel "Reason" "testing cross-page rethreading"
addPostParam "mode" "post"
withStatus 301 True $ get $ comment_url originalId
Just location <- do
statusIsResp 301
withResponse ( \SResponse { simpleHeaders = h } ->
return $ lookup "Location" h
)
(newId, True) <- getLatestCommentId
let new_url = BSC.unpack location
desired_url =
"http://localhost:3000/c/"
++ (\(PersistInt64 i) -> show i) (toPersistValue newId)
assertEqual
("Redirect not matching! ("
++ show new_url
++ " /= "
++ show desired_url
++ ")")
new_url
desired_url
This diff is collapsed.
......@@ -4,7 +4,6 @@ module TestHandler where
import Import
import Control.Concurrent.STM
import Network.Wai.Logger
import System.Log.FastLogger
import Yesod.Core.Types
......@@ -12,12 +11,11 @@ import Yesod.Default.Config
testHandler :: Handler a -> IO (Either ErrorResponse a)
testHandler handler = do
events <- atomically newTChan :: IO (TChan SnowdriftEvent)
logger_set <- System.Log.FastLogger.newStderrLoggerSet 4096
let extra = Extra "copyright" "sourcerepo" (Just "ghrepo") "siteproject" Nothing
config = AppConfig Development 3000 "http://localhost:3000" (error "HostPreferences") extra
app = App (return ()) config (error "StaticSettings") (error "PersistConfigPool") (error "Manager") (error "PersistConf") (error "Logger") events (const [])
app = App (return ()) config (error "StaticSettings") (error "PersistConfigPool") (error "Manager") (error "PersistConf") (error "Logger")
(date_getter, date_updater) <- Network.Wai.Logger.clockDateCacher
......
......@@ -49,14 +49,8 @@ import qualified Text.XML as XML
import Foundation as TestImport
import Model as TestImport
hiding (userNotificationContent, projectNotificationContent)
import Model.Currency (Milray (..))
import Model.Language
import Model.Notification
(UserNotificationType(..)
,UserNotificationDelivery(..)
,ProjectNotificationType(..)
,ProjectNotificationDelivery(..))
import TimedYesodTest as TestImport
......@@ -207,15 +201,6 @@ postComment route stmts = do
byLabel "Language" "en"
stmts
getLatestCommentId :: YesodExample App (CommentId, Bool)
getLatestCommentId = do
[ (Value comment_id, Value approved) ] <- testDB $ select $ from $ \comment -> do
orderBy [ desc $ comment ^. CommentId ]
limit 1
return (comment ^. CommentId, not_ $ isNothing $ comment ^. CommentApprovedTs)
return (comment_id, approved)
snowdrift :: Text
snowdrift = "snowdrift"
......@@ -247,58 +232,12 @@ errorUnlessExpected msg expected actual =
<> ": expected " <> show expected
<> ", but got " <> show actual
newWiki :: Text -> Language -> Text -> Text -> YesodExample App ()
newWiki project language page content = do
get200 $ NewWikiR project language page
withStatus 200 False $ request $ do
addToken
setUrl $ NewWikiR project language page
setMethod "POST"
byLabel "Page Content" content
addPostParam "mode" "preview"
withStatus 303 False $ request $ do
addToken
setUrl $ NewWikiR project language page
setMethod "POST"
byLabel "Page Content" content
addPostParam "mode" "post"
keyToInt64 :: PersistField a => a -> Int64
keyToInt64 k = let PersistInt64 i = toPersistValue k in i
shpack :: Show a => a -> Text
shpack = T.pack . show
editWiki :: Text -> Language -> Text -> Text -> Text -> YesodExample App ()
editWiki project language page content comment = do
get200 $ EditWikiR project language page
snowdrift_id <- snowdriftId
wiki_target <- testDB $ getByOrError $ UniqueWikiTarget snowdrift_id LangEn page
let page_id = wikiTargetPage $ entityVal wiki_target
wiki_last_edit <- testDB $ getByOrError $ UniqueWikiLastEdit page_id LangEn
let last_edit = entityVal wiki_last_edit
withStatus 200 False $ request $ do
addToken
setUrl $ WikiR project language page
setMethod "POST"
byLabel "Page Content" content
byLabel "Comment" comment
addPostParam "f1" $ shpack $ keyToInt64 $ wikiLastEditEdit last_edit
addPostParam "mode" "preview"
withStatus 303 False $ request $ do
addToken
setUrl $ WikiR project language page
setMethod "POST"
byLabel "Page Content" content
byLabel "Comment" comment
addPostParam "mode" "post"
addPostParam "f1" $ shpack $ keyToInt64 $ wikiLastEditEdit last_edit
establish :: UserId -> YesodExample App ()
establish user_id = do
get200 $ UserR user_id
......@@ -329,36 +268,6 @@ acceptHonorPledge =
setMethod "POST"
setUrl HonorPledgeR
-- Copied from 'Model.User' but without the constraint in the result.
deleteUserNotifPrefs :: UserId -> UserNotificationType -> SqlPersistM ()
deleteUserNotifPrefs user_id notif_type =
delete $ from $ \unp ->
where_ $ unp ^. UserNotificationPrefUser ==. val user_id
&&. unp ^. UserNotificationPrefType ==. val notif_type
-- Copied from 'Model.User' but without the constraint in the result.
deleteProjectNotifPrefs :: UserId -> ProjectId -> ProjectNotificationType
-> SqlPersistM ()
deleteProjectNotifPrefs user_id project_id notif_type =
delete $ from $ \pnp ->
where_ $ pnp ^. ProjectNotificationPrefUser ==. val user_id
&&. pnp ^. ProjectNotificationPrefProject ==. val project_id
&&. pnp ^. ProjectNotificationPrefType ==. val notif_type
-- Copied from 'Model.User' but without the constraint in the result.
updateUserNotifPrefs :: UserId -> UserNotificationType
-> UserNotificationDelivery -> SqlPersistM ()
updateUserNotifPrefs user_id notif_type notif_deliv = do
deleteUserNotifPrefs user_id notif_type
insert_ $ UserNotificationPref user_id notif_type notif_deliv
-- Copied from 'Model.User' but without the constraint in the result.
updateProjectNotifPrefs :: UserId -> ProjectId -> ProjectNotificationType
-> ProjectNotificationDelivery -> SqlPersistM ()
updateProjectNotifPrefs user_id project_id notif_type notif_deliv = do
deleteProjectNotifPrefs user_id project_id notif_type
insert_ $ ProjectNotificationPref user_id project_id notif_type notif_deliv
-- 'forkEventHandler' sleeps for one second in between
-- runs, so some tests will fail without this delay.
withDelay :: MonadIO m => m a -> m a
......@@ -461,20 +370,6 @@ changeWatchStatus route =
setMethod "POST"
setUrl route
newBlogPost :: Text -> YesodExample App ()
newBlogPost page = do
let route = NewBlogPostR snowdrift
get200 route
withStatus 303 False $ request $ do
addToken
setMethod "POST"
setUrl route
byLabel "Title for this blog post" "testing"
byLabel "Handle for the URL" page
byLabel "Content" "testing"
addPostParam "mode" "post"
loadFunds :: UserId -> Int -> Example ()
loadFunds user_id n = do
let route = UserBalanceR user_id
......
......@@ -7,26 +7,14 @@ module Main where
import Import
import TestImport
import Control.Exception (bracket)
import System.Directory (removeFile, getTemporaryDirectory)
import System.IO
import System.IO.Unsafe
import Test.Hspec (hspec, describe, it)
import Test.Hspec (hspec)
import Yesod.Default.Config
import qualified Data.Text as Text
import Application (makeFoundation)
import Model.Markdown
import TestHandler
-- All test modules
import BlogTest
import CommentTest
import DiscussionTest
import NotifyTest
import UserTest
import WikiTest
main :: IO ()
main = do
......@@ -34,29 +22,10 @@ main = do
{ csParseExtra = parseExtra
}
foundation <- makeFoundation conf
withTempFile $ spec foundation
spec foundation
withTempFile :: (FileName -> IO a) -> IO ()
withTempFile f = bracket
(do tmp <- getTemporaryDirectory; openTempFile tmp "emails")
(removeFile . fst)
(\(file, handle) -> do hClose handle; void $ f $ FileName $ Text.pack file)
spec :: App -> FileName -> IO ()
spec foundation file =
spec :: App -> IO ()
spec foundation =
hspec $ do
describe "fix links" $
it "works correctly on all examples" $ do
let mismatches = unsafePerformIO $ testHandler testFixLinks
case mismatches of
Right [] -> True
_ -> False
yesodSpec foundation $ do
let config = appSettings foundation
userSpecs
notifySpecs config file
wikiSpecs
blogSpecs
discussionSpecs
commentSpecs config
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment