mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
emver for registry appears complete, more testing required but should be ready for beta testing
This commit is contained in:
Keagan McClelland
@@ -30,6 +30,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
|
||||
|
||||
resources-path: "_env:RESOURCES_PATH:/var/www/html/resources"
|
||||
ssl-path: "_env:SSL_PATH:/var/ssl"
|
||||
ssl-auto: "_env:SSL_AUTO:true"
|
||||
registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"
|
||||
tor-port: "_env:TOR_PORT:447"
|
||||
static-bin-dir: "_env:STATIC_BIN:/usr/local/bin/"
|
||||
|
||||
@@ -174,6 +174,7 @@ appMain = do
|
||||
|
||||
startApp :: RegistryCtx -> IO ()
|
||||
startApp foundation = do
|
||||
when (sslAuto . appSettings $ foundation) $ do
|
||||
-- set up ssl certificates
|
||||
putStrLn @Text "Setting up SSL"
|
||||
_ <- setupSsl $ appSettings foundation
|
||||
@@ -207,7 +208,17 @@ startWeb foundation = do
|
||||
let actions = (action, torAction)
|
||||
|
||||
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)
|
||||
when shouldRestart $ do
|
||||
putMVar (appShouldRestartWeb foundation) False
|
||||
|
||||
@@ -7,24 +7,25 @@ module Database.Queries where
|
||||
import Startlude
|
||||
import Database.Persist.Sql
|
||||
import Lib.Types.AppIndex
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
import Model
|
||||
import Orphans.Emver ( )
|
||||
|
||||
fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp))
|
||||
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 :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion))
|
||||
fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] []
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
time <- liftIO getCurrentTime
|
||||
insertUnique $ Version time
|
||||
insertUnique $ SVersion time
|
||||
Nothing
|
||||
sId
|
||||
versionInfoVersion
|
||||
@@ -32,7 +33,7 @@ createAppVersion sId VersionInfo {..} = do
|
||||
versionInfoOsRequired
|
||||
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
|
||||
time <- liftIO $ getCurrentTime
|
||||
insert_ $ Metric time appId versionId
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@@ -11,8 +12,7 @@ import Startlude
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Data.Aeson
|
||||
import qualified Data.Attoparsec.ByteString.Char8
|
||||
as Atto
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Char
|
||||
import Data.Conduit
|
||||
@@ -35,9 +35,8 @@ import Yesod.Persist.Core
|
||||
|
||||
import Foundation
|
||||
import Lib.Registry
|
||||
import Lib.Semver
|
||||
import Lib.Types.AppIndex
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
import Lib.Types.FileSystem
|
||||
import Lib.Error
|
||||
import Lib.External.AppMgr
|
||||
@@ -58,15 +57,16 @@ instance Show FileExtension where
|
||||
show (FileExtension f Nothing ) = f
|
||||
show (FileExtension f (Just e)) = f <.> e
|
||||
|
||||
userAgentOsVersionParser :: Atto.Parser AppVersion
|
||||
userAgentOsVersionParser :: Atto.Parser Version
|
||||
userAgentOsVersionParser = do
|
||||
void $ (Atto.string "EmbassyOS" <|> Atto.string "AmbassadorOS" <|> Atto.string "MeshOS") *> Atto.char '/'
|
||||
semverParserBS
|
||||
parseVersion
|
||||
|
||||
getEmbassyOsVersion :: Handler (Maybe AppVersion)
|
||||
getEmbassyOsVersion :: Handler (Maybe Version)
|
||||
getEmbassyOsVersion = userAgentOsVersion
|
||||
where
|
||||
userAgentOsVersion = (hush . Atto.parseOnly userAgentOsVersionParser <=< requestHeaderUserAgent) <$> waiRequest
|
||||
userAgentOsVersion =
|
||||
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
|
||||
|
||||
getAppsManifestR :: Handler TypedContent
|
||||
getAppsManifestR = do
|
||||
@@ -99,8 +99,7 @@ getAppManifestR appId = do
|
||||
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
|
||||
manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt
|
||||
pure $ TypedContent "application/json" (toContent manifest)
|
||||
where
|
||||
appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
where appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
|
||||
getAppConfigR :: AppIdentifier -> Handler TypedContent
|
||||
getAppConfigR appId = do
|
||||
@@ -113,8 +112,7 @@ getAppConfigR appId = do
|
||||
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
|
||||
config <- handleS9ErrT $ getConfig appMgrDir appDir appExt
|
||||
pure $ TypedContent "application/json" (toContent config)
|
||||
where
|
||||
appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
where appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
|
||||
getAppR :: Extension "s9pk" -> Handler TypedContent
|
||||
getAppR e = do
|
||||
@@ -129,7 +127,9 @@ getApp rootDir ext@(Extension appId) = do
|
||||
Just t -> pure t
|
||||
appVersions <- liftIO $ getAvailableAppVersions rootDir ext
|
||||
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
|
||||
Just (RegisteredAppVersion (appVersion, filePath)) -> do
|
||||
exists <- liftIO $ doesFileExist filePath >>= \case
|
||||
@@ -137,7 +137,7 @@ getApp rootDir ext@(Extension appId) = do
|
||||
False -> pure NonExistent
|
||||
determineEvent exists (extension ext) filePath appVersion
|
||||
where
|
||||
determineEvent :: FileExistence -> String -> FilePath -> AppVersion -> HandlerFor RegistryCtx TypedContent
|
||||
determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent
|
||||
-- for app files
|
||||
determineEvent Existent "s9pk" fp av = do
|
||||
_ <- recordMetrics appId rootDir av
|
||||
@@ -152,7 +152,7 @@ chunkIt fp = do
|
||||
addHeader "Content-Length" (show sz)
|
||||
respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS
|
||||
|
||||
recordMetrics :: String -> FilePath -> AppVersion -> HandlerFor RegistryCtx ()
|
||||
recordMetrics :: String -> FilePath -> Version -> HandlerFor RegistryCtx ()
|
||||
recordMetrics appId rootDir appVersion = do
|
||||
let appId' = T.pack appId
|
||||
manifest <- liftIO $ getAppManifest rootDir
|
||||
|
||||
@@ -7,15 +7,17 @@ import Startlude
|
||||
import Data.Aeson
|
||||
import Yesod.Core.Content
|
||||
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
import Orphans.Emver ( )
|
||||
|
||||
data AppVersionRes = AppVersionRes
|
||||
{ appVersionVersion :: AppVersion
|
||||
, appVersionMinCompanion :: Maybe AppVersion
|
||||
} deriving (Eq, Show)
|
||||
{ appVersionVersion :: Version
|
||||
, appVersionMinCompanion :: Maybe Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppVersionRes where
|
||||
toJSON AppVersionRes{ appVersionVersion, appVersionMinCompanion } = object $
|
||||
["version" .= appVersionVersion] <> case appVersionMinCompanion of
|
||||
toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion } =
|
||||
object $ ["version" .= appVersionVersion] <> case appVersionMinCompanion of
|
||||
Nothing -> []
|
||||
Just x -> ["minCompanion" .= x]
|
||||
|
||||
|
||||
@@ -14,7 +14,7 @@ import Yesod.Core
|
||||
import Foundation
|
||||
import Handler.Types.Status
|
||||
import Lib.Registry
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
import Settings
|
||||
import System.FilePath ( (</>) )
|
||||
import Util.Shared
|
||||
@@ -34,7 +34,7 @@ getVersionSysR :: Text -> Handler (Maybe AppVersionRes)
|
||||
getVersionSysR sysAppId = runMaybeT $ do
|
||||
sysDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
|
||||
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 ""
|
||||
|
||||
getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes)
|
||||
|
||||
@@ -7,6 +7,7 @@ module Lib.Registry where
|
||||
|
||||
import Startlude
|
||||
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import Data.HashMap.Lazy hiding ( mapMaybe )
|
||||
import qualified GHC.Read ( Read(..) )
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
@@ -14,30 +15,32 @@ import System.Directory
|
||||
import System.FilePath
|
||||
import Yesod.Core
|
||||
|
||||
import Lib.Semver
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
|
||||
type Registry = HashMap String (HashMap AppVersion FilePath)
|
||||
type Registry = HashMap String (HashMap Version FilePath)
|
||||
|
||||
newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath) deriving (Eq, Show)
|
||||
instance HasAppVersion RegisteredAppVersion where
|
||||
version (RegisteredAppVersion (av, _)) = av
|
||||
newtype RegisteredAppVersion = RegisteredAppVersion { unRegisteredAppVersion :: (Version, FilePath) } deriving (Eq, Show)
|
||||
data MaxVersion a = MaxVersion
|
||||
{ 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
|
||||
getAvailableAppVersions :: KnownSymbol a => FilePath -> Extension a -> IO [RegisteredAppVersion]
|
||||
getAvailableAppVersions rootDirectory ext@(Extension appId) = do
|
||||
versions <- mapMaybe (readMaybe . toS) <$> getSubDirectories (rootDirectory </> appId)
|
||||
fmap catMaybes . for versions $ \v ->
|
||||
getVersionedFileFromDir rootDirectory ext v
|
||||
>>= \case
|
||||
versions <- mapMaybe (hush . Atto.parseOnly parseVersion . toS) <$> getSubDirectories (rootDirectory </> appId)
|
||||
fmap catMaybes . for versions $ \v -> getVersionedFileFromDir rootDirectory ext v >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile)
|
||||
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
|
||||
getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> AppVersion -> IO (Maybe FilePath)
|
||||
getVersionedFileFromDir rootDirectory ext@(Extension appId) v = getUnversionedFileFromDir (rootDirectory </> appId </> show v) ext
|
||||
getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> Version -> IO (Maybe FilePath)
|
||||
getVersionedFileFromDir rootDirectory ext@(Extension appId) v =
|
||||
getUnversionedFileFromDir (rootDirectory </> appId </> show v) ext
|
||||
|
||||
-- /root/appId.ext
|
||||
getUnversionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe FilePath)
|
||||
@@ -66,8 +69,7 @@ instance KnownSymbol a => Read (Extension a) where
|
||||
readsPrec _ s = case (symbolVal $ Proxy @a) of
|
||||
"" -> [(Extension s, "")]
|
||||
other -> [ (Extension file, "") | ext' == "" <.> other ]
|
||||
where
|
||||
(file, ext') = splitExtension s
|
||||
where (file, ext') = splitExtension s
|
||||
|
||||
withPeriod :: String -> String
|
||||
withPeriod word@(a : _) = case a of
|
||||
|
||||
@@ -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
|
||||
@@ -2,24 +2,24 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Lib.Types.AppIndex where
|
||||
|
||||
import Startlude
|
||||
import Startlude hiding ( Any )
|
||||
|
||||
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
|
||||
import Lib.Types.Emver
|
||||
import Orphans.Emver ( )
|
||||
|
||||
type AppIdentifier = Text
|
||||
|
||||
data VersionInfo = VersionInfo
|
||||
{ versionInfoVersion :: AppVersion
|
||||
{ versionInfoVersion :: Version
|
||||
, versionInfoReleaseNotes :: Text
|
||||
, versionInfoDependencies :: HM.HashMap Text AppVersionSpec
|
||||
, versionInfoOsRequired :: AppVersionSpec
|
||||
, versionInfoOsRecommended :: AppVersionSpec
|
||||
, versionInfoDependencies :: HM.HashMap Text VersionRange
|
||||
, versionInfoOsRequired :: VersionRange
|
||||
, versionInfoOsRecommended :: VersionRange
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -31,8 +31,8 @@ instance FromJSON VersionInfo where
|
||||
versionInfoVersion <- o .: "version"
|
||||
versionInfoReleaseNotes <- o .: "release-notes"
|
||||
versionInfoDependencies <- o .:? "dependencies" .!= HM.empty
|
||||
versionInfoOsRequired <- o .:? "os-version-required" .!= AppVersionAny
|
||||
versionInfoOsRecommended <- o .:? "os-version-recommended" .!= AppVersionAny
|
||||
versionInfoOsRequired <- o .:? "os-version-required" .!= Any
|
||||
versionInfoOsRecommended <- o .:? "os-version-recommended" .!= Any
|
||||
pure VersionInfo { .. }
|
||||
|
||||
instance ToJSON VersionInfo where
|
||||
@@ -82,12 +82,12 @@ instance ToJSON AppManifest where
|
||||
toJSON = toJSON . unAppManifest
|
||||
|
||||
|
||||
filterOsRequired :: AppVersion -> StoreApp -> Maybe StoreApp
|
||||
filterOsRequired :: Version -> 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 :: Version -> StoreApp -> Maybe StoreApp
|
||||
filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of
|
||||
[] -> Nothing
|
||||
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
|
||||
|
||||
256
src/Lib/Types/Emver.hs
Normal file
256
src/Lib/Types/Emver.hs
Normal 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)
|
||||
@@ -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
13
src/Model.hs
@@ -11,7 +11,8 @@ module Model where
|
||||
|
||||
import Startlude
|
||||
import Database.Persist.TH
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
import Orphans.Emver ( )
|
||||
|
||||
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
||||
@@ -27,14 +28,14 @@ SApp
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
Version
|
||||
SVersion sql=version
|
||||
createdAt UTCTime
|
||||
updatedAt UTCTime Maybe
|
||||
appId SAppId
|
||||
number AppVersion
|
||||
number Version
|
||||
releaseNotes Text
|
||||
osVersionRequired AppVersionSpec default='*'
|
||||
osVersionRecommended AppVersionSpec default='*'
|
||||
osVersionRequired VersionRange default='*'
|
||||
osVersionRecommended VersionRange default='*'
|
||||
UniqueBin appId number
|
||||
deriving Eq
|
||||
deriving Show
|
||||
@@ -43,7 +44,7 @@ Version
|
||||
Metric
|
||||
createdAt UTCTime
|
||||
appId SAppId
|
||||
version VersionId
|
||||
version SVersionId
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|]
|
||||
|
||||
35
src/Orphans/Emver.hs
Normal file
35
src/Orphans/Emver.hs
Normal 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
|
||||
@@ -23,8 +23,9 @@ import Network.Wai.Handler.Warp ( HostPreference )
|
||||
import System.FilePath ( (</>) )
|
||||
import Yesod.Default.Config2 ( configSettingsYml )
|
||||
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
import Lib.Types.AppIndex
|
||||
import Orphans.Emver ( )
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
-- theoretically even a database.
|
||||
@@ -44,8 +45,9 @@ data AppSettings = AppSettings
|
||||
-- ^ Should all log messages be displayed?
|
||||
, resourcesDir :: FilePath
|
||||
, sslPath :: FilePath
|
||||
, sslAuto :: Bool
|
||||
, registryHostname :: Text
|
||||
, registryVersion :: AppVersion
|
||||
, registryVersion :: Version
|
||||
, sslKeyLocation :: FilePath
|
||||
, sslCsrLocation :: FilePath
|
||||
, sslCertLocation :: FilePath
|
||||
@@ -63,6 +65,7 @@ instance FromJSON AppSettings where
|
||||
appShouldLogAll <- o .:? "should-log-all" .!= False
|
||||
resourcesDir <- o .: "resources-path"
|
||||
sslPath <- o .: "ssl-path"
|
||||
sslAuto <- o .: "ssl-auto"
|
||||
registryHostname <- o .: "registry-hostname"
|
||||
torPort <- o .: "tor-port"
|
||||
staticBinDir <- o .: "static-bin-dir"
|
||||
|
||||
@@ -9,14 +9,16 @@ import Yesod.Core
|
||||
|
||||
import Foundation
|
||||
import Lib.Registry
|
||||
import Lib.Semver
|
||||
import Lib.Types.Semver
|
||||
import Lib.Types.Emver
|
||||
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
|
||||
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
|
||||
spec <- case readMaybe specString of
|
||||
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
|
||||
Just t -> pure t
|
||||
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
|
||||
|
||||
@@ -65,5 +65,5 @@ extra-deps:
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
# docker:
|
||||
# enable: true
|
||||
docker:
|
||||
enable: true
|
||||
|
||||
Reference in New Issue
Block a user