registry/test/TestImport.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}

module TestImport
    ( module TestImport
    , module X
    ) where

import Startlude
import Application           (makeFoundation, makeLogWare)
import Foundation            as X
import Test.Hspec            as X
import Yesod.Default.Config2 (useEnv, loadYamlSettings)
import Yesod.Test            as X
import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
import Database.Persist.Sql
import Text.Shakespeare.Text (st)
import Yesod.Core
import qualified Data.Text as T

runHandler :: Handler a -> YesodExample AgentCtx a
runHandler handler = do
    app <- getTestYesod
    fakeHandlerGetLogger appLogger app handler

withApp :: SpecWith (TestApp AgentCtx) -> Spec
withApp = before $ do
    settings <- loadYamlSettings
        ["config/settings.yml"]
        []
        useEnv
    foundation <- makeFoundation settings
    wipeDB foundation
    logWare <- liftIO $ makeLogWare foundation
    return (foundation, logWare)

getTables :: DB [Text]
getTables = do
    tables <- rawSql [st|
        SELECT table_name
        FROM information_schema.tables
        WHERE table_schema = 'public'
        AND table_type = 'BASE TABLE';
    |] []

    return $ fmap unSingle tables

wipeDB :: AgentCtx -> IO ()
wipeDB app = runDBWithApp app $ do
    tables <- getTables
    sqlBackend <- ask

    let escapedTables = map (T.unpack . connEscapeName sqlBackend . DBName) tables
        query = "TRUNCATE TABLE " ++ (intercalate ", " escapedTables)
    rawExecute (T.pack query) []

runDBtest :: SqlPersistM a -> YesodExample AgentCtx a
runDBtest query = do
    app <- getTestYesod
    liftIO $ runDBWithApp app query

runDBWithApp :: AgentCtx -> SqlPersistM a -> IO a
runDBWithApp app query = runSqlPersistMPool query (appConnPool app)

-- A convenient synonym for database access functions
type DB a = forall (m :: * -> *).
    (MonadUnliftIO m) => ReaderT SqlBackend m a