-
Notifications
You must be signed in to change notification settings - Fork 1
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
broken by `PrimerJSON` change in previous commit NB `UpdateSessionName` still passes
- Loading branch information
Showing
6 changed files
with
1 addition
and
401 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,78 +1 @@ | ||
| {-# LANGUAGE BlockArguments #-} | ||
|
|
||
| module Tests.DeleteSession where | ||
|
|
||
| import Foreword | ||
|
|
||
| import Primer.App ( | ||
| newApp, | ||
| ) | ||
| import Primer.Database ( | ||
| DbError (SessionIdNotFound), | ||
| SessionId, | ||
| deleteSession, | ||
| getCurrentTime, | ||
| insertSession, | ||
| newSessionId, | ||
| querySessionId, | ||
| safeMkSessionName, | ||
| updateSessionApp, | ||
| ) | ||
| import Primer.Database.Selda ( | ||
| SeldaDbException (UpdateAppNonExistentSession), | ||
| ) | ||
| import Primer.Database.Selda.Test.Util ( | ||
| runTmpDb, | ||
| ) | ||
| import Primer.Test.Util ( | ||
| assertException, | ||
| (@?=), | ||
| ) | ||
| import Test.Tasty (TestTree) | ||
| import Test.Tasty.HUnit (testCaseSteps) | ||
|
|
||
| expectedError :: SessionId -> SeldaDbException -> Bool | ||
| expectedError id_ (UpdateAppNonExistentSession s) = s == id_ | ||
| expectedError _ _ = False | ||
|
|
||
| test_deleteSession :: TestTree | ||
| test_deleteSession = testCaseSteps "deleteSession" $ \step' -> | ||
| runTmpDb $ do | ||
| let step = liftIO . step' | ||
|
|
||
| step "Insert program" | ||
| now <- getCurrentTime | ||
| let version = "git123" | ||
| let name = safeMkSessionName "test deleteSession" | ||
| sessionId <- liftIO newSessionId | ||
| insertSession version sessionId newApp name now | ||
|
|
||
| step "Delete the session" | ||
| r1 <- deleteSession sessionId | ||
| r1 @?= Right () | ||
|
|
||
| step "Ensure the session has been deleted" | ||
| r2 <- querySessionId sessionId | ||
| r2 @?= Left (SessionIdNotFound sessionId) | ||
|
|
||
| step "Try to delete the session again" | ||
| r3 <- deleteSession sessionId | ||
| r3 @?= Left (SessionIdNotFound sessionId) | ||
|
|
||
| step "Try to delete a non-existent session" | ||
| nonexistentSessionId <- liftIO newSessionId | ||
| r4 <- deleteSession nonexistentSessionId | ||
| r4 @?= Left (SessionIdNotFound nonexistentSessionId) | ||
|
|
||
| step "Insert another new program" | ||
| let name2 = safeMkSessionName "test deleteSession 2" | ||
| sessionId2 <- liftIO newSessionId | ||
| insertSession version sessionId2 newApp name2 now | ||
|
|
||
| step "Delete the new session" | ||
| r5 <- deleteSession sessionId2 | ||
| r5 @?= Right () | ||
|
|
||
| step "Attempt to update the deleted session" | ||
| now' <- getCurrentTime | ||
| assertException "deleteSession" (expectedError sessionId2) $ updateSessionApp version sessionId2 newApp now' |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,111 +1 @@ | ||
| {-# LANGUAGE BlockArguments #-} | ||
|
|
||
| module Tests.InsertSession where | ||
|
|
||
| import Foreword | ||
|
|
||
| import Primer.App ( | ||
| newApp, | ||
| newEmptyApp, | ||
| ) | ||
| import Primer.Database ( | ||
| SessionData (..), | ||
| SessionId, | ||
| insertSession, | ||
| newSessionId, | ||
| querySessionId, | ||
| safeMkSessionName, | ||
| ) | ||
| import Primer.Database.Selda ( | ||
| SeldaDbException (InsertError), | ||
| ) | ||
| import Primer.Database.Selda.Test.Util ( | ||
| lowPrecisionCurrentTime, | ||
| runTmpDb, | ||
| ) | ||
| import Primer.Test.App ( | ||
| comprehensive, | ||
| ) | ||
| import Primer.Test.Util ( | ||
| assertException, | ||
| (@?=), | ||
| ) | ||
| import Test.Tasty (TestTree) | ||
| import Test.Tasty.HUnit (testCaseSteps) | ||
|
|
||
| expectedError :: SessionId -> SeldaDbException -> Bool | ||
| expectedError id_ (InsertError s _) = s == id_ | ||
| expectedError _ _ = False | ||
|
|
||
| test_insertSession_roundtrip :: TestTree | ||
| test_insertSession_roundtrip = testCaseSteps "insertSession database round-tripping" $ \step' -> | ||
| runTmpDb $ do | ||
| let step = liftIO . step' | ||
| step "Insert comprehensive" | ||
| now <- lowPrecisionCurrentTime | ||
| let version = "git123" | ||
| let name = safeMkSessionName "comprehensive" | ||
| sessionId <- liftIO newSessionId | ||
| insertSession version sessionId comprehensive name now | ||
|
|
||
| step "Retrieve it" | ||
| result <- querySessionId sessionId | ||
| result @?= Right (SessionData comprehensive name now) | ||
|
|
||
| let jpName = safeMkSessionName "サンプルプログラム" | ||
| step "Insert app with Japanese name" | ||
| sid1 <- liftIO newSessionId | ||
| insertSession version sid1 comprehensive jpName now | ||
| r1 <- querySessionId sid1 | ||
| r1 @?= Right (SessionData comprehensive jpName now) | ||
|
|
||
| let cnName = safeMkSessionName "示例程序" | ||
| step "Insert app with simplified Chinese name" | ||
| sid2 <- liftIO newSessionId | ||
| insertSession version sid2 comprehensive cnName now | ||
| r2 <- querySessionId sid2 | ||
| r2 @?= Right (SessionData comprehensive cnName now) | ||
|
|
||
| let arName = safeMkSessionName "برنامج مثال" | ||
| step "Insert app with Arabic name" | ||
| sid3 <- liftIO newSessionId | ||
| insertSession version sid3 comprehensive arName now | ||
| r3 <- querySessionId sid3 | ||
| r3 @?= Right (SessionData comprehensive arName now) | ||
|
|
||
| let emName = safeMkSessionName "😄😂🤣🤗 🦊 🦈" | ||
| step "Insert app with emoji name" | ||
| sid4 <- liftIO newSessionId | ||
| insertSession version sid4 comprehensive emName now | ||
| r4 <- querySessionId sid4 | ||
| r4 @?= Right (SessionData comprehensive emName now) | ||
|
|
||
| test_insertSession_failure :: TestTree | ||
| test_insertSession_failure = testCaseSteps "insertSession failure modes" $ \step' -> | ||
| runTmpDb $ do | ||
| let step = liftIO . step' | ||
|
|
||
| step "Insert program" | ||
| now <- lowPrecisionCurrentTime | ||
| let version = "git123" | ||
| let name = safeMkSessionName "testNewApp" | ||
| sessionId <- liftIO newSessionId | ||
| insertSession version sessionId newApp name now | ||
|
|
||
| step "Attempt to insert the same program and metadata again" | ||
| assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newApp name now | ||
|
|
||
| step "Attempt to insert a different program with the same metadata" | ||
| assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newEmptyApp name now | ||
|
|
||
| step "Attempt to insert the same program with a different version" | ||
| let newVersion = "new-" <> version | ||
| assertException "insertSession" (expectedError sessionId) $ insertSession newVersion sessionId newApp name now | ||
|
|
||
| step "Attempt to insert the same program with a different name" | ||
| let newName = safeMkSessionName "new name" | ||
| assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newApp newName now | ||
|
|
||
| step "Attempt to insert the same program with a different timestamp" | ||
| now' <- lowPrecisionCurrentTime | ||
| assertException "insertSession" (expectedError sessionId) $ insertSession version sessionId newApp newName now' |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,53 +1 @@ | ||
| {-# LANGUAGE BlockArguments #-} | ||
| {-# LANGUAGE RecordWildCards #-} | ||
|
|
||
| module Tests.ListSessions where | ||
|
|
||
| import Foreword | ||
|
|
||
| import Primer.App (newApp) | ||
| import Primer.Database ( | ||
| LastModified (..), | ||
| OffsetLimit (OL, limit, offset), | ||
| Page (pageContents, total), | ||
| Session (Session), | ||
| insertSession, | ||
| listSessions, | ||
| safeMkSessionName, | ||
| ) | ||
| import Primer.Database.Selda.SQLite ( | ||
| SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), | ||
| ) | ||
| import Primer.Database.Selda.Test.Util ( | ||
| mkSessionRow, | ||
| runTmpDb, | ||
| ) | ||
| import Primer.Test.Util ((@?=)) | ||
| import Test.Tasty (TestTree) | ||
| import Test.Tasty.HUnit (testCaseSteps) | ||
|
|
||
| test_listSessions :: TestTree | ||
| test_listSessions = testCaseSteps "listSessions" $ \step' -> | ||
| runTmpDb $ do | ||
| let step = liftIO . step' | ||
| let m = 345 | ||
| step "Insert all sessions" | ||
| 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" | ||
| pAll <- listSessions $ OL{offset = 0, limit = Nothing} | ||
| total pAll @?= m | ||
| pageContents pAll @?= expectedRows | ||
| step "Get 25" | ||
| p25 <- listSessions $ OL{offset = 0, limit = Just 25} | ||
| total p25 @?= m | ||
| pageContents p25 @?= map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) (take 25 rows) | ||
| step "Get 76-100" | ||
| p75 <- listSessions $ OL{offset = 75, limit = Just 25} | ||
| total p75 @?= m | ||
| pageContents p75 @?= map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) (take 25 $ drop 75 rows) | ||
| step "Get crossing end" | ||
| pLast <- listSessions $ OL{offset = m - 10, limit = Just 25} | ||
| total pLast @?= m | ||
| pageContents pLast @?= map (\r -> Session (uuid r) (safeMkSessionName $ name r) (LastModified $ lastmodified r)) (drop (m - 10) rows) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,80 +1 @@ | ||
| {-# LANGUAGE BlockArguments #-} | ||
|
|
||
| module Tests.QuerySessionId where | ||
|
|
||
| import Foreword | ||
|
|
||
| import Data.Aeson qualified as Aeson ( | ||
| encode, | ||
| ) | ||
| import Primer.App ( | ||
| newApp, | ||
| ) | ||
| import Primer.Database ( | ||
| DbError (SessionIdNotFound), | ||
| LastModified (..), | ||
| SessionData (..), | ||
| defaultSessionName, | ||
| insertSession, | ||
| newSessionId, | ||
| querySessionId, | ||
| safeMkSessionName, | ||
| ) | ||
| import Primer.Database.Selda.SQLite qualified as Schema ( | ||
| SessionRow (SessionRow, app, gitversion, lastmodified, name, uuid), | ||
| ) | ||
| import Primer.Database.Selda.Test.Util ( | ||
| insertSessionRow, | ||
| lowPrecisionCurrentTime, | ||
| runTmpDb, | ||
| ) | ||
| import Primer.Test.Util ((@?=)) | ||
| 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 | ||
| -- insert into the database using 'insertSession' etc. Therefore, | ||
| -- these tests are focused on finding corner cases and testing for | ||
| -- particular failure modes. | ||
| -- | ||
| -- Note that several of these corner cases are things that should | ||
| -- "never happen" because our types make them impossible, but we test | ||
| -- them anyway (using the raw database interface to circumvent our | ||
| -- types) to ensure we can handle database corruption, bugs, schema | ||
| -- migration issues, etc. | ||
|
|
||
| test_querySessionId :: TestTree | ||
| test_querySessionId = testCaseSteps "querySessionId corner cases" $ \step' -> | ||
| runTmpDb $ do | ||
| let step = liftIO . step' | ||
|
|
||
| step "Insert program" | ||
| now <- lowPrecisionCurrentTime | ||
| let version = "git123" | ||
| let name = safeMkSessionName "test querySessionId" | ||
| sessionId <- liftIO newSessionId | ||
| insertSession version sessionId newApp name now | ||
|
|
||
| step "Attempt to look up a session that doesn't exist" | ||
| nonexistentSessionId <- liftIO newSessionId | ||
| r1 <- querySessionId nonexistentSessionId | ||
| r1 @?= Left (SessionIdNotFound nonexistentSessionId) | ||
|
|
||
| step "Attempt to fetch a session whose name is invalid" | ||
| invalidNameSessionId <- liftIO newSessionId | ||
| let invalidName = "" | ||
| let invalidNameRow = | ||
| Schema.SessionRow | ||
| { Schema.uuid = invalidNameSessionId | ||
| , Schema.gitversion = version | ||
| , Schema.app = Aeson.encode newApp | ||
| , Schema.name = invalidName | ||
| , Schema.lastmodified = utcTime now | ||
| } | ||
| insertSessionRow invalidNameRow | ||
| r3 <- querySessionId invalidNameSessionId | ||
| -- In this scenario, we should get the program back with the | ||
| -- default session name, rather than the invalid name we used to | ||
| -- store it in the database. | ||
| r3 @?= Right (SessionData newApp defaultSessionName now) |
Oops, something went wrong.