diff --git a/.gitignore b/.gitignore index 9f3013b..e5150ad 100644 --- a/.gitignore +++ b/.gitignore @@ -27,4 +27,4 @@ stack.yaml.lock agent_* agent.* version -hie.yaml \ No newline at end of file +**/*.s9pk \ No newline at end of file diff --git a/README.md b/README.md index 6617d98..a05e085 100644 --- a/README.md +++ b/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 ``` diff --git a/apps.yaml b/apps.yaml deleted file mode 100644 index 645eadd..0000000 --- a/apps.yaml +++ /dev/null @@ -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 \ No newline at end of file diff --git a/config/compatibility.json b/config/compatibility.json new file mode 100644 index 0000000..af055e9 --- /dev/null +++ b/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" + } \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index b56286a..6780d74 100644 --- a/config/settings.yml +++ b/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" \ No newline at end of file +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" \ No newline at end of file diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..3e092b8 --- /dev/null +++ b/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" \ No newline at end of file diff --git a/package.yaml b/package.yaml index 9f9fed6..bfa756c 100644 --- a/package.yaml +++ b/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 diff --git a/resources/apps/apps.yaml b/resources/apps/apps.yaml index 645eadd..0023250 100644 --- a/resources/apps/apps.yaml +++ b/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 \ No newline at end of file diff --git a/resources/apps/bitcoind/0.18.1/bitcoind.s9pk b/resources/apps/bitcoind/0.18.1/bitcoind.s9pk deleted file mode 100644 index 07ac068..0000000 Binary files a/resources/apps/bitcoind/0.18.1/bitcoind.s9pk and /dev/null differ diff --git a/src/Application.hs b/src/Application.hs index ffeca29..ac27d77 100644 --- a/src/Application.hs +++ b/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. diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs new file mode 100644 index 0000000..d15d664 --- /dev/null +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 8709129..e468dcb 100644 --- a/src/Foundation.hs +++ b/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 \ No newline at end of file diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index d622b9e..2a111e4 100644 --- a/src/Handler/Apps.hs +++ b/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 \ No newline at end of file diff --git a/src/Lib/Semver.hs b/src/Lib/Semver.hs index 56b0ac0..e80f721 100644 --- a/src/Lib/Semver.hs +++ b/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 \ No newline at end of file diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs index 4eea5a6..a03c4c9 100644 --- a/src/Lib/Types/Semver.hs +++ b/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 ------------------------------------------------------------------------------------------------------------------------ diff --git a/src/Model.hs b/src/Model.hs new file mode 100644 index 0000000..98c2fae --- /dev/null +++ b/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 +|] diff --git a/src/Settings.hs b/src/Settings.hs index f6ad150..5dd489c 100644 --- a/src/Settings.hs +++ b/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 - , sslCertLocation :: FilePath + , sslCsrLocation :: 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 {..} diff --git a/stack.yaml b/stack.yaml index efd76a5..e13d38c 100644 --- a/stack.yaml +++ b/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. diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index 83ac4c7..b1b1b37 100644 --- a/test/Handler/AppSpec.hs +++ b/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 \ No newline at end of file + 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 \ No newline at end of file diff --git a/test/TestImport.hs b/test/TestImport.hs index d0b6752..c2f958d 100644 --- a/test/TestImport.hs +++ b/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) \ No newline at end of file + 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