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'")
# 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"

37
package.yaml
View File

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

4
src/Application.hs
View File

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

23
src/Database/Queries.hs
View File

@@ -6,9 +6,9 @@ module Database.Queries where
import Startlude
import Database.Persist.Sql
import Model
import Settings
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] []
@@ -19,29 +19,20 @@ fetchAppVersion appVersion appId = selectFirst [VersionNumber ==. appVersion, Ve
createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp))
createApp appId StoreApp {..} = do
time <- liftIO getCurrentTime
insertUnique $ SApp
time
Nothing
storeAppTitle
appId
storeAppDescShort
storeAppDescLong
storeAppIconType
insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType
createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> ReaderT SqlBackend m (Maybe (Key Version))
createAppVersion sId VersionInfo {..} = do
time <- liftIO getCurrentTime
insertUnique $ Version
time
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
insert_ $ Metric time appId versionId

3
src/Foundation.hs
View File

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

51
src/Handler/Apps.hs
View File

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

21
src/Handler/Version.hs
View File

@@ -10,8 +10,6 @@ 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 Network.HTTP.Types
import Yesod.Core
@@ -33,19 +31,14 @@ 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 ""
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
@@ -56,11 +49,3 @@ getVersionWSpec rootDir ext = do
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

14
src/Lib/Error.hs
View File

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

26
src/Lib/Semver.hs
View File

@@ -4,21 +4,17 @@ import Startlude
import Lib.Types.Semver
(<||) :: HasAppVersion a => a -> AppVersionSpecification -> Bool
(<||) :: HasAppVersion a => a -> AppVersionSpec -> 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
(<||) 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

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 }

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

@@ -11,6 +11,8 @@ import qualified GHC.Show (Show (..))
import Control.Monad.Fail
import Data.Aeson
import qualified Data.Attoparsec.ByteString.Char8
as AttoBS
import Data.Char ( isDigit )
import Data.String.Interpolate
import Data.Text
@@ -34,8 +36,7 @@ instance PathPiece AppVersion where
toPathPiece = show
instance Show AppVersion where
show (AppVersion (a, b, c, d))
| d == 0 = [i|#{a}.#{b}.#{c}|]
show (AppVersion (a, b, c, d)) | d == 0 = [i|#{a}.#{b}.#{c}|]
| otherwise = [i|#{a}.#{b}.#{c}+#{d}|]
instance IsString AppVersion where
@@ -46,8 +47,7 @@ instance IsString AppVersion where
instance ToJSON AppVersion where
toJSON = String . show
instance FromJSON AppVersion where
parseJSON = withText "app version" $ \t ->
case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t of
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"
@@ -69,44 +69,50 @@ 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 == "*"
instance Read AppVersionSpec where
readsPrec _ s = if s == "*"
then [(AppVersionAny, "")]
else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
(Just m, Just av) -> [(AppVersionSpecification m av, "")]
(Just m, Just av) -> [(AppVersionSpec 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
toPathPiece = show
instance Show AppVersionSpecification where
instance Show AppVersionSpec where
show AppVersionAny = "*"
show (AppVersionSpecification r b) = show r <> show b
instance ToJSON AppVersionSpecification where
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 == "*"
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 $ AppVersionSpecification requestModifier baseVersion
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,8 +129,7 @@ instance Show SemverRequestModifier where
show SVGreaterThanEq = ">="
instance FromJSON SemverRequestModifier where
parseJSON = withText "semver request modifier" $ \t ->
case readMaybe . toS $ t of
parseJSON = withText "semver request modifier" $ \t -> case readMaybe . toS $ t of
Just m -> pure m
Nothing -> fail "invalid semver request modifier"
@@ -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)

5
src/Model.hs
View File

@@ -1,8 +1,11 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Model where
@@ -30,6 +33,8 @@ Version
appId SAppId
number AppVersion
releaseNotes Text
osVersionRequired AppVersionSpec default='*'
osVersionRecommended AppVersionSpec default='*'
UniqueBin appId number
deriving Eq
deriving Show

55
src/Settings.hs
View File

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

24
src/Startlude.hs
View File

@@ -4,14 +4,28 @@ module Startlude
)
where
import Control.Arrow as X ((&&&))
import Control.Comonad as X
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.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 Protolude as X
hiding ( bool
, hush
, isLeft
, isRight
, note
, readMaybe
, tryIO
, (<.>)
)
import qualified Protolude as P
( readMaybe )
id :: a -> a
id = identity

10
stack.yaml
View File

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