WebDriver doCommand customization

wdtest.hs

{-# LANGUAGE OverloadedStrings, FlexibleContexts, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, GeneralizedNewtypeDeriving #-}

import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Trans.Control (MonadBaseControl(..), StM)
import Control.Monad.Catch (MonadThrow, MonadCatch)
import Control.Exception.Base (fromException, SomeException(..))
import Control.Exception.Lifted (throwIO, catch)
import Control.Monad.IO.Class
import Control.Monad.Fix
import Control.Monad.Trans.State.Strict (StateT, get, put)
import Data.Aeson
import Data.Text (Text)
import Test.WebDriver
import Test.WebDriver.Class (WebDriver(..), Method)
import Test.WebDriver.Internal (mkRequest, sendHTTPRequest, getJSONResult)
import Test.WebDriver.Config (WebDriverConfig(..))
import Test.WebDriver.Session (WDSession, WDSessionState)
import Test.WebDriver.Commands.Wait
import Control.Concurrent
import System.Process

newtype MyWD a =  MyWD (WD a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadFix, WDSessionState)

instance MonadBase IO MyWD where
    liftBase = MyWD . liftBase

instance MonadBaseControl IO MyWD where
    type StM MyWD a = StM (StateT WDSession IO) a

    liftBaseWith f = MyWD . WD $
        liftBaseWith $ \runInBase -> f (\(MyWD (WD st)) -> runInBase $ st)

    restoreM = MyWD . restoreM

instance WebDriver MyWD where
    doCommand method path args = do
        result <- myDoCommand method path args
        case result of
           Left e -> case fromException e of
               Just (FailedCommand StaleElementReference _) ->
                   pause >> myDoCommand method path args >>= either throwIO return
               _ -> throwIO e
           Right yay -> return yay

myDoCommand :: (ToJSON a, FromJSON b) => Method -> Text -> a -> MyWD (Either SomeException b)
myDoCommand method path args =
    mkRequest method path args
    >>= sendHTTPRequest
    >>= either throwIO return
    >>= getJSONResult
    >>= return

myRunSession :: WebDriverConfig conf => conf -> MyWD a -> IO a
myRunSession conf (MyWD wd) = do
  sess <- mkSession conf
  caps <- mkCaps conf
  runWD sess $ createSession caps >> wd

main = myRunSession defaultConfig $ do
    openPage "http://localhost:8000"
    title <- getTitle
    expect (title == "3ml")
    setImplicitWait 5000
    smokeTests
    closeSession

pause = liftIO (threadDelay 1000000)

smokeTests = do
    -- Anonymous User

    -- View story
    sampleStories <- findElem (ById "storytiles") >>= \elt -> findElemsFrom elt (ByTag "a")
    click (head sampleStories)
    goHome
    -- Count sample story links
    -- Check menu items


    -- Teacher stuff

    -- Register new school account
    registerNewSchool "Monkey Test School" "Head Gorilla" "[email protected]" "gobananasagain" "gobananasagain"
    -- Activate account (call psql)
    activateNewRegistrations
    -- Log in as registered teacher
    login "[email protected]" "gobananasagain"
    -- Create student accounts
    createStudents
    -- Log out
    -- Register new teacher in same school
    -- Attempt login as new teacher (fail)
    -- Log in as original teacher
    -- Activate account and logout
    -- Log in as new teacher
    -- Create class and add students to it
    -- Find a story
    --    Search for something
    --    Enter browser
    --    Select stories
    --    Return to stories
    --    Create anthology from basket
    --    View anthologies
    --    Check count of stories in new anthology
    -- Log out

    logout

    -- Student stuff

    -- Log in
    -- Find a story
    -- Complete story
    -- View leaderboard

activateNewRegistrations = liftIO $ callCommand "psql my3ml -c \"UPDATE login SET active = true WHERE active = false AND user_type = 'SchoolAdmin'\""

goHome = findElem (ByLinkText "Home") >>= click


createStudents = do
    findElem (ByLinkText "Teacher") >>= click
    findElem (ById "add-students-button") >>= click
    newStudentsForm <- findElem (ByTag "form")
    newStudentsTextArea <- findElemFrom newStudentsForm (ByTag "textarea")
    sendKeys "Monkey 1, Monkey 2, Monkey 3, Monkey 4, Monkey 5, Gorilla 1, Gorilla 2" newStudentsTextArea
    submit newStudentsForm
    pause


registerNewSchool schoolName teacherName email password confirmPassword = do
    goHome
    findElem (ByLinkText "Sign up") >>= click
    regSchool <- findElem (ById "register-school")
    click regSchool
    regForm <- findElem (ByTag "form")
    [i1, i2, i3, i4, i5] <- findElemsFrom regForm (ByTag "input")
    sendKeys schoolName i1
    sendKeys teacherName i2
    sendKeys email i3
    sendKeys password i4
    sendKeys confirmPassword i5
    findElemFrom regForm (ByTag "button") >>= click


login name pass = do
    findElem (ByLinkText "Sign in") >>= click
    loginForm <- findElem (ByTag "form")
    [nameInput, passwordInput] <- findElemsFrom loginForm (ByTag "input")
    sendKeys name nameInput
    sendKeys pass passwordInput
    -- submit loginForm
    findElemFrom loginForm (ByTag "button") >>= click

logout = findElem (ByLinkText "Sign out") >>= click