rework to normalize version in db and small cleanups

.gitignore

@@ -27,4 +27,5 @@ stack.yaml.lock
 agent_*
 agent.*
 version
-hie.yaml
+hie.yaml
+**/*.s9pk

config/compatibility.json

@@ -2,5 +2,6 @@
     "0.1.0": "1.0.0",
     "0.1.1": "1.0.0",
     "0.1.2": "1.1.0",
-    "0.1.3": "1.1.0"
+    "0.1.3": "1.1.0",
+    "0.1.4": "1.1.0"
   }

src/Database/Queries.hs

@@ -5,51 +5,44 @@
 module Database.Queries where
 
 import Startlude
-import Lib.Types.Semver
 import Database.Persist.Sql
 import Model
 import Settings
+import Lib.Types.Semver
 
-fetchApp :: MonadIO m => AppIdentifier -> AppVersion -> ReaderT SqlBackend m (Maybe (Entity SApp))
+fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp))
-fetchApp appId appVersion = selectFirst [SAppAppId ==. appId, SAppVersion ==. appVersion] [] 
+fetchApp appId = selectFirst [SAppAppId ==. appId] [] 
 
-createApp :: MonadIO m => AppIdentifier -> AppSeed -> ReaderT SqlBackend m (Maybe (Key SApp))
+fetchAppVersion :: MonadIO m => AppVersion -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity Version))
-createApp appId AppSeed{..} = do
+fetchAppVersion appVersion appId = selectFirst [VersionNumber ==. appVersion, VersionAppId ==. appId] [] 
-    time <- liftIO $ getCurrentTime
-    insertUnique $ SApp
-        time
-        Nothing
-        appSeedTitle
-        appId
-        appSeedDescShort
-        appSeedDescLong
-        appSeedVersion
-        appSeedReleaseNotes
-        appSeedIconType
 
-createMetric :: MonadIO m => Maybe (Key SApp) -> AppIdentifier -> ReaderT SqlBackend m ()
+createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Key SApp)
-createMetric appId event = do
+createApp appId StoreApp{..} = do
-    time <- liftIO $ getCurrentTime 
+    time <- liftIO getCurrentTime
-    insert_ $ Metric
+    insert $ SApp
-        time
-        appId
-        event
-
-createAllAppVersions ::  MonadIO m => StoreApp -> AppIdentifier -> ReaderT SqlBackend m ()
-createAllAppVersions app appId = do
-    time <- liftIO $ getCurrentTime
-    -- inseryt new records and replace existing records (matching any unique constraint)
-    putMany $ toList $ storeAppToSeed time appId app
-
-storeAppToSeed :: UTCTime -> AppIdentifier -> StoreApp -> NonEmpty SApp
-storeAppToSeed time appId StoreApp{..} = map (\b -> SApp
         time
         Nothing
         storeAppTitle
         appId
         storeAppDescShort
         storeAppDescLong
-        (version' b)
-        (releaseNotes' b)
         storeAppIconType
-    ) storeAppVersionInfo
+    
+createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> ReaderT SqlBackend m (Key Version)
+createAppVersion sId VersionInfo{..} = do
+    time <- liftIO getCurrentTime
+    insert $ Version
+        time
+        Nothing
+        sId
+        versionInfoVersion
+        versionInfoReleaseNotes
+
+createMetric :: MonadIO m => Maybe (Key SApp) -> Maybe (Key Version) -> AppIdentifier -> ReaderT SqlBackend m ()
+createMetric appId versionId event = do
+    time <- liftIO $ getCurrentTime 
+    insert_ $ Metric
+        time
+        appId
+        versionId
+        event

src/Handler/Apps.hs

@@ -11,7 +11,6 @@ import           Startlude
 import           Control.Monad.Logger
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BS
-import qualified Data.List.NonEmpty as NE
 import           Data.Char
 import           Data.Conduit
 import qualified Data.Conduit.Binary  as CB
@@ -22,7 +21,6 @@ import           System.Directory
 import           Yesod.Core
 import           Yesod.Persist.Core
 
-
 import           Foundation
 import           Lib.Registry
 import           Lib.Semver
@@ -67,6 +65,7 @@ getApp rootDir ext@(Extension appId) = do
         Just t  -> pure t
     appVersions <- liftIO $ getAvailableAppVersions rootDir ext
     putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions
+    -- this always returns the max version, not the one specified in query param, why?
     case getSpecifiedAppVersion spec appVersions of
         Nothing -> notFound
         Just (RegisteredAppVersion (appVersion, filePath)) -> do
@@ -74,32 +73,31 @@ getApp rootDir ext@(Extension appId) = do
             if exists
                 then do
                     let appId' = T.pack appId
-                    ai <- runDB $ fetchApp appId' appVersion
+                    manifest <- liftIO $ getAppManifest rootDir
-                    _ <- case ai of
+                    (storeApp, versionInfo) <- case HM.lookup appId' $ unAppManifest manifest of
-                        Nothing -> do
-                            -- save the app if it does not yet exist in db at particular version (automatic eventual transfer from using apps.yaml to db record)
-                            manifest <- liftIO $ getAppManifest rootDir
-                            deets <- case HM.lookup appId' $ unAppManifest manifest of
                                 Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text)
-                                Just StoreApp{..} -> do
+                                Just sa -> do
                                     -- look up at specfic version
-                                    VersionInfo{..} <- case NE.filter (\v -> appVersion == version' v) storeAppVersionInfo of
+                                    vi <- case find ((appVersion ==) . versionInfoVersion) (storeAppVersionInfo sa) of
-                                                            [] -> sendResponseStatus status400 ("App version not present in manifest" :: Text)
+                                            Nothing -> sendResponseStatus status400 ("App version not present in manifest" :: Text)
-                                                            x : _ -> pure x
+                                            Just x -> pure x
-                                    pure $ AppSeed
+                                    pure (sa, vi)
-                                        { appSeedTitle = storeAppTitle
+                    -- lazy load app at requested version if it does not yet exist to automatically transfer from using apps.yaml
-                                        , appSeedDescShort = storeAppDescShort
+                    sa <- runDB $ fetchApp appId'
-                                        , appSeedDescLong = storeAppDescLong
+                    (appKey, versionKey) <- case sa of
-                                        , appSeedVersion = version'
+                        Nothing -> do
-                                        , appSeedReleaseNotes = releaseNotes'
+                            ak <- runDB $ createApp appId' storeApp
-                                        , appSeedIconType = storeAppIconType
+                            vk <- runDB $ createAppVersion ak versionInfo
-                                        }
+                            pure (ak, vk)
-                            appKey <- runDB $ createApp appId' deets
+                        Just a -> do
-                            case appKey of
+                            let appKey' = entityKey a
-                                Nothing -> $logWarn $ "app at this version already exists in db, no need to insert" -- unreachable
+                            maybeVer <- runDB $ fetchAppVersion appVersion appKey'
-                                -- log app download
+                            case maybeVer of
-                                Just k -> runDB $ createMetric (Just k) appId'
+                                Nothing -> do
-                        Just a -> runDB $ createMetric (Just $ entityKey a) appId'
+                                    av <- runDB $ createAppVersion appKey' versionInfo
+                                    pure (appKey', av)
+                                Just v -> pure (appKey', entityKey v)
+                    runDB $ createMetric (Just appKey) (Just versionKey) appId'
                     sz <- liftIO $ fileSize <$> getFileStatus filePath
                     addHeader "Content-Length" (show sz)
                     respondSource typePlain $ CB.sourceFile filePath .| awaitForever sendChunkBS

src/Lib/Semver.hs

@@ -43,4 +43,4 @@ instance HasAppVersion AppVersion where
 
 appVersionMax :: HasAppVersion a => [a] -> Maybe a
 appVersionMax [] = Nothing
-appVersionMax as = Just $ maximumBy (\a1 a2 -> version a1 `compare` version a2) as
+appVersionMax as = Just $ maximumBy (compare `on` version) as

src/Lib/Types/Semver.hs

@@ -62,8 +62,8 @@ instance FromJSONKey AppVersion where
         Just x -> pure x
 
 instance PersistField AppVersion where
-    toPersistValue = toPersistValue @String . show
+    toPersistValue = toPersistValue @Text . show
-    fromPersistValue = note "" . readMaybe <=< fromPersistValue
+    fromPersistValue = note "invalid app version" . readMaybe <=< fromPersistValue
 
 instance PersistFieldSql AppVersion where
     sqlType _ = SqlString

src/Model.hs

@@ -19,16 +19,26 @@ SApp
     appId Text
     descShort Text
     descLong Text
-    version AppVersion
-    releaseNotes Text
     iconType Text
-    UniqueVersion version
+    UniqueAppId appId
     deriving Eq
     deriving Show
 
+Version
+    createdAt UTCTime
+    updatedAt UTCTime Maybe
+    appId SAppId
+    number AppVersion
+    releaseNotes Text
+    UniqueNumber number
+    deriving Eq
+    deriving Show
+
+
 Metric
     createdAt UTCTime
     appId SAppId Maybe default=null
+    version VersionId Maybe default=null
     event Text
     deriving Eq
     deriving Show

src/Settings.hs

@@ -91,18 +91,10 @@ compileTimeAppSettings =
 
 getAppManifest :: FilePath -> IO AppManifest
 getAppManifest resourcesDir = do
-    let appFile = (</> "apps.yaml") $ resourcesDir
+    let appFile = (</> "apps.yaml") resourcesDir
     loadYamlSettings [appFile] [] useEnv
 
 type AppIdentifier = Text
-data AppSeed = AppSeed 
-    { appSeedTitle :: Text
-    , appSeedDescShort :: Text
-    , appSeedDescLong :: Text
-    , appSeedVersion :: AppVersion
-    , appSeedReleaseNotes :: Text
-    , appSeedIconType :: Text
-    } deriving (Show)
     
 data StoreApp = StoreApp 
     { storeAppTitle :: Text
@@ -131,12 +123,12 @@ instance FromJSON AppManifest where
         return $ AppManifest (HM.fromList apps)
 
 data VersionInfo = VersionInfo 
-    { version' :: AppVersion
+    { versionInfoVersion :: AppVersion
-    , releaseNotes' :: Text
+    , versionInfoReleaseNotes :: Text
     } deriving (Eq, Ord, Show)
 
 instance FromJSON VersionInfo where
     parseJSON = withObject "version info" $ \o -> do
-        version' <- o .: "version"
+        versionInfoVersion <- o .: "version"
-        releaseNotes' <- o .: "release-notes"
+        versionInfoReleaseNotes <- o .: "release-notes"
         pure VersionInfo {..}

test/Handler/AppSpec.hs

@@ -3,8 +3,10 @@
 module Handler.AppSpec (spec) where
 
 import Startlude
-import TestImport
 import Database.Persist.Sql
+import Data.Maybe
+
+import TestImport
 import Model
 
 spec :: Spec
@@ -23,6 +25,12 @@ spec = do
                 setMethod "GET"
                 setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text)
             statusIs 404
+    describe "GET /apps/:appId with unknown app" $
+        withApp $ it "fails to get an unregistered app" $ do
+            request $ do
+                setMethod "GET"
+                setUrl ("/apps/tempapp.s9pk?spec=0.0.1" :: Text)
+            statusIs 404
     describe "GET /apps/:appId with existing version spec for bitcoin" $
         withApp $ it "creates app and metric records" $ do
             request $ do
@@ -43,3 +51,6 @@ spec = do
             metrics <- runDBtest $ selectList [MetricEvent ==. "cups"] []
             assertEq "app should exist" (length apps) 1
             assertEq "metric should exist" (length metrics) 1
+            let app = fromJust $ head apps
+            version <- runDBtest $ selectList [VersionAppId ==. entityKey app] []
+            assertEq "version should exist" (length version) 1

test/TestImport.hs

@@ -44,7 +44,7 @@ getTables = do
         AND table_type = 'BASE TABLE';
     |] []
 
-    return $ map unSingle tables
+    return $ fmap unSingle tables
 
 wipeDB :: AgentCtx -> IO ()
 wipeDB app = runDBWithApp app $ do
@@ -52,7 +52,7 @@ wipeDB app = runDBWithApp app $ do
     sqlBackend <- ask
 
     let escapedTables = map (T.unpack . connEscapeName sqlBackend . DBName) tables
-        query = "TRUNCATE TABLE " ++ (intercalate ", " $ escapedTables)
+        query = "TRUNCATE TABLE " ++ (intercalate ", " escapedTables)
     rawExecute (T.pack query) []
 
 runDBtest :: SqlPersistM a -> YesodExample AgentCtx a
@@ -63,6 +63,6 @@ runDBtest query = do
 runDBWithApp :: AgentCtx -> SqlPersistM a -> IO a
 runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
 
--- A convenient synonym for database access functions.
+-- A convenient synonym for database access functions
 type DB a = forall (m :: * -> *).
     (MonadUnliftIO m) => ReaderT SqlBackend m a