Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-30 19:54:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

emver for registry appears complete, more testing required but should be ready for beta testing

Browse Source
This commit is contained in:
Keagan McClelland
2020-10-28 17:43:36 -06:00
parent 8cad3095fa
commit 28edfc2f87
16 changed files with 416 additions and 298 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

@@ -30,6 +30,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
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"
ssl-auto: "_env:SSL_AUTO:true"
registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com" registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"
tor-port: "_env:TOR_PORT:447" tor-port: "_env:TOR_PORT:447"
static-bin-dir: "_env:STATIC_BIN:/usr/local/bin/" static-bin-dir: "_env:STATIC_BIN:/usr/local/bin/"

39
src/Application.hs
View File

@@ -174,20 +174,21 @@ appMain = do
startApp :: RegistryCtx -> IO () startApp :: RegistryCtx -> IO ()
startApp foundation = do startApp foundation = do
-- set up ssl certificates when (sslAuto . appSettings $ foundation) $ do
putStrLn @Text "Setting up SSL" -- set up ssl certificates
_ <- setupSsl $ appSettings foundation putStrLn @Text "Setting up SSL"
putStrLn @Text "SSL Setup Complete" _ <- setupSsl $ appSettings foundation
putStrLn @Text "SSL Setup Complete"
-- certbot renew loop -- certbot renew loop
void . forkIO $ forever $ flip runReaderT foundation $ do void . forkIO $ forever $ flip runReaderT foundation $ do
shouldRenew <- doesSslNeedRenew shouldRenew <- doesSslNeedRenew
putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew
when shouldRenew $ do when shouldRenew $ do
putStrLn @Text "Renewing SSL Certs." putStrLn @Text "Renewing SSL Certs."
renewSslCerts renewSslCerts
liftIO $ restartWeb foundation liftIO $ restartWeb foundation
liftIO $ sleep 86_400 liftIO $ sleep 86_400
startWeb foundation startWeb foundation
@@ -207,7 +208,17 @@ startWeb foundation = do
let actions = (action, torAction) let actions = (action, torAction)
setWebProcessThreadId (join (***) asyncThreadId actions) foundation setWebProcessThreadId (join (***) asyncThreadId actions) foundation
void $ both waitCatch actions (clearRes, torRes) <- both waitCatch actions
case clearRes of
Left e -> do
putStr @Text "Clearnet ServerError: "
print e
Right _ -> pure ()
case torRes of
Left e -> do
putStr @Text "Tor ServerError: "
print e
Right _ -> pure ()
shouldRestart <- takeMVar (appShouldRestartWeb foundation) shouldRestart <- takeMVar (appShouldRestartWeb foundation)
when shouldRestart $ do when shouldRestart $ do
putMVar (appShouldRestartWeb foundation) False putMVar (appShouldRestartWeb foundation) False

25
src/Database/Queries.hs
View File

@@ -7,32 +7,33 @@ module Database.Queries where
import Startlude import Startlude
import Database.Persist.Sql import Database.Persist.Sql
import Lib.Types.AppIndex import Lib.Types.AppIndex
import Lib.Types.Semver import Lib.Types.Emver
import Model import Model
import Orphans.Emver ( )
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 => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion))
fetchAppVersion appVersion appId = selectFirst [VersionNumber ==. appVersion, VersionAppId ==. appId] [] fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. 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 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 :: MonadIO m => Key SApp -> VersionInfo -> ReaderT SqlBackend m (Maybe (Key SVersion))
createAppVersion sId VersionInfo {..} = do createAppVersion sId VersionInfo {..} = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
insertUnique $ Version time insertUnique $ SVersion time
Nothing Nothing
sId sId
versionInfoVersion versionInfoVersion
versionInfoReleaseNotes versionInfoReleaseNotes
versionInfoOsRequired versionInfoOsRequired
versionInfoOsRecommended versionInfoOsRecommended
createMetric :: MonadIO m => Key SApp -> Key Version -> ReaderT SqlBackend m () createMetric :: MonadIO m => Key SApp -> Key SVersion -> ReaderT SqlBackend m ()
createMetric appId versionId = do createMetric appId versionId = do
time <- liftIO $ getCurrentTime time <- liftIO $ getCurrentTime
insert_ $ Metric time appId versionId insert_ $ Metric time appId versionId

38
src/Handler/Apps.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@@ -11,8 +12,7 @@ import Startlude
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import qualified Data.Attoparsec.ByteString.Char8 import qualified Data.Attoparsec.Text as Atto
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
@@ -35,9 +35,8 @@ import Yesod.Persist.Core
import Foundation import Foundation
import Lib.Registry import Lib.Registry
import Lib.Semver
import Lib.Types.AppIndex import Lib.Types.AppIndex
import Lib.Types.Semver import Lib.Types.Emver
import Lib.Types.FileSystem import Lib.Types.FileSystem
import Lib.Error import Lib.Error
import Lib.External.AppMgr import Lib.External.AppMgr
@@ -58,15 +57,16 @@ 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 :: Atto.Parser Version
userAgentOsVersionParser = do userAgentOsVersionParser = do
void $ (Atto.string "EmbassyOS" <|> Atto.string "AmbassadorOS" <|> Atto.string "MeshOS") *> Atto.char '/' void $ (Atto.string "EmbassyOS" <|> Atto.string "AmbassadorOS" <|> Atto.string "MeshOS") *> Atto.char '/'
semverParserBS parseVersion
getEmbassyOsVersion :: Handler (Maybe AppVersion) getEmbassyOsVersion :: Handler (Maybe Version)
getEmbassyOsVersion = userAgentOsVersion getEmbassyOsVersion = userAgentOsVersion
where where
userAgentOsVersion = (hush . Atto.parseOnly userAgentOsVersionParser <=< requestHeaderUserAgent) <$> waiRequest userAgentOsVersion =
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
getAppsManifestR :: Handler TypedContent getAppsManifestR :: Handler TypedContent
getAppsManifestR = do getAppsManifestR = do
@@ -91,30 +91,28 @@ getSysR e = do
getAppManifestR :: AppIdentifier -> Handler TypedContent getAppManifestR :: AppIdentifier -> Handler TypedContent
getAppManifestR appId = do getAppManifestR appId = do
appSettings <- appSettings <$> getYesod appSettings <- appSettings <$> getYesod
let appsDir = (</> "apps") . resourcesDir $ appSettings let appsDir = (</> "apps") . resourcesDir $ appSettings
let appMgrDir = staticBinDir $ appSettings let appMgrDir = staticBinDir $ appSettings
av <- getVersionFromQuery appsDir appExt >>= \case av <- getVersionFromQuery appsDir appExt >>= \case
Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text) Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text)
Just v -> pure v Just v -> pure v
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt
pure $ TypedContent "application/json" (toContent manifest) pure $ TypedContent "application/json" (toContent manifest)
where where appExt = Extension (toS appId) :: Extension "s9pk"
appExt = Extension (toS appId) :: Extension "s9pk"
getAppConfigR :: AppIdentifier -> Handler TypedContent getAppConfigR :: AppIdentifier -> Handler TypedContent
getAppConfigR appId = do getAppConfigR appId = do
appSettings <- appSettings <$> getYesod appSettings <- appSettings <$> getYesod
let appsDir = (</> "apps") . resourcesDir $ appSettings let appsDir = (</> "apps") . resourcesDir $ appSettings
let appMgrDir = staticBinDir $ appSettings let appMgrDir = staticBinDir $ appSettings
av <- getVersionFromQuery appsDir appExt >>= \case av <- getVersionFromQuery appsDir appExt >>= \case
Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text) Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text)
Just v -> pure v Just v -> pure v
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
config <- handleS9ErrT $ getConfig appMgrDir appDir appExt config <- handleS9ErrT $ getConfig appMgrDir appDir appExt
pure $ TypedContent "application/json" (toContent config) pure $ TypedContent "application/json" (toContent config)
where where appExt = Extension (toS appId) :: Extension "s9pk"
appExt = Extension (toS appId) :: Extension "s9pk"
getAppR :: Extension "s9pk" -> Handler TypedContent getAppR :: Extension "s9pk" -> Handler TypedContent
getAppR e = do getAppR e = do
@@ -129,7 +127,9 @@ getApp rootDir ext@(Extension appId) = do
Just t -> pure t Just t -> pure t
appVersions <- liftIO $ getAvailableAppVersions rootDir ext appVersions <- liftIO $ getAvailableAppVersions rootDir ext
putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions
case getSpecifiedAppVersion spec appVersions of let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions
let best = fst . getMaxVersion <$> foldMap (Just . MaxVersion . (, fst . unRegisteredAppVersion)) satisfactory
case best of
Nothing -> notFound Nothing -> notFound
Just (RegisteredAppVersion (appVersion, filePath)) -> do Just (RegisteredAppVersion (appVersion, filePath)) -> do
exists <- liftIO $ doesFileExist filePath >>= \case exists <- liftIO $ doesFileExist filePath >>= \case
@@ -137,7 +137,7 @@ getApp rootDir ext@(Extension appId) = do
False -> pure NonExistent False -> pure NonExistent
determineEvent exists (extension ext) filePath appVersion determineEvent exists (extension ext) filePath appVersion
where where
determineEvent :: FileExistence -> String -> FilePath -> AppVersion -> HandlerFor RegistryCtx TypedContent determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent
-- for app files -- for app files
determineEvent Existent "s9pk" fp av = do determineEvent Existent "s9pk" fp av = do
_ <- recordMetrics appId rootDir av _ <- recordMetrics appId rootDir av
@@ -152,7 +152,7 @@ chunkIt fp = do
addHeader "Content-Length" (show sz) addHeader "Content-Length" (show sz)
respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS
recordMetrics :: String -> FilePath -> AppVersion -> HandlerFor RegistryCtx () recordMetrics :: String -> FilePath -> Version -> HandlerFor RegistryCtx ()
recordMetrics appId rootDir appVersion = do recordMetrics appId rootDir appVersion = do
let appId' = T.pack appId let appId' = T.pack appId
manifest <- liftIO $ getAppManifest rootDir manifest <- liftIO $ getAppManifest rootDir

14
src/Handler/Types/Status.hs
View File

@@ -7,15 +7,17 @@ import Startlude
import Data.Aeson import Data.Aeson
import Yesod.Core.Content import Yesod.Core.Content
import Lib.Types.Semver import Lib.Types.Emver
import Orphans.Emver ( )
data AppVersionRes = AppVersionRes data AppVersionRes = AppVersionRes
{ appVersionVersion :: AppVersion { appVersionVersion :: Version
, appVersionMinCompanion :: Maybe AppVersion , appVersionMinCompanion :: Maybe Version
} deriving (Eq, Show) }
deriving (Eq, Show)
instance ToJSON AppVersionRes where instance ToJSON AppVersionRes where
toJSON AppVersionRes{ appVersionVersion, appVersionMinCompanion } = object $ toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion } =
["version" .= appVersionVersion] <> case appVersionMinCompanion of object $ ["version" .= appVersionVersion] <> case appVersionMinCompanion of
Nothing -> [] Nothing -> []
Just x -> ["minCompanion" .= x] Just x -> ["minCompanion" .= x]

6
src/Handler/Version.hs
View File

@@ -14,7 +14,7 @@ import Yesod.Core
import Foundation import Foundation
import Handler.Types.Status import Handler.Types.Status
import Lib.Registry import Lib.Registry
import Lib.Types.Semver import Lib.Types.Emver
import Settings import Settings
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import Util.Shared import Util.Shared
@@ -34,10 +34,10 @@ 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
pure $ avr { appVersionMinCompanion = Just $ AppVersion (1, 1, 0, 0) } pure $ avr { appVersionMinCompanion = Just $ Version (1, 1, 0, 0) }
where sysExt = Extension (toS sysAppId) :: Extension "" 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
av <- getVersionFromQuery rootDir ext av <- getVersionFromQuery rootDir ext
pure $ liftA2 AppVersionRes av (pure Nothing) pure $ liftA2 AppVersionRes av (pure Nothing)

48
src/Lib/Registry.hs
View File

@@ -7,37 +7,40 @@ module Lib.Registry where
import Startlude import Startlude
import Data.HashMap.Lazy hiding (mapMaybe) import qualified Data.Attoparsec.Text as Atto
import qualified GHC.Read (Read (..)) import Data.HashMap.Lazy hiding ( mapMaybe )
import qualified GHC.Show (Show (..)) import qualified GHC.Read ( Read(..) )
import qualified GHC.Show ( Show(..) )
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import Yesod.Core import Yesod.Core
import Lib.Semver import Lib.Types.Emver
import Lib.Types.Semver
type Registry = HashMap String (HashMap AppVersion FilePath) type Registry = HashMap String (HashMap Version FilePath)
newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath) deriving (Eq, Show) newtype RegisteredAppVersion = RegisteredAppVersion { unRegisteredAppVersion :: (Version, FilePath) } deriving (Eq, Show)
instance HasAppVersion RegisteredAppVersion where data MaxVersion a = MaxVersion
version (RegisteredAppVersion (av, _)) = av { getMaxVersion :: (a, a -> Version)
}
instance Semigroup (MaxVersion a) where
(MaxVersion (a, f)) <> (MaxVersion (b, g)) = if f a > g b then MaxVersion (a, f) else MaxVersion (b, g)
-- retrieve all valid semver folder names with queried for file: rootDirectory/appId/[0.0.0 ...]/appId.extension -- retrieve all valid semver folder names with queried for file: rootDirectory/appId/[0.0.0 ...]/appId.extension
getAvailableAppVersions :: KnownSymbol a => FilePath -> Extension a -> IO [RegisteredAppVersion] getAvailableAppVersions :: KnownSymbol a => FilePath -> Extension a -> IO [RegisteredAppVersion]
getAvailableAppVersions rootDirectory ext@(Extension appId) = do getAvailableAppVersions rootDirectory ext@(Extension appId) = do
versions <- mapMaybe (readMaybe . toS) <$> getSubDirectories (rootDirectory </> appId) versions <- mapMaybe (hush . Atto.parseOnly parseVersion . toS) <$> getSubDirectories (rootDirectory </> appId)
fmap catMaybes . for versions $ \v -> fmap catMaybes . for versions $ \v -> getVersionedFileFromDir rootDirectory ext v >>= \case
getVersionedFileFromDir rootDirectory ext v Nothing -> pure Nothing
>>= \case Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile)
Nothing -> pure Nothing
Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile)
where where
getSubDirectories path = (fmap (fromRight []) . try @SomeException $ listDirectory path) >>= filterM (doesDirectoryExist . (path </>)) getSubDirectories path = (fmap (fromRight []) . try @SomeException $ listDirectory path)
>>= filterM (doesDirectoryExist . (path </>))
-- /root/appId/version/appId.ext -- /root/appId/version/appId.ext
getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> AppVersion -> IO (Maybe FilePath) getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> Version -> IO (Maybe FilePath)
getVersionedFileFromDir rootDirectory ext@(Extension appId) v = getUnversionedFileFromDir (rootDirectory </> appId </> show v) ext getVersionedFileFromDir rootDirectory ext@(Extension appId) v =
getUnversionedFileFromDir (rootDirectory </> appId </> show v) ext
-- /root/appId.ext -- /root/appId.ext
getUnversionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe FilePath) getUnversionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe FilePath)
@@ -65,16 +68,15 @@ instance KnownSymbol a => Show (Extension a) where
instance KnownSymbol a => Read (Extension a) where instance KnownSymbol a => Read (Extension a) where
readsPrec _ s = case (symbolVal $ Proxy @a) of readsPrec _ s = case (symbolVal $ Proxy @a) of
"" -> [(Extension s, "")] "" -> [(Extension s, "")]
other -> [(Extension file, "") | ext' == "" <.> other] other -> [ (Extension file, "") | ext' == "" <.> other ]
where where (file, ext') = splitExtension s
(file, ext') = splitExtension s
withPeriod :: String -> String withPeriod :: String -> String
withPeriod word@(a:_) = case a of withPeriod word@(a : _) = case a of
'.' -> word '.' -> word
_ -> "." <> word _ -> "." <> word
withPeriod word = word withPeriod word = word
instance KnownSymbol a => PathPiece (Extension a) where instance KnownSymbol a => PathPiece (Extension a) where
fromPathPiece = readMaybe . toS fromPathPiece = readMaybe . toS
toPathPiece = show toPathPiece = show

42
src/Lib/Semver.hs
View File

@@ -1,42 +0,0 @@
module Lib.Semver where
import Startlude
import Lib.Types.Semver
(<||) :: 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
minor :: AppVersion -> Word16
minor (AppVersion (_, a, _, _)) = a
patch :: AppVersion -> Word16
patch (AppVersion (_, _, a, _)) = a
build :: AppVersion -> Word16
build (AppVersion (_, _, _, a)) = a
hasGiven :: (AppVersion -> Word16) -> AppVersion -> AppVersion -> Bool
hasGiven projection av = (== projection av) . projection
getSpecifiedAppVersion :: HasAppVersion a => AppVersionSpec -> [a] -> Maybe a
getSpecifiedAppVersion avSpec = appVersionMax . filter (<|| avSpec)
class HasAppVersion a where
version :: a -> AppVersion
instance HasAppVersion AppVersion where
version = id
appVersionMax :: HasAppVersion a => [a] -> Maybe a
appVersionMax [] = Nothing
appVersionMax as = Just $ maximumBy (compare `on` version) as

22
src/Lib/Types/AppIndex.hs
View File

@@ -2,24 +2,24 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Lib.Types.AppIndex where module Lib.Types.AppIndex where
import Startlude import Startlude hiding ( Any )
import Control.Monad.Fail import Control.Monad.Fail
import Data.Aeson import Data.Aeson
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Lib.Semver import Lib.Types.Emver
import Lib.Types.Semver import Orphans.Emver ( )
type AppIdentifier = Text type AppIdentifier = Text
data VersionInfo = VersionInfo data VersionInfo = VersionInfo
{ versionInfoVersion :: AppVersion { versionInfoVersion :: Version
, versionInfoReleaseNotes :: Text , versionInfoReleaseNotes :: Text
, versionInfoDependencies :: HM.HashMap Text AppVersionSpec , versionInfoDependencies :: HM.HashMap Text VersionRange
, versionInfoOsRequired :: AppVersionSpec , versionInfoOsRequired :: VersionRange
, versionInfoOsRecommended :: AppVersionSpec , versionInfoOsRecommended :: VersionRange
} }
deriving (Eq, Show) deriving (Eq, Show)
@@ -31,8 +31,8 @@ instance FromJSON VersionInfo where
versionInfoVersion <- o .: "version" versionInfoVersion <- o .: "version"
versionInfoReleaseNotes <- o .: "release-notes" versionInfoReleaseNotes <- o .: "release-notes"
versionInfoDependencies <- o .:? "dependencies" .!= HM.empty versionInfoDependencies <- o .:? "dependencies" .!= HM.empty
versionInfoOsRequired <- o .:? "os-version-required" .!= AppVersionAny versionInfoOsRequired <- o .:? "os-version-required" .!= Any
versionInfoOsRecommended <- o .:? "os-version-recommended" .!= AppVersionAny versionInfoOsRecommended <- o .:? "os-version-recommended" .!= Any
pure VersionInfo { .. } pure VersionInfo { .. }
instance ToJSON VersionInfo where instance ToJSON VersionInfo where
@@ -82,12 +82,12 @@ instance ToJSON AppManifest where
toJSON = toJSON . unAppManifest toJSON = toJSON . unAppManifest
filterOsRequired :: AppVersion -> StoreApp -> Maybe StoreApp filterOsRequired :: Version -> StoreApp -> Maybe StoreApp
filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of
[] -> Nothing [] -> Nothing
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs } (x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
filterOsRecommended :: AppVersion -> StoreApp -> Maybe StoreApp filterOsRecommended :: Version -> StoreApp -> Maybe StoreApp
filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of
[] -> Nothing [] -> Nothing
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs } (x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }

256
src/Lib/Types/Emver.hs Normal file
View File

@@ -0,0 +1,256 @@
{- |
Module : Lib.Types.SemverQuad
Description : Semver with 4th digit extension
License : Start9 Non-Commercial
Maintainer : keagan@start9labs.com
Stability : experimental
Portability : portable
This module was designed to address the problem of releasing updates to Embassy Packages where the upstream project was
either unaware of or apathetic towards supporting their application on the Embassy platform. In most cases, the original
package will support <https://semver.org/spec/v2.0.0.html semver2>. This leaves us with the problem where we would like
to preserve the original package's version, since one of the goals of the Embassy platform is transparency. However, on
occasion, we have screwed up and published a version of a package that needed to have its metadata updated. In this
scenario we were left with the conundrum of either unilaterally claiming a version number of a package we did not author
or let the issue persist until the next update. Neither of these promote good user experiences, for different reasons.
This module extends the semver standard linked above with a 4th digit, which is given PATCH semantics.
-}
module Lib.Types.Emver
( major
, minor
, patch
, quad
, satisfies
, (<||)
, (||>)
-- we do not export 'None' because it is useful for its internal algebraic properties only
, VersionRange(Anchor, Any, None)
, Version(..)
, AnyRange(..)
, AllRange(..)
, conj
, disj
, exactly
, parseVersion
, parseRange
)
where
import Prelude
import qualified Data.Attoparsec.Text as Atto
import Data.Function
import Data.Functor ( (<&>)
, ($>)
)
import Control.Applicative ( liftA2
, Alternative((<|>))
)
import Data.String ( IsString(..) )
import qualified Data.Text as T
-- | AppVersion is the core representation of the SemverQuad type.
newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord)
instance Show Version where
show (Version (x, y, z, q)) =
let postfix = if q == 0 then "" else '.' : show q in show x <> "." <> show y <> "." <> show z <> postfix
instance IsString Version where
fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s)
-- | A change in the value found at 'major' implies a breaking change in the API that this version number describes
major :: Version -> Word
major (Version (x, _, _, _)) = x
-- | A change in the value found at 'minor' implies a backwards compatible addition to the API that this version number
-- describes
minor :: Version -> Word
minor (Version (_, y, _, _)) = y
-- | A change in the value found at 'patch' implies that the implementation of the API has changed without changing the
-- invariants promised by the API. In many cases this will be incremented when repairing broken functionality
patch :: Version -> Word
patch (Version (_, _, z, _)) = z
-- | This is the fundamentally new value in comparison to the original semver 2.0 specification. It is given the same
-- semantics as 'patch' above, which begs the question, when should you update this value instead of that one. Generally
-- speaking, if you are both the package author and maintainer, you should not ever increment this number, as it is
-- redundant with 'patch'. However, if you maintain a package on some distribution channel, and you are /not/ the
-- original author, then it is encouraged for you to increment 'quad' instead of 'patch'.
quad :: Version -> Word
quad (Version (_, _, _, q)) = q
-- | 'Operator' is the type that specifies how to compare against the target version. Right includes equality, Left
-- excludes it
type Operator = Either Ordering Ordering
-- | 'VersionRange' is the algebra of sets of versions. They can be constructed by having an 'Anchor' term which
-- compares against the target version, or can be described with 'Conj' which is a conjunction, or 'Disj', which is a
-- disjunction. The 'Any' and 'All' terms are primarily there to round out the algebra, but 'Any' is also exposed due to
-- its usage in semantic versioning in general. The 'None' term is not useful to the end user as there would be no
-- reasonable usage of it to describe version sets. It is included for its utility as a unit on 'Disj' and possibly as
-- a zero on 'Conj'
--
-- Laws (reflected in implementations of smart constructors):
-- Commutativity of conjunction: Conj a b === Conj b a
-- Commutativity of disjunction: Disj a b === Disj b a
-- Associativity of conjunction: Conj (Conj a b) c === Conj a (Conj b c)
-- Associativity of disjunction: Disj (Disj a b) c === Disj a (Disj b c)
-- Identity of conjunction: Any `Conj` a === a
-- Identity of disjunction: None `Disj` a === a
-- Zero of conjunction: None `Conj` a === None
-- Zero of disjunction: Any `Disj` a === Any
-- Distributivity of conjunction over disjunction: Conj a (Disj b c) === Disj (Conj a b) (Conj a c)
-- Distributivity of disjunction over conjunction: Disj a (Conj b c) === Conj (Disj a b) (Disj a c)
data VersionRange
= Anchor Operator Version
| Conj VersionRange VersionRange
| Disj VersionRange VersionRange
| Any
| None
deriving (Eq)
-- | Smart constructor for conjunctions. Eagerly evaluates zeros and identities
conj :: VersionRange -> VersionRange -> VersionRange
conj Any b = b
conj a Any = a
conj None _ = None
conj _ None = None
conj a b = Conj a b
-- | Smart constructor for disjunctions. Eagerly evaluates zeros and identities
disj :: VersionRange -> VersionRange -> VersionRange
disj Any _ = Any
disj _ Any = Any
disj None b = b
disj a None = a
disj a b = Disj a b
exactly :: Version -> VersionRange
exactly = Anchor (Left EQ)
instance Show VersionRange where
show (Anchor ( Left EQ) v ) = '=' : show v
show (Anchor ( Right EQ) v ) = '=' : show v
show (Anchor ( Left LT) v ) = '<' : show v
show (Anchor ( Right LT) v ) = '<' : '=' : show v
show (Anchor ( Left GT) v ) = '>' : show v
show (Anchor ( Right GT) v ) = '>' : '=' : show v
show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (show a) <> " " <> paren (show b)
show (Conj a@(Disj _ _) b ) = paren (show a) <> " " <> show b
show (Conj a b@(Disj _ _)) = show a <> " " <> paren (show b)
show (Conj a b ) = show a <> " " <> show b
show (Disj a b ) = show a <> " || " <> show b
show Any = "*"
show None = "!"
instance Read VersionRange where
readsPrec _ s = case Atto.parseOnly parseRange (T.pack s) of
Left _ -> []
Right a -> [(a, "")]
paren :: String -> String
paren = mappend "(" . flip mappend ")"
newtype AnyRange = AnyRange { unAnyRange :: VersionRange }
instance Semigroup AnyRange where
(<>) = AnyRange <<$>> disj `on` unAnyRange
instance Monoid AnyRange where
mempty = AnyRange None
newtype AllRange = AllRange { unAllRange :: VersionRange }
instance Semigroup AllRange where
(<>) = AllRange <<$>> conj `on` unAllRange
instance Monoid AllRange where
mempty = AllRange Any
-- | Predicate for deciding whether the 'Version' is in the 'VersionRange'
satisfies :: Version -> VersionRange -> Bool
satisfies v (Anchor op v') =
either (\c x y -> compare x y == c) (\c x y -> let c' = compare x y in c' == c || c' == EQ) op v v'
satisfies v (Conj a b) = v `satisfies` a && v `satisfies` b
satisfies v (Disj a b) = v `satisfies` a || v `satisfies` b
satisfies _ Any = True
satisfies _ None = False
(<||) :: Version -> VersionRange -> Bool
(<||) = satisfies
{-# INLINE (<||) #-}
(||>) :: VersionRange -> Version -> Bool
(||>) = flip satisfies
{-# INLINE (||>) #-}
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
(<<$>>) = fmap . fmap
{-# INLINE (<<$>>) #-}
parseOperator :: Atto.Parser Operator
parseOperator =
(Atto.char '=' $> Left EQ)
<|> (Atto.string ">=" $> Right GT)
<|> (Atto.string "<=" $> Right LT)
<|> (Atto.char '>' $> Left GT)
<|> (Atto.char '<' $> Left LT)
parseVersion :: Atto.Parser Version
parseVersion = do
major' <- Atto.decimal <* Atto.char '.'
minor' <- Atto.decimal <* Atto.char '.'
patch' <- Atto.decimal
quad' <- Atto.option 0 $ Atto.char '.' *> Atto.decimal
pure $ Version (major', minor', patch', quad')
-- >>> Atto.parseOnly parseRange "=2.3.4 1.2.3.4 - 2.3.4.5 (>3.0.0 || <3.4.5)"
-- Right =2.3.4 >=1.2.3.4 <=2.3.4.5 ((>3.0.0 || <3.4.5))
parseRange :: Atto.Parser VersionRange
parseRange = s <|> (Atto.char '*' *> pure Any)
where
sub = Atto.char '(' *> Atto.skipSpace *> parseRange <* Atto.skipSpace <* Atto.char ')'
s =
unAnyRange
. foldMap AnyRange
<$> ((p <|> sub) `Atto.sepBy1` (Atto.skipSpace *> Atto.string "||" <* Atto.skipSpace))
p = unAllRange . foldMap AllRange <$> ((a <|> sub) `Atto.sepBy1` Atto.space)
a = liftA2 Anchor parseOperator parseVersion <|> caret <|> tilde <|> wildcard <|> hyphen
-- >>> Atto.parseOnly parseRange "^2.3.4.5"
-- Right >=2.3.4.5 <3.0.0
caret :: Atto.Parser VersionRange
caret = (Atto.char '^' *> parseVersion) <&> \case
v@(Version (0, 0, 0, _)) -> Anchor (Left EQ) v
v@(Version (0, 0, z, _)) -> rangeIE v (Version (0, 0, z + 1, 0))
v@(Version (0, y, _, _)) -> rangeIE v (Version (0, y + 1, 0, 0))
v@(Version (x, _, _, _)) -> rangeIE v (Version (x + 1, 0, 0, 0))
-- >>> Atto.parseOnly tilde "~1.2.3.4"
-- Right >=1.2.3.4 <1.2.4
tilde :: Atto.Parser VersionRange
tilde = (Atto.char '~' *> (Atto.decimal `Atto.sepBy1` Atto.char '.')) >>= \case
[x, y, z, q] -> pure $ rangeIE (Version (x, y, z, q)) (Version (x, y, z + 1, 0))
[x, y, z] -> pure $ rangeIE (Version (x, y, z, 0)) (Version (x, y + 1, 0, 0))
[x, y] -> pure $ rangeIE (Version (x, y, 0, 0)) (Version (x, y + 1, 0, 0))
[x] -> pure $ rangeIE (Version (x, 0, 0, 0)) (Version (x + 1, 0, 0, 0))
o -> fail $ "Invalid number of version numbers: " <> show (length o)
range :: Bool -> Bool -> Version -> Version -> VersionRange
range inc0 inc1 v0 v1 =
let f = if inc0 then Right else Left
g = if inc1 then Right else Left
in Conj (Anchor (f GT) v0) (Anchor (g LT) v1)
rangeIE :: Version -> Version -> VersionRange
rangeIE = range True False
-- >>> Atto.parseOnly wildcard "1.2.3.x"
-- Right >=1.2.3 <1.2.4
wildcard :: Atto.Parser VersionRange
wildcard = (Atto.many1 (Atto.decimal <* Atto.char '.') <* Atto.char 'x') >>= \case
[x, y, z] -> pure $ rangeIE (Version (x, y, z, 0)) (Version (x, y, z + 1, 0))
[x, y] -> pure $ rangeIE (Version (x, y, 0, 0)) (Version (x, y + 1, 0, 0))
[x] -> pure $ rangeIE (Version (x, 0, 0, 0)) (Version (x + 1, 0, 0, 0))
o -> fail $ "Invalid number of version numbers: " <> show (length o)
-- >>> Atto.parseOnly hyphen "0.1.2.3 - 1.2.3.4"
-- Right >=0.1.2.3 <=1.2.3.4
hyphen :: Atto.Parser VersionRange
hyphen = liftA2 (range True True) parseVersion (Atto.skipSpace *> Atto.char '-' *> Atto.skipSpace *> parseVersion)

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

@@ -1,154 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Lib.Types.Semver where
import Startlude hiding ( break )
import qualified GHC.Read ( Read(..) )
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
import Yesod.Core
import Database.Persist.Sql
------------------------------------------------------------------------------------------------------------------------
-- Semver AppVersion
------------------------------------------------------------------------------------------------------------------------
newtype AppVersion = AppVersion
{ unAppVersion :: (Word16, Word16, Word16, Word16) } deriving (Eq, Ord, Hashable)
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), "")]
_ -> []
instance PathPiece AppVersion where
fromPathPiece = readMaybe . toS
toPathPiece = show
instance Show AppVersion where
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
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"
instance ToTypedContent AppVersion where
toTypedContent = toTypedContent . toJSON
instance ToContent AppVersion where
toContent = toContent . toJSON
instance FromJSONKey AppVersion where
fromJSONKey = FromJSONKeyTextParser $ \t -> case readMaybe (toS t) of
Nothing -> fail "invalid app version"
Just x -> pure x
instance PersistField AppVersion where
toPersistValue = toPersistValue @Text . show
fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue
instance PersistFieldSql AppVersion where
sqlType _ = SqlString
------------------------------------------------------------------------------------------------------------------------
-- Semver AppVersionSpec
------------------------------------------------------------------------------------------------------------------------
data AppVersionSpec =
AppVersionAny
| AppVersionSpec SemverRequestModifier AppVersion
deriving Eq
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 AppVersionSpec where
fromPathPiece = readMaybe . toS
toPathPiece = show
instance Show AppVersionSpec where
show AppVersionAny = "*"
show (AppVersionSpec r b) = show r <> show b
instance ToJSON AppVersionSpec where
toJSON = String . show
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
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
------------------------------------------------------------------------------------------------------------------------
data SemverRequestModifier = SVEquals | SVLessThan | SVGreaterThan | SVGreatestWithMajor | SVGreatestWithMajorMinor | SVLessThanEq | SVGreaterThanEq deriving (Eq, Bounded, Enum)
instance Show SemverRequestModifier where
show SVEquals = "="
show SVLessThan = "<"
show SVGreaterThan = ">"
show SVGreatestWithMajor = "~"
show SVGreatestWithMajorMinor = "^"
show SVLessThanEq = "<="
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"
instance Read SemverRequestModifier where
readsPrec _ = \case
"" -> [(SVGreatestWithMajorMinor, "")]
"=" -> [(SVEquals, "")]
"<" -> [(SVLessThan, "")]
">" -> [(SVGreaterThan, "")]
"~" -> [(SVGreatestWithMajor, "")]
"^" -> [(SVGreatestWithMajorMinor, "")]
"<=" -> [(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)

13
src/Model.hs
View File

@@ -11,7 +11,8 @@ module Model where
import Startlude import Startlude
import Database.Persist.TH import Database.Persist.TH
import Lib.Types.Semver import Lib.Types.Emver
import Orphans.Emver ( )
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
@@ -27,14 +28,14 @@ SApp
deriving Eq deriving Eq
deriving Show deriving Show
Version SVersion sql=version
createdAt UTCTime createdAt UTCTime
updatedAt UTCTime Maybe updatedAt UTCTime Maybe
appId SAppId appId SAppId
number AppVersion number Version
releaseNotes Text releaseNotes Text
osVersionRequired AppVersionSpec default='*' osVersionRequired VersionRange default='*'
osVersionRecommended AppVersionSpec default='*' osVersionRecommended VersionRange default='*'
UniqueBin appId number UniqueBin appId number
deriving Eq deriving Eq
deriving Show deriving Show
@@ -43,7 +44,7 @@ Version
Metric Metric
createdAt UTCTime createdAt UTCTime
appId SAppId appId SAppId
version VersionId version SVersionId
deriving Eq deriving Eq
deriving Show deriving Show
|] |]

35
src/Orphans/Emver.hs Normal file
View File

@@ -0,0 +1,35 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module is here for the express purpose of keeping ecosystem dependencies separate from the core library.
-- The core library should in theory be only dependent on base, text, and attoparsec. These are reasonable dependencies.
-- aeson, persistent, and yesod are not. So we put those here as they will not be extracted into a separate library.
module Orphans.Emver where
import Startlude
import Data.Aeson
import qualified Data.Attoparsec.Text as Atto
import Lib.Types.Emver
import Database.Persist.Sql
import qualified Data.Text as T
import Control.Monad.Fail ( MonadFail(fail) )
instance FromJSON Version where
parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion
instance ToJSON Version where
toJSON = String . show
instance FromJSON VersionRange where
parseJSON = withText "Emver" $ either fail pure . Atto.parseOnly parseRange
instance ToJSON VersionRange where
toJSON = String . show
instance PersistField Version where
toPersistValue = PersistText . show
fromPersistValue = first T.pack . Atto.parseOnly parseVersion <=< fromPersistValue
instance PersistFieldSql Version where
sqlType _ = SqlString
instance PersistField VersionRange where
toPersistValue = PersistText . show
fromPersistValue = first T.pack . Atto.parseOnly parseRange <=< fromPersistValue
instance PersistFieldSql VersionRange where
sqlType _ = SqlString

7
src/Settings.hs
View File

@@ -23,8 +23,9 @@ import Network.Wai.Handler.Warp ( HostPreference )
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import Yesod.Default.Config2 ( configSettingsYml ) import Yesod.Default.Config2 ( configSettingsYml )
import Lib.Types.Semver import Lib.Types.Emver
import Lib.Types.AppIndex import Lib.Types.AppIndex
import Orphans.Emver ( )
-- | 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.
@@ -44,8 +45,9 @@ data AppSettings = AppSettings
-- ^ Should all log messages be displayed? -- ^ Should all log messages be displayed?
, resourcesDir :: FilePath , resourcesDir :: FilePath
, sslPath :: FilePath , sslPath :: FilePath
, sslAuto :: Bool
, registryHostname :: Text , registryHostname :: Text
, registryVersion :: AppVersion , registryVersion :: Version
, sslKeyLocation :: FilePath , sslKeyLocation :: FilePath
, sslCsrLocation :: FilePath , sslCsrLocation :: FilePath
, sslCertLocation :: FilePath , sslCertLocation :: FilePath
@@ -63,6 +65,7 @@ instance FromJSON AppSettings where
appShouldLogAll <- o .:? "should-log-all" .!= False appShouldLogAll <- o .:? "should-log-all" .!= False
resourcesDir <- o .: "resources-path" resourcesDir <- o .: "resources-path"
sslPath <- o .: "ssl-path" sslPath <- o .: "ssl-path"
sslAuto <- o .: "ssl-auto"
registryHostname <- o .: "registry-hostname" registryHostname <- o .: "registry-hostname"
torPort <- o .: "tor-port" torPort <- o .: "tor-port"
staticBinDir <- o .: "static-bin-dir" staticBinDir <- o .: "static-bin-dir"

10
src/Util/Shared.hs
View File

@@ -9,14 +9,16 @@ import Yesod.Core
import Foundation import Foundation
import Lib.Registry import Lib.Registry
import Lib.Semver import Lib.Types.Emver
import Lib.Types.Semver import Data.Semigroup
getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersion) getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version)
getVersionFromQuery rootDir ext = do getVersionFromQuery 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
pure $ version <$> getSpecifiedAppVersion spec appVersions let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions
let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory
pure best

4
stack.yaml
View File

@@ -65,5 +65,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: docker:
# enable: true enable: true