Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

finalize persistence ofapp download metrics

Browse Source
This commit is contained in:
Lucy Cifferello
2020-06-06 21:52:57 -06:00
parent fa354b3dae
commit 2fb72aeca4
10 changed files with 203 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
config/settings.yml
View File

@@ -32,3 +32,11 @@ app-compatibility-path: "_env:APP_COMPATIBILITY_CONFIG:/etc/start9/registry/comp
resources-path: "_env:RESOURCES_PATH:/var/www/html/resources"
ssl-path: "_env:SSL_PATH:/var/ssl"
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"

1
package.yaml
View File

@@ -38,6 +38,7 @@ dependencies:
- monad-loops
- persistent
- persistent-sqlite
- persistent-postgresql
- persistent-template
- process
- protolude

15
src/Application.hs
View File

@@ -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.

36
src/Database/Queries.hs Normal file
View File

@@ -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

13
src/Foundation.hs
View File

@@ -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

25
src/Handler/Apps.hs
View File

@@ -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

2
src/Lib/Semver.hs
View File

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

10
src/Lib/Types/Semver.hs
View File

@@ -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
------------------------------------------------------------------------------------------------------------------------

34
src/Model.hs Normal file
View File

@@ -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
|]

67
src/Settings.hs
View File

@@ -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"
@@ -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 {..}