We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

TestImport.hs 3.77 KB
Newer Older
David L. L. Thomas's avatar
David L. L. Thomas committed
1 2 3 4
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module TestImport
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
5
    ( runDB
David L. L. Thomas's avatar
David L. L. Thomas committed
6 7 8 9 10 11
    , Spec
    , Example
    , needsLogin
    , login
    , liftIO
    , extractLocation
12
    , statusIsResp
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
13
    , module TestImport
David L. L. Thomas's avatar
David L. L. Thomas committed
14 15 16
    ) where

import Yesod (Yesod, RedirectUrl)
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
17 18
import Yesod.Test as TestImport
import Database.Persist as TestImport hiding (get)
David L. L. Thomas's avatar
David L. L. Thomas committed
19 20 21 22 23 24
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool)
import Control.Monad.IO.Class (liftIO, MonadIO)

import Network.URI (URI (uriPath), parseURI)
import Network.HTTP.Types (StdMethod (..), renderStdMethod)
import Network.Wai.Test (SResponse (..))
25 26
import qualified Test.HUnit as HUnit
import qualified Network.HTTP.Types as H
David L. L. Thomas's avatar
David L. L. Thomas committed
27 28

import qualified Data.ByteString as B
29 30 31 32

import qualified Data.Text as T
import Data.Text (Text)

David L. L. Thomas's avatar
David L. L. Thomas committed
33
import Data.Text.Encoding (decodeUtf8)
David L. L. Thomas's avatar
Cleanup  
David L. L. Thomas committed
34 35
import Foundation as TestImport
import Model as TestImport
David L. L. Thomas's avatar
David L. L. Thomas committed
36

37 38
import Control.Monad (when)

David L. L. Thomas's avatar
David L. L. Thomas committed
39 40 41 42

type Spec = YesodSpec App
type Example = YesodExample App

43 44
testDB :: SqlPersistM a -> Example a
testDB query = do
David L. L. Thomas's avatar
David L. L. Thomas committed
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59
    pool <- fmap connPool getTestYesod
    liftIO $ runSqlPersistMPool query pool


-- Adjust as necessary to the url prefix in the Testing configuration
testRoot :: Text
testRoot = "http://localhost:3000/"

-- Force failure by swearing that black is white, and pigs can fly...
assertFailure :: String -> YesodExample site ()
assertFailure msg = assertEqual msg True False

-- Convert an absolute URL (eg extracted from responses) to just the path
-- for use in test requests.
urlPath :: Text -> Text
60
urlPath = T.pack . maybe "" uriPath . parseURI . T.unpack
David L. L. Thomas's avatar
David L. L. Thomas committed
61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76

-- Stages in login process, used below
firstRedirect :: (Yesod site, RedirectUrl site url) => StdMethod -> url -> YesodExample site (Maybe B.ByteString)
firstRedirect method url = do
    request $ do
        setMethod $ renderStdMethod method
        setUrl url

    extractLocation  -- We should get redirected to the login page

assertLoginPage :: Yesod site => Text -> YesodExample site ()
assertLoginPage loc = do
    assertEqual "correct login redirection location"
                (testRoot `T.append` "/auth/login") loc

    get $ urlPath loc
77
    statusIsResp 200
David L. L. Thomas's avatar
David L. L. Thomas committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
    bodyContains "Login"


submitLogin :: Yesod site => Text -> Text -> YesodExample site ()
submitLogin user pass = do
    -- Ideally we would extract this url from the login form on the current page
    request $ do
        setMethod "POST"
        setUrl $ urlPath testRoot `T.append` "auth/page/hashdb/login"
        addPostParam "username" user
        addPostParam "password" pass


extractLocation :: YesodExample site (Maybe B.ByteString)
extractLocation = do
93
    statusIsResp 302
David L. L. Thomas's avatar
David L. L. Thomas committed
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
    withResponse ( \ SResponse { simpleHeaders = h } ->
                        return $ lookup "Location" h
                 )

-- Check that accessing the url with the given method requires login, and
-- that it redirects us to what looks like the login page.
--
needsLogin :: (RedirectUrl site url, Yesod site) => StdMethod -> url -> YesodExample site ()
needsLogin method url = do
    mbloc <- firstRedirect method url
    maybe (assertFailure "Should have location header") (assertLoginPage . decodeUtf8) mbloc

-- Do a login (using hashdb auth).  This just attempts to go to the home
-- url, and follows through the login process.  It should probably be the
-- first thing in each "it" spec.
--
login :: (Yesod site) => YesodExample site ()
login = do
    get $ urlPath $ testRoot `T.append` "/auth/login"
    statusIs 200
    submitLogin "test" "test"

116 117 118 119 120 121 122 123

statusIsResp :: Int -> YesodExample site ()
statusIsResp number = withResponse $ \ SResponse { simpleStatus = s } -> do
  when (H.statusCode s /= number) printBody
  liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat
    [ "Expected status was ", show number
    , " but received status was ", show $ H.statusCode s
    ]
124