User.hs

{-# LANGUAGE OverloadedStrings #-}
module Test.User where

import Control.Monad
import Control.Monad.Trans
import qualified Data.Text as T
import Data.Maybe
import Test.WebDriver
import Test.WebDriver.Commands.Wait
import System.Random

import DarcsDen.Settings (baseUrl)

createAccount :: String -> WD (String, String)
createAccount email = do
    openPage (baseUrl++"register")
    [name, password] <- replicateM 2 g8
    elems <- mapM (findElem.ById) ["name", "email", "password1", "password2", "security_question"]
    mapM_ (uncurry sendKeys) (zip (map T.pack [name, email, password, password, "darcs"]) elems)
    (findElem.ByCSS $ ".buttons > input[value=\"sign me up\"]") >>= click
    return $ (name, password)
  where
    g8 = liftIO $ replicateM 8 $ getStdRandom $ randomR ('a', 'z')

createOAuthAccount :: T.Text -> (String -> String -> WD ()) -> String -> String -> WD String
createOAuthAccount buttonSelector oAuthLogin user pass = do
    openPage (baseUrl ++ "register")
    (findElem.ByCSS $ buttonSelector) >>= click
    oAuthLogin user pass
    name <- liftIO $ replicateM 8 $ getStdRandom $ randomR ('a', 'z')
    (findElem.ById $ "name") >>= clearInput
    (findElem.ById $ "name") >>= sendKeys (T.pack name) 
    (findElem.ByCSS $ ".buttons > input[value=\"sign me up\"]") >>= click
    return name

syncOAuthAccount :: T.Text -> (String -> String -> WD ()) -> String -> String -> WD ()
syncOAuthAccount buttonSelector oAuthLogin user pass = do
    openPage (baseUrl ++ "settings")
    (findElem.ByCSS $ buttonSelector) >>= click
    oAuthLogin user pass

loginOAuthAccount :: T.Text -> Selector -> WD ()
loginOAuthAccount buttonSelector approveSelector = do
    (waitUntil 10 (findElem.ByCSS $ "li.login > a")) >>= click
    (waitUntil 10 (findElem.ByCSS $ buttonSelector)) >>= click
    na <- fmap ((==baseUrl).take (length baseUrl)) getCurrentURL
    unless na $ findElem approveSelector >>= click

getUser :: WD (Maybe String)
getUser = fmap (fmap (drop (length baseUrl).T.unpack)) (fmap listToMaybe (findElems.ByCSS $ "li.home > a") >>= maybe (return Nothing) (flip attr "href"))

logout :: WD ()
logout = (findElem.ByCSS $ "li.logout > a") >>= click