diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index edf2aea..575461f 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -11,17 +11,18 @@ import Startlude import Control.Monad.Logger import Data.Aeson import qualified Data.ByteString.Lazy as BS +import Data.Char import Data.Conduit import qualified Data.Conduit.Binary as CB +import qualified Data.Text as T import qualified GHC.Show (Show (..)) +import Network.HTTP.Types import System.Directory import Yesod.Core import Foundation -import Handler.Types.Status import Lib.Registry import Lib.Semver -import Lib.Types.Semver import System.FilePath ((<.>)) import System.Posix.Files (fileSize, getFileStatus) @@ -47,7 +48,10 @@ getAppR = getApp appResourceDir getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent getApp rootDir ext = do - spec <- querySpecD mostRecentVersion <$> lookupGetParam "spec" + 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 putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions case getSpecifiedAppVersion spec appVersions of diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 7abbaf8..e37be56 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -29,9 +29,3 @@ instance ToContent (Maybe AppVersionRes) where toContent = toContent . toJSON instance ToTypedContent (Maybe AppVersionRes) where toTypedContent = toTypedContent . toJSON - -querySpec :: Maybe Text -> Maybe AppVersionSpecification -querySpec = (readMaybe . toS =<<) - -querySpecD :: AppVersionSpecification -> Maybe Text -> AppVersionSpecification -querySpecD defaultSpec = fromMaybe defaultSpec . querySpec diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 6cdae66..84a08a7 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -7,8 +7,10 @@ module Handler.Version where import Startlude import Control.Monad.Trans.Maybe +import Data.Char import qualified Data.HashMap.Strict as HM import Data.String.Interpolate.IsString +import qualified Data.Text as T import Network.HTTP.Types import Yesod.Core @@ -39,7 +41,10 @@ getVersionSysR sysAppId = runMaybeT $ do getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes) getVersionWSpec rootDir ext = do - spec <- querySpecD mostRecentVersion <$> lookupGetParam "spec" + 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 let av = version <$> getSpecifiedAppVersion spec appVersions pure $ liftA2 AppVersionRes av (pure Nothing) diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs index caa810b..3e3e288 100644 --- a/src/Lib/Registry.hs +++ b/src/Lib/Registry.hs @@ -42,7 +42,7 @@ instance HasAppVersion RegisteredAppVersion where -- 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 <$> getSubDirectories (rootDirectory appId) + versions <- mapMaybe (readMaybe . toS) <$> getSubDirectories (rootDirectory appId) fmap catMaybes . for versions $ \v -> getVersionedFileFromDir rootDirectory ext v >>= \case diff --git a/src/Lib/Semver.hs b/src/Lib/Semver.hs index bb78134..56b0ac0 100644 --- a/src/Lib/Semver.hs +++ b/src/Lib/Semver.hs @@ -5,6 +5,7 @@ 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 diff --git a/src/Lib/Types/Semver.hs b/src/Lib/Types/Semver.hs index c59c970..4eea5a6 100644 --- a/src/Lib/Types/Semver.hs +++ b/src/Lib/Types/Semver.hs @@ -38,8 +38,8 @@ instance Show AppVersion where 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 @@ -47,7 +47,7 @@ instance FromJSON AppVersion where 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" + _ -> fail "unknown versioning" instance ToTypedContent AppVersion where toTypedContent = toTypedContent . toJSON instance ToContent AppVersion where @@ -62,16 +62,17 @@ instance FromJSONKey AppVersion where -- Semver AppVersionSpecification ------------------------------------------------------------------------------------------------------------------------ -data AppVersionSpecification = AppVersionSpecification - { requestModifier :: SemverRequestModifier - , baseVersion :: AppVersion - } +data AppVersionSpecification = + AppVersionAny + | AppVersionSpecification SemverRequestModifier AppVersion instance Read AppVersionSpecification where readsPrec _ s = - case (readMaybe . toS $ svMod, readMaybe . toS $ version) of - (Just m, Just av) -> [(AppVersionSpecification m av, "")] - _ -> [] + 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 @@ -80,15 +81,19 @@ instance PathPiece AppVersionSpecification where toPathPiece = show instance Show AppVersionSpecification where + show AppVersionAny = "*" show (AppVersionSpecification r b) = show r <> show b instance ToJSON AppVersionSpecification where toJSON = String . show instance FromJSON AppVersionSpecification where - parseJSON = withText "app version spec" $ \t -> do - let (svMod, version) = break isDigit t - baseVersion <- parseJSON . String $ version - requestModifier <- parseJSON . String $ svMod - pure $ AppVersionSpecification {..} + 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 mostRecentVersion :: AppVersionSpecification mostRecentVersion = AppVersionSpecification SVGreaterThanEq $ AppVersion (0,0,0,0) diff --git a/src/Startlude.hs b/src/Startlude.hs index fff9cd5..fe88aea 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -10,7 +10,12 @@ import Control.Error.Util as X import Data.Coerce as X import Data.String as X (String, fromString) import Data.Time.Clock as X -import Protolude as X hiding (bool, hush, isLeft, isRight, note, tryIO, (<.>)) +import Protolude as X hiding (bool, hush, isLeft, isRight, note, readMaybe, tryIO, (<.>)) +import qualified Protolude as P (readMaybe) id :: a -> a id = identity + +readMaybe :: Read a => Text -> Maybe a +readMaybe = P.readMaybe . toS +{-# INLINE readMaybe #-}