cleans semver

src/Lib/Resource.hs

@@ -2,13 +2,13 @@
 
 module Lib.Resource where
 
-import           Startlude         hiding (empty)
+import           Startlude         hiding (empty, toList)
 
-import           Data.Aeson
 import           Data.HashMap.Lazy hiding (mapMaybe)
 import           System.Directory
 import           System.FilePath
 
+import           Lib.Semver
 import           Lib.Types.Semver
 
 
@@ -26,6 +26,10 @@ s9pkFile appId = toS appId <.> "s9pk"
 
 type Registry = HashMap String (HashMap AppVersion FilePath)
 
+newtype RegisteredAppVersion = RegisteredAppVersion (AppVersion, FilePath)
+instance HasAppVersion RegisteredAppVersion where
+    version (RegisteredAppVersion (av, _)) = av
+
 loadResources :: MonadIO m => m Registry
 loadResources = liftIO $ do
     appDirectories <- getSubDirectories resourcePath
@@ -33,13 +37,14 @@ loadResources = liftIO $ do
         ( \hm appId -> do
             subdirs <- getSubDirectories (resourcePath </> appId)
             let validVersions = mapMaybe readMaybe subdirs
-            let newAppVersions = fromList $ fmap (, s9pkFile appId) validVersions
+            let newAppVersions = fromList $ fmap (\v -> (v, resourcePath </> show v </> s9pkFile appId)) validVersions
             pure $ insert appId newAppVersions hm
         ) empty appDirectories
     where
         getSubDirectories path = listDirectory path >>= filterM (fmap not . doesFileExist)
 
 getAppFile :: Registry -> String -> AppVersion -> Maybe FilePath
-getAppFile r appId av = do
-    s9pk <- lookup av <=< lookup appId $ r
-    pure $ resourcePath </> appId </> show av </> s9pk
+getAppFile r appId av = lookup av <=< lookup appId $ r
+
+registeredAppVersions :: Registry -> String -> [RegisteredAppVersion]
+registeredAppVersions r appId = fromMaybe [] $ fmap RegisteredAppVersion . toList <$> lookup appId r

src/Lib/Types/Semver.hs

@@ -14,6 +14,10 @@ import           Data.String.Interpolate
 import           Data.Text
 import           Yesod.Core
 
+------------------------------------------------------------------------------------------------------------------------
+-- Semver AppVersion
+------------------------------------------------------------------------------------------------------------------------
+
 newtype AppVersion = AppVersion
     { unAppVersion :: (Word16, Word16, Word16) } deriving (Eq, Ord)
 
@@ -55,11 +59,27 @@ instance ToContent AppVersion where
     where
         d `diffy` d1 = fromIntegral . abs $ (fromIntegral d :: Integer) - (fromIntegral d1 :: Integer)
 
+------------------------------------------------------------------------------------------------------------------------
+-- Semver AppVersionSpecification
+------------------------------------------------------------------------------------------------------------------------
+
 data AppVersionSpecification = AppVersionSpecification
     { requestModifier :: SemverRequestModifier
     , baseVersion     :: AppVersion
     }
 
+instance Read AppVersionSpecification where
+    readsPrec _ s =
+        case (readMaybe . toS $ svMod, readMaybe . toS $ version) of
+            (Just m, Just av) -> [(AppVersionSpecification m av, "")]
+            _                 -> []
+        where
+            (svMod, version) = break isDigit . toS $ s
+
+instance PathPiece AppVersionSpecification where
+    fromPathPiece = readMaybe . toS
+    toPathPiece = show
+
 instance Show AppVersionSpecification where
     show (AppVersionSpecification r b) = show r <> show b
 instance ToJSON AppVersionSpecification where
@@ -71,6 +91,10 @@ instance FromJSON AppVersionSpecification where
         requestModifier <- parseJSON . String $ svMod
         pure $ AppVersionSpecification {..}
 
+------------------------------------------------------------------------------------------------------------------------
+-- Semver RequestModifier
+------------------------------------------------------------------------------------------------------------------------
+
 data SemverRequestModifier = SVEquals | SVLessThan | SVGreaterThan | SVGreatestWithMajor | SVGreatestWithMajorMinor | SVLessThanEq | SVGreaterThanEq deriving (Eq, Bounded, Enum)
 instance Show SemverRequestModifier where
     show SVEquals                 = "="
@@ -82,13 +106,19 @@ instance Show SemverRequestModifier where
     show SVGreaterThanEq          = ">="
 
 instance FromJSON SemverRequestModifier where
-    parseJSON = withText "semver request modifier" $ \case
-        ""   -> pure SVGreatestWithMajorMinor
-        "="  -> pure SVEquals
-        "<"  -> pure SVLessThan
-        ">"  -> pure SVGreaterThan
-        "~"  -> pure SVGreatestWithMajor
-        "^"  -> pure SVGreatestWithMajorMinor
-        "<=" -> pure SVLessThanEq
-        ">=" -> pure SVGreaterThanEq
-        _    -> 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
+        ""   -> [(SVGreatestWithMajorMinor, "")]
+        "="  -> [(SVEquals, "")]
+        "<"  -> [(SVLessThan, "")]
+        ">"  -> [(SVGreaterThan, "")]
+        "~"  -> [(SVGreatestWithMajor, "")]
+        "^"  -> [(SVGreatestWithMajorMinor, "")]
+        "<=" -> [(SVLessThanEq, "")]
+        ">=" -> [(SVGreaterThanEq, "")]
+        _    -> []