finalize persistence ofapp download metrics

config/settings.yml

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

package.yaml

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

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.

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

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
 

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

src/Lib/Semver.hs

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

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

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

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