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

removes compatibility dependency, filters apps/versions based off of user agent header

Browse Source
This commit is contained in:
Keagan McClelland
2020-09-21 17:45:23 -06:00
parent 4a8a0588b0
commit a192bce08c
15 changed files with 293 additions and 242 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

@@ -28,7 +28,6 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'") # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'")
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
app-compatibility-path: "_env:APP_COMPATIBILITY_CONFIG:/etc/start9/registry/compatibility.json"
resources-path: "_env:RESOURCES_PATH:/var/www/html/resources" resources-path: "_env:RESOURCES_PATH:/var/www/html/resources"
ssl-path: "_env:SSL_PATH:/var/ssl" ssl-path: "_env:SSL_PATH:/var/ssl"
registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com" registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"

37
package.yaml
View File

@@ -11,41 +11,29 @@ default-extensions:
- OverloadedStrings - OverloadedStrings
dependencies: dependencies:
- base >=4.9.1.0 && <5 - base >=4.12 && <5
- aeson >=1.4 && <1.5 - aeson
- attoparsec
- bytestring - bytestring
- casing - casing
- comonad
- conduit - conduit
- conduit-extra - conduit-extra
- data-default - data-default
- directory - directory
- dns
- either
- errors - errors
- extra - extra
- file-embed - file-embed
- fast-logger >=2.2 && <2.5 - fast-logger
- filepath - filepath
- http-client
- http-conduit
- http-types - http-types
- interpolate - interpolate
- jose-jwt
- lens - lens
- lens-aeson - monad-logger
- memory
- monad-logger >=0.3 && <0.4
- monad-loops
- persistent - persistent
- persistent-sqlite
- persistent-postgresql - persistent-postgresql
- persistent-template - persistent-template
- process - process
- protolude - protolude
- safe
- singletons
- split
- template-haskell - template-haskell
- text >=0.11 && <2.0 - text >=0.11 && <2.0
- time - time
@@ -54,16 +42,13 @@ dependencies:
- unix - unix
- wai - wai
- wai-cors - wai-cors
- wai-extra >=3.0 && <3.1 - wai-extra
- wai-logger >=2.2 && <2.4 - warp
- warp >=3.0 && <3.3
- warp-tls - warp-tls
- yaml >=0.11 && <0.12 - yaml
- yesod >=1.6 && <1.7 - yesod
- yesod-core >=1.6 && <1.7 - yesod-core
- yesod-static - yesod-persistent
- yesod-persistent >= 1.6 && < 1.7
- shakespeare >=2.0 && <2.1
library: library:
source-dirs: src source-dirs: src

4
src/Application.hs
View File

@@ -80,10 +80,6 @@ makeFoundation appSettings = do
appWebServerThreadId <- newEmptyMVar appWebServerThreadId <- newEmptyMVar
appShouldRestartWeb <- newMVar False appShouldRestartWeb <- newMVar False
appCompatibilityMap <- decode . toS <$> readFile (appCompatibilityPath appSettings) >>= \case
Nothing -> panic "invalid compatibility config"
Just x -> pure x
-- We need a log function to create a connection pool. We need a connection -- We need a log function to create a connection pool. We need a connection
-- pool to create our foundation. And we need our foundation to get a -- pool to create our foundation. And we need our foundation to get a
-- logging function. To get out of this loop, we initially create a -- logging function. To get out of this loop, we initially create a

49
src/Database/Queries.hs
View File

@@ -4,44 +4,35 @@
module Database.Queries where module Database.Queries where
import Startlude import Startlude
import Database.Persist.Sql import Database.Persist.Sql
import Model import Lib.Types.AppIndex
import Settings import Lib.Types.Semver
import Lib.Types.Semver import Model
fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp)) fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp))
fetchApp appId = selectFirst [SAppAppId ==. appId] [] fetchApp appId = selectFirst [SAppAppId ==. appId] []
fetchAppVersion :: MonadIO m => AppVersion -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity Version)) fetchAppVersion :: MonadIO m => AppVersion -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity Version))
fetchAppVersion appVersion appId = selectFirst [VersionNumber ==. appVersion, VersionAppId ==. appId] [] fetchAppVersion appVersion appId = selectFirst [VersionNumber ==. appVersion, VersionAppId ==. appId] []
createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp)) createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp))
createApp appId StoreApp{..} = do createApp appId StoreApp {..} = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
insertUnique $ SApp insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType
time
Nothing
storeAppTitle
appId
storeAppDescShort
storeAppDescLong
storeAppIconType
createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> ReaderT SqlBackend m (Maybe (Key Version)) createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> ReaderT SqlBackend m (Maybe (Key Version))
createAppVersion sId VersionInfo{..} = do createAppVersion sId VersionInfo {..} = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
insertUnique $ Version insertUnique $ Version time
time Nothing
Nothing sId
sId versionInfoVersion
versionInfoVersion versionInfoReleaseNotes
versionInfoReleaseNotes versionInfoOsRequired
versionInfoOsRecommended
createMetric :: MonadIO m => Key SApp -> Key Version -> ReaderT SqlBackend m () createMetric :: MonadIO m => Key SApp -> Key Version -> ReaderT SqlBackend m ()
createMetric appId versionId = do createMetric appId versionId = do
time <- liftIO $ getCurrentTime time <- liftIO $ getCurrentTime
insert_ $ Metric insert_ $ Metric time appId versionId
time
appId
versionId

3
src/Foundation.hs
View File

@@ -9,14 +9,12 @@ module Foundation where
import Startlude import Startlude
import Control.Monad.Logger ( LogSource ) import Control.Monad.Logger ( LogSource )
import qualified Data.HashMap.Strict as HM
import Database.Persist.Sql import Database.Persist.Sql
import Lib.Registry import Lib.Registry
import Yesod.Core import Yesod.Core
import Yesod.Core.Types ( Logger ) import Yesod.Core.Types ( Logger )
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
import Lib.Types.Semver
import Settings import Settings
import Yesod.Persist.Core import Yesod.Persist.Core
@@ -31,7 +29,6 @@ data RegistryCtx = RegistryCtx
, appLogger :: Logger , appLogger :: Logger
, appWebServerThreadId :: MVar (ThreadId, ThreadId) , appWebServerThreadId :: MVar (ThreadId, ThreadId)
, appShouldRestartWeb :: MVar Bool , appShouldRestartWeb :: MVar Bool
, appCompatibilityMap :: HM.HashMap AppVersion AppVersion
, appConnPool :: ConnectionPool , appConnPool :: ConnectionPool
} }

51
src/Handler/Apps.hs
View File

@@ -11,33 +11,38 @@ import Startlude
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import qualified Data.Attoparsec.ByteString.Char8
as Atto
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char import Data.Char
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import Database.Persist
import qualified GHC.Show ( Show(..) ) import qualified GHC.Show ( Show(..) )
import Network.HTTP.Types import Network.HTTP.Types
import System.Directory import System.Directory
import Yesod.Core
import Yesod.Persist.Core
import Foundation
import Lib.Registry
import Lib.Semver
import Lib.Types.Semver
import Lib.Types.FileSystem
import Lib.Error
import System.FilePath ( (<.>) import System.FilePath ( (<.>)
, (</>) , (</>)
) )
import System.Posix.Files ( fileSize import System.Posix.Files ( fileSize
, getFileStatus , getFileStatus
) )
import Yesod.Core
import Yesod.Persist.Core
import Foundation
import Lib.Registry
import Lib.Semver
import Lib.Types.AppIndex
import Lib.Types.Semver
import Lib.Types.FileSystem
import Lib.Error
import Settings import Settings
import Database.Queries import Database.Queries
import qualified Data.HashMap.Strict as HM import Network.Wai ( Request(requestHeaderUserAgent) )
import Database.Persist
pureLog :: Show a => a -> Handler a pureLog :: Show a => a -> Handler a
pureLog = liftA2 (*>) ($logInfo . show) pure pureLog = liftA2 (*>) ($logInfo . show) pure
@@ -50,10 +55,30 @@ instance Show FileExtension where
show (FileExtension f Nothing ) = f show (FileExtension f Nothing ) = f
show (FileExtension f (Just e)) = f <.> e show (FileExtension f (Just e)) = f <.> e
userAgentOsVersionParser :: Atto.Parser AppVersion
userAgentOsVersionParser = do
void $ (Atto.string "AmbassadorOS" <|> Atto.string "EmbassyOS") *> Atto.char '/'
semverParserBS
getEmbassyOsVersion :: Handler (Maybe AppVersion)
getEmbassyOsVersion = userAgentOsVersion
where
userAgentOsVersion = (hush . Atto.parseOnly userAgentOsVersionParser <=< requestHeaderUserAgent) <$> waiRequest
getAppsManifestR :: Handler TypedContent getAppsManifestR :: Handler TypedContent
getAppsManifestR = do getAppsManifestR = do
appResourceDir <- (</> "apps" </> "apps.yaml") . resourcesDir . appSettings <$> getYesod osVersion <- getEmbassyOsVersion
respondSource typePlain $ CB.sourceFile appResourceDir .| awaitForever sendChunkBS appResourceFile <- (</> "apps" </> "apps.yaml") . resourcesDir . appSettings <$> getYesod
manifest@AppManifest { unAppManifest } <- liftIO (Yaml.decodeFileEither appResourceFile) >>= \case
Left e -> do
$logError "COULD NOT PARSE APP INDEX! CORRECT IMMEDIATELY!"
$logError (show e)
sendResponseStatus status500 ("Internal Server Error" :: Text)
Right a -> pure a
let pruned = case osVersion of
Nothing -> manifest
Just av -> AppManifest $ HM.mapMaybe (filterOsRecommended av) unAppManifest
pure $ TypedContent "application/x-yaml" (toContent $ Yaml.encode pruned)
getSysR :: Extension "" -> Handler TypedContent getSysR :: Extension "" -> Handler TypedContent
getSysR e = do getSysR e = do

29
src/Handler/Version.hs
View File

@@ -10,9 +10,7 @@ import Startlude
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Char import Data.Char
import qualified Data.HashMap.Strict as HM import qualified Data.Text as T
import Data.String.Interpolate.IsString
import qualified Data.Text as T
import Network.HTTP.Types import Network.HTTP.Types
import Yesod.Core import Yesod.Core
@@ -22,7 +20,7 @@ import Lib.Registry
import Lib.Semver import Lib.Semver
import Lib.Types.Semver import Lib.Types.Semver
import Settings import Settings
import System.FilePath ((</>)) import System.FilePath ( (</>) )
getVersionR :: Handler AppVersionRes getVersionR :: Handler AppVersionRes
getVersionR = do getVersionR = do
@@ -33,34 +31,21 @@ getVersionAppR :: Text -> Handler (Maybe AppVersionRes)
getVersionAppR appId = do getVersionAppR appId = do
appsDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod appsDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
getVersionWSpec appsDir appExt getVersionWSpec appsDir appExt
where where appExt = Extension (toS appId) :: Extension "s9pk"
appExt = Extension (toS appId) :: Extension "s9pk"
getVersionSysR :: Text -> Handler (Maybe AppVersionRes) getVersionSysR :: Text -> Handler (Maybe AppVersionRes)
getVersionSysR sysAppId = runMaybeT $ do getVersionSysR sysAppId = runMaybeT $ do
sysDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod sysDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
avr <- MaybeT $ getVersionWSpec sysDir sysExt avr <- MaybeT $ getVersionWSpec sysDir sysExt
minComp <- lift $ case sysAppId of pure $ avr { appVersionMinCompanion = Just $ AppVersion (1, 1, 0, 0) }
"agent" -> Just <$> meshCompanionCompatibility (appVersionVersion avr) where sysExt = Extension (toS sysAppId) :: Extension ""
_ -> pure Nothing
pure $ avr { appVersionMinCompanion = minComp }
where
sysExt = Extension (toS sysAppId) :: Extension ""
getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes) getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes)
getVersionWSpec rootDir ext = do getVersionWSpec rootDir ext = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
spec <- case readMaybe specString of spec <- case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t Just t -> pure t
appVersions <- liftIO $ getAvailableAppVersions rootDir ext appVersions <- liftIO $ getAvailableAppVersions rootDir ext
let av = version <$> getSpecifiedAppVersion spec appVersions let av = version <$> getSpecifiedAppVersion spec appVersions
pure $ liftA2 AppVersionRes av (pure Nothing) pure $ liftA2 AppVersionRes av (pure Nothing)
meshCompanionCompatibility :: AppVersion -> Handler AppVersion
meshCompanionCompatibility av = getsYesod appCompatibilityMap >>= \hm ->
case HM.lookup av hm of
Nothing -> do
$logError [i|MESH DEPLOYMENT "#{av}" HAS NO COMPATIBILITY ENTRY! FIX IMMEDIATELY|]
sendResponseStatus status500 ("Internal Server Error" :: Text)
Just x -> pure x

22
src/Lib/Error.hs
View File

@@ -8,7 +8,8 @@ import Yesod.Core
type S9ErrT m = ExceptT S9Error m type S9ErrT m = ExceptT S9Error m
data S9Error = PersistentE Text deriving (Show, Eq) data S9Error = PersistentE Text
deriving (Show, Eq)
instance Exception S9Error instance Exception S9Error
@@ -17,8 +18,7 @@ toError :: S9Error -> Error
toError = \case toError = \case
PersistentE t -> Error DATABASE_ERROR t PersistentE t -> Error DATABASE_ERROR t
data ErrorCode = data ErrorCode = DATABASE_ERROR
DATABASE_ERROR
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON ErrorCode where instance ToJSON ErrorCode where
toJSON = String . show toJSON = String . show
@@ -26,12 +26,10 @@ instance ToJSON ErrorCode where
data Error = Error data Error = Error
{ errorCode :: ErrorCode { errorCode :: ErrorCode
, errorMessage :: Text , errorMessage :: Text
} deriving (Eq, Show) }
deriving (Eq, Show)
instance ToJSON Error where instance ToJSON Error where
toJSON Error{..} = object toJSON Error {..} = object ["code" .= errorCode, "message" .= errorMessage]
[ "code" .= errorCode
, "message" .= errorMessage
]
instance ToContent Error where instance ToContent Error where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent Error where instance ToTypedContent Error where
@@ -48,15 +46,15 @@ toStatus = \case
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
handleS9ErrT action = runExceptT action >>= \case handleS9ErrT action = runExceptT action >>= \case
Left e -> toStatus >>= sendResponseStatus $ e Left e -> toStatus >>= sendResponseStatus $ e
Right a -> pure a Right a -> pure a
handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
handleS9ErrNuclear action = runExceptT action >>= \case handleS9ErrNuclear action = runExceptT action >>= \case
Left e -> throwIO e Left e -> throwIO e
Right a -> pure a Right a -> pure a
errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a
errOnNothing status res entity = case entity of errOnNothing status res entity = case entity of
Nothing -> sendResponseStatus status res Nothing -> sendResponseStatus status res
Just a -> pure a Just a -> pure a

30
src/Lib/Semver.hs
View File

@@ -4,21 +4,17 @@ import Startlude
import Lib.Types.Semver import Lib.Types.Semver
(<||) :: HasAppVersion a => a -> AppVersionSpecification -> Bool (<||) :: HasAppVersion a => a -> AppVersionSpec -> Bool
(<||) _ AppVersionAny = True (<||) _ AppVersionAny = True
(<||) a (AppVersionSpecification SVEquals av1) = version a == av1 (<||) a (AppVersionSpec SVEquals av1) = version a == av1
(<||) a (AppVersionSpecification SVLessThan av1) = version a < av1 (<||) a (AppVersionSpec SVLessThan av1) = version a < av1
(<||) a (AppVersionSpecification SVGreaterThan av1) = version a > av1 (<||) a (AppVersionSpec SVGreaterThan av1) = version a > av1
(<||) a (AppVersionSpecification SVLessThanEq av1) = version a <= av1 (<||) a (AppVersionSpec SVLessThanEq av1) = version a <= av1
(<||) a (AppVersionSpecification SVGreaterThanEq av1) = version a >= av1 (<||) a (AppVersionSpec SVGreaterThanEq av1) = version a >= av1
(<||) a (AppVersionSpecification SVGreatestWithMajor av1) -- "maj.*" (<||) a (AppVersionSpec SVGreatestWithMajor av1) = major av == major av1 && av >= av1 -- "maj.*"
= major av == major av1 && av >= av1 where av = version a
where (<||) a (AppVersionSpec SVGreatestWithMajorMinor av1) = major av == major av1 && minor av == minor av1 && av >= av1 -- "maj.min.*"
av = version a where av = version a
(<||) a (AppVersionSpecification SVGreatestWithMajorMinor av1) -- "maj.min.*"
= major av == major av1 && minor av == minor av1 && av >= av1
where
av = version a
major :: AppVersion -> Word16 major :: AppVersion -> Word16
major (AppVersion (a, _, _, _)) = a major (AppVersion (a, _, _, _)) = a
@@ -32,7 +28,7 @@ build (AppVersion (_, _, _, a)) = a
hasGiven :: (AppVersion -> Word16) -> AppVersion -> AppVersion -> Bool hasGiven :: (AppVersion -> Word16) -> AppVersion -> AppVersion -> Bool
hasGiven projection av = (== projection av) . projection hasGiven projection av = (== projection av) . projection
getSpecifiedAppVersion :: HasAppVersion a => AppVersionSpecification -> [a] -> Maybe a getSpecifiedAppVersion :: HasAppVersion a => AppVersionSpec -> [a] -> Maybe a
getSpecifiedAppVersion avSpec = appVersionMax . filter (<|| avSpec) getSpecifiedAppVersion avSpec = appVersionMax . filter (<|| avSpec)
class HasAppVersion a where class HasAppVersion a where
@@ -43,4 +39,4 @@ instance HasAppVersion AppVersion where
appVersionMax :: HasAppVersion a => [a] -> Maybe a appVersionMax :: HasAppVersion a => [a] -> Maybe a
appVersionMax [] = Nothing appVersionMax [] = Nothing
appVersionMax as = Just $ maximumBy (compare `on` version) as appVersionMax as = Just $ maximumBy (compare `on` version) as

90
src/Lib/Types/AppIndex.hs Normal file
View File

@@ -0,0 +1,90 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Lib.Types.AppIndex where
import Startlude
import Control.Monad.Fail
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.List.NonEmpty as NE
import Lib.Semver
import Lib.Types.Semver
type AppIdentifier = Text
data VersionInfo = VersionInfo
{ versionInfoVersion :: AppVersion
, versionInfoReleaseNotes :: Text
, versionInfoOsRequired :: AppVersionSpec
, versionInfoOsRecommended :: AppVersionSpec
}
deriving (Eq, Show)
instance Ord VersionInfo where
compare = compare `on` versionInfoVersion
instance FromJSON VersionInfo where
parseJSON = withObject "version info" $ \o -> do
versionInfoVersion <- o .: "version"
versionInfoReleaseNotes <- o .: "release-notes"
versionInfoOsRequired <- o .:? "os-version-required" .!= AppVersionAny
versionInfoOsRecommended <- o .:? "os-version-recommended" .!= AppVersionAny
pure VersionInfo { .. }
instance ToJSON VersionInfo where
toJSON VersionInfo {..} = object
[ "version" .= versionInfoVersion
, "release-notes" .= versionInfoReleaseNotes
, "os-version-required" .= versionInfoOsRequired
, "os-version-recommended" .= versionInfoOsRecommended
]
data StoreApp = StoreApp
{ storeAppTitle :: Text
, storeAppDescShort :: Text
, storeAppDescLong :: Text
, storeAppVersionInfo :: NonEmpty VersionInfo
, storeAppIconType :: Text
}
deriving Show
instance ToJSON StoreApp where
toJSON StoreApp {..} = object
[ "title" .= storeAppTitle
, "icon-type" .= storeAppIconType
, "description" .= object ["short" .= storeAppDescShort, "long" .= storeAppDescLong]
, "version-info" .= storeAppVersionInfo
]
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)
instance ToJSON AppManifest where
toJSON = toJSON . unAppManifest
filterOsRequired :: AppVersion -> StoreApp -> Maybe StoreApp
filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of
[] -> Nothing
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
filterOsRecommended :: AppVersion -> StoreApp -> Maybe StoreApp
filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of
[] -> Nothing
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }

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

@@ -4,14 +4,16 @@
module Lib.Types.Semver where module Lib.Types.Semver where
import Startlude hiding (break) import Startlude hiding ( break )
import qualified GHC.Read (Read (..)) import qualified GHC.Read ( Read(..) )
import qualified GHC.Show (Show (..)) import qualified GHC.Show ( Show(..) )
import Control.Monad.Fail import Control.Monad.Fail
import Data.Aeson import Data.Aeson
import Data.Char (isDigit) import qualified Data.Attoparsec.ByteString.Char8
as AttoBS
import Data.Char ( isDigit )
import Data.String.Interpolate import Data.String.Interpolate
import Data.Text import Data.Text
import Yesod.Core import Yesod.Core
@@ -27,30 +29,28 @@ newtype AppVersion = AppVersion
instance Read AppVersion where instance Read AppVersion where
readsPrec _ s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of readsPrec _ s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of
Just [major, minor, patch, build] -> [(AppVersion (major, minor, patch, build), "")] Just [major, minor, patch, build] -> [(AppVersion (major, minor, patch, build), "")]
Just [major, minor, patch] -> [(AppVersion (major, minor, patch, 0), "")] Just [major, minor, patch] -> [(AppVersion (major, minor, patch, 0), "")]
_ -> [] _ -> []
instance PathPiece AppVersion where instance PathPiece AppVersion where
fromPathPiece = readMaybe . toS fromPathPiece = readMaybe . toS
toPathPiece = show toPathPiece = show
instance Show AppVersion where instance Show AppVersion where
show (AppVersion (a, b, c, d)) show (AppVersion (a, b, c, d)) | d == 0 = [i|#{a}.#{b}.#{c}|]
| d == 0 = [i|#{a}.#{b}.#{c}|] | otherwise = [i|#{a}.#{b}.#{c}+#{d}|]
| otherwise = [i|#{a}.#{b}.#{c}+#{d}|]
instance IsString AppVersion where instance IsString AppVersion where
fromString s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of fromString s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of
Just [major, minor, patch, build] -> AppVersion (major, minor, patch, build) Just [major, minor, patch, build] -> AppVersion (major, minor, patch, build)
Just [major, minor, patch] -> AppVersion (major, minor, patch, 0) Just [major, minor, patch] -> AppVersion (major, minor, patch, 0)
_ -> panic . toS $ "Invalid App Version: " <> s _ -> panic . toS $ "Invalid App Version: " <> s
instance ToJSON AppVersion where instance ToJSON AppVersion where
toJSON = String . show toJSON = String . show
instance FromJSON AppVersion where instance FromJSON AppVersion where
parseJSON = withText "app version" $ \t -> parseJSON = withText "app version" $ \t -> case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t of
case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t of Just [a, b, c, d] -> pure $ AppVersion (a, b, c, d)
Just [a, b, c, d] -> pure $ AppVersion (a, b, c, d) Just [a, b, c] -> pure $ AppVersion (a, b, c, 0)
Just [a, b, c] -> pure $ AppVersion (a, b, c, 0) _ -> fail "unknown versioning"
_ -> fail "unknown versioning"
instance ToTypedContent AppVersion where instance ToTypedContent AppVersion where
toTypedContent = toTypedContent . toJSON toTypedContent = toTypedContent . toJSON
instance ToContent AppVersion where instance ToContent AppVersion where
@@ -59,54 +59,60 @@ instance ToContent AppVersion where
instance FromJSONKey AppVersion where instance FromJSONKey AppVersion where
fromJSONKey = FromJSONKeyTextParser $ \t -> case readMaybe (toS t) of fromJSONKey = FromJSONKeyTextParser $ \t -> case readMaybe (toS t) of
Nothing -> fail "invalid app version" Nothing -> fail "invalid app version"
Just x -> pure x Just x -> pure x
instance PersistField AppVersion where instance PersistField AppVersion where
toPersistValue = toPersistValue @Text . show toPersistValue = toPersistValue @Text . show
fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue
instance PersistFieldSql AppVersion where instance PersistFieldSql AppVersion where
sqlType _ = SqlString sqlType _ = SqlString
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
-- Semver AppVersionSpecification -- Semver AppVersionSpec
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
data AppVersionSpecification = data AppVersionSpec =
AppVersionAny AppVersionAny
| AppVersionSpecification SemverRequestModifier AppVersion | AppVersionSpec SemverRequestModifier AppVersion
deriving Eq
instance Read AppVersionSpecification where instance Read AppVersionSpec where
readsPrec _ s = readsPrec _ s = if s == "*"
if s == "*" then [(AppVersionAny, "")]
then [(AppVersionAny, "")] else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of (Just m, Just av) -> [(AppVersionSpec m av, "")]
(Just m, Just av) -> [(AppVersionSpecification m av, "")] _ -> []
_ -> [] where (svMod, version) = break isDigit . toS $ s
where
(svMod, version) = break isDigit . toS $ s
instance PathPiece AppVersionSpecification where instance PathPiece AppVersionSpec where
fromPathPiece = readMaybe . toS fromPathPiece = readMaybe . toS
toPathPiece = show toPathPiece = show
instance Show AppVersionSpecification where instance Show AppVersionSpec where
show AppVersionAny = "*" show AppVersionAny = "*"
show (AppVersionSpecification r b) = show r <> show b show (AppVersionSpec r b) = show r <> show b
instance ToJSON AppVersionSpecification where instance ToJSON AppVersionSpec where
toJSON = String . show toJSON = String . show
instance FromJSON AppVersionSpecification where instance FromJSON AppVersionSpec where
parseJSON = withText "app version spec" $ \t -> parseJSON = withText "app version spec" $ \t -> if t == "*"
if t == "*" then pure AppVersionAny
then pure AppVersionAny else do
else do let (svMod, version) = break isDigit t
let (svMod, version) = break isDigit t baseVersion <- parseJSON . String $ version
baseVersion <- parseJSON . String $ version requestModifier <- parseJSON . String $ svMod
requestModifier <- parseJSON . String $ svMod pure $ AppVersionSpec requestModifier baseVersion
pure $ AppVersionSpecification requestModifier baseVersion
mostRecentVersion :: AppVersionSpecification instance PersistField AppVersionSpec where
mostRecentVersion = AppVersionSpecification SVGreaterThanEq $ AppVersion (0,0,0,0) toPersistValue = PersistText . show
fromPersistValue (PersistText spec) = note ("Invalid Semver Requirement: " <> spec) . readMaybe $ spec
fromPersistValue other = Left $ "Persistent Type Mismatch. Expected 'PersistText _' got " <> show other
instance PersistFieldSql AppVersionSpec where
sqlType _ = SqlString
mostRecentVersion :: AppVersionSpec
mostRecentVersion = AppVersionSpec SVGreaterThanEq $ AppVersion (0, 0, 0, 0)
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
-- Semver RequestModifier -- Semver RequestModifier
@@ -123,10 +129,9 @@ instance Show SemverRequestModifier where
show SVGreaterThanEq = ">=" show SVGreaterThanEq = ">="
instance FromJSON SemverRequestModifier where instance FromJSON SemverRequestModifier where
parseJSON = withText "semver request modifier" $ \t -> parseJSON = withText "semver request modifier" $ \t -> case readMaybe . toS $ t of
case readMaybe . toS $ t of Just m -> pure m
Just m -> pure m Nothing -> fail "invalid semver request modifier"
Nothing -> fail "invalid semver request modifier"
instance Read SemverRequestModifier where instance Read SemverRequestModifier where
readsPrec _ = \case readsPrec _ = \case
@@ -139,3 +144,11 @@ instance Read SemverRequestModifier where
"<=" -> [(SVLessThanEq, "")] "<=" -> [(SVLessThanEq, "")]
">=" -> [(SVGreaterThanEq, "")] ">=" -> [(SVGreaterThanEq, "")]
_ -> [] _ -> []
semverParserBS :: AttoBS.Parser AppVersion
semverParserBS = do
major <- AttoBS.decimal <* AttoBS.char '.'
minor <- AttoBS.decimal <* AttoBS.char '.'
patch <- AttoBS.decimal
build <- AttoBS.option 0 $ AttoBS.char '+' *> AttoBS.decimal
pure $ AppVersion (major, minor, patch, build)

7
src/Model.hs
View File

@@ -1,12 +1,15 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Model where module Model where
import Startlude import Startlude
import Database.Persist.TH import Database.Persist.TH
import Lib.Types.Semver import Lib.Types.Semver
@@ -30,6 +33,8 @@ Version
appId SAppId appId SAppId
number AppVersion number AppVersion
releaseNotes Text releaseNotes Text
osVersionRequired AppVersionSpec default='*'
osVersionRecommended AppVersionSpec default='*'
UniqueBin appId number UniqueBin appId number
deriving Eq deriving Eq
deriving Show deriving Show

55
src/Settings.hs
View File

@@ -7,27 +7,24 @@
-- declared in the Foundation.hs file. -- declared in the Foundation.hs file.
module Settings where module Settings where
import Paths_start9_registry ( version )
import Startlude import Startlude
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
import Control.Monad.Fail ( fail )
import Data.Maybe import Data.Maybe
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
import Data.Version ( showVersion ) import Data.Version ( showVersion )
import Data.FileEmbed ( embedFile ) import Data.FileEmbed ( embedFile )
import Data.Yaml ( decodeEither' ) import Data.Yaml ( decodeEither' )
import Data.Yaml.Config
import Database.Persist.Postgresql ( PostgresConf ) import Database.Persist.Postgresql ( PostgresConf )
import Network.Wai.Handler.Warp ( HostPreference ) 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 System.FilePath ( (</>) )
import qualified Data.HashMap.Strict as HM import Yesod.Default.Config2 ( configSettingsYml )
import Data.Yaml.Config
import Lib.Types.Semver
import Lib.Types.AppIndex
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database. -- theoretically even a database.
@@ -41,12 +38,10 @@ data AppSettings = AppSettings
, appIpFromHeader :: Bool , appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting -- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy. -- behind a reverse proxy.
, appDetailedRequestLogging :: Bool , appDetailedRequestLogging :: Bool
-- ^ Use detailed request logging system -- ^ Use detailed request logging system
, appShouldLogAll :: Bool , appShouldLogAll :: Bool
-- ^ Should all log messages be displayed? -- ^ Should all log messages be displayed?
, appCompatibilityPath :: FilePath
, resourcesDir :: FilePath , resourcesDir :: FilePath
, sslPath :: FilePath , sslPath :: FilePath
, registryHostname :: Text , registryHostname :: Text
@@ -65,7 +60,6 @@ instance FromJSON AppSettings where
appIpFromHeader <- o .: "ip-from-header" appIpFromHeader <- o .: "ip-from-header"
appDetailedRequestLogging <- o .:? "detailed-logging" .!= True appDetailedRequestLogging <- o .:? "detailed-logging" .!= True
appShouldLogAll <- o .:? "should-log-all" .!= False appShouldLogAll <- o .:? "should-log-all" .!= False
appCompatibilityPath <- o .: "app-compatibility-path"
resourcesDir <- o .: "resources-path" resourcesDir <- o .: "resources-path"
sslPath <- o .: "ssl-path" sslPath <- o .: "ssl-path"
registryHostname <- o .: "registry-hostname" registryHostname <- o .: "registry-hostname"
@@ -96,42 +90,3 @@ getAppManifest :: FilePath -> IO AppManifest
getAppManifest resourcesDir = do getAppManifest resourcesDir = do
let appFile = (</> "apps.yaml") resourcesDir let appFile = (</> "apps.yaml") resourcesDir
loadYamlSettings [appFile] [] useEnv 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 { .. }

30
src/Startlude.hs
View File

@@ -4,14 +4,28 @@ module Startlude
) )
where where
import Control.Arrow as X ((&&&)) import Control.Arrow as X
import Control.Comonad as X ( (&&&) )
import Control.Error.Util as X -- import Control.Comonad as X
import Data.Coerce as X import Control.Error.Util as X
import Data.String as X (String, fromString) import Data.Coerce as X
import Data.Time.Clock as X import Data.String as X
import Protolude as X hiding (bool, hush, isLeft, isRight, note, readMaybe, tryIO, (<.>)) ( String
import qualified Protolude as P (readMaybe) , fromString
)
import Data.Time.Clock as X
import Protolude as X
hiding ( bool
, hush
, isLeft
, isRight
, note
, readMaybe
, tryIO
, (<.>)
)
import qualified Protolude as P
( readMaybe )
id :: a -> a id :: a -> a
id = identity id = identity

10
stack.yaml
View File

@@ -17,7 +17,7 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-13.30 resolver: lts-16.15
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@@ -41,9 +41,9 @@ packages:
# #
extra-deps: extra-deps:
- protolude-0.2.4 - protolude-0.2.4
- git: https://github.com/CaptJakk/jose-jwt.git # - git: https://github.com/CaptJakk/jose-jwt.git
commit: 63210e8d05543dac932ddfe5c212450beb88374c # commit: 63210e8d05543dac932ddfe5c212450beb88374c
- haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541 # - haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}
@@ -68,3 +68,5 @@ extra-deps:
# #
# Allow a newer minor version of GHC than the snapshot specifies # Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor # compiler-check: newer-minor
# docker:
# enable: true