From 2fb72aeca41c8f479dac0498e7c95c4b25f9d5c6 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello Date: Sat, 6 Jun 2020 21:52:57 -0600 Subject: [PATCH] finalize persistence ofapp download metrics --- config/settings.yml | 10 +++++- package.yaml | 1 + src/Application.hs | 15 ++++++--- src/Database/Queries.hs | 36 +++++++++++++++++++++ src/Foundation.hs | 15 ++++++++- src/Handler/Apps.hs | 27 +++++++++++++--- src/Lib/Semver.hs | 4 +-- src/Lib/Types/Semver.hs | 10 ++++++ src/Model.hs | 34 ++++++++++++++++++++ src/Settings.hs | 69 ++++++++++++++++++++++++++++++++++++++--- 10 files changed, 203 insertions(+), 18 deletions(-) create mode 100644 src/Database/Queries.hs create mode 100644 src/Model.hs diff --git a/config/settings.yml b/config/settings.yml index b56286a..926b295 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:" + password: "_env:PG_PASSWORD:" + host: "_env:PG_HOST:localhost" + port: "_env:PG_PORT:5432" \ No newline at end of file diff --git a/package.yaml b/package.yaml index 9f9fed6..f41deb9 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ dependencies: - monad-loops - persistent - persistent-sqlite +- persistent-postgresql - persistent-template - process - protolude diff --git a/src/Application.hs b/src/Application.hs index ffeca29..ff6ddec 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) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, @@ -57,7 +58,6 @@ import Lib.Ssl import Settings 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 +84,20 @@ 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) -- 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..fdf6c51 --- /dev/null +++ b/src/Database/Queries.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Database.Queries where + +import Startlude +import Lib.Types.Semver +import Database.Persist.Sql +import Model +import Settings + +fetchApp :: MonadIO m => AppIdentifier -> AppVersion -> ReaderT SqlBackend m (Maybe (Entity App)) +fetchApp appId appVersion = selectFirst [AppAppId ==. appId, AppSemver ==. appVersion] [] + +createApp :: MonadIO m => AppIdentifier -> AppSeed -> ReaderT SqlBackend m (Key App) +createApp appId AppSeed{..} = do + time <- liftIO $ getCurrentTime + insert $ App + time + Nothing + title + appId + descShort + descLong + semver + releaseNotes + iconType + +createMetric :: MonadIO m => Maybe (Key App) -> AppIdentifier -> ReaderT SqlBackend m (Key Metric) +createMetric appId event = do + time <- liftIO $ getCurrentTime + insert $ Metric + time + appId + event \ No newline at end of file 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..672eea8 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -19,6 +19,8 @@ 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 +28,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 @@ -54,7 +59,7 @@ getAppR e = do 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) @@ -63,13 +68,25 @@ getApp rootDir ext = do putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions 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 + ai <- runDB $ fetchApp appId' appVersion + _ <- case ai of + Nothing -> do + -- save the app if it does not yet exist in db at particular version (automatic eventual transfer from using app.yaml to db record) + rd <- resourcesDir . appSettings <$> getYesod + manifest <- liftIO $ getAppManifest rd + deets <- case HM.lookup appId' $ unAppManifest manifest of + Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text) + Just x -> pure x + appKey <- runDB $ createApp appId' deets + -- log app download + runDB $ createMetric (Just appKey) appId' + Just a -> runDB $ createMetric (Just $ entityKey a) appId' sz <- liftIO $ fileSize <$> getFileStatus filePath addHeader "Content-Length" (show sz) respondSource typePlain $ CB.sourceFile filePath .| awaitForever sendChunkBS - else notFound - - + else notFound \ No newline at end of file diff --git a/src/Lib/Semver.hs b/src/Lib/Semver.hs index 56b0ac0..0dd3e65 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 (\a1 a2 -> version a1 `compare` version a2) as \ No newline at end of file diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs index 4eea5a6..6aa59f5 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 @String . show + fromPersistValue = note "" . 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..2291369 --- /dev/null +++ b/src/Model.hs @@ -0,0 +1,34 @@ +{-# 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| +App + createdAt UTCTime + updatedAt UTCTime Maybe + title Text + appId Text + descShort Text + descLong Text + semver AppVersion + releaseNotes Text + iconType Text + deriving Eq + deriving Show + +Metric + createdAt UTCTime + appId AppId Maybe default=null + event Text + deriving Eq + deriving Show +|] diff --git a/src/Settings.hs b/src/Settings.hs index f6ad150..49188a7 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -16,17 +16,21 @@ 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 +48,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 +69,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 +87,59 @@ compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of Error e -> panic $ toS e Success settings -> settings + +getAppManifest :: FilePath -> IO AppManifest +getAppManifest resourcesDir = do + let appResourceDir = ( "apps" "apps.yaml") $ resourcesDir + loadYamlSettings [appResourceDir] [] useEnv + +type AppIdentifier = Text +data AppSeed = AppSeed + { title :: Text + , descShort :: Text + , descLong :: Text + , semver :: AppVersion + , releaseNotes :: Text + , iconType :: Text + } deriving (Show) + +newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier AppSeed} + 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 + title <- config .: "title" + iconType <- config .: "icon-type" + desc <- config .: "description" + ver <- config .: "version-info" + let descShort = short desc + let descLong = long desc + let semver = version' ver + let releaseNotes = notes ver + return $ (appId, AppSeed {..}) + return $ AppManifest (HM.fromList apps) + +data VersionInfo = VersionInfo + { version' :: AppVersion + , notes :: Text + } deriving (Show) + +instance FromJSON VersionInfo where + parseJSON = withObject "version info" $ \o -> do + version' <- o .: "version" + notes <- o .: "release-notes" + pure VersionInfo {..} + +data AppDescription = AppDescription + { short :: Text + , long :: Text + } deriving (Show) + +instance FromJSON AppDescription where + parseJSON = withObject "app desc" $ \o -> do + short <- o .: "short" + long <- o .: "long" + pure AppDescription {..} \ No newline at end of file