more robust testing

apps.yaml

@@ -1,9 +0,0 @@
-bitcoind:
-  title: "Bitcoin Core"
-  description:
-    short: "A Bitcoin Full Node"
-    long: "The bitcoin full node implementation by Bitcoin Core."
-  version-info:
-    - version: 0.18.1
-      release-notes: "Some stuff"
-  icon-type: png

package.yaml

@@ -62,6 +62,7 @@ dependencies:
 - yesod-core >=1.6 && <1.7
 - yesod-static
 - yesod-persistent >= 1.6 && < 1.7
+- shakespeare >=2.0 && <2.1
 
 library:
   source-dirs: src

resources/apps/apps.yaml

@@ -6,4 +6,17 @@ bitcoind:
   version-info:
     - version: 0.18.1
       release-notes: "Some stuff"
+    - version: 0.18.2
+      release-notes: "Some more stuff"
+  icon-type: png
+cups:
+  title: "Cups Messenger"
+  description:
+    short: "P2P Encrypted messaging"
+    long: "Peer-to-peer encrypted messaging platform that operates over tor."
+  version-info:
+    - version: 0.2.1
+      release-notes: "Some stuff"
+    - version: 0.2.2
+      release-notes: "Some more stuff"
   icon-type: png

src/Database/Queries.hs

@@ -10,24 +10,24 @@ import Database.Persist.Sql
 import Model
 import Settings
 
-fetchApp :: MonadIO m => AppIdentifier -> AppVersion -> ReaderT SqlBackend m (Maybe (Entity App))
+fetchApp :: MonadIO m => AppIdentifier -> AppVersion -> ReaderT SqlBackend m (Maybe (Entity SApp))
-fetchApp appId appVersion = selectFirst [AppAppId ==. appId, AppSemver ==. appVersion] [] 
+fetchApp appId appVersion = selectFirst [SAppAppId ==. appId, SAppVersion ==. appVersion] [] 
 
-createApp :: MonadIO m => AppIdentifier -> AppSeed -> ReaderT SqlBackend m (Maybe (Key App))
+createApp :: MonadIO m => AppIdentifier -> AppSeed -> ReaderT SqlBackend m (Maybe (Key SApp))
 createApp appId AppSeed{..} = do
     time <- liftIO $ getCurrentTime
-    insertUnique $ App
+    insertUnique $ SApp
         time
         Nothing
-        title
+        appSeedTitle
         appId
-        descShort
+        appSeedDescShort
-        descLong
+        appSeedDescLong
-        appVersion
+        appSeedVersion
-        releaseNotes'
+        appSeedReleaseNotes
-        iconType
+        appSeedIconType
 
-createMetric :: MonadIO m => Maybe (Key App) -> AppIdentifier -> ReaderT SqlBackend m ()
+createMetric :: MonadIO m => Maybe (Key SApp) -> AppIdentifier -> ReaderT SqlBackend m ()
 createMetric appId event = do
     time <- liftIO $ getCurrentTime 
     insert_ $ Metric
@@ -41,15 +41,15 @@ createAllAppVersions app appId = do
     -- inseryt new records and replace existing records (matching any unique constraint)
     putMany $ toList $ storeAppToSeed time appId app
 
-storeAppToSeed :: UTCTime -> AppIdentifier -> StoreApp -> NonEmpty App
+storeAppToSeed :: UTCTime -> AppIdentifier -> StoreApp -> NonEmpty SApp
-storeAppToSeed time appId StoreApp{..} = map (\b -> App
+storeAppToSeed time appId StoreApp{..} = map (\b -> SApp
         time
         Nothing
         storeAppTitle
         appId
         storeAppDescShort
         storeAppDescLong
-        (semver b)
+        (version' b)
-        (releaseNotes b)
+        (releaseNotes' b)
         storeAppIconType
-    ) storeAppSemver
+    ) storeAppVersionInfo

src/Handler/Apps.hs

@@ -83,22 +83,22 @@ getApp rootDir ext@(Extension appId) = do
                                 Nothing -> sendResponseStatus status400 ("App not present in manifest" :: Text)
                                 Just StoreApp{..} -> do
                                     -- look up at specfic version
-                                    VersionInfo{..} <- case NE.filter (\v -> appVersion == semver v) storeAppSemver of
+                                    VersionInfo{..} <- case NE.filter (\v -> appVersion == version' v) storeAppVersionInfo of
                                                             [] -> sendResponseStatus status400 ("App version not present in manifest" :: Text)
                                                             x : _ -> pure x
                                     pure $ AppSeed
-                                        { title = storeAppTitle
+                                        { appSeedTitle = storeAppTitle
-                                        , descShort = storeAppDescShort
+                                        , appSeedDescShort = storeAppDescShort
-                                        , descLong = storeAppDescLong
+                                        , appSeedDescLong = storeAppDescLong
-                                        , appVersion = semver
+                                        , appSeedVersion = version'
-                                        , releaseNotes' = releaseNotes
+                                        , appSeedReleaseNotes = releaseNotes'
-                                        , iconType = storeAppIconType
+                                        , appSeedIconType = storeAppIconType
                                         }
-                            -- create metric based off these app details
                             appKey <- runDB $ createApp appId' deets
                             case appKey of
-                                Nothing -> $logWarn $ "app at this version already exists in db, no need to insert"
+                                Nothing -> $logWarn $ "app at this version already exists in db, no need to insert" -- unreachable
-                                Just k -> runDB $ createMetric (Just k) appId' -- log app download
+                                -- log app download
+                                Just k -> runDB $ createMetric (Just k) appId'
                         Just a -> runDB $ createMetric (Just $ entityKey a) appId'
                     sz <- liftIO $ fileSize <$> getFileStatus filePath
                     addHeader "Content-Length" (show sz)

src/Model.hs

@@ -12,23 +12,23 @@ import           Lib.Types.Semver
 
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-App
+SApp
     createdAt UTCTime
     updatedAt UTCTime Maybe
     title Text
     appId Text
     descShort Text
     descLong Text
-    semver AppVersion
+    version AppVersion
     releaseNotes Text
     iconType Text
-    UniqueSemver semver
+    UniqueVersion version
     deriving Eq
     deriving Show
 
 Metric
     createdAt UTCTime
-    appId AppId Maybe default=null
+    appId SAppId Maybe default=null
     event Text
     deriving Eq
     deriving Show

src/Settings.hs

@@ -96,19 +96,19 @@ getAppManifest resourcesDir = do
 
 type AppIdentifier = Text
 data AppSeed = AppSeed 
-    { title :: Text
+    { appSeedTitle :: Text
-    , descShort :: Text
+    , appSeedDescShort :: Text
-    , descLong :: Text
+    , appSeedDescLong :: Text
-    , appVersion :: AppVersion
+    , appSeedVersion :: AppVersion
-    , releaseNotes' :: Text
+    , appSeedReleaseNotes :: Text
-    , iconType :: Text
+    , appSeedIconType :: Text
     } deriving (Show)
     
 data StoreApp = StoreApp 
     { storeAppTitle :: Text
     , storeAppDescShort :: Text
     , storeAppDescLong :: Text
-    , storeAppSemver :: NonEmpty VersionInfo -- TODO rename
+    , storeAppVersionInfo :: NonEmpty VersionInfo
     , storeAppIconType :: Text
     } deriving (Show)
 
@@ -124,19 +124,19 @@ instance FromJSON AppManifest where
             storeAppIconType <- config .: "icon-type"
             storeAppDescShort <- config .: "description" >>= (.: "short")
             storeAppDescLong <- config .: "description" >>= (.: "long")
-            storeAppSemver <- config .: "version-info" >>= \case
+            storeAppVersionInfo <- config .: "version-info" >>= \case
                 [] -> fail "No Valid Version Info"
                 (x:xs) -> pure $ x :| xs
             return $ (appId, StoreApp {..})
         return $ AppManifest (HM.fromList apps)
 
 data VersionInfo = VersionInfo 
-    { semver :: AppVersion
+    { version' :: AppVersion
-    , releaseNotes :: Text
+    , releaseNotes' :: Text
     } deriving (Eq, Ord, Show)
 
 instance FromJSON VersionInfo where
     parseJSON = withObject "version info" $ \o -> do
-        semver <- o .: "version"
+        version' <- o .: "version"
-        releaseNotes <- o .: "release-notes"
+        releaseNotes' <- o .: "release-notes"
         pure VersionInfo {..}

test/Handler/AppSpec.hs

@@ -4,6 +4,8 @@ module Handler.AppSpec (spec) where
 
 import Startlude
 import TestImport
+import Database.Persist.Sql
+import Model
 
 spec :: Spec
 spec = do
@@ -15,15 +17,29 @@ spec = do
             bodyContains "bitcoind"
             bodyContains "version: 0.18.1"
             statusIs 200
-    describe "GET /apps/:appId" $
+    describe "GET /apps/:appId with unknown version spec for bitcoin" $
         withApp $ it "fails to get unknown app" $ do
             request $ do
                 setMethod "GET"
-                setUrl ("/apps/bitcoind.s9pk?spec=0.18.2" :: Text)
+                setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text)
             statusIs 404
-    describe "GET /apps/:appId" $
+    describe "GET /apps/:appId with existing version spec for bitcoin" $
-        withApp $ it "makes da records" $ do
+        withApp $ it "creates app and metric records" $ do
             request $ do
                 setMethod "GET"
                 setUrl ("/apps/bitcoind.s9pk?spec=0.18.1" :: Text)
             statusIs 200
+            apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] []
+            metrics <- runDBtest $ selectList [MetricEvent ==. "bitcoind"] []
+            assertEq "app should exist" (length apps) 1
+            assertEq "metric should exist" (length metrics) 1
+    describe "GET /apps/:appId with existing version spec for cups" $
+        withApp $ it "creates app and metric records" $ do
+            request $ do
+                setMethod "GET"
+                setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text)
+            statusIs 200
+            apps <- runDBtest $ selectList [SAppAppId ==. "cups"] []
+            metrics <- runDBtest $ selectList [MetricEvent ==. "cups"] []
+            assertEq "app should exist" (length apps) 1
+            assertEq "metric should exist" (length metrics) 1

test/TestImport.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
 
 module TestImport
     ( module TestImport
@@ -12,6 +14,10 @@ import Test.Hspec            as X
 import Yesod.Default.Config2 (useEnv, loadYamlSettings)
 import Yesod.Test            as X
 import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
+import Database.Persist.Sql
+import Text.Shakespeare.Text (st)
+import Yesod.Core
+import qualified Data.Text as T
 
 runHandler :: Handler a -> YesodExample AgentCtx a
 runHandler handler = do
@@ -25,5 +31,38 @@ withApp = before $ do
         []
         useEnv
     foundation <- makeFoundation settings
+    wipeDB foundation
     logWare <- liftIO $ makeLogWare foundation
     return (foundation, logWare)
+
+getTables :: DB [Text]
+getTables = do
+    tables <- rawSql [st|
+        SELECT table_name
+        FROM information_schema.tables
+        WHERE table_schema = 'public'
+        AND table_type = 'BASE TABLE';
+    |] []
+
+    return $ map unSingle tables
+
+wipeDB :: AgentCtx -> IO ()
+wipeDB app = runDBWithApp app $ do
+    tables <- getTables
+    sqlBackend <- ask
+
+    let escapedTables = map (T.unpack . connEscapeName sqlBackend . DBName) tables
+        query = "TRUNCATE TABLE " ++ (intercalate ", " $ escapedTables)
+    rawExecute (T.pack query) []
+
+runDBtest :: SqlPersistM a -> YesodExample AgentCtx a
+runDBtest query = do
+    app <- getTestYesod
+    liftIO $ runDBWithApp app query
+
+runDBWithApp :: AgentCtx -> SqlPersistM a -> IO a
+runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
+
+-- A convenient synonym for database access functions.
+type DB a = forall (m :: * -> *).
+    (MonadUnliftIO m) => ReaderT SqlBackend m a