1
1
mirror of https://github.com/aelve/guide.git synced 2024-11-30 20:31:17 +03:00
guide/tests/WebSpec.hs

690 lines
23 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
2016-08-24 18:05:27 +03:00
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE GADTs #-}
2016-08-21 14:32:52 +03:00
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module WebSpec (tests) where
import BasePrelude hiding (catch, bracket)
-- Monads
import Control.Monad.IO.Class
2016-08-24 18:05:27 +03:00
import Control.Monad.Loops
2016-08-21 14:32:52 +03:00
-- Concurrency
import qualified SlaveThread as Slave
2016-08-24 18:05:27 +03:00
-- Containers
import qualified Data.Set as Set
2016-08-21 14:32:52 +03:00
-- Text
import Data.Text.All (Text)
2016-08-23 16:03:54 +03:00
import qualified Data.Text.All as T
2016-08-21 14:32:52 +03:00
-- Files
import System.Directory
-- Testing
2016-09-01 01:25:46 +03:00
import Test.Hspec.WebDriver hiding (shouldHaveAttr, shouldHaveText, click)
import qualified Test.Hspec.WebDriver as WD
2016-08-21 14:32:52 +03:00
import Test.WebDriver.Commands.Wait
import Test.WebDriver.Exceptions
import qualified Test.Hspec.Expectations as Hspec
-- URLs
import Network.URI
-- Exceptions
import Control.Monad.Catch
-- Site
import qualified Guide
import Config (Config(..))
2016-08-24 18:05:27 +03:00
import Utils (ordNub)
2016-08-21 14:32:52 +03:00
-----------------------------------------------------------------------------
-- Tests
-----------------------------------------------------------------------------
tests :: IO ()
tests = run $ do
mainPageTests
categoryTests
2016-08-22 17:10:29 +03:00
markdownTests
2016-08-21 14:32:52 +03:00
mainPageTests :: Spec
mainPageTests = session "main page" $ using Firefox $ do
openGuide "/"
wd "is initially empty" $ do
2016-08-22 16:11:14 +03:00
checkPresent "#categories"
checkNotPresent "#categories > *"
2016-08-21 14:32:52 +03:00
wd "has a google-token" $ do
2016-09-01 01:25:46 +03:00
"meta[name=google-site-verification]" `shouldHaveAttr`
("content", "some-google-token")
2016-08-21 14:32:52 +03:00
wd "has a title" $ do
2016-09-01 01:25:46 +03:00
"h1" `shouldHaveText` "Aelve Guide: Haskell"
describe "subtitle" $ do
wd "is present" $ do
2016-09-01 01:25:46 +03:00
sub <- select ".subtitle"
fs <- fontSize sub; fs `shouldBeInRange` (15,17)
wd "has a discuss link" $ do
checkPresent ".subtitle a[href='http://discuss.link']"
describe "footer" $ do
2016-08-21 14:32:52 +03:00
wd "is present" $ do
2016-08-22 16:11:14 +03:00
checkPresent "#footer"
2016-08-21 14:32:52 +03:00
wd "isn't overflowing" $ do
setWindowSize (900, 500) -- the footer is about 800px wide
2016-09-01 01:25:46 +03:00
footer <- select "#footer"
(width, height) <- elemSize footer
2016-08-23 16:03:54 +03:00
width `shouldBeInRange` (750, 850)
height `shouldBeInRange` (60, 70)
2016-08-21 14:32:52 +03:00
-- and now it shall be overflowing
setWindowSize (700, 500)
2016-09-01 01:25:46 +03:00
waitUntil 2 (expect . inRange (90, 140) . snd =<< elemSize footer)
`catch` \(_::ExpectFailed) -> return ()
2016-09-01 01:25:46 +03:00
height2 <- snd <$> elemSize footer
height2 `shouldBeInRange` (90, 140)
2016-08-21 14:32:52 +03:00
categoryTests :: Spec
categoryTests = session "categories" $ using Firefox $ do
openGuide "/"
wd "add a new category" $ do
2016-08-22 18:09:46 +03:00
createCategory "Some category"
2016-08-22 16:11:14 +03:00
checkPresent ".category"
2016-08-21 14:32:52 +03:00
url <- getCurrentRelativeURL
2016-08-24 22:17:54 +03:00
(slug, _) <- parseCategoryURL (uriPath url)
slug `shouldBe` "some-category"
2016-08-21 14:32:52 +03:00
describe "created category" $ do
wd "has a link to the main page" $ do
2016-09-01 01:25:46 +03:00
titleLink <- select "h1 > a"
titleLink `shouldHaveText` "Aelve Guide: Haskell"
2016-08-22 16:11:14 +03:00
getBackAfterwards $ do
2016-09-01 01:25:46 +03:00
changesURL $ click titleLink
2016-08-22 16:11:14 +03:00
url <- getCurrentRelativeURL
uriPath url `shouldBe` "/haskell"
2016-08-21 14:32:52 +03:00
wd "has a subtitle" $ do
2016-08-22 16:11:14 +03:00
checkPresent ".subtitle"
2016-08-21 14:32:52 +03:00
wd "doesn't have an add-category field" $ do
2016-08-22 16:11:14 +03:00
checkNotPresent ".add-category"
2016-08-24 22:17:54 +03:00
wd "is present on the main page" $ do
catURL <- getCurrentURL
openGuidePage "/"
2016-09-01 01:25:46 +03:00
changesURL $ click (ByLinkText "Some category")
2016-08-24 22:17:54 +03:00
do u <- getCurrentURL
u `shouldBe` catURL
wd "is initially empty" $ do
checkPresent ".items"
checkNotPresent (".items" :// Not ".dummy")
2016-08-22 21:15:40 +03:00
describe "category properties" $ do
describe "title" $ do
wd "is present" $ do
2016-08-24 01:00:19 +03:00
e <- select categoryTitle; e `shouldHaveText` "Some category"
fs <- fontSize e; fs `shouldBeInRange` (20, 26)
2016-08-22 21:15:40 +03:00
wd "can be changed" $ do
form <- openCategoryEditForm
2016-08-24 18:05:27 +03:00
do inp <- select (form :// "input[name=title]")
2016-08-22 21:15:40 +03:00
clearInput inp
2016-08-24 22:17:54 +03:00
sendKeys ("Cat 1" <> _enter) inp
2016-09-01 01:25:46 +03:00
checkNotPresent (form :& Displayed)
categoryTitle `shouldHaveText` "Cat 1"
2016-08-24 22:17:54 +03:00
wd "changes page slug when changed" $ do
changesURL $ refresh
do (slug, _) <- parseCategoryURL . uriPath =<< getCurrentRelativeURL
slug `shouldBe` "cat-1"
form <- openCategoryEditForm
do inp <- select (form :// "input[name=title]")
clearInput inp
sendKeys ("Cat 2" <> _enter) inp
2016-09-01 01:25:46 +03:00
checkNotPresent (form :& Displayed)
2016-08-24 22:17:54 +03:00
changesURL $ refresh
do (slug, _) <- parseCategoryURL . uriPath =<< getCurrentRelativeURL
slug `shouldBe` "cat-2"
wd "is changed on the front page too" $ do
(_, id1) <- parseCategoryURL . uriPath =<< getCurrentRelativeURL
openGuidePage "/"
checkNotPresent (ByLinkText "Some category")
checkNotPresent (ByLinkText "Cat 1")
2016-09-01 01:25:46 +03:00
changesURL $ click (ByLinkText "Cat 2")
2016-08-24 22:17:54 +03:00
(slug2, id2) <- parseCategoryURL . uriPath =<< getCurrentRelativeURL
id1 `shouldBe` id2; slug2 `shouldBe` "cat-2"
2016-08-22 21:15:40 +03:00
describe "group" $ do
wd "is present" $ do
2016-09-01 01:25:46 +03:00
group_ <- select categoryGroup
group_ `shouldHaveText` "Miscellaneous"
fs <- fontSize group_; fs `shouldBeInRange` (12, 15)
2016-08-22 21:15:40 +03:00
wd "can be changed" $ do
form <- openCategoryEditForm
2016-08-24 18:05:27 +03:00
do inp <- select (form :// "input[name=group]")
2016-08-22 21:15:40 +03:00
clearInput inp
sendKeys ("Basics" <> _enter) inp
2016-09-01 01:25:46 +03:00
checkNotPresent (form :& Displayed)
categoryGroup `shouldHaveText` "Basics"
2016-08-24 22:17:54 +03:00
wd "is changed on the front page too" $ do
2016-08-28 15:00:35 +03:00
onAnotherPage "/" $ do
2016-08-24 22:17:54 +03:00
catLink <- select (ByLinkText "Cat 2")
groupHeader <- select ((".category-group" :<// catLink) :// "h2")
groupHeader `shouldHaveText` "Basics"
2016-08-28 15:00:35 +03:00
describe "status" $ do
wd "is “stub” by default" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
chosenOption <- select (form :// "select[name=status] option:checked")
chosenOption `shouldHaveText` "Stub"
2016-08-28 15:00:35 +03:00
onAnotherPage "/" $ do
2016-09-01 01:25:46 +03:00
ByLinkText "Cat 2" `shouldHaveAttr` ("class", "status-stub")
2016-08-28 15:00:35 +03:00
wd "can be changed" $ do
form <- openCategoryEditForm
sel <- select (form :// "select[name=status]")
opt <- select (sel :// HasText "Complete")
selectDropdown sel opt
2016-09-01 01:25:46 +03:00
click (form :// ".save")
2016-08-28 15:00:35 +03:00
onAnotherPage "/" $ do
2016-09-01 01:25:46 +03:00
ByLinkText "Cat 2" `shouldHaveAttr` ("class", "status-finished")
2016-08-30 16:55:06 +03:00
wd "create two items for further tests" $ do
createItem "some item"
createItem "another item"
describe "pros/cons enabled" $ do
wd "checkbox enabled by default" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
checkbox <- select (form :// "[name=pros-cons-enabled]")
shouldBeSelected checkbox
click (form :// ".cancel")
wd "section is shown in an item" $ do
mapM_ shouldBeDisplayed =<< selectAll ".item-traits"
wd "section isn't shown after unchecking the checkbox" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
click (form :// "[name=pros-cons-enabled]")
click (form :// ".save")
waitUntil 2 $
expect . not =<< anyM isDisplayed =<< selectAll ".item-traits"
wd "section is shown again after checking the checkbox" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
click (form :// "[name=pros-cons-enabled]")
click (form :// ".save")
waitUntil 2 $
expect =<< allM isDisplayed =<< selectAll ".item-traits"
2016-08-30 16:55:06 +03:00
describe "ecosystem enabled" $ do
wd "checkbox enabled by default" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
checkbox <- select (form :// "[name=ecosystem-enabled]")
shouldBeSelected checkbox
click (form :// ".cancel")
2016-08-30 16:55:06 +03:00
wd "section is shown in an item" $ do
mapM_ shouldBeDisplayed =<< selectAll ".item-ecosystem"
wd "section isn't shown after unchecking the checkbox" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
click (form :// "[name=ecosystem-enabled]")
click (form :// ".save")
2016-08-30 16:55:06 +03:00
waitUntil 2 $
expect . not =<< anyM isDisplayed =<< selectAll ".item-ecosystem"
wd "section is shown again after checking the checkbox" $ do
form <- openCategoryEditForm
2016-09-01 01:25:46 +03:00
click (form :// "[name=ecosystem-enabled]")
click (form :// ".save")
2016-08-30 16:55:06 +03:00
waitUntil 2 $
expect =<< allM isDisplayed =<< selectAll ".item-ecosystem"
2016-08-30 18:06:06 +03:00
describe "deleting a category" $ do
wd "dismissing the alert doesn't do anything" $ do
2016-09-01 01:25:46 +03:00
click (".category h2" :// ByLinkText "delete")
2016-08-30 18:06:06 +03:00
dismissAlert
catURL <- getCurrentURL
openGuidePage "/"
2016-09-01 01:25:46 +03:00
changesURL $ click (ByLinkText "Cat 2")
2016-08-30 18:06:06 +03:00
do u <- getCurrentURL
u `shouldBe` catURL
wd "accepting the alert deletes the category" $ do
catURL <- getCurrentURL
changesURL $ do
2016-09-01 01:25:46 +03:00
click (".category h2" :// ByLinkText "delete")
2016-08-30 18:06:06 +03:00
acceptAlert
url <- getCurrentRelativeURL
uriPath url `shouldBe` "/haskell"
checkNotPresent (ByLinkText "Cat 2")
openPage catURL
2016-09-01 01:25:46 +03:00
"body" `shouldHaveText` "Something went wrong"
-- Feed button works
-- Description editing works
2016-08-22 16:11:14 +03:00
2016-08-22 17:10:29 +03:00
markdownTests :: Spec
markdownTests = session "markdown" $ using Firefox $ do
openGuide "/"
describe "Markdown isn't allowed in category names" $ do
wd "when creating a category" $ do
2016-08-22 18:09:46 +03:00
createCategory "*foo*"
2016-09-01 01:25:46 +03:00
categoryTitle `shouldHaveText` "*foo*"
2016-08-22 17:10:29 +03:00
wd "when changing existing category's name" $ do
form <- openCategoryEditForm
2016-08-24 18:05:27 +03:00
do inp <- select (form :// "input[name=title]")
2016-08-22 17:10:29 +03:00
clearInput inp
sendKeys ("foo `bar`" <> _enter) inp
2016-09-01 01:25:46 +03:00
checkNotPresent (form :& Displayed)
categoryTitle `shouldHaveText` "foo `bar`"
2016-08-21 14:32:52 +03:00
-----------------------------------------------------------------------------
2016-08-22 18:09:46 +03:00
-- Helpers dealing with guide specifically
-----------------------------------------------------------------------------
2016-08-24 22:17:54 +03:00
parseCategoryURL :: String -> WD (String, String)
parseCategoryURL url = do
case T.stripPrefix "/haskell/" (T.toStrict url) of
Nothing -> expectationFailure $
printf "%s doesn't start with /haskell/" (show url)
Just u -> do
let (slug, catId) = T.breakOnEnd "-" u
slug `shouldSatisfy` ("not null", not . T.null)
T.last slug `shouldBe` '-'
return (T.toString (T.init slug), T.toString catId)
2016-08-22 18:09:46 +03:00
openGuide :: String -> SpecWith (WdTestSession ())
2016-08-24 18:05:27 +03:00
openGuide s = wd ("load " ++ s) (openGuidePage s)
openGuidePage :: String -> WD ()
2016-08-24 22:17:54 +03:00
openGuidePage s = changesURL $ openPage ("http://localhost:8080/haskell" ++ s)
2016-08-22 18:09:46 +03:00
2016-08-28 15:00:35 +03:00
onAnotherPage :: String -> WD a -> WD a
onAnotherPage s x = getBackAfterwards $ do
openGuidePage s
x
2016-08-22 18:09:46 +03:00
-- Assumes that the main page is open
createCategory :: Text -> WD ()
createCategory t =
changesURL $ sendKeys (t <> _enter) =<< select ".add-category"
-- Assumes that the category page is open
createItem :: Text -> WD Element
createItem t = do
let selectItems = selectAll ".item"
items <- selectItems
sendKeys (t <> _enter) =<< select ".add-item"
waitUntil 2 (expect . (\xs -> length xs > length items) =<< selectItems)
items2 <- selectItems
case items2 \\ items of
[] -> expectationFailure "an item wasn't created"
[x] -> return x
_ -> expectationFailure "more than one item was created"
categoryTitle :: Selector
categoryTitle = ByCSS ".category-title"
2016-08-23 16:03:54 +03:00
categoryGroup :: Selector
categoryGroup = ByCSS ".category .group"
openCategoryEditForm :: WD Element
openCategoryEditForm = do
2016-09-01 01:25:46 +03:00
click (".category h2" :// ByLinkText "edit")
select ".category-info form"
2016-08-22 18:09:46 +03:00
-----------------------------------------------------------------------------
-- Utilities for webdriver
2016-08-21 14:32:52 +03:00
-----------------------------------------------------------------------------
2016-09-01 01:25:46 +03:00
isAlive :: Element -> WD Bool
isAlive e = do
let handler ex@(FailedCommand t _)
| t `elem` [NoSuchElement, StaleElementReference] = return False
| otherwise = throw ex
(isEnabled e >> return True) `catch` handler
click :: CanSelect a => a -> WD ()
click s = WD.click =<< select s
shouldHaveAttr :: CanSelect a => a -> (Text, Text) -> WD ()
s `shouldHaveAttr` (a, txt) = do
e <- select s
e `WD.shouldHaveAttr` (a, txt)
shouldHaveText :: CanSelect a => a -> Text -> WD ()
s `shouldHaveText` txt = do
e <- select s
e `WD.shouldHaveText` txt
highlight :: Element -> WD ()
highlight e = do
html <- executeJS [JSArg e]
"arguments[0].style.border='thick solid #FF0000';\
\return arguments[0].outerHTML;"
liftIO $ putStrLn html
2016-08-28 15:00:35 +03:00
selectDropdown
:: Element -- ^ Dropdown
-> Element -- ^ Option to select
-> WD ()
selectDropdown sel opt = void
(executeJS [JSArg sel, JSArg opt]
"sel=arguments[0];opt=arguments[1];\
\for (var i=0;i<sel.options.length;i++)\
\{if (sel.options[i]==opt)\
\{sel.selectedIndex=i;break;}}" :: WD (Maybe ()))
2016-08-24 18:05:27 +03:00
getDescendants :: Element -> WD [Element]
getDescendants e = findElemsFrom e (ByXPath ".//*")
getChildren :: Element -> WD [Element]
getChildren e = findElemsFrom e (ByXPath "./*")
data ComplexSelector where
-- | Descendants (not including the element itself)
2016-08-24 18:05:27 +03:00
(://) :: (CanSelect a, CanSelect b) => a -> b -> ComplexSelector
-- | Children
(:/) :: (CanSelect a, CanSelect b) => a -> b -> ComplexSelector
-- | Parents
(:<//) :: (CanSelect a, CanSelect b) => a -> b -> ComplexSelector
-- | Direct parents
(:</) :: (CanSelect a, CanSelect b) => a -> b -> ComplexSelector
-- | And
(:&) :: (CanSelect a, CanSelect b) => a -> b -> ComplexSelector
-- | Or
(:|) :: (CanSelect a, CanSelect b) => a -> b -> ComplexSelector
-- | Not
Not :: CanSelect a => a -> ComplexSelector
2016-08-25 15:05:23 +03:00
-- | Elements with specific text
2016-08-28 15:00:35 +03:00
HasText :: Text -> ComplexSelector
2016-08-25 15:05:23 +03:00
-- | Elements that contain specific text
ContainsText :: Text -> ComplexSelector
-- | Only pick the first N selected elements
Take :: CanSelect a => Int -> a -> ComplexSelector
-- | Displayed element
Displayed :: ComplexSelector
2016-08-24 18:05:27 +03:00
deriving instance Show ComplexSelector
defSelectAll :: CanSelect a => a -> WD [Element]
defSelectAll s = filterElems s =<< findElems (ByXPath "//")
defFilterElems :: CanSelect a => a -> [Element] -> WD [Element]
defFilterElems s es = do
ss <- Set.fromList <$> selectAll s
return (filter (`Set.member` ss) es)
defAnyElem :: CanSelect a => a -> [Element] -> WD Bool
defAnyElem s es = do
ss <- Set.fromList <$> selectAll s
return (any (`Set.member` ss) es)
class Show a => CanSelect a where
selectAll :: a -> WD [Element]
2016-08-24 18:05:27 +03:00
selectAll = defSelectAll
filterElems :: a -> [Element] -> WD [Element]
filterElems = defFilterElems
anyElem :: a -> [Element] -> WD Bool
anyElem = defAnyElem
instance CanSelect Element where
2016-09-01 01:25:46 +03:00
-- We take care not to select an element if it's stale.
selectAll e = filterM isAlive [e]
filterElems s es = do
alive <- isAlive s
return $ if alive then filter (s ==) es else []
anyElem s es = do
alive <- isAlive s
return $ if alive then any (s ==) es else False
2016-08-24 18:05:27 +03:00
instance CanSelect Selector where
selectAll s = findElems s
2016-08-24 18:05:27 +03:00
instance (a ~ Text) => CanSelect a where
selectAll t = findElems (ByCSS t)
instance CanSelect ComplexSelector where
selectAll s = case s of
(a :// b) -> do
as <- selectAll a
ordNub.concat <$> mapM (filterElems b <=< getDescendants) as
(a :/ b) -> do
as <- selectAll a
ordNub.concat <$> mapM (filterElems b <=< getChildren) as
(a :<// b) -> filterM (anyElem b <=< getDescendants) =<< selectAll a
(a :</ b) -> filterM (anyElem b <=< getChildren) =<< selectAll a
(a :& b) -> do
filterElems b =<< selectAll a
(a :| b) -> do
as <- Set.fromList <$> selectAll a
bs <- Set.fromList <$> selectAll b
return (Set.toList (as `Set.union` bs))
2016-08-25 15:05:23 +03:00
Take n a -> take n <$> selectAll a
--
Not a -> defSelectAll (Not a)
2016-08-28 15:00:35 +03:00
HasText t -> defSelectAll (HasText t)
2016-08-25 15:05:23 +03:00
ContainsText t -> defSelectAll (ContainsText t)
Displayed -> defSelectAll Displayed
2016-08-24 18:05:27 +03:00
filterElems s es = case s of
Not a -> (es \\) <$> filterElems a es
2016-08-28 15:00:35 +03:00
HasText t -> filterM (fmap (== t) . getText) es
2016-08-25 15:05:23 +03:00
ContainsText t -> filterM (fmap (t `T.isInfixOf`) . getText) es
Displayed -> filterM isDisplayed es
2016-08-24 18:05:27 +03:00
_ -> defFilterElems s es
anyElem s es = case s of
Not a -> (== length es) . length <$> filterElems a es
2016-08-28 15:00:35 +03:00
HasText t -> anyM (fmap (== t) . getText) es
ContainsText t -> anyM (fmap (t `T.isInfixOf`) . getText) es
Displayed -> anyM isDisplayed es
2016-08-24 18:05:27 +03:00
_ -> defAnyElem s es
class ToSelector a where
toSelector :: a -> Selector
instance ToSelector Selector where
toSelector = id
instance ToSelector Text where
toSelector = ByCSS
-- | Ensure that the element is the only element matching the selector.
2016-08-24 18:05:27 +03:00
select :: CanSelect a => a -> WD Element
select x = do
2016-09-01 01:25:46 +03:00
-- True = found more than one element
-- False = found no elements
v <- liftIO $ newIORef False
let findOne = do
es <- selectAll x
case es of
[e] -> return e
[] -> do liftIO $ writeIORef v False
unexpected "select: no elements"
_ -> do liftIO $ writeIORef v True
unexpected "select: more than one element"
let handler = do
moreThanOne <- liftIO $ readIORef v
if moreThanOne
then expectationFailure $
printf "%s isn't unique on the page" (show x)
else expectationFailure $
printf "%s wasn't found on the page" (show x)
waitUntil 2 findOne `onTimeout` handler
-- | Select one of the elements matching the selector.
selectSome :: CanSelect a => a -> WD Element
selectSome x = do
es <- selectAll x
when (null es) $ expectationFailure $
printf "%s wasn't found on the page" (show x)
return (head es)
2016-08-23 16:03:54 +03:00
-- | @font-size@ of an element, in pixels
2016-09-01 01:25:46 +03:00
fontSize :: CanSelect a => a -> WD Double
fontSize s = do
e <- select s
2016-08-23 16:03:54 +03:00
mbProp <- cssProp e "font-size"
case mbProp of
2016-08-24 22:17:54 +03:00
Nothing -> expectationFailure $
printf "expected %s to have font-size" (show e)
2016-08-23 16:03:54 +03:00
Just fs -> case reads (T.toString fs) of
[(d, "px")] -> return d
2016-08-24 22:17:54 +03:00
_ -> expectationFailure $
printf "couldn't parse font-size of %s: %s" (show e) (show fs)
2016-08-23 16:03:54 +03:00
2016-08-22 16:11:14 +03:00
changesURL :: WD a -> WD a
changesURL x = do
url <- getCurrentURL
a <- x
waitUntil 2 (expect =<< ((/= url) <$> getCurrentURL))
2016-08-22 16:11:14 +03:00
return a
getBackAfterwards :: WD a -> WD a
getBackAfterwards x = do
url <- getCurrentURL
a <- x
openPage url
return a
2016-08-21 14:32:52 +03:00
_TODO :: MonadIO m => m ()
_TODO = error "test not implemented"
wd :: String -> WD a -> SpecWith (WdTestSession ())
wd x act = it x (runWD (void act))
2016-08-22 17:10:29 +03:00
_pause :: WD ()
_pause = do
liftIO $ putStr "press Enter to continue testing, or “q” to quit: "
x <- liftIO $ getLine
when (x == "q") $
expectationFailure "quit"
2016-08-21 14:32:52 +03:00
2016-08-24 18:05:27 +03:00
checkPresent :: CanSelect a => a -> WD ()
2016-08-24 22:17:54 +03:00
checkPresent x = void (select x)
checkPresentSome :: CanSelect a => a -> WD ()
checkPresentSome x = void (selectSome x)
2016-08-22 16:11:14 +03:00
2016-08-24 18:05:27 +03:00
checkNotPresent :: CanSelect a => a -> WD ()
2016-09-01 01:25:46 +03:00
checkNotPresent x = waitUntil 2 $ do
2016-08-22 16:11:14 +03:00
es <- selectAll x
2016-09-01 01:25:46 +03:00
when (not (null es)) $ unexpected $
2016-08-22 16:11:14 +03:00
printf "expected %s not to be present on the page" (show x)
2016-08-21 14:32:52 +03:00
getCurrentRelativeURL :: WD URI
getCurrentRelativeURL = do
url <- getCurrentURL
case parseURI url of
Nothing -> error ("couldn't parse as URL: " ++ url)
Just u -> do
maybe "" uriRegName (uriAuthority u) `shouldBe` "localhost"
return u
run :: Spec -> IO ()
run ts = do
let prepare = do
exold <- doesDirectoryExist "state-old"
when exold $ error "state-old exists"
ex <- doesDirectoryExist "state"
when ex $ renameDirectory "state" "state-old"
-- Start the server
--
-- Using 'Slave.fork' in 'Guide.mainWith' ensures that threads started
-- inside of 'mainWith' will be killed too when the thread dies.
tid <- Slave.fork $ Guide.mainWith Config {
_baseUrl = "/",
_googleToken = "some-google-token",
_adminPassword = "123",
_prerender = False,
_discussLink = Just "http://discuss.link" }
2016-08-21 14:32:52 +03:00
-- Using a delay so that “Spock is running on port 8080” would be
-- printed before the first test.
threadDelay 100000
return tid
let finalise tid = do
killThread tid
ex <- doesDirectoryExist "state"
when ex $ removeDirectoryRecursive "state"
exold <- doesDirectoryExist "state-old"
when exold $ renameDirectory "state-old" "state"
bracket prepare finalise $ \_ -> do
hspec ts
_site :: IO ()
_site = run $ do
session "_" $ using Firefox $ do
wd "_" $ do
openGuidePage "/"
_pause
2016-08-24 22:17:54 +03:00
expectationFailure :: MonadIO m => String -> m a
expectationFailure s = do
liftIO (Hspec.expectationFailure s)
undefined
2016-08-21 14:32:52 +03:00
shouldSatisfy :: (Show a, MonadIO m) => a -> (String, a -> Bool) -> m ()
shouldSatisfy a (s, p) = unless (p a) $
expectationFailure (printf "expected %s to %s" (show a) s)
2016-08-23 16:03:54 +03:00
shouldBeInRange :: (Show a, Ord a, MonadIO m) => a -> (a, a) -> m ()
shouldBeInRange a (x, y) =
shouldSatisfy a ("be in range " ++ show (x,y), \n -> n >= x && n <= y)
2016-09-01 01:25:46 +03:00
shouldHaveProp :: CanSelect a => a -> (Text, Text) -> WD ()
s `shouldHaveProp` (a, txt) = do
e <- select s
2016-08-23 16:03:54 +03:00
t <- cssProp e a
unless (Just txt == t) $ expectationFailure $
printf "expected property %s of %s to be %s, got %s"
a (show e) (show txt) (show t)
2016-09-01 01:25:46 +03:00
shouldBeSelected :: CanSelect a => a -> WD ()
shouldBeSelected s = do
e <- select s
x <- isSelected e
e `shouldSatisfy` ("be checked/selected", const x)
shouldBeDisplayed :: CanSelect a => a -> WD ()
shouldBeDisplayed s = do
e <- select s
x <- isDisplayed e
e `shouldSatisfy` ("be displayed", const x)
shouldBeHidden :: CanSelect a => a -> WD ()
shouldBeHidden s = do
e <- select s
x <- isDisplayed e
e `shouldSatisfy` ("be hidden", const (not x))
2016-08-21 14:32:52 +03:00
_backspace, _enter, _esc :: Text
(_backspace, _enter, _esc) = ("\xE003", "\xE007", "\xE00C")
_shift, _ctrl, _alt, _command :: Text
(_shift, _ctrl, _alt, _command) = ("\xE008", "\xE009", "\xE00A", "\xE03D")
{-
NULL \uE000
CANCEL \uE001
HELP \uE002
TAB \uE004
CLEAR \uE005
RETURN \uE006
PAUSE \uE00B
SPACE \uE00D
PAGE_UP \uE00E
PAGE_DOWN \uE00F
END \uE010
HOME \uE011
ARROW_LEFT \uE012
ARROW_UP \uE013
ARROW_RIGHT \uE014
ARROW_DOWN \uE015
INSERT \uE016
DELETE \uE017
F1 \uE031
F2 \uE032
F3 \uE033
F4 \uE034
F5 \uE035
F6 \uE036
F7 \uE037
F8 \uE038
F9 \uE039
F10 \uE03A
F11 \uE03B
F12 \uE03C
META \uE03D
ZENKAKU_HANKAKU \uE040
SEMICOLON \uE018
EQUALS \uE019
NUMPAD0 \uE01A
NUMPAD1 \uE01B
NUMPAD2 \uE01C
NUMPAD3 \uE01D
NUMPAD4 \uE01E
NUMPAD5 \uE01F
NUMPAD6 \uE020
NUMPAD7 \uE021
NUMPAD8 \uE022
NUMPAD9 \uE023
MULTIPLY \uE024
ADD \uE025
SEPARATOR \uE026
SUBTRACT \uE027
DECIMAL \uE028
DIVIDE \uE029
-}