mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
removes compatibility dependency, filters apps/versions based off of user agent header
This commit is contained in:
Keagan McClelland
@@ -80,10 +80,6 @@ makeFoundation appSettings = do
|
||||
appWebServerThreadId <- newEmptyMVar
|
||||
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
|
||||
-- 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
|
||||
|
||||
@@ -4,44 +4,35 @@
|
||||
|
||||
module Database.Queries where
|
||||
|
||||
import Startlude
|
||||
import Database.Persist.Sql
|
||||
import Model
|
||||
import Settings
|
||||
import Lib.Types.Semver
|
||||
import Startlude
|
||||
import Database.Persist.Sql
|
||||
import Lib.Types.AppIndex
|
||||
import Lib.Types.Semver
|
||||
import Model
|
||||
|
||||
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 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 appId StoreApp{..} = do
|
||||
createApp appId StoreApp {..} = do
|
||||
time <- liftIO getCurrentTime
|
||||
insertUnique $ SApp
|
||||
time
|
||||
Nothing
|
||||
storeAppTitle
|
||||
appId
|
||||
storeAppDescShort
|
||||
storeAppDescLong
|
||||
storeAppIconType
|
||||
|
||||
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
|
||||
createAppVersion sId VersionInfo {..} = do
|
||||
time <- liftIO getCurrentTime
|
||||
insertUnique $ Version
|
||||
time
|
||||
Nothing
|
||||
sId
|
||||
versionInfoVersion
|
||||
versionInfoReleaseNotes
|
||||
insertUnique $ Version time
|
||||
Nothing
|
||||
sId
|
||||
versionInfoVersion
|
||||
versionInfoReleaseNotes
|
||||
versionInfoOsRequired
|
||||
versionInfoOsRecommended
|
||||
|
||||
createMetric :: MonadIO m => Key SApp -> Key Version -> ReaderT SqlBackend m ()
|
||||
createMetric appId versionId = do
|
||||
time <- liftIO $ getCurrentTime
|
||||
insert_ $ Metric
|
||||
time
|
||||
appId
|
||||
versionId
|
||||
time <- liftIO $ getCurrentTime
|
||||
insert_ $ Metric time appId versionId
|
||||
|
||||
@@ -9,14 +9,12 @@ module Foundation where
|
||||
import Startlude
|
||||
|
||||
import Control.Monad.Logger ( LogSource )
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Database.Persist.Sql
|
||||
import Lib.Registry
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types ( Logger )
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
|
||||
import Lib.Types.Semver
|
||||
import Settings
|
||||
import Yesod.Persist.Core
|
||||
|
||||
@@ -31,7 +29,6 @@ data RegistryCtx = RegistryCtx
|
||||
, appLogger :: Logger
|
||||
, appWebServerThreadId :: MVar (ThreadId, ThreadId)
|
||||
, appShouldRestartWeb :: MVar Bool
|
||||
, appCompatibilityMap :: HM.HashMap AppVersion AppVersion
|
||||
, appConnPool :: ConnectionPool
|
||||
}
|
||||
|
||||
|
||||
@@ -11,33 +11,38 @@ import Startlude
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Data.Aeson
|
||||
import qualified Data.Attoparsec.ByteString.Char8
|
||||
as Atto
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Char
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Yaml as Yaml
|
||||
import Database.Persist
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
import Network.HTTP.Types
|
||||
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.Posix.Files ( fileSize
|
||||
, 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 Database.Queries
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Database.Persist
|
||||
import Network.Wai ( Request(requestHeaderUserAgent) )
|
||||
|
||||
pureLog :: Show a => a -> Handler a
|
||||
pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||
@@ -50,10 +55,30 @@ instance Show FileExtension where
|
||||
show (FileExtension f Nothing ) = f
|
||||
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 = do
|
||||
appResourceDir <- (</> "apps" </> "apps.yaml") . resourcesDir . appSettings <$> getYesod
|
||||
respondSource typePlain $ CB.sourceFile appResourceDir .| awaitForever sendChunkBS
|
||||
osVersion <- getEmbassyOsVersion
|
||||
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 e = do
|
||||
|
||||
@@ -10,9 +10,7 @@ import Startlude
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Char
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Types
|
||||
import Yesod.Core
|
||||
|
||||
@@ -22,7 +20,7 @@ import Lib.Registry
|
||||
import Lib.Semver
|
||||
import Lib.Types.Semver
|
||||
import Settings
|
||||
import System.FilePath ((</>))
|
||||
import System.FilePath ( (</>) )
|
||||
|
||||
getVersionR :: Handler AppVersionRes
|
||||
getVersionR = do
|
||||
@@ -33,34 +31,21 @@ getVersionAppR :: Text -> Handler (Maybe AppVersionRes)
|
||||
getVersionAppR appId = do
|
||||
appsDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
|
||||
getVersionWSpec appsDir appExt
|
||||
where
|
||||
appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
where appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
|
||||
getVersionSysR :: Text -> Handler (Maybe AppVersionRes)
|
||||
getVersionSysR sysAppId = runMaybeT $ do
|
||||
sysDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
|
||||
avr <- MaybeT $ getVersionWSpec sysDir sysExt
|
||||
minComp <- lift $ case sysAppId of
|
||||
"agent" -> Just <$> meshCompanionCompatibility (appVersionVersion avr)
|
||||
_ -> pure Nothing
|
||||
pure $ avr { appVersionMinCompanion = minComp }
|
||||
where
|
||||
sysExt = Extension (toS sysAppId) :: Extension ""
|
||||
avr <- MaybeT $ getVersionWSpec sysDir sysExt
|
||||
pure $ avr { appVersionMinCompanion = Just $ AppVersion (1, 1, 0, 0) }
|
||||
where sysExt = Extension (toS sysAppId) :: Extension ""
|
||||
|
||||
getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes)
|
||||
getVersionWSpec rootDir ext = do
|
||||
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)
|
||||
Just t -> pure t
|
||||
appVersions <- liftIO $ getAvailableAppVersions rootDir ext
|
||||
let av = version <$> getSpecifiedAppVersion spec appVersions
|
||||
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
|
||||
|
||||
@@ -8,7 +8,8 @@ import Yesod.Core
|
||||
|
||||
type S9ErrT m = ExceptT S9Error m
|
||||
|
||||
data S9Error = PersistentE Text deriving (Show, Eq)
|
||||
data S9Error = PersistentE Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Exception S9Error
|
||||
|
||||
@@ -17,8 +18,7 @@ toError :: S9Error -> Error
|
||||
toError = \case
|
||||
PersistentE t -> Error DATABASE_ERROR t
|
||||
|
||||
data ErrorCode =
|
||||
DATABASE_ERROR
|
||||
data ErrorCode = DATABASE_ERROR
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON ErrorCode where
|
||||
toJSON = String . show
|
||||
@@ -26,12 +26,10 @@ instance ToJSON ErrorCode where
|
||||
data Error = Error
|
||||
{ errorCode :: ErrorCode
|
||||
, errorMessage :: Text
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON Error where
|
||||
toJSON Error{..} = object
|
||||
[ "code" .= errorCode
|
||||
, "message" .= errorMessage
|
||||
]
|
||||
toJSON Error {..} = object ["code" .= errorCode, "message" .= errorMessage]
|
||||
instance ToContent Error where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent Error where
|
||||
@@ -48,15 +46,15 @@ toStatus = \case
|
||||
|
||||
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
|
||||
handleS9ErrT action = runExceptT action >>= \case
|
||||
Left e -> toStatus >>= sendResponseStatus $ e
|
||||
Left e -> toStatus >>= sendResponseStatus $ e
|
||||
Right a -> pure a
|
||||
|
||||
handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
|
||||
handleS9ErrNuclear action = runExceptT action >>= \case
|
||||
Left e -> throwIO e
|
||||
Left e -> throwIO e
|
||||
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
|
||||
Nothing -> sendResponseStatus status res
|
||||
Just a -> pure a
|
||||
Just a -> pure a
|
||||
|
||||
@@ -4,21 +4,17 @@ import Startlude
|
||||
|
||||
import Lib.Types.Semver
|
||||
|
||||
(<||) :: HasAppVersion a => a -> AppVersionSpecification -> Bool
|
||||
(<||) _ AppVersionAny = True
|
||||
(<||) a (AppVersionSpecification SVEquals av1) = version a == av1
|
||||
(<||) a (AppVersionSpecification SVLessThan av1) = version a < av1
|
||||
(<||) a (AppVersionSpecification SVGreaterThan av1) = version a > av1
|
||||
(<||) a (AppVersionSpecification SVLessThanEq av1) = version a <= av1
|
||||
(<||) a (AppVersionSpecification SVGreaterThanEq av1) = version a >= av1
|
||||
(<||) a (AppVersionSpecification SVGreatestWithMajor av1) -- "maj.*"
|
||||
= major av == major av1 && av >= av1
|
||||
where
|
||||
av = version a
|
||||
(<||) a (AppVersionSpecification SVGreatestWithMajorMinor av1) -- "maj.min.*"
|
||||
= major av == major av1 && minor av == minor av1 && av >= av1
|
||||
where
|
||||
av = version a
|
||||
(<||) :: HasAppVersion a => a -> AppVersionSpec -> Bool
|
||||
(<||) _ AppVersionAny = True
|
||||
(<||) a (AppVersionSpec SVEquals av1) = version a == av1
|
||||
(<||) a (AppVersionSpec SVLessThan av1) = version a < av1
|
||||
(<||) a (AppVersionSpec SVGreaterThan av1) = version a > av1
|
||||
(<||) a (AppVersionSpec SVLessThanEq av1) = version a <= av1
|
||||
(<||) a (AppVersionSpec SVGreaterThanEq av1) = version a >= av1
|
||||
(<||) a (AppVersionSpec SVGreatestWithMajor av1) = major av == major av1 && av >= av1 -- "maj.*"
|
||||
where av = version a
|
||||
(<||) a (AppVersionSpec SVGreatestWithMajorMinor av1) = major av == major av1 && minor av == minor av1 && av >= av1 -- "maj.min.*"
|
||||
where av = version a
|
||||
|
||||
major :: AppVersion -> Word16
|
||||
major (AppVersion (a, _, _, _)) = a
|
||||
@@ -32,7 +28,7 @@ build (AppVersion (_, _, _, a)) = a
|
||||
hasGiven :: (AppVersion -> Word16) -> AppVersion -> AppVersion -> Bool
|
||||
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)
|
||||
|
||||
class HasAppVersion a where
|
||||
@@ -43,4 +39,4 @@ instance HasAppVersion AppVersion where
|
||||
|
||||
appVersionMax :: HasAppVersion a => [a] -> Maybe a
|
||||
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
90
src/Lib/Types/AppIndex.hs
Normal 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 }
|
||||
@@ -4,14 +4,16 @@
|
||||
|
||||
module Lib.Types.Semver where
|
||||
|
||||
import Startlude hiding (break)
|
||||
import Startlude hiding ( break )
|
||||
|
||||
import qualified GHC.Read (Read (..))
|
||||
import qualified GHC.Show (Show (..))
|
||||
import qualified GHC.Read ( Read(..) )
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
|
||||
import Control.Monad.Fail
|
||||
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.Text
|
||||
import Yesod.Core
|
||||
@@ -27,30 +29,28 @@ newtype AppVersion = AppVersion
|
||||
instance Read AppVersion where
|
||||
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] -> [(AppVersion (major, minor, patch, 0), "")]
|
||||
_ -> []
|
||||
Just [major, minor, patch] -> [(AppVersion (major, minor, patch, 0), "")]
|
||||
_ -> []
|
||||
instance PathPiece AppVersion where
|
||||
fromPathPiece = readMaybe . toS
|
||||
toPathPiece = show
|
||||
toPathPiece = show
|
||||
|
||||
instance Show AppVersion where
|
||||
show (AppVersion (a, b, c, d))
|
||||
| d == 0 = [i|#{a}.#{b}.#{c}|]
|
||||
| otherwise = [i|#{a}.#{b}.#{c}+#{d}|]
|
||||
show (AppVersion (a, b, c, d)) | d == 0 = [i|#{a}.#{b}.#{c}|]
|
||||
| otherwise = [i|#{a}.#{b}.#{c}+#{d}|]
|
||||
|
||||
instance IsString AppVersion where
|
||||
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] -> AppVersion (major, minor, patch, 0)
|
||||
_ -> panic . toS $ "Invalid App Version: " <> s
|
||||
Just [major, minor, patch] -> AppVersion (major, minor, patch, 0)
|
||||
_ -> panic . toS $ "Invalid App Version: " <> s
|
||||
instance ToJSON AppVersion where
|
||||
toJSON = String . show
|
||||
instance FromJSON AppVersion where
|
||||
parseJSON = withText "app version" $ \t ->
|
||||
case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t of
|
||||
Just [a, b, c, d] -> pure $ AppVersion (a, b, c, d)
|
||||
Just [a, b, c] -> pure $ AppVersion (a, b, c, 0)
|
||||
_ -> fail "unknown versioning"
|
||||
parseJSON = withText "app version" $ \t -> case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t of
|
||||
Just [a, b, c, d] -> pure $ AppVersion (a, b, c, d)
|
||||
Just [a, b, c] -> pure $ AppVersion (a, b, c, 0)
|
||||
_ -> fail "unknown versioning"
|
||||
instance ToTypedContent AppVersion where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent AppVersion where
|
||||
@@ -59,54 +59,60 @@ instance ToContent AppVersion where
|
||||
instance FromJSONKey AppVersion where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case readMaybe (toS t) of
|
||||
Nothing -> fail "invalid app version"
|
||||
Just x -> pure x
|
||||
Just x -> pure x
|
||||
|
||||
instance PersistField AppVersion where
|
||||
toPersistValue = toPersistValue @Text . show
|
||||
toPersistValue = toPersistValue @Text . show
|
||||
fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue
|
||||
|
||||
instance PersistFieldSql AppVersion where
|
||||
sqlType _ = SqlString
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Semver AppVersionSpecification
|
||||
-- Semver AppVersionSpec
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
data AppVersionSpecification =
|
||||
data AppVersionSpec =
|
||||
AppVersionAny
|
||||
| AppVersionSpecification SemverRequestModifier AppVersion
|
||||
| AppVersionSpec SemverRequestModifier AppVersion
|
||||
deriving Eq
|
||||
|
||||
instance Read AppVersionSpecification where
|
||||
readsPrec _ s =
|
||||
if s == "*"
|
||||
then [(AppVersionAny, "")]
|
||||
else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
|
||||
(Just m, Just av) -> [(AppVersionSpecification m av, "")]
|
||||
_ -> []
|
||||
where
|
||||
(svMod, version) = break isDigit . toS $ s
|
||||
instance Read AppVersionSpec where
|
||||
readsPrec _ s = if s == "*"
|
||||
then [(AppVersionAny, "")]
|
||||
else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
|
||||
(Just m, Just av) -> [(AppVersionSpec m av, "")]
|
||||
_ -> []
|
||||
where (svMod, version) = break isDigit . toS $ s
|
||||
|
||||
instance PathPiece AppVersionSpecification where
|
||||
instance PathPiece AppVersionSpec where
|
||||
fromPathPiece = readMaybe . toS
|
||||
toPathPiece = show
|
||||
toPathPiece = show
|
||||
|
||||
instance Show AppVersionSpecification where
|
||||
show AppVersionAny = "*"
|
||||
show (AppVersionSpecification r b) = show r <> show b
|
||||
instance ToJSON AppVersionSpecification where
|
||||
instance Show AppVersionSpec where
|
||||
show AppVersionAny = "*"
|
||||
show (AppVersionSpec r b) = show r <> show b
|
||||
instance ToJSON AppVersionSpec where
|
||||
toJSON = String . show
|
||||
instance FromJSON AppVersionSpecification where
|
||||
parseJSON = withText "app version spec" $ \t ->
|
||||
if t == "*"
|
||||
then pure AppVersionAny
|
||||
else do
|
||||
let (svMod, version) = break isDigit t
|
||||
baseVersion <- parseJSON . String $ version
|
||||
requestModifier <- parseJSON . String $ svMod
|
||||
pure $ AppVersionSpecification requestModifier baseVersion
|
||||
instance FromJSON AppVersionSpec where
|
||||
parseJSON = withText "app version spec" $ \t -> if t == "*"
|
||||
then pure AppVersionAny
|
||||
else do
|
||||
let (svMod, version) = break isDigit t
|
||||
baseVersion <- parseJSON . String $ version
|
||||
requestModifier <- parseJSON . String $ svMod
|
||||
pure $ AppVersionSpec requestModifier baseVersion
|
||||
|
||||
mostRecentVersion :: AppVersionSpecification
|
||||
mostRecentVersion = AppVersionSpecification SVGreaterThanEq $ AppVersion (0,0,0,0)
|
||||
instance PersistField AppVersionSpec where
|
||||
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
|
||||
@@ -123,10 +129,9 @@ instance Show SemverRequestModifier where
|
||||
show SVGreaterThanEq = ">="
|
||||
|
||||
instance FromJSON SemverRequestModifier where
|
||||
parseJSON = withText "semver request modifier" $ \t ->
|
||||
case readMaybe . toS $ t of
|
||||
Just m -> pure m
|
||||
Nothing -> fail "invalid semver request modifier"
|
||||
parseJSON = withText "semver request modifier" $ \t -> case readMaybe . toS $ t of
|
||||
Just m -> pure m
|
||||
Nothing -> fail "invalid semver request modifier"
|
||||
|
||||
instance Read SemverRequestModifier where
|
||||
readsPrec _ = \case
|
||||
@@ -139,3 +144,11 @@ instance Read SemverRequestModifier where
|
||||
"<=" -> [(SVLessThanEq, "")]
|
||||
">=" -> [(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)
|
||||
|
||||
@@ -1,12 +1,15 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model where
|
||||
|
||||
import Startlude
|
||||
import Startlude
|
||||
import Database.Persist.TH
|
||||
import Lib.Types.Semver
|
||||
|
||||
@@ -30,6 +33,8 @@ Version
|
||||
appId SAppId
|
||||
number AppVersion
|
||||
releaseNotes Text
|
||||
osVersionRequired AppVersionSpec default='*'
|
||||
osVersionRecommended AppVersionSpec default='*'
|
||||
UniqueBin appId number
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
@@ -7,27 +7,24 @@
|
||||
-- declared in the Foundation.hs file.
|
||||
module Settings where
|
||||
|
||||
import Paths_start9_registry ( version )
|
||||
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 Data.Yaml.Config
|
||||
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
|
||||
import Yesod.Default.Config2 ( configSettingsYml )
|
||||
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.AppIndex
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
-- theoretically even a database.
|
||||
@@ -41,12 +38,10 @@ data AppSettings = AppSettings
|
||||
, appIpFromHeader :: Bool
|
||||
-- ^ Get the IP address from the header when logging. Useful when sitting
|
||||
-- behind a reverse proxy.
|
||||
|
||||
, appDetailedRequestLogging :: Bool
|
||||
-- ^ Use detailed request logging system
|
||||
, appShouldLogAll :: Bool
|
||||
-- ^ Should all log messages be displayed?
|
||||
, appCompatibilityPath :: FilePath
|
||||
, resourcesDir :: FilePath
|
||||
, sslPath :: FilePath
|
||||
, registryHostname :: Text
|
||||
@@ -65,7 +60,6 @@ instance FromJSON AppSettings where
|
||||
appIpFromHeader <- o .: "ip-from-header"
|
||||
appDetailedRequestLogging <- o .:? "detailed-logging" .!= True
|
||||
appShouldLogAll <- o .:? "should-log-all" .!= False
|
||||
appCompatibilityPath <- o .: "app-compatibility-path"
|
||||
resourcesDir <- o .: "resources-path"
|
||||
sslPath <- o .: "ssl-path"
|
||||
registryHostname <- o .: "registry-hostname"
|
||||
@@ -96,42 +90,3 @@ 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 { .. }
|
||||
|
||||
@@ -4,14 +4,28 @@ module Startlude
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Arrow as X ((&&&))
|
||||
import Control.Comonad as X
|
||||
import Control.Error.Util as X
|
||||
import Data.Coerce as X
|
||||
import Data.String as X (String, 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)
|
||||
import Control.Arrow as X
|
||||
( (&&&) )
|
||||
-- import Control.Comonad as X
|
||||
import Control.Error.Util as X
|
||||
import Data.Coerce as X
|
||||
import Data.String as X
|
||||
( String
|
||||
, 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 = identity
|
||||
|
||||
Reference in New Issue
Block a user