Created
February 27, 2018 21:09
-
-
Save tekul/5f04086ed3fccde5785790f25ab8dcad to your computer and use it in GitHub Desktop.
WebDriver doCommand customization
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
| {-# 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" "hg@mt.zoo" "gobananasagain" "gobananasagain" | |
| -- Activate account (call psql) | |
| activateNewRegistrations | |
| -- Log in as registered teacher | |
| login "hg@mt.zoo" "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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment