From 28edfc2f87bb31df8e5dab824c3bd2a579cc9e94 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 28 Oct 2020 17:43:36 -0600 Subject: [PATCH] emver for registry appears complete, more testing required but should be ready for beta testing --- config/settings.yml | 1 + src/Application.hs | 39 ++++-- src/Database/Queries.hs | 25 ++-- src/Handler/Apps.hs | 38 +++--- src/Handler/Types/Status.hs | 14 +- src/Handler/Version.hs | 6 +- src/Lib/Registry.hs | 48 +++---- src/Lib/Semver.hs | 42 ------ src/Lib/Types/AppIndex.hs | 22 ++-- src/Lib/Types/Emver.hs | 256 ++++++++++++++++++++++++++++++++++++ src/Lib/Types/Semver.hs | 154 ---------------------- src/Model.hs | 13 +- src/Orphans/Emver.hs | 35 +++++ src/Settings.hs | 7 +- src/Util/Shared.hs | 10 +- stack.yaml | 4 +- 16 files changed, 416 insertions(+), 298 deletions(-) delete mode 100644 src/Lib/Semver.hs create mode 100644 src/Lib/Types/Emver.hs delete mode 100644 src/Lib/Types/Semver.hs create mode 100644 src/Orphans/Emver.hs diff --git a/config/settings.yml b/config/settings.yml index f2222e1..6b4d3c2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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/" diff --git a/src/Application.hs b/src/Application.hs index 8576c3f..02ee5c5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -174,20 +174,21 @@ appMain = do startApp :: RegistryCtx -> IO () startApp foundation = do - -- set up ssl certificates - putStrLn @Text "Setting up SSL" - _ <- setupSsl $ appSettings foundation - putStrLn @Text "SSL Setup Complete" + when (sslAuto . appSettings $ foundation) $ do + -- set up ssl certificates + putStrLn @Text "Setting up SSL" + _ <- setupSsl $ appSettings foundation + putStrLn @Text "SSL Setup Complete" - -- certbot renew loop - void . forkIO $ forever $ flip runReaderT foundation $ do - shouldRenew <- doesSslNeedRenew - putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew - when shouldRenew $ do - putStrLn @Text "Renewing SSL Certs." - renewSslCerts - liftIO $ restartWeb foundation - liftIO $ sleep 86_400 + -- certbot renew loop + void . forkIO $ forever $ flip runReaderT foundation $ do + shouldRenew <- doesSslNeedRenew + putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew + when shouldRenew $ do + putStrLn @Text "Renewing SSL Certs." + renewSslCerts + liftIO $ restartWeb foundation + liftIO $ sleep 86_400 startWeb 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 diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index d82e64e..3ab607d 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -7,32 +7,33 @@ 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 - Nothing - sId - versionInfoVersion - versionInfoReleaseNotes - versionInfoOsRequired - versionInfoOsRecommended + insertUnique $ SVersion time + Nothing + sId + versionInfoVersion + versionInfoReleaseNotes + 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 diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 443b26f..15bb4f8 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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 @@ -91,30 +91,28 @@ getSysR e = do getAppManifestR :: AppIdentifier -> Handler TypedContent getAppManifestR appId = do appSettings <- appSettings <$> getYesod - let appsDir = ( "apps") . resourcesDir $ appSettings + let appsDir = ( "apps") . resourcesDir $ appSettings let appMgrDir = staticBinDir $ appSettings av <- getVersionFromQuery appsDir appExt >>= \case Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text) - Just v -> pure v + Just v -> pure v 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 appSettings <- appSettings <$> getYesod - let appsDir = ( "apps") . resourcesDir $ appSettings + let appsDir = ( "apps") . resourcesDir $ appSettings let appMgrDir = staticBinDir $ appSettings av <- getVersionFromQuery appsDir appExt >>= \case Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text) - Just v -> pure v + Just v -> pure v 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 diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index e37be56..56af484 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -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] diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index fe1f65e..a746450 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -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,10 +34,10 @@ 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) getVersionWSpec rootDir ext = do av <- getVersionFromQuery rootDir ext - pure $ liftA2 AppVersionRes av (pure Nothing) \ No newline at end of file + pure $ liftA2 AppVersionRes av (pure Nothing) diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs index 0db0957..7889ecb 100644 --- a/src/Lib/Registry.hs +++ b/src/Lib/Registry.hs @@ -7,37 +7,40 @@ module Lib.Registry where import Startlude -import Data.HashMap.Lazy hiding (mapMaybe) -import qualified GHC.Read (Read (..)) -import qualified GHC.Show (Show (..)) +import qualified Data.Attoparsec.Text as Atto +import Data.HashMap.Lazy hiding ( mapMaybe ) +import qualified GHC.Read ( Read(..) ) +import qualified GHC.Show ( Show(..) ) 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 - Nothing -> pure Nothing - Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile) + 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) @@ -65,16 +68,15 @@ instance KnownSymbol a => Show (Extension a) where 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 + other -> [ (Extension file, "") | ext' == "" <.> other ] + where (file, ext') = splitExtension s withPeriod :: String -> String -withPeriod word@(a:_) = case a of +withPeriod word@(a : _) = case a of '.' -> word _ -> "." <> word withPeriod word = word instance KnownSymbol a => PathPiece (Extension a) where fromPathPiece = readMaybe . toS - toPathPiece = show + toPathPiece = show diff --git a/src/Lib/Semver.hs b/src/Lib/Semver.hs deleted file mode 100644 index b11796c..0000000 --- a/src/Lib/Semver.hs +++ /dev/null @@ -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 diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index b360e94..2d9e0fb 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -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 } diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs new file mode 100644 index 0000000..b528f11 --- /dev/null +++ b/src/Lib/Types/Emver.hs @@ -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 . 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) diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs deleted file mode 100644 index 4da86e4..0000000 --- a/src/Lib/Types/Semver.hs +++ /dev/null @@ -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) diff --git a/src/Model.hs b/src/Model.hs index d10803f..54edc0b 100644 --- a/src/Model.hs +++ b/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 |] diff --git a/src/Orphans/Emver.hs b/src/Orphans/Emver.hs new file mode 100644 index 0000000..24976a3 --- /dev/null +++ b/src/Orphans/Emver.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index e6160f4..a6910db 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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" diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index dc3c590..c183e1e 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -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 \ No newline at end of file + let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions + let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory + pure best diff --git a/stack.yaml b/stack.yaml index ba07302..32c982b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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