diff --git a/config/settings.yml b/config/settings.yml index 7865304..629418c 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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'") # 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" ssl-path: "_env:SSL_PATH:/var/ssl" registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com" diff --git a/package.yaml b/package.yaml index a2d0a7e..e6d87e2 100644 --- a/package.yaml +++ b/package.yaml @@ -11,41 +11,29 @@ default-extensions: - OverloadedStrings dependencies: -- base >=4.9.1.0 && <5 -- aeson >=1.4 && <1.5 +- base >=4.12 && <5 +- aeson +- attoparsec - bytestring - casing -- comonad - conduit - conduit-extra - data-default - directory -- dns -- either - errors - extra - file-embed -- fast-logger >=2.2 && <2.5 +- fast-logger - filepath -- http-client -- http-conduit - http-types - interpolate -- jose-jwt - lens -- lens-aeson -- memory -- monad-logger >=0.3 && <0.4 -- monad-loops +- monad-logger - persistent -- persistent-sqlite - persistent-postgresql - persistent-template - process - protolude -- safe -- singletons -- split - template-haskell - text >=0.11 && <2.0 - time @@ -54,16 +42,13 @@ dependencies: - unix - wai - wai-cors -- wai-extra >=3.0 && <3.1 -- wai-logger >=2.2 && <2.4 -- warp >=3.0 && <3.3 +- wai-extra +- warp - warp-tls -- yaml >=0.11 && <0.12 -- yesod >=1.6 && <1.7 -- yesod-core >=1.6 && <1.7 -- yesod-static -- yesod-persistent >= 1.6 && < 1.7 -- shakespeare >=2.0 && <2.1 +- yaml +- yesod +- yesod-core +- yesod-persistent library: source-dirs: src diff --git a/src/Application.hs b/src/Application.hs index 104a77b..9ac1ac7 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index d15d664..d82e64e 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 5e0e323..ddfdf71 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 } diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index b68e374..a483a0c 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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 diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 7cb7a45..39018fe 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -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 diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index a1af45f..db796f6 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -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 \ No newline at end of file + Just a -> pure a diff --git a/src/Lib/Semver.hs b/src/Lib/Semver.hs index e80f721..b11796c 100644 --- a/src/Lib/Semver.hs +++ b/src/Lib/Semver.hs @@ -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 \ No newline at end of file +appVersionMax as = Just $ maximumBy (compare `on` version) as diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs new file mode 100644 index 0000000..490f2a7 --- /dev/null +++ b/src/Lib/Types/AppIndex.hs @@ -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 } diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs index a03c4c9..4da86e4 100644 --- a/src/Lib/Types/Semver.hs +++ b/src/Lib/Types/Semver.hs @@ -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) diff --git a/src/Model.hs b/src/Model.hs index 98c2fae..d10803f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index c01da97..2a3cc26 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 { .. } diff --git a/src/Startlude.hs b/src/Startlude.hs index fe88aea..4a22c47 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index e13d38c..30009f4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-13.30 +resolver: lts-16.15 # User packages to be built. # Various formats can be used as shown in the example below. @@ -41,9 +41,9 @@ packages: # extra-deps: - protolude-0.2.4 - - git: https://github.com/CaptJakk/jose-jwt.git - commit: 63210e8d05543dac932ddfe5c212450beb88374c - - haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541 + # - git: https://github.com/CaptJakk/jose-jwt.git + # commit: 63210e8d05543dac932ddfe5c212450beb88374c + # - haskell-src-exts-1.21.1@sha256:11d18ec3f463185f81b7819376b532e3087f8192cffc629aac5c9eec88897b35,4541 # Override default flag values for local packages and extra-deps # flags: {} @@ -68,3 +68,5 @@ extra-deps: # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor +# docker: + # enable: true \ No newline at end of file