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

Commit e079c94e authored by David L. L. Thomas's avatar David L. L. Thomas

Testing database restore

parent 008e9bc8
......@@ -17,12 +17,14 @@ import qualified Database.Persist
import qualified Database.Persist.Sql
import Network.HTTP.Conduit (newManager, def)
import Version
import Control.Monad.Logger (runLoggingT)
import Control.Monad.Logger (runLoggingT, runStderrLoggingT)
import Control.Monad.Trans.Resource
import System.IO (stdout)
import System.Directory
import System.Log.FastLogger (mkLogger)
import Database.Persist.Postgresql (pgConnStr, withPostgresqlConn)
import qualified Data.List as L
import Data.Text as T
import qualified Data.Text.IO as T
......@@ -58,6 +60,11 @@ import Handler.BuildFeed
import Widgets.Navbar
import Data.ByteString (ByteString)
import System.Posix.Env.ByteString
import Control.Monad.Reader
version :: (Text, Text)
version = $(mkVersion)
......@@ -66,6 +73,17 @@ version = $(mkVersion)
-- comments there for more details.
mkYesodDispatch "App" resourcesApp
-- probably not thread safe
withEnv :: (MonadIO m) => ByteString -> ByteString -> m a -> m a
withEnv k v action = do
original <- liftIO $ getEnv k
liftIO $ setEnv k v True
result <- action
liftIO $ maybe (unsetEnv k) (\ v' -> setEnv k v' True) original
return result
-- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database
......@@ -90,6 +108,19 @@ makeFoundation conf = do
logger <- mkLogger True stdout
let foundation = App navbar conf s p manager dbconf logger
case appEnv conf of
Testing -> do
(withEnv "PGDATABASE" "template1" $ applyEnv (persistConfig foundation)) >>= \ dbconf' -> do
let runDBNoTransaction (SqlPersistT r) = runReaderT r
runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runDBNoTransaction $ do
liftIO $ putStrLn "dropping database..."
rawExecute "DROP DATABASE IF EXISTS snowdrift_test;" []
liftIO $ putStrLn "creating database..."
rawExecute "CREATE DATABASE snowdrift_test WITH TEMPLATE snowdrift_test_template;" []
liftIO $ putStrLn "ready."
_ -> return ()
flip runLoggingT (messageLoggerSource foundation logger) $ runResourceT $ do
Database.Persist.runPool dbconf doMigration p
Database.Persist.Sql.runSqlPool migrateTriggers p
......
......@@ -57,8 +57,6 @@ widgetFileSettings = def
}
}
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
widgetFile = (if development then widgetFileReload
......
......@@ -156,6 +156,8 @@ library
, github < 0.8
, async < 2.1 && >= 2.0
, universe
, unix
, mtl
executable SnowdriftProcessPayments
......@@ -228,3 +230,5 @@ test-suite test
, network
, http-types
, wai-test
, unix
, mtl
{-# LANGUAGE OverloadedStrings #-}
module DiscussionTest
( discussionSpecs
) where
import TestImport
import qualified Data.List as L
discussionSpecs :: Spec
discussionSpecs =
ydescribe "discussion: rethreading" $ do
yit "loads the discussion page" $ do
login
get $ DiscussWikiR "snowdrift" "about"
statusIs 200
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module TestImport
( module Yesod.Test
, module Model
, module Foundation
, module Database.Persist
, runDB
, Spec
, Example
, needsLogin
, login
, liftIO
, extractLocation
) where
import Yesod (Yesod, RedirectUrl)
import Yesod.Test
import Database.Persist hiding (get)
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 (..))
import qualified Data.ByteString as B
import Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Foundation
import Model
type Spec = YesodSpec App
type Example = YesodExample App
runDB :: SqlPersistM a -> Example a
runDB query = do
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
urlPath = pack . maybe "" uriPath . parseURI . unpack
-- 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
statusIs 200
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 >>= liftIO . print
extractLocation :: YesodExample site (Maybe B.ByteString)
extractLocation = do
statusIs 303
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
liftIO $ putStrLn "Logging in..."
get $ urlPath $ testRoot `T.append` "/auth/login"
statusIs 200
liftIO $ putStrLn "Submitting login."
submitLogin "test" "test"
liftIO $ putStrLn "Logged in."
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Import
import TestImport
import Yesod.Default.Config
-- import Yesod.Test
import Test.Hspec (hspec)
import Application (makeFoundation)
import DiscussionTest
main :: IO ()
main = do
conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing)
{ csParseExtra = parseExtra
}
foundation <- makeFoundation conf
hspec $ do
yesodSpec foundation $ do
discussionSpecs
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment