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

Merge pull request #8 from Start9Labs/persistence

Browse Source 
Persistence
This commit is contained in:
Lucy C
2020-06-23 13:57:49 -06:00
committed by GitHub
parent fa354b3dae f3e344ed1e
commit 16a409c514
19 changed files with 352 additions and 32 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

4
README.md
View File

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

9
apps.yaml
View File

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

7
config/compatibility.json Normal file
View File

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

10
config/settings.yml
View File

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

8
hie.yaml Normal file
View File

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

4
package.yaml
View File

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

13
resources/apps/apps.yaml
View File

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

19
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, 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.

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

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

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

42
src/Handler/Apps.hs
View File

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

4
src/Lib/Semver.hs
View File

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

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 @Text . show
fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue
instance PersistFieldSql AppVersion where
sqlType _ = SqlString
------------------------------------------------------------------------------------------------------------------------
-- Semver AppVersionSpecification
------------------------------------------------------------------------------------------------------------------------

44
src/Model.hs Normal file
View File

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

58
src/Settings.hs
View File

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

2
stack.yaml
View File

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

45
test/Handler/AppSpec.hs
View File

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

41
test/TestImport.hs
View File

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