removes compatibility dependency, filters apps/versions based off of user agent header

2026-03-31 20:23:39 +00:00 · 2020-09-21 17:45:23 -06:00
parent 4a8a0588b0
commit a192bce08c
15 changed files with 293 additions and 242 deletions
--- a/src/Lib/Error.hs
+++ b/src/Lib/Error.hs
@@ -8,7 +8,8 @@ import           Yesod.Core

 type S9ErrT m = ExceptT S9Error m

-data S9Error = PersistentE Text deriving (Show, Eq)
+data S9Error = PersistentE Text
+    deriving (Show, Eq)

 instance Exception S9Error

@@ -17,8 +18,7 @@ toError :: S9Error -> Error
 toError = \case
    PersistentE t -> Error DATABASE_ERROR t

-data ErrorCode =
-      DATABASE_ERROR
+data ErrorCode = DATABASE_ERROR
    deriving (Eq, Show)
 instance ToJSON ErrorCode where
    toJSON = String . show
@@ -26,12 +26,10 @@ instance ToJSON ErrorCode where
 data Error = Error
    { errorCode    :: ErrorCode
    , errorMessage :: Text
-    } deriving (Eq, Show)
+    }
+    deriving (Eq, Show)
 instance ToJSON Error where
-    toJSON Error{..} = object
-        [ "code" .= errorCode
-        , "message" .= errorMessage
-        ]
+    toJSON Error {..} = object ["code" .= errorCode, "message" .= errorMessage]
 instance ToContent Error where
    toContent = toContent . toJSON
 instance ToTypedContent Error where
@@ -48,15 +46,15 @@ toStatus = \case

 handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
 handleS9ErrT action = runExceptT action >>= \case
-    Left e -> toStatus >>= sendResponseStatus $ e
+    Left  e -> toStatus >>= sendResponseStatus $ e
    Right a -> pure a

 handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
 handleS9ErrNuclear action = runExceptT action >>= \case
-    Left e -> throwIO e
+    Left  e -> throwIO e
    Right a -> pure a

-errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a 
+errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a
 errOnNothing status res entity = case entity of
    Nothing -> sendResponseStatus status res
-    Just a -> pure a
+    Just a  -> pure a
--- a/src/Lib/Semver.hs
+++ b/src/Lib/Semver.hs
@@ -4,21 +4,17 @@ import           Startlude

 import           Lib.Types.Semver

-(<||) :: HasAppVersion a => a -> AppVersionSpecification -> Bool
-(<||) _ AppVersionAny                                 = True
-(<||) a (AppVersionSpecification SVEquals av1)        = version a == av1
-(<||) a (AppVersionSpecification SVLessThan av1)      = version a < av1
-(<||) a (AppVersionSpecification SVGreaterThan av1)   = version a > av1
-(<||) a (AppVersionSpecification SVLessThanEq av1)    = version a <= av1
-(<||) a (AppVersionSpecification SVGreaterThanEq av1) = version a >= av1
-(<||) a (AppVersionSpecification SVGreatestWithMajor av1) -- "maj.*"
-    = major av == major av1 && av >= av1
-    where
-        av = version a
-(<||) a (AppVersionSpecification SVGreatestWithMajorMinor av1) -- "maj.min.*"
-    = major av == major av1 && minor av == minor av1 && av >= av1
-    where
-        av = version a
+(<||) :: HasAppVersion a => a -> AppVersionSpec -> Bool
+(<||) _ AppVersionAny                            = True
+(<||) a (AppVersionSpec SVEquals            av1) = version a == av1
+(<||) a (AppVersionSpec SVLessThan          av1) = version a < av1
+(<||) a (AppVersionSpec SVGreaterThan       av1) = version a > av1
+(<||) a (AppVersionSpec SVLessThanEq        av1) = version a <= av1
+(<||) a (AppVersionSpec SVGreaterThanEq     av1) = version a >= av1
+(<||) a (AppVersionSpec SVGreatestWithMajor av1) = major av == major av1 && av >= av1 -- "maj.*"
+    where av = version a
+(<||) a (AppVersionSpec SVGreatestWithMajorMinor av1) = major av == major av1 && minor av == minor av1 && av >= av1 -- "maj.min.*"
+    where av = version a

 major :: AppVersion -> Word16
 major (AppVersion (a, _, _, _)) = a
@@ -32,7 +28,7 @@ build (AppVersion (_, _, _, a)) = a
 hasGiven :: (AppVersion -> Word16) -> AppVersion -> AppVersion -> Bool
 hasGiven projection av = (== projection av) . projection

-getSpecifiedAppVersion :: HasAppVersion a => AppVersionSpecification -> [a] -> Maybe a
+getSpecifiedAppVersion :: HasAppVersion a => AppVersionSpec -> [a] -> Maybe a
 getSpecifiedAppVersion avSpec = appVersionMax . filter (<|| avSpec)

 class HasAppVersion a where
@@ -43,4 +39,4 @@ instance HasAppVersion AppVersion where

 appVersionMax :: HasAppVersion a => [a] -> Maybe a
 appVersionMax [] = Nothing
-appVersionMax as = Just $ maximumBy (compare `on` version) as
+appVersionMax as = Just $ maximumBy (compare `on` version) as
--- a/src/Lib/Types/AppIndex.hs
+++ b/src/Lib/Types/AppIndex.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Lib.Types.AppIndex where
+
+import           Startlude
+
+import           Control.Monad.Fail
+import           Data.Aeson
+import qualified Data.HashMap.Strict           as HM
+import qualified Data.List.NonEmpty            as NE
+
+import           Lib.Semver
+import           Lib.Types.Semver
+
+type AppIdentifier = Text
+
+data VersionInfo = VersionInfo
+    { versionInfoVersion       :: AppVersion
+    , versionInfoReleaseNotes  :: Text
+    , versionInfoOsRequired    :: AppVersionSpec
+    , versionInfoOsRecommended :: AppVersionSpec
+    }
+    deriving (Eq, Show)
+
+instance Ord VersionInfo where
+    compare = compare `on` versionInfoVersion
+
+instance FromJSON VersionInfo where
+    parseJSON = withObject "version info" $ \o -> do
+        versionInfoVersion       <- o .: "version"
+        versionInfoReleaseNotes  <- o .: "release-notes"
+        versionInfoOsRequired    <- o .:? "os-version-required" .!= AppVersionAny
+        versionInfoOsRecommended <- o .:? "os-version-recommended" .!= AppVersionAny
+        pure VersionInfo { .. }
+
+instance ToJSON VersionInfo where
+    toJSON VersionInfo {..} = object
+        [ "version" .= versionInfoVersion
+        , "release-notes" .= versionInfoReleaseNotes
+        , "os-version-required" .= versionInfoOsRequired
+        , "os-version-recommended" .= versionInfoOsRecommended
+        ]
+
+data StoreApp = StoreApp
+    { storeAppTitle       :: Text
+    , storeAppDescShort   :: Text
+    , storeAppDescLong    :: Text
+    , storeAppVersionInfo :: NonEmpty VersionInfo
+    , storeAppIconType    :: Text
+    }
+    deriving Show
+
+instance ToJSON StoreApp where
+    toJSON StoreApp {..} = object
+        [ "title" .= storeAppTitle
+        , "icon-type" .= storeAppIconType
+        , "description" .= object ["short" .= storeAppDescShort, "long" .= storeAppDescLong]
+        , "version-info" .= storeAppVersionInfo
+        ]
+
+newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier StoreApp}
+    deriving (Show)
+
+instance FromJSON AppManifest where
+    parseJSON = withObject "app details to seed" $ \o -> do
+        apps <- for (HM.toList o) $ \(appId', c) -> do
+            appId               <- parseJSON $ String appId'
+            config              <- parseJSON c
+            storeAppTitle       <- config .: "title"
+            storeAppIconType    <- config .: "icon-type"
+            storeAppDescShort   <- config .: "description" >>= (.: "short")
+            storeAppDescLong    <- config .: "description" >>= (.: "long")
+            storeAppVersionInfo <- config .: "version-info" >>= \case
+                []       -> fail "No Valid Version Info"
+                (x : xs) -> pure $ x :| xs
+            return $ (appId, StoreApp { .. })
+        return $ AppManifest (HM.fromList apps)
+instance ToJSON AppManifest where
+    toJSON = toJSON . unAppManifest
+
+
+filterOsRequired :: AppVersion -> StoreApp -> Maybe StoreApp
+filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of
+    []       -> Nothing
+    (x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
+
+filterOsRecommended :: AppVersion -> StoreApp -> Maybe StoreApp
+filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of
+    []       -> Nothing
+    (x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
--- a/src/Lib/Types/Semver.hs
+++ b/src/Lib/Types/Semver.hs
@@ -4,14 +4,16 @@

 module Lib.Types.Semver where

-import           Startlude               hiding (break)
+import           Startlude               hiding ( break )

-import qualified GHC.Read                (Read (..))
-import qualified GHC.Show                (Show (..))
+import qualified GHC.Read                       ( Read(..) )
+import qualified GHC.Show                       ( Show(..) )

 import           Control.Monad.Fail
 import           Data.Aeson
-import           Data.Char               (isDigit)
+import qualified Data.Attoparsec.ByteString.Char8
+                                               as AttoBS
+import           Data.Char                      ( isDigit )
 import           Data.String.Interpolate
 import           Data.Text
 import           Yesod.Core
@@ -27,30 +29,28 @@ newtype AppVersion = AppVersion
 instance Read AppVersion where
    readsPrec _ s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of
        Just [major, minor, patch, build] -> [(AppVersion (major, minor, patch, build), "")]
-        Just [major, minor, patch]        -> [(AppVersion (major, minor, patch,     0), "")]
-        _                                 -> []
+        Just [major, minor, patch] -> [(AppVersion (major, minor, patch, 0), "")]
+        _ -> []
 instance PathPiece AppVersion where
    fromPathPiece = readMaybe . toS
-    toPathPiece = show
+    toPathPiece   = show

 instance Show AppVersion where
-    show (AppVersion (a, b, c, d))
-        | d == 0 = [i|#{a}.#{b}.#{c}|]
-        | otherwise = [i|#{a}.#{b}.#{c}+#{d}|]
+    show (AppVersion (a, b, c, d)) | d == 0    = [i|#{a}.#{b}.#{c}|]
+                                   | otherwise = [i|#{a}.#{b}.#{c}+#{d}|]

 instance IsString AppVersion where
    fromString s = case traverse (readMaybe . toS) $ splitOn "+" <=< splitOn "." $ (toS s) of
        Just [major, minor, patch, build] -> AppVersion (major, minor, patch, build)
-        Just [major, minor, patch]        -> AppVersion (major, minor, patch, 0)
-        _                                 -> panic . toS $ "Invalid App Version: " <> s
+        Just [major, minor, patch] -> AppVersion (major, minor, patch, 0)
+        _ -> panic . toS $ "Invalid App Version: " <> s
 instance ToJSON AppVersion where
    toJSON = String . show
 instance FromJSON AppVersion where
-    parseJSON = withText "app version" $ \t ->
-        case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t  of
-            Just [a, b, c, d] -> pure $ AppVersion (a, b, c, d)
-            Just [a, b, c]    -> pure $ AppVersion (a, b, c, 0)
-            _                 -> fail "unknown versioning"
+    parseJSON = withText "app version" $ \t -> case traverse (decode . toS) $ splitOn "+" <=< splitOn "." $ t of
+        Just [a, b, c, d] -> pure $ AppVersion (a, b, c, d)
+        Just [a, b, c]    -> pure $ AppVersion (a, b, c, 0)
+        _                 -> fail "unknown versioning"
 instance ToTypedContent AppVersion where
    toTypedContent = toTypedContent . toJSON
 instance ToContent AppVersion where
@@ -59,54 +59,60 @@ instance ToContent AppVersion where
 instance FromJSONKey AppVersion where
    fromJSONKey = FromJSONKeyTextParser $ \t -> case readMaybe (toS t) of
        Nothing -> fail "invalid app version"
-        Just x -> pure x
+        Just x  -> pure x

 instance PersistField AppVersion where
-    toPersistValue = toPersistValue @Text . show
+    toPersistValue   = toPersistValue @Text . show
    fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue

 instance PersistFieldSql AppVersion where
    sqlType _ = SqlString

 ------------------------------------------------------------------------------------------------------------------------
-- Semver AppVersionSpecification
+-- Semver AppVersionSpec
 ------------------------------------------------------------------------------------------------------------------------

-data AppVersionSpecification =
+data AppVersionSpec =
      AppVersionAny
-    | AppVersionSpecification SemverRequestModifier AppVersion
+    | AppVersionSpec SemverRequestModifier AppVersion
+    deriving Eq

-instance Read AppVersionSpecification where
-    readsPrec _ s =
-        if s == "*"
-            then [(AppVersionAny, "")]
-            else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
-                (Just m, Just av) -> [(AppVersionSpecification m av, "")]
-                _                 -> []
-        where
-            (svMod, version) = break isDigit . toS $ s
+instance Read AppVersionSpec where
+    readsPrec _ s = if s == "*"
+        then [(AppVersionAny, "")]
+        else case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
+            (Just m, Just av) -> [(AppVersionSpec m av, "")]
+            _                 -> []
+        where (svMod, version) = break isDigit . toS $ s

-instance PathPiece AppVersionSpecification where
+instance PathPiece AppVersionSpec where
    fromPathPiece = readMaybe . toS
-    toPathPiece = show
+    toPathPiece   = show

-instance Show AppVersionSpecification where
-    show AppVersionAny                 = "*"
-    show (AppVersionSpecification r b) = show r <> show b
-instance ToJSON AppVersionSpecification where
+instance Show AppVersionSpec where
+    show AppVersionAny        = "*"
+    show (AppVersionSpec r b) = show r <> show b
+instance ToJSON AppVersionSpec where
    toJSON = String . show
-instance FromJSON AppVersionSpecification where
-    parseJSON = withText "app version spec" $ \t ->
-        if t == "*"
-            then pure AppVersionAny
-            else do
-                let (svMod, version) = break isDigit t
-                baseVersion <- parseJSON . String $ version
-                requestModifier <- parseJSON . String $ svMod
-                pure $ AppVersionSpecification requestModifier baseVersion
+instance FromJSON AppVersionSpec where
+    parseJSON = withText "app version spec" $ \t -> if t == "*"
+        then pure AppVersionAny
+        else do
+            let (svMod, version) = break isDigit t
+            baseVersion     <- parseJSON . String $ version
+            requestModifier <- parseJSON . String $ svMod
+            pure $ AppVersionSpec requestModifier baseVersion

-mostRecentVersion :: AppVersionSpecification
-mostRecentVersion = AppVersionSpecification SVGreaterThanEq $ AppVersion (0,0,0,0)
+instance PersistField AppVersionSpec where
+    toPersistValue = PersistText . show
+    fromPersistValue (PersistText spec) = note ("Invalid Semver Requirement: " <> spec) . readMaybe $ spec
+    fromPersistValue other              = Left $ "Persistent Type Mismatch. Expected 'PersistText _' got " <> show other
+
+instance PersistFieldSql AppVersionSpec where
+    sqlType _ = SqlString
+
+mostRecentVersion :: AppVersionSpec
+mostRecentVersion = AppVersionSpec SVGreaterThanEq $ AppVersion (0, 0, 0, 0)

 ------------------------------------------------------------------------------------------------------------------------
 -- Semver RequestModifier
@@ -123,10 +129,9 @@ instance Show SemverRequestModifier where
    show SVGreaterThanEq          = ">="

 instance FromJSON SemverRequestModifier where
-    parseJSON = withText "semver request modifier" $ \t ->
-        case readMaybe . toS $ t of
-            Just m  -> pure m
-            Nothing -> fail "invalid semver request modifier"
+    parseJSON = withText "semver request modifier" $ \t -> case readMaybe . toS $ t of
+        Just m  -> pure m
+        Nothing -> fail "invalid semver request modifier"

 instance Read SemverRequestModifier where
    readsPrec _ = \case
@@ -139,3 +144,11 @@ instance Read SemverRequestModifier where
        "<=" -> [(SVLessThanEq, "")]
        ">=" -> [(SVGreaterThanEq, "")]
        _    -> []
+
+semverParserBS :: AttoBS.Parser AppVersion
+semverParserBS = do
+    major <- AttoBS.decimal <* AttoBS.char '.'
+    minor <- AttoBS.decimal <* AttoBS.char '.'
+    patch <- AttoBS.decimal
+    build <- AttoBS.option 0 $ AttoBS.char '+' *> AttoBS.decimal
+    pure $ AppVersion (major, minor, patch, build)