diff --git a/hie.yaml b/hie.yaml index 3e053dc51..57d1fefe1 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,12 +6,18 @@ cradle: - path: "primer/gen" component: "primer:lib:primer-hedgehog" + - path: "primer/testlib" + component: "primer:lib:primer-testlib" + - path: "primer/test" component: "primer:test:primer-test" - path: "primer-rel8/src" component: "lib:primer-rel8" + - path: "primer-rel8/testlib" + component: "primer-rel8:lib:primer-rel8-testlib" + - path: "primer-rel8/test" component: "primer-rel8:test:primer-rel8-test" diff --git a/primer-rel8/primer-rel8.cabal b/primer-rel8/primer-rel8.cabal index c091c0390..4d0d2c431 100644 --- a/primer-rel8/primer-rel8.cabal +++ b/primer-rel8/primer-rel8.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: primer-rel8 version: 0.7.2.0 license: AGPL-3.0-or-later @@ -48,6 +48,41 @@ library , time ^>=1.11 , uuid ^>=1.3.15 +library primer-rel8-testlib + visibility: public + exposed-modules: Primer.Database.Rel8.Test.Util + hs-source-dirs: testlib + default-language: GHC2021 + default-extensions: + NoImplicitPrelude + DataKinds + DerivingStrategies + DerivingVia + LambdaCase + OverloadedStrings + + ghc-options: + -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths + + build-depends: + , base + , bytestring + , hasql + , hasql-pool + , logging-effect + , port-utils ^>=0.2.1 + , postgres-options ^>=0.2 + , primer + , primer-rel8 + , rel8 + , temporary ^>=1.3 + , time + , tmp-postgres ^>=1.34.1.0 + , typed-process >=0.2.8 && <0.2.11 + , utf8-string ^>=1.0 + , uuid + test-suite primer-rel8-test type: exitcode-stdio-1.0 main-is: Test.hs @@ -58,7 +93,6 @@ test-suite primer-rel8-test Tests.QuerySessionId Tests.UpdateSessionApp Tests.UpdateSessionName - TestUtils default-language: GHC2021 default-extensions: @@ -87,20 +121,14 @@ test-suite primer-rel8-test , hasql , hasql-pool , logging-effect - , port-utils ^>=0.2.1 - , postgres-options ^>=0.2 - , primer - , primer-rel8 + , primer-rel8:{primer-rel8, primer-rel8-testlib} + , primer:{primer, primer-testlib} , rel8 - , tasty ^>=1.4.2.1 - , tasty-discover ^>=4.2.4 - , tasty-hunit ^>=0.10.0 - , temporary ^>=1.3 + , tasty ^>=1.4.2.1 + , tasty-discover ^>=4.2.4 + , tasty-hunit ^>=0.10.0 , text , time - , tmp-postgres ^>=1.34.1.0 - , typed-process >=0.2.8 && <0.2.11 - , utf8-string ^>=1.0 , uuid --TODO This currently breaks with haskell.nix, so we manually add it to `flake.nix` instead. diff --git a/primer-rel8/test/Tests/InsertSession.hs b/primer-rel8/test/Tests/InsertSession.hs index 2f5786546..53216297b 100644 --- a/primer-rel8/test/Tests/InsertSession.hs +++ b/primer-rel8/test/Tests/InsertSession.hs @@ -19,15 +19,19 @@ import Primer.Database ( import Primer.Database.Rel8.Rel8Db ( Rel8DbException (InsertError), ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) -import TestUtils ( - assertException, +import Primer.Database.Rel8.Test.Util ( lowPrecisionCurrentTime, runTmpDb, - testApp, + ) +import Primer.Test.App ( + comprehensive, + ) +import Primer.Test.Util ( + assertException, (@?=), ) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCaseSteps) expectedError :: SessionId -> Rel8DbException -> Bool expectedError id_ (InsertError s _) = s == id_ @@ -37,44 +41,44 @@ test_insertSession_roundtrip :: TestTree test_insertSession_roundtrip = testCaseSteps "insertSession database round-tripping" $ \step' -> runTmpDb $ do let step = liftIO . step' - step "Insert testApp" + step "Insert comprehensive" now <- lowPrecisionCurrentTime let version = "git123" - let name = safeMkSessionName "testApp" + let name = safeMkSessionName "comprehensive" sessionId <- liftIO newSessionId - insertSession version sessionId testApp name now + insertSession version sessionId comprehensive name now step "Retrieve it" result <- querySessionId sessionId - result @?= Right (SessionData testApp name now) + result @?= Right (SessionData comprehensive name now) let jpName = safeMkSessionName "サンプルプログラム" step "Insert app with Japanese name" sid1 <- liftIO newSessionId - insertSession version sid1 testApp jpName now + insertSession version sid1 comprehensive jpName now r1 <- querySessionId sid1 - r1 @?= Right (SessionData testApp jpName now) + r1 @?= Right (SessionData comprehensive jpName now) let cnName = safeMkSessionName "示例程序" step "Insert app with simplified Chinese name" sid2 <- liftIO newSessionId - insertSession version sid2 testApp cnName now + insertSession version sid2 comprehensive cnName now r2 <- querySessionId sid2 - r2 @?= Right (SessionData testApp cnName now) + r2 @?= Right (SessionData comprehensive cnName now) let arName = safeMkSessionName "برنامج مثال" step "Insert app with Arabic name" sid3 <- liftIO newSessionId - insertSession version sid3 testApp arName now + insertSession version sid3 comprehensive arName now r3 <- querySessionId sid3 - r3 @?= Right (SessionData testApp arName now) + r3 @?= Right (SessionData comprehensive arName now) let emName = safeMkSessionName "😄😂🤣🤗 🦊 🦈" step "Insert app with emoji name" sid4 <- liftIO newSessionId - insertSession version sid4 testApp emName now + insertSession version sid4 comprehensive emName now r4 <- querySessionId sid4 - r4 @?= Right (SessionData testApp emName now) + r4 @?= Right (SessionData comprehensive emName now) test_insertSession_failure :: TestTree test_insertSession_failure = testCaseSteps "insertSession failure modes" $ \step' -> diff --git a/primer-rel8/test/Tests/ListSessions.hs b/primer-rel8/test/Tests/ListSessions.hs index 641f0fe0a..777a4c904 100644 --- a/primer-rel8/test/Tests/ListSessions.hs +++ b/primer-rel8/test/Tests/ListSessions.hs @@ -5,7 +5,6 @@ module Tests.ListSessions where import Foreword -import Data.UUID.V4 (nextRandom) import Primer.App (newApp) import Primer.Database ( LastModified (..), @@ -19,27 +18,13 @@ import Primer.Database ( import Primer.Database.Rel8 ( SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), ) -import Rel8 (Result) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) -import TestUtils ( - lowPrecisionCurrentTime, +import Primer.Database.Rel8.Test.Util ( + mkSessionRow, runTmpDb, - (@?=), ) - -mkSession :: Int -> IO (SessionRow Result) -mkSession n = do - u <- nextRandom - now <- lowPrecisionCurrentTime - pure $ - SessionRow - { uuid = u - , gitversion = "test-version" - , app = newApp - , name = "name-" <> show n - , lastmodified = utcTime now - } +import Primer.Test.Util ((@?=)) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCaseSteps) test_listSessions :: TestTree test_listSessions = testCaseSteps "listSessions" $ \step' -> @@ -47,7 +32,7 @@ test_listSessions = testCaseSteps "listSessions" $ \step' -> let step = liftIO . step' let m = 345 step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse mkSession [1 .. m] + rows <- liftIO $ sortOn name <$> traverse mkSessionRow [1 .. m] forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) let expectedRows = map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows step "Get all, offset+limit" diff --git a/primer-rel8/test/Tests/QuerySessionId.hs b/primer-rel8/test/Tests/QuerySessionId.hs index 2e9e82420..202be6aae 100644 --- a/primer-rel8/test/Tests/QuerySessionId.hs +++ b/primer-rel8/test/Tests/QuerySessionId.hs @@ -20,15 +20,15 @@ import Primer.Database ( import Primer.Database.Rel8.Schema qualified as Schema ( SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), ) -import Rel8 (lit) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) -import TestUtils ( +import Primer.Database.Rel8.Test.Util ( insertSessionRow, lowPrecisionCurrentTime, runTmpDbWithPool, - (@?=), ) +import Primer.Test.Util ((@?=)) +import Rel8 (lit) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCaseSteps) -- Note: 'querySessionId' gets plenty of coverage in our other unit -- tests by virtue of the fact we use it to retrieve results that we diff --git a/primer-rel8/test/Tests/UpdateSessionApp.hs b/primer-rel8/test/Tests/UpdateSessionApp.hs index 5edd3745e..6b59cf1bb 100644 --- a/primer-rel8/test/Tests/UpdateSessionApp.hs +++ b/primer-rel8/test/Tests/UpdateSessionApp.hs @@ -20,15 +20,19 @@ import Primer.Database ( import Primer.Database.Rel8 ( Rel8DbException (UpdateAppNonExistentSession), ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) -import TestUtils ( - assertException, +import Primer.Database.Rel8.Test.Util ( lowPrecisionCurrentTime, runTmpDb, - testApp, + ) +import Primer.Test.App ( + comprehensive, + ) +import Primer.Test.Util ( + assertException, (@?=), ) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCaseSteps) expectedError :: SessionId -> Rel8DbException -> Bool expectedError id_ (UpdateAppNonExistentSession s) = s == id_ @@ -58,15 +62,15 @@ test_updateSessionApp_roundtrip = testCaseSteps "updateSessionApp database round r2 @?= Right (SessionData newEmptyApp name now) step "Update it with a new app" - updateSessionApp newVersion sessionId testApp now + updateSessionApp newVersion sessionId comprehensive now r3 <- querySessionId sessionId - r3 @?= Right (SessionData testApp name now) + r3 @?= Right (SessionData comprehensive name now) step "Update it with a new time" now' <- lowPrecisionCurrentTime - updateSessionApp newVersion sessionId testApp now' + updateSessionApp newVersion sessionId comprehensive now' r4 <- querySessionId sessionId - r4 @?= Right (SessionData testApp name now') + r4 @?= Right (SessionData comprehensive name now') test_updateSessionApp_failure :: TestTree test_updateSessionApp_failure = testCaseSteps "updateSessionApp failure modes" $ \step' -> diff --git a/primer-rel8/test/Tests/UpdateSessionName.hs b/primer-rel8/test/Tests/UpdateSessionName.hs index 1a95805c9..803f4ea8e 100644 --- a/primer-rel8/test/Tests/UpdateSessionName.hs +++ b/primer-rel8/test/Tests/UpdateSessionName.hs @@ -19,14 +19,16 @@ import Primer.Database ( import Primer.Database.Rel8 ( Rel8DbException (UpdateNameNonExistentSession), ) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCaseSteps) -import TestUtils ( - assertException, +import Primer.Database.Rel8.Test.Util ( lowPrecisionCurrentTime, runTmpDb, + ) +import Primer.Test.Util ( + assertException, (@?=), ) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCaseSteps) expectedError :: SessionId -> Rel8DbException -> Bool expectedError id_ (UpdateNameNonExistentSession s) = s == id_ diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/testlib/Primer/Database/Rel8/Test/Util.hs similarity index 62% rename from primer-rel8/test/TestUtils.hs rename to primer-rel8/testlib/Primer/Database/Rel8/Test/Util.hs index 1665105cd..92d626eca 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/testlib/Primer/Database/Rel8/Test/Util.hs @@ -1,10 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module TestUtils ( - (@?=), - assertException, +module Primer.Database.Rel8.Test.Util ( + deployDb, insertSessionRow, - testApp, + mkSessionRow, withDbSetup, lowPrecisionCurrentTime, runTmpDb, @@ -19,14 +18,13 @@ import Control.Monad.Log ( discardLogging, ) import Data.ByteString.Lazy.UTF8 as BL -import Data.Map.Strict qualified as Map import Data.String (String) import Data.Time ( UTCTime (..), diffTimeToPicoseconds, picosecondsToDiffTime, ) -import Data.Typeable (typeOf) +import Data.UUID.V4 (nextRandom) import Database.PostgreSQL.Simple.Options qualified as Options import Database.Postgres.Temp ( DB, @@ -50,56 +48,32 @@ import Hasql.Pool ( ) import Hasql.Session (statement) import Network.Socket.Free (getFreePort) -import Primer.App ( - App, - Prog (..), - defaultProg, - mkApp, - ) -import Primer.Core ( - baseName, - mkSimpleModuleName, - ) -import Primer.Core.DSL (create) +import Primer.App (newApp) import Primer.Database ( LastModified (..), getCurrentTime, ) import Primer.Database.Rel8 ( Rel8DbT, + SessionRow (..), runRel8DbT, ) import Primer.Database.Rel8.Schema as Schema hiding (app) -import Primer.Examples (comprehensive) -import Primer.Module ( - Module ( - Module, - moduleDefs, - moduleName, - moduleTypes - ), - builtinModule, - primitiveModule, - ) import Rel8 ( Expr, Insert (Insert, into, onConflict, returning, rows), OnConflict (Abort), + Result, Returning (NumberOfRowsAffected), insert, values, ) -import System.IO.Temp (getCanonicalTemporaryDirectory) +import System.IO.Temp (withSystemTempDirectory) import System.Process.Typed ( proc, readProcessStdout, runProcess_, ) -import Test.Tasty.HUnit ( - assertBool, - assertFailure, - ) -import Test.Tasty.HUnit qualified as HUnit -- The PostgreSQL host, username, and password can be chosen -- statically, but we need to choose the port dynamically in order to @@ -148,19 +122,19 @@ withDbSetup f = do , Options.host = pure host } throwEither $ do - tmpdir <- getCanonicalTemporaryDirectory - let cc = - defaultCacheConfig - { cacheTemporaryDirectory = tmpdir - , cacheDirectoryType = Temporary - } - in withDbCacheConfig cc $ \dbCache -> - let combinedConfig = dbConfig <> cacheConfig dbCache - in do - hash_ <- sqitchEventChangeId - migratedConfig <- throwEither $ cacheAction (tmpdir <> "/" <> hash_) (deployDb port) combinedConfig - withConfig migratedConfig $ \db -> - bracket (acquire 1 (Just 1000000) $ toConnectionString db) release f + withSystemTempDirectory "primer-tmp-postgres" $ \tmpdir -> + let cc = + defaultCacheConfig + { cacheTemporaryDirectory = tmpdir + , cacheDirectoryType = Temporary + } + in withDbCacheConfig cc $ \dbCache -> + let combinedConfig = dbConfig <> cacheConfig dbCache + in do + hash_ <- sqitchEventChangeId + migratedConfig <- throwEither $ cacheAction (tmpdir <> "/" <> hash_) (deployDb port) combinedConfig + withConfig migratedConfig $ \db -> + bracket (acquire 1 (Just 1000000) $ toConnectionString db) release f runTmpDb :: Rel8DbT (DiscardLoggingT (WithSeverity ()) IO) () -> IO () runTmpDb tests = @@ -171,27 +145,6 @@ runTmpDbWithPool :: (Pool -> Rel8DbT (DiscardLoggingT (WithSeverity ()) IO) ()) runTmpDbWithPool tests = withDbSetup $ \pool -> discardLogging $ runRel8DbT (tests pool) pool -(@?=) :: (MonadIO m, Eq a, Show a) => a -> a -> m () -x @?= y = liftIO $ x HUnit.@?= y -infix 1 @?= - -type ExceptionPredicate e = (e -> Bool) - -assertException :: - (HasCallStack, Exception e, MonadIO m, MonadCatch m) => - String -> - ExceptionPredicate e -> - m a -> - m () -assertException msg p action = do - r <- try action - case r of - Right _ -> liftIO $ assertFailure $ msg <> " should have thrown " <> exceptionType <> ", but it succeeded" - Left e -> liftIO $ assertBool (wrongException e) (p e) - where - wrongException e = msg <> " threw " <> show e <> ", but we expected " <> exceptionType - exceptionType = (show . typeOf) p - -- | Like @MonadDb.insertSession@, but allows us to insert things -- directly into the database that otherwise might not be permitted by -- the type system. This is useful for testing purposes. @@ -211,27 +164,6 @@ insertSessionRow row pool = , returning = NumberOfRowsAffected } --- | An initial test 'App' instance that contains all default type --- definitions (including primitive types), all primitive functions, --- and a top-level definition with extensive coverage of Primer's --- core language. -testApp :: App -testApp = - let modName = mkSimpleModuleName "TestModule" - ((defName, def), id_) = create $ comprehensive modName - testProg = - defaultProg - { progImports = [builtinModule, primitiveModule] - , progModules = - [ Module - { moduleName = mkSimpleModuleName "TestModule" - , moduleTypes = mempty - , moduleDefs = Map.singleton (baseName defName) def - } - ] - } - in mkApp id_ (toEnum 0) testProg - -- | PostgreSQL's timestamp type has a precision of 1 microsecond, but -- 'getCurrentTime' has a precision of 1 picosecond. In order to -- compare times for our tests, we need to truncate the precision of @@ -239,12 +171,24 @@ testApp = -- -- Ref: -- https://www.postgresql.org/docs/13/datatype-datetime.html --- --- Note: we should DRY this, see: --- https://github.com/hackworthltd/primer/issues/273 lowPrecisionCurrentTime :: (MonadIO m) => m LastModified lowPrecisionCurrentTime = do LastModified (UTCTime day time) <- getCurrentTime -- truncate to microseconds let time' = picosecondsToDiffTime $ diffTimeToPicoseconds time `div` 1000000 * 1000000 pure $ LastModified $ UTCTime day time' + +-- | Return a 'SessionRow', which is useful for testing the database +-- without needing to go through the Primer API. +mkSessionRow :: Int -> IO (SessionRow Result) +mkSessionRow n = do + u <- nextRandom + now <- lowPrecisionCurrentTime + pure $ + SessionRow + { uuid = u + , gitversion = "test-version" + , app = newApp + , name = "name-" <> show n + , lastmodified = utcTime now + } diff --git a/primer-service/primer-service.cabal b/primer-service/primer-service.cabal index 838d8898d..3c7accbca 100644 --- a/primer-service/primer-service.cabal +++ b/primer-service/primer-service.cabal @@ -181,31 +181,26 @@ test-suite service-test , aeson-pretty , base , bytestring - , hasql-pool - , hedgehog ^>=1.1.1 - , hedgehog-quickcheck ^>=0.1.1 - , hspec ^>=2.9.4 - , logging-effect + , hedgehog ^>=1.1.1 + , hedgehog-quickcheck ^>=0.1.1 + , hspec ^>=2.9.4 , openapi3 - , postgres-options ^>=0.2 - , pretty-simple ^>=4.0.0 - , primer-rel8 + , postgres-options ^>=0.2 + , pretty-simple ^>=4.0.0 + , primer-rel8:{primer-rel8, primer-rel8-testlib} , primer-service - , primer:{primer, primer-hedgehog} - , QuickCheck ^>=2.14.2 - , rel8 ^>=1.4 + , primer:{primer, primer-hedgehog, primer-testlib} + , QuickCheck ^>=2.14.2 + , rel8 ^>=1.4 , servant-openapi3 - , tasty ^>=1.4.1 - , tasty-discover ^>=4.2.4 - , tasty-golden ^>=2.3.5 - , tasty-hedgehog ^>=1.2.0 - , tasty-hspec ^>=1.2.0.1 - , tasty-hunit ^>=0.10.0 - , temporary ^>=1.3 + , tasty ^>=1.4.1 + , tasty-discover ^>=4.2.4 + , tasty-golden ^>=2.3.5 + , tasty-hedgehog ^>=1.2.0 + , tasty-hspec ^>=1.2.0.1 + , tasty-hunit ^>=0.10.0 , text , time - , tmp-postgres ^>=1.34.1.0 - , typed-process ^>=0.2.8 , uuid --TODO This currently breaks with haskell.nix, so we manually add it to `flake.nix` instead. diff --git a/primer-service/test/Tests/Pagination.hs b/primer-service/test/Tests/Pagination.hs index 68cc785a5..8c5238a53 100644 --- a/primer-service/test/Tests/Pagination.hs +++ b/primer-service/test/Tests/Pagination.hs @@ -5,50 +5,18 @@ module Tests.Pagination where import Foreword -import Control.Monad.Log ( - DiscardLoggingT, - WithSeverity, - discardLogging, - ) -import Data.String (String) -import Data.Time ( - UTCTime (..), - diffTimeToPicoseconds, - picosecondsToDiffTime, - ) -import Data.UUID.V4 (nextRandom) -import Database.PostgreSQL.Simple.Options qualified as Options -import Database.Postgres.Temp ( - DB, - DirectoryType (Temporary), - cacheAction, - cacheConfig, - cacheDirectoryType, - cacheTemporaryDirectory, - defaultCacheConfig, - optionsToDefaultConfig, - toConnectionString, - withConfig, - withDbCacheConfig, - ) -import Hasql.Pool ( - Pool, - acquire, - release, - ) import Primer.App (newApp) import Primer.Database ( LastModified (..), Session (Session), - getCurrentTime, insertSession, listSessions, safeMkSessionName, ) -import Primer.Database.Rel8 ( - Rel8DbT, - SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), - runRel8DbT, +import Primer.Database.Rel8 (SessionRow (..)) +import Primer.Database.Rel8.Test.Util ( + mkSessionRow, + runTmpDb, ) import Primer.Pagination ( Pagination (Pagination, page, size), @@ -66,114 +34,21 @@ import Primer.Pagination ( thisPage, totalItems, ) -import Rel8 (Result) -import System.IO.Temp (withSystemTempDirectory) -import System.Process.Typed ( - proc, - runProcess_, - ) +import Primer.Test.Util ((@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCaseSteps) import Test.Tasty.HUnit qualified as HUnit --- | PostgreSQL's timestamp type has a precision of 1 microsecond, but --- 'getCurrentTime' has a precision of 1 picosecond. In order to --- compare times for our tests, we need to truncate the precision of --- the time returned by 'getCurrentTime'. --- --- Ref: --- https://www.postgresql.org/docs/13/datatype-datetime.html --- --- Note: we should DRY this, see: --- https://github.com/hackworthltd/primer/issues/273 -lowPrecisionCurrentTime :: (MonadIO m) => m LastModified -lowPrecisionCurrentTime = do - LastModified (UTCTime day time) <- getCurrentTime - -- truncate to microseconds - let time' = picosecondsToDiffTime $ diffTimeToPicoseconds time `div` 1000000 * 1000000 - pure $ LastModified $ UTCTime day time' - -(@?=) :: (MonadIO m, Eq a, Show a) => a -> a -> m () -x @?= y = liftIO $ x HUnit.@?= y -infix 1 @?= - assertFailure :: MonadIO m => Text -> m a assertFailure = liftIO . HUnit.assertFailure . toS -host :: String -host = "localhost" - -port :: Int -port = 5432 - -user :: String -user = "postgres" - -password :: String -password = "primer" - --- | This action requires that the Sqitch script @primer-sqitch@ is in --- the process's path. If you run this test via Nix, Nix will --- guarantee that precondition. -deployDb :: DB -> IO () -deployDb _ = - let url = "db:postgres://" <> user <> ":" <> password <> "@" <> host <> ":" <> show port - in runProcess_ $ proc "primer-sqitch" ["deploy", "--verify", url] - -withSetup :: (Pool -> IO ()) -> IO () -withSetup f = - let throwEither x = either throwIO pure =<< x - dbConfig = - optionsToDefaultConfig - mempty - { Options.port = pure port - , Options.user = pure user - , Options.password = pure password - , Options.host = pure host - } - in do - throwEither $ - withSystemTempDirectory "primer-tmp-postgres" $ \tmpdir -> - let cc = - defaultCacheConfig - { cacheTemporaryDirectory = tmpdir - , cacheDirectoryType = Temporary - } - in withDbCacheConfig cc $ \dbCache -> - let combinedConfig = dbConfig <> cacheConfig dbCache - in do - migratedConfig <- throwEither $ cacheAction (tmpdir <> "/pagination") deployDb combinedConfig - withConfig migratedConfig $ \db -> - bracket (acquire 1 (Just 1000000) $ toConnectionString db) release f - --- This is copied from `primer-rel8` and should be refactored into a --- common testing library. See: --- --- https://github.com/hackworthltd/primer/issues/273 -runTmpDb :: Rel8DbT (DiscardLoggingT (WithSeverity ()) IO) () -> IO () -runTmpDb tests = - withSetup $ \pool -> discardLogging $ runRel8DbT tests pool - -mkSession :: Int -> IO (SessionRow Result) -mkSession n = do - u <- nextRandom - now <- lowPrecisionCurrentTime - pure $ - SessionRow - { uuid = u - , gitversion = "test-version" - , app = newApp - , name = "name-" <> show n - , lastmodified = utcTime now - } - test_pagination :: TestTree test_pagination = testCaseSteps "pagination" $ \step' -> runTmpDb $ do let step = liftIO . step' let m = 345 step "Insert all sessions" - rows <- liftIO $ sortOn name <$> traverse mkSession [1 .. m] + rows <- liftIO $ sortOn name <$> traverse mkSessionRow [1 .. m] forM_ rows (\SessionRow{..} -> insertSession gitversion uuid newApp (safeMkSessionName name) (LastModified lastmodified)) let expectedRows = map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) rows step "Get all, paged" diff --git a/primer/primer.cabal b/primer/primer.cabal index 961ffa902..2f9f34992 100644 --- a/primer/primer.cabal +++ b/primer/primer.cabal @@ -164,6 +164,39 @@ library primer-hedgehog , tasty-discover ^>=4.2.4 , tasty-hedgehog ^>=1.2.0 +library primer-testlib + visibility: public + exposed-modules: + Primer.Test.App + Primer.Test.Util + + other-modules: + hs-source-dirs: testlib + default-language: GHC2021 + default-extensions: + NoImplicitPrelude + DataKinds + DerivingStrategies + DerivingVia + LambdaCase + OverloadedStrings + + ghc-options: + -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths + + build-depends: + , base + , containers + , exceptions + , hedgehog + , logging-effect + , optics + , primer + , stm + , stm-containers + , tasty-hunit ^>=0.10.0 + test-suite primer-test type: exitcode-stdio-1.0 main-is: Test.hs @@ -203,7 +236,6 @@ test-suite primer-test Tests.Utils Tests.Zipper Tests.Zipper.BindersAbove - TestUtils default-language: GHC2021 default-extensions: @@ -248,6 +280,7 @@ test-suite primer-test , prettyprinter-ansi-terminal , primer , primer-hedgehog + , primer-testlib , protolude , stm , stm-containers @@ -255,7 +288,7 @@ test-suite primer-test , tasty-discover , tasty-golden ^>=2.3.5 , tasty-hedgehog - , tasty-hunit ^>=0.10.0 + , tasty-hunit , text , time , transformers diff --git a/primer/test/Tests/API.hs b/primer/test/Tests/API.hs index f56eb3aa8..febd17e66 100644 --- a/primer/test/Tests/API.hs +++ b/primer/test/Tests/API.hs @@ -40,6 +40,12 @@ import Primer.Examples ( ) import Primer.Gen.API (genExprTreeOpts) import Primer.Gen.Core.Raw (evalExprGen, genExpr, genType) +import Primer.Test.Util ( + ExceptionPredicate, + assertException, + runAPI, + (@?=), + ) import Protolude.Unsafe (unsafeFromJust) import Tasty ( Property, @@ -48,12 +54,6 @@ import Tasty ( import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit hiding ((@?=)) -import TestUtils ( - ExceptionPredicate, - assertException, - runAPI, - (@?=), - ) import Text.Pretty.Simple (pShowNoColor) tasty_viewTreeExpr_injective :: Property diff --git a/primer/test/Tests/Action.hs b/primer/test/Tests/Action.hs index a31b15c1d..2ca172371 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -33,6 +33,7 @@ import Primer.Gen.Core.Raw ( genExpr, ) import Primer.Module (builtinModule) +import Primer.Test.Util (clearMeta, constructCon, constructRefinedCon, constructTCon) import Primer.Typecheck (SmartHoles (NoSmartHoles, SmartHoles)) import Primer.Zipper ( down, @@ -45,7 +46,6 @@ import Primer.Zipper ( import Tasty (Property, property) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import TestM (evalTestM) -import TestUtils (clearMeta, constructCon, constructRefinedCon, constructTCon) -- Note: 'maximum' is partial, but we believe that 'maxID' itself is -- safe due to the fact that 'universe x' always contains at least diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index f64e19128..b21f94938 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -95,6 +95,7 @@ import Primer.Module ( ) import Primer.Name (Name (unName)) import Primer.Questions (variablesInScopeExpr, variablesInScopeTy) +import Primer.Test.Util (testNoSevereLogs) import Primer.Typecheck ( CheckEverythingRequest (CheckEverything, toCheck, trusted), SmartHoles (NoSmartHoles, SmartHoles), @@ -107,7 +108,6 @@ import Tasty (Property, withDiscards, withTests) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit (Assertion, (@?=)) -import TestUtils (testNoSevereLogs) import Tests.Typecheck (TypeCacheAlpha (TypeCacheAlpha), runTypecheckTestMIn) import Text.Pretty.Simple (pShowNoColor) diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index de43733b1..3f4124631 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -115,6 +115,8 @@ import Primer.Log (PureLogT, runPureLogT) import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), builtinModule, moduleDefsQualified, moduleTypesQualified, primitiveModule) import Primer.Name import Primer.Primitives (PrimDef (IntAdd, ToUpper), primitiveGVar, tChar) +import Primer.Test.Util (LogMsg, assertNoSevereLogs, constructCon, constructTCon, zeroIDs, zeroTypeIDs) +import Primer.Test.Util qualified as Util import Primer.TypeDef (ASTTypeDef (..), TypeDef (..), ValCon (..), typeDefAST) import Primer.Typecheck ( KindError (UnknownTypeConstructor), @@ -123,8 +125,6 @@ import Primer.Typecheck ( ) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import TestM (TestM, evalTestM) -import TestUtils (LogMsg, assertNoSevereLogs, constructCon, constructTCon, zeroIDs, zeroTypeIDs) -import TestUtils qualified import Tests.Typecheck (checkProgWellFormed) import Prelude (error) @@ -818,9 +818,9 @@ unit_copy_paste_import = } importModules [m] prog <- gets appProg - case (findGlobalByName prog $ TestUtils.gvn ["M"] "foo", Map.assocs . moduleDefsQualified <$> progModules prog) of + case (findGlobalByName prog $ Util.gvn ["M"] "foo", Map.assocs . moduleDefsQualified <$> progModules prog) of (Just (DefAST fooDef), [[(i, _)]]) -> do - let fromDef = TestUtils.gvn ["M"] "foo" + let fromDef = Util.gvn ["M"] "foo" fromType = getID $ astDefType fooDef fromExpr = getID $ astDefExpr fooDef _ <- @@ -1733,13 +1733,13 @@ deleteDef :: Name -> ProgAction deleteDef = DeleteDef . gvn tcn :: Name -> TyConName -tcn = TestUtils.tcn $ unModuleName mainModuleName +tcn = Util.tcn $ unModuleName mainModuleName vcn :: Name -> ValConName -vcn = TestUtils.vcn $ unModuleName mainModuleName +vcn = Util.vcn $ unModuleName mainModuleName gvn :: Name -> GVarName -gvn = TestUtils.gvn $ unModuleName mainModuleName +gvn = Util.gvn $ unModuleName mainModuleName astDef :: Name -> Expr -> Type -> (Name, ASTDef) astDef n e t = (n, ASTDef e t) diff --git a/primer/test/Tests/Database.hs b/primer/test/Tests/Database.hs index 829ae0544..db2db6c71 100644 --- a/primer/test/Tests/Database.hs +++ b/primer/test/Tests/Database.hs @@ -52,10 +52,10 @@ import Primer.Examples ( even3App, ) import Primer.Log (PureLogT, runPureLogT) +import Primer.Test.Util (LogMsg, assertNoSevereLogs) import StmContainers.Map qualified as StmMap import Test.Tasty import Test.Tasty.HUnit -import TestUtils (LogMsg, assertNoSevereLogs) test_unmodified :: TestTree test_unmodified = diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index b89ff935e..5a14a31a5 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -59,11 +59,11 @@ import Primer.Eval ( import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), builtinModule, primitiveModule) import Primer.Primitives (PrimDef (EqChar, ToUpper), primitiveGVar, tChar) import Primer.Primitives.DSL (pfun) +import Primer.Test.Util (gvn, primDefs, vcn) import Primer.TypeDef (TypeDef (..)) import Primer.Zipper (target) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM (evalTestM) -import TestUtils (gvn, primDefs, vcn) import Tests.Action.Prog (runAppTestM) -- * 'tryReduce' tests diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index 98a9f40e8..a42655efc 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -83,6 +83,12 @@ import Primer.Primitives ( tInt, ) import Primer.Primitives.DSL (pfun) +import Primer.Test.Util ( + assertNoSevereLogs, + primDefs, + testNoSevereLogs, + zeroIDs, + ) import Primer.TypeDef (TypeDef (..), TypeDefMap) import Primer.Typecheck ( SmartHoles (NoSmartHoles), @@ -99,12 +105,6 @@ import Tasty ( ) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM -import TestUtils ( - assertNoSevereLogs, - primDefs, - testNoSevereLogs, - zeroIDs, - ) import Tests.Action.Prog (runAppTestM) import Tests.Eval ((~=)) import Tests.Gen.Core.Typed (checkTest) diff --git a/primer/test/Tests/NullDb.hs b/primer/test/Tests/NullDb.hs index 8a409d13e..4db62d9ea 100644 --- a/primer/test/Tests/NullDb.hs +++ b/primer/test/Tests/NullDb.hs @@ -25,12 +25,12 @@ import Primer.Examples ( even3App, mapOddApp, ) -import Test.Tasty -import Test.Tasty.HUnit (testCaseSteps) -import TestUtils ( +import Primer.Test.Util ( assertException, (@?=), ) +import Test.Tasty +import Test.Tasty.HUnit (testCaseSteps) -- 'Primer.Database.NullDbT' is only used to implement tests, but we -- test it here to ensure that any tests built on top of it should diff --git a/primer/test/Tests/Prelude/Utils.hs b/primer/test/Tests/Prelude/Utils.hs index c4b567956..d0ddb3f33 100644 --- a/primer/test/Tests/Prelude/Utils.hs +++ b/primer/test/Tests/Prelude/Utils.hs @@ -12,8 +12,8 @@ import Primer.Log (runPureLogT) import Primer.Module (builtinModule, moduleDefsQualified, moduleTypesQualified, primitiveModule) import Primer.Prelude (prelude) import Primer.Pretty (prettyExpr, sparse) +import Primer.Test.Util (isSevereLog, zeroIDs) import TestM (TestM, evalTestM) -import TestUtils (isSevereLog, zeroIDs) import Tests.EvalFull (evalResultExpr) import Prelude (error) diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 94712ffc2..f4d165e39 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -58,6 +58,7 @@ import Primer.Eval ( ) import Primer.Module (Module (Module, moduleDefs, moduleTypes), moduleName) import Primer.Name (Name, unsafeMkName) +import Primer.Test.Util (gvn, vcn) import Primer.TypeDef ( ASTTypeDef (..), TypeDef (..), @@ -68,7 +69,6 @@ import System.FilePath (takeBaseName) import Test.Tasty hiding (after) import Test.Tasty.Golden import Test.Tasty.HUnit -import TestUtils (gvn, vcn) -- | Check that encoding the value produces the file. test_encode :: TestTree diff --git a/primer/test/Tests/Transform.hs b/primer/test/Tests/Transform.hs index 3ea8da9f5..27f8c2e94 100644 --- a/primer/test/Tests/Transform.hs +++ b/primer/test/Tests/Transform.hs @@ -6,8 +6,8 @@ import Primer.Builtins import Primer.Core import Primer.Core.DSL import Primer.Core.Transform +import Primer.Test.Util (clearMeta, clearTypeMeta, vcn) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) -import TestUtils (clearMeta, clearTypeMeta, vcn) -- When renaming we have to be careful of binding sites. If we're renaming x to -- y and we encounter a binding site for a new variable v, then there are three diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index 13bf7add4..041b85e12 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -85,6 +85,12 @@ import Primer.Module (Module (..), builtinModule, primitiveModule) import Primer.Name (Name, NameCounter) import Primer.Primitives (PrimDef (HexToNat), tChar) import Primer.Primitives.DSL (pfun) +import Primer.Test.Util ( + tcn, + vcn, + zeroIDs, + zeroTypeIDs, + ) import Primer.TypeDef ( ASTTypeDef (..), TypeDef (..), @@ -114,12 +120,6 @@ import Primer.Typecheck ( import Tasty (Property, property, withDiscards, withTests) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM (TestM, evalTestM) -import TestUtils ( - tcn, - vcn, - zeroIDs, - zeroTypeIDs, - ) import Tests.Gen.Core.Typed unit_identity :: Assertion diff --git a/primer/test/Tests/Unification.hs b/primer/test/Tests/Unification.hs index 3ec675939..fb0c343c7 100644 --- a/primer/test/Tests/Unification.hs +++ b/primer/test/Tests/Unification.hs @@ -39,6 +39,7 @@ import Primer.Module (Module, builtinModule, primitiveModule) import Primer.Name (NameCounter) import Primer.Primitives (tInt) import Primer.Subst (substTys) +import Primer.Test.Util (tcn) import Primer.TypeDef (ASTTypeDef (ASTTypeDef, astTypeDefConstructors, astTypeDefNameHints, astTypeDefParameters), TypeDef (TypeDefAST)) import Primer.Typecheck ( Cxt, @@ -54,7 +55,6 @@ import Primer.Unification (unify) import Tasty (Property, withDiscards) import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) import TestM (evalTestM) -import TestUtils (tcn) import Tests.Gen.Core.Typed ( checkKindTest, checkValidContextTest, diff --git a/primer/testlib/Primer/Test/App.hs b/primer/testlib/Primer/Test/App.hs new file mode 100644 index 000000000..8da4decae --- /dev/null +++ b/primer/testlib/Primer/Test/App.hs @@ -0,0 +1,50 @@ +module Primer.Test.App ( + comprehensive, +) where + +import Foreword + +import Data.Map.Strict qualified as Map +import Primer.App ( + App, + Prog (..), + defaultProg, + mkApp, + ) +import Primer.Core ( + baseName, + mkSimpleModuleName, + ) +import Primer.Core.DSL (create) +import Primer.Examples qualified as Examples +import Primer.Module ( + Module ( + Module, + moduleDefs, + moduleName, + moduleTypes + ), + builtinModule, + primitiveModule, + ) + +-- | An initial test 'App' instance that contains all default type +-- definitions (including primitive types), all primitive functions, +-- and a top-level definition with extensive coverage of Primer's +-- core language. +comprehensive :: App +comprehensive = + let modName = mkSimpleModuleName "TestModule" + ((defName, def), id_) = create $ Examples.comprehensive modName + testProg = + defaultProg + { progImports = [builtinModule, primitiveModule] + , progModules = + [ Module + { moduleName = mkSimpleModuleName "TestModule" + , moduleTypes = mempty + , moduleDefs = Map.singleton (baseName defName) def + } + ] + } + in mkApp id_ (toEnum 0) testProg diff --git a/primer/test/TestUtils.hs b/primer/testlib/Primer/Test/Util.hs similarity index 99% rename from primer/test/TestUtils.hs rename to primer/testlib/Primer/Test/Util.hs index 61d48ebb4..ce5e2db0b 100644 --- a/primer/test/TestUtils.hs +++ b/primer/testlib/Primer/Test/Util.hs @@ -1,5 +1,5 @@ -- | Utilities useful across several types of tests. -module TestUtils ( +module Primer.Test.Util ( (@?=), ExceptionPredicate, assertException,