Merge pull request #8 from Start9Labs/persistence

Persistence

.gitignore

@@ -27,4 +27,4 @@ stack.yaml.lock
 agent_*
 agent.*
 version
-hie.yaml
+**/*.s9pk

README.md

@@ -37,6 +37,10 @@ As your code changes, your site will be automatically recompiled and redeployed
 - Follow github instructions to install for specific GHC version ie. `stack ./install.hs hie`
 - Install VSCode Haskell Language Server Extension
 
+To create `hie.yaml` if it does not exist:
+- gather executables by running `stack ide targets`
+- see [here](https://github.com/haskell/haskell-ide-engine#project-configuration) for file setup details
+
 ## Tests
 
 ```

apps.yaml

@@ -1,9 +0,0 @@
-bitcoind:
-  title: "Bitcoin Core"
-  description:
-    short: "A Bitcoin Full Node"
-    long: "The bitcoin full node implementation by Bitcoin Core."
-  version-info:
-    - version: 0.18.1
-      release-notes: "Some stuff"
-  icon-type: png

config/compatibility.json

@@ -0,0 +1,7 @@
+{
+    "0.1.0": "1.0.0",
+    "0.1.1": "1.0.0",
+    "0.1.2": "1.1.0",
+    "0.1.3": "1.1.0",
+    "0.1.4": "1.1.0"
+  }

config/settings.yml

@@ -31,4 +31,12 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
 app-compatibility-path: "_env:APP_COMPATIBILITY_CONFIG:/etc/start9/registry/compatibility.json"
 resources-path: "_env:RESOURCES_PATH:/var/www/html/resources" 
 ssl-path: "_env:SSL_PATH:/var/ssl"
-registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"
+registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"
+
+database:
+  database: "_env:PG_DATABASE:start9_registry"
+  poolsize: "_env:PG_POOL_SIZE:2"
+  user: "_env:PG_USER:user"
+  password: "_env:PG_PASSWORD:password"
+  host: "_env:PG_HOST:localhost"
+  port: "_env:PG_PORT:5432"

hie.yaml

@@ -0,0 +1,8 @@
+cradle:
+  stack:
+  - path: "./"
+    component: "start9-registry:lib"
+  - path: "./app"
+    component: "start9-registry:exe:start9-registry"
+  - path: "./test"
+    component: "start9-registry:test:start9-registry-test"

package.yaml

@@ -1,5 +1,5 @@
 name: start9-registry
-version: 0.0.0
+version: 0.1.0
 
 default-extensions:
 - NoImplicitPrelude
@@ -38,6 +38,7 @@ dependencies:
 - monad-loops
 - persistent
 - persistent-sqlite
+- persistent-postgresql
 - persistent-template
 - process
 - protolude
@@ -61,6 +62,7 @@ dependencies:
 - yesod-core >=1.6 && <1.7
 - yesod-static
 - yesod-persistent >= 1.6 && < 1.7
+- shakespeare >=2.0 && <2.1
 
 library:
   source-dirs: src

resources/apps/apps.yaml

@@ -6,4 +6,17 @@ bitcoind:
   version-info:
     - version: 0.18.1
       release-notes: "Some stuff"
+    - version: 0.18.2
+      release-notes: "Some more stuff"
+  icon-type: png
+cups:
+  title: "Cups Messenger"
+  description:
+    short: "P2P Encrypted messaging"
+    long: "Peer-to-peer encrypted messaging platform that operates over tor."
+  version-info:
+    - version: 0.2.1
+      release-notes: "Some stuff"
+    - version: 0.2.2
+      release-notes: "Some more stuff"
   icon-type: png

src/Application.hs

@@ -27,10 +27,11 @@ module Application
 
 import           Startlude
 
-import           Control.Monad.Logger                  (liftLoc)
+import           Control.Monad.Logger                  (liftLoc, runLoggingT)
 import           Data.Aeson
 import           Data.Default
 import           Data.IORef
+import           Database.Persist.Postgresql           (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration)
 import           Language.Haskell.TH.Syntax            (qLocation)
 import           Network.Wai
 import           Network.Wai.Handler.Warp              (Settings, defaultSettings, defaultShouldDisplayException,
@@ -55,9 +56,9 @@ import           Handler.Icons
 import           Handler.Version
 import           Lib.Ssl
 import           Settings
+import           Model
 import           System.Posix.Process
 
-
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
 -- comments there for more details.
@@ -84,13 +85,23 @@ makeFoundation appSettings = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation = AgentCtx {..}
+    let mkFoundation appConnPool = AgentCtx {..}
         -- The AgentCtx {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
+        tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation"
+        logFunc = messageLoggerSource tempFoundation appLogger
+
+    -- Create the database connection pool
+    pool <- flip runLoggingT logFunc $ createPostgresqlPool
+        (pgConnStr $ appDatabaseConf appSettings)
+        (pgPoolSize . appDatabaseConf $ appSettings)
+
+    -- Preform database migration using application logging settings
+    runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
 
     -- Return the foundation
-    return $ mkFoundation
+    return $ mkFoundation pool
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.

src/Database/Queries.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Database.Queries where
+
+import Startlude
+import Database.Persist.Sql
+import Model
+import Settings
+import Lib.Types.Semver
+
+fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp))
+fetchApp appId = selectFirst [SAppAppId ==. appId] [] 
+
+fetchAppVersion :: MonadIO m => AppVersion -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity Version))
+fetchAppVersion appVersion appId = selectFirst [VersionNumber ==. appVersion, VersionAppId ==. appId] [] 
+
+createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp))
+createApp appId StoreApp{..} = do
+    time <- liftIO getCurrentTime
+    insertUnique $ SApp
+        time
+        Nothing
+        storeAppTitle
+        appId
+        storeAppDescShort
+        storeAppDescLong
+        storeAppIconType
+    
+createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> ReaderT SqlBackend m (Maybe (Key Version))
+createAppVersion sId VersionInfo{..} = do
+    time <- liftIO getCurrentTime
+    insertUnique $ Version
+        time
+        Nothing
+        sId
+        versionInfoVersion
+        versionInfoReleaseNotes
+
+createMetric :: MonadIO m => Key SApp -> Key Version -> ReaderT SqlBackend m ()
+createMetric appId versionId = do
+    time <- liftIO $ getCurrentTime 
+    insert_ $ Metric
+        time
+        appId
+        versionId

src/Foundation.hs

@@ -19,6 +19,7 @@ import qualified Yesod.Core.Unsafe    as Unsafe
 
 import           Lib.Types.Semver
 import           Settings
+import           Yesod.Persist.Core
 
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -31,6 +32,7 @@ data AgentCtx = AgentCtx
     , appLogger            :: Logger
     , appWebServerThreadId :: IORef (Maybe ThreadId)
     , appCompatibilityMap  :: HM.HashMap AppVersion AppVersion
+    , appConnPool          :: ConnectionPool
     }
 
 setWebProcessThreadId :: ThreadId -> AgentCtx -> IO ()
@@ -85,6 +87,17 @@ instance Yesod AgentCtx where
     makeLogger :: AgentCtx -> IO Logger
     makeLogger = return . appLogger
 
+-- How to run database actions.
+instance YesodPersist AgentCtx where
+    type YesodPersistBackend AgentCtx = SqlBackend
+    runDB :: SqlPersistT Handler a -> Handler a
+    runDB action = runSqlPool action . appConnPool =<< getYesod
+
+instance YesodPersistRunner AgentCtx where
+    getDBRunner :: Handler (DBRunner AgentCtx, Handler ())
+    getDBRunner = defaultGetDBRunner appConnPool
+
+
 unsafeHandler :: AgentCtx -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
@@ -97,4 +110,4 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
 
 appLogFunc :: AgentCtx -> LogFunc
-appLogFunc = appLogger >>= flip messageLoggerSource
+appLogFunc = appLogger >>= flip messageLoggerSource

src/Handler/Apps.hs

@@ -19,6 +19,7 @@ import qualified GHC.Show             (Show (..))
 import           Network.HTTP.Types
 import           System.Directory
 import           Yesod.Core
+import           Yesod.Persist.Core
 
 import           Foundation
 import           Lib.Registry
@@ -26,6 +27,9 @@ import           Lib.Semver
 import           System.FilePath      ((<.>), (</>))
 import           System.Posix.Files   (fileSize, getFileStatus)
 import           Settings
+import           Database.Queries
+import qualified Data.HashMap.Strict as HM
+import           Database.Persist
 
 pureLog :: Show a => a -> Handler a
 pureLog = liftA2 (*>) ($logInfo . show) pure
@@ -50,26 +54,56 @@ getSysR e = do
 
 getAppR :: Extension "s9pk" -> Handler TypedContent
 getAppR e = do
-    appResourceDir <- (</> "apps" </> "apps.yaml") . resourcesDir . appSettings <$> getYesod
+    appResourceDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
     getApp appResourceDir e
 
 getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent
-getApp rootDir ext = do
+getApp rootDir ext@(Extension appId) = do
     specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
     spec <- case readMaybe specString of
         Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
         Just t  -> pure t
     appVersions <- liftIO $ getAvailableAppVersions rootDir ext
     putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions
+    -- this always returns the max version, not the one specified in query param, why?
     case getSpecifiedAppVersion spec appVersions of
         Nothing -> notFound
-        Just (RegisteredAppVersion (_, filePath)) -> do
+        Just (RegisteredAppVersion (appVersion, filePath)) -> do
             exists <- liftIO $ doesFileExist filePath
             if exists
                 then do
+                    let appId' = T.pack appId
+                    manifest <- liftIO $ getAppManifest rootDir
+                    (storeApp, versionInfo) <- case HM.lookup appId' $ unAppManifest manifest of
+                                Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text)
+                                Just sa -> do
+                                    -- look up at specfic version
+                                    vi <- case find ((appVersion ==) . versionInfoVersion) (storeAppVersionInfo sa) of
+                                            Nothing -> sendResponseStatus status400 ("App version not present in manifest" :: Text)
+                                            Just x -> pure x
+                                    pure (sa, vi)
+                    -- lazy load app at requested version if it does not yet exist to automatically transfer from using apps.yaml
+                    sa <- runDB $ fetchApp appId'
+                    (appKey, versionKey) <- case sa of
+                        Nothing -> do
+                            appKey' <- runDB $ createApp appId' storeApp >>= errOnNothing status500 "duplicate app created"
+                            versionKey' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing status500 "duplicate app version created"
+                            pure (appKey', versionKey')
+                        Just a -> do
+                            let appKey' = entityKey a
+                            existingVersion <- runDB $ fetchAppVersion appVersion appKey'
+                            case existingVersion of
+                                Nothing -> do
+                                    appVersion' <- runDB $ createAppVersion appKey' versionInfo >>= errOnNothing status500 "duplicate app version created"
+                                    pure (appKey', appVersion')
+                                Just v -> pure (appKey', entityKey v)
+                    runDB $ createMetric appKey versionKey
                     sz <- liftIO $ fileSize <$> getFileStatus filePath
                     addHeader "Content-Length" (show sz)
                     respondSource typePlain $ CB.sourceFile filePath .| awaitForever sendChunkBS
                 else notFound
 
-
+errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a 
+errOnNothing status res entity = case entity of
+    Nothing -> sendResponseStatus status res
+    Just a -> pure a

src/Lib/Semver.hs

@@ -43,6 +43,4 @@ instance HasAppVersion AppVersion where
 
 appVersionMax :: HasAppVersion a => [a] -> Maybe a
 appVersionMax [] = Nothing
-appVersionMax as = Just $ maximumBy (\a1 a2 -> version a1 `compare` version a2) as
+appVersionMax as = Just $ maximumBy (compare `on` version) as
-
-

src/Lib/Types/Semver.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Lib.Types.Semver where
 
 import           Startlude               hiding (break)
@@ -13,6 +15,7 @@ import           Data.Char               (isDigit)
 import           Data.String.Interpolate
 import           Data.Text
 import           Yesod.Core
+import           Database.Persist.Sql
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Semver AppVersion
@@ -58,6 +61,13 @@ instance FromJSONKey AppVersion where
         Nothing -> fail "invalid app version"
         Just x -> pure x
 
+instance PersistField AppVersion where
+    toPersistValue = toPersistValue @Text . show
+    fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue
+
+instance PersistFieldSql AppVersion where
+    sqlType _ = SqlString
+
 ------------------------------------------------------------------------------------------------------------------------
 -- Semver AppVersionSpecification
 ------------------------------------------------------------------------------------------------------------------------

src/Model.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+module Model where
+
+import Startlude
+import           Database.Persist.TH
+import           Lib.Types.Semver
+
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+SApp
+    createdAt UTCTime
+    updatedAt UTCTime Maybe
+    title Text
+    appId Text
+    descShort Text
+    descLong Text
+    iconType Text
+    UniqueAppId appId
+    deriving Eq
+    deriving Show
+
+Version
+    createdAt UTCTime
+    updatedAt UTCTime Maybe
+    appId SAppId
+    number AppVersion
+    releaseNotes Text
+    UniqueBin appId number
+    deriving Eq
+    deriving Show
+
+
+Metric
+    createdAt UTCTime
+    appId SAppId
+    version VersionId
+    deriving Eq
+    deriving Show
+|]

src/Settings.hs

@@ -10,23 +10,28 @@ module Settings where
 import           Startlude
 
 import qualified Control.Exception        as Exception
+import           Control.Monad.Fail               (fail)
 import           Data.Maybe
 import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Version          (showVersion)
 import           Data.FileEmbed           (embedFile)
 import           Data.Yaml                (decodeEither')
+import           Database.Persist.Postgresql (PostgresConf)
 import           Network.Wai.Handler.Warp (HostPreference)
 import           Yesod.Default.Config2    (applyEnvValue, configSettingsYml)
 import           Paths_start9_registry (version)
 import           Lib.Types.Semver
 import           System.FilePath ((</>))
+import qualified Data.HashMap.Strict as HM
+import Data.Yaml.Config
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
 data AppSettings = AppSettings
-    { appHost                   :: HostPreference
+    { appDatabaseConf           :: PostgresConf
+    , appHost                   :: HostPreference
     -- ^ Host/interface the server should bind to.
     , appPort                   :: Word16
     -- ^ Port to listen on
@@ -44,12 +49,13 @@ data AppSettings = AppSettings
     , registryHostname          :: Text
     , registryVersion           :: AppVersion
     , sslKeyLocation            :: FilePath
-    , sslCsrLocation :: FilePath
+    , sslCsrLocation            :: FilePath
-    , sslCertLocation :: FilePath
+    , sslCertLocation           :: FilePath
     }
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
+        appDatabaseConf           <- o .: "database"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
         appIpFromHeader           <- o .: "ip-from-header"
@@ -64,7 +70,7 @@ instance FromJSON AppSettings where
         let sslCsrLocation = sslPath </> "certificate.csr"
         let sslCertLocation = sslPath </> "certificate.pem"
         let registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version
-        
+
         return AppSettings { .. }
 
 -- | Raw bytes at compile time of @config/settings.yml@
@@ -82,3 +88,47 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Error   e        -> panic $ toS e
         Success settings -> settings
+
+getAppManifest :: FilePath -> IO AppManifest
+getAppManifest resourcesDir = do
+    let appFile = (</> "apps.yaml") resourcesDir
+    loadYamlSettings [appFile] [] useEnv
+
+type AppIdentifier = Text
+    
+data StoreApp = StoreApp 
+    { storeAppTitle :: Text
+    , storeAppDescShort :: Text
+    , storeAppDescLong :: Text
+    , storeAppVersionInfo :: NonEmpty VersionInfo
+    , storeAppIconType :: Text
+    } deriving (Show)
+
+newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier StoreApp}
+    deriving (Show)
+
+instance FromJSON AppManifest where
+    parseJSON = withObject "app details to seed" $ \o -> do
+        apps <- for (HM.toList o) $ \(appId', c) -> do
+            appId <- parseJSON $ String appId'
+            config <- parseJSON c
+            storeAppTitle <- config .: "title"
+            storeAppIconType <- config .: "icon-type"
+            storeAppDescShort <- config .: "description" >>= (.: "short")
+            storeAppDescLong <- config .: "description" >>= (.: "long")
+            storeAppVersionInfo <- config .: "version-info" >>= \case
+                [] -> fail "No Valid Version Info"
+                (x:xs) -> pure $ x :| xs
+            return $ (appId, StoreApp {..})
+        return $ AppManifest (HM.fromList apps)
+
+data VersionInfo = VersionInfo 
+    { versionInfoVersion :: AppVersion
+    , versionInfoReleaseNotes :: Text
+    } deriving (Eq, Ord, Show)
+
+instance FromJSON VersionInfo where
+    parseJSON = withObject "version info" $ \o -> do
+        versionInfoVersion <- o .: "version"
+        versionInfoReleaseNotes <- o .: "release-notes"
+        pure VersionInfo {..}

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-13.19
+resolver: lts-13.30
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

test/Handler/AppSpec.hs

@@ -3,14 +3,55 @@
 module Handler.AppSpec (spec) where
 
 import Startlude
+import Database.Persist.Sql
+import Data.Maybe
+
 import TestImport
+import Model
 
 spec :: Spec
-spec = describe "GET /apps" $
+spec = do
+    describe "GET /apps" $
         withApp $ it "returns list of apps" $ do
             request $ do
                 setMethod "GET"
                 setUrl ("/apps" :: Text)
             bodyContains "bitcoind"
             bodyContains "version: 0.18.1"
-            statusIs 200
+            statusIs 200
+    describe "GET /apps/:appId with unknown version spec for bitcoin" $
+        withApp $ it "fails to get unknown app" $ do
+            request $ do
+                setMethod "GET"
+                setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text)
+            statusIs 404
+    describe "GET /apps/:appId with unknown app" $
+        withApp $ it "fails to get an unregistered app" $ do
+            request $ do
+                setMethod "GET"
+                setUrl ("/apps/tempapp.s9pk?spec=0.0.1" :: Text)
+            statusIs 404
+    describe "GET /apps/:appId with existing version spec for bitcoin" $
+        withApp $ it "creates app and metric records" $ do
+            request $ do
+                setMethod "GET"
+                setUrl ("/apps/bitcoind.s9pk?spec=0.18.1" :: Text)
+            statusIs 200
+            apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] []
+            assertEq "app should exist" (length apps) 1
+            let app = fromJust $ head apps
+            metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
+            assertEq "metric should exist" (length metrics) 1
+    describe "GET /apps/:appId with existing version spec for cups" $
+        withApp $ it "creates app and metric records" $ do
+            request $ do
+                setMethod "GET"
+                setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text)
+            statusIs 200
+            apps <- runDBtest $ selectList [SAppAppId ==. "cups"] []
+            assertEq "app should exist" (length apps) 1
+            let app = fromJust $ head apps
+            metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
+            assertEq "metric should exist" (length metrics) 1
+            version <- runDBtest $ selectList [VersionAppId ==. entityKey app] []
+            assertEq "version should exist" (length version) 1

test/TestImport.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
 
 module TestImport
     ( module TestImport
@@ -12,6 +14,10 @@ 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
@@ -25,5 +31,38 @@ withApp = before $ do
         []
         useEnv
     foundation <- makeFoundation settings
+    wipeDB foundation
     logWare <- liftIO $ makeLogWare foundation
-    return (foundation, logWare)
+    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