Merge pull request #4 from Start9Labs/bugfix/version-spec-resilience

Bugfix/version spec resilience

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

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

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)

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

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

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)

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 #-}