From 733b289bf9acde5cb8fdf6ff3cad93dd77bd2d15 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 30 Nov 2018 21:53:17 +0100 Subject: [PATCH] Fix #243 --- db.sh | 4 +--- src/Model/Migration.hs | 20 ++++++++++++++------ src/Model/Types.hs | 10 +++++----- test/Model/TypesSpec.hs | 26 ++++++++++++++++++++++++++ 4 files changed, 46 insertions(+), 14 deletions(-) diff --git a/db.sh b/db.sh index 28bd04d89..bb9685550 100755 --- a/db.sh +++ b/db.sh @@ -1,6 +1,4 @@ -#!/usr/bin/env bash - -set -xe +#!/usr/bin/env -S bash -xe stack build --fast --flag uniworx:library-only --flag uniworx:dev stack exec uniworxdb -- $@ diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 1aa9fe36a..ac11d3241 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -93,8 +93,8 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|] , whenM (tableExists "sheet") $ -- Better JSON encoding [executeQQ| - ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json; - ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json; + ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb; + ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb; |] ) , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|] @@ -154,7 +154,7 @@ customMigrations = Map.fromListWith (>>) Just load -> update uid [SheetCorrectorLoad =. load] _other -> error $ "Could not parse Load: " <> show str [executeQQ| - ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json; + ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE jsonb USING "load"::jsonb; |] ) , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|] @@ -170,7 +170,7 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] , whenM (tableExists "sheet") $ [executeQQ| - ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }'; + ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }'; |] ) , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] @@ -179,13 +179,13 @@ customMigrations = Map.fromListWith (>>) [executeQQ| DELETE FROM "user" WHERE "plugin" <> 'LDAP'; ALTER TABLE "user" DROP COLUMN "plugin"; - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" json DEFAULT '"ldap"'; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" jsonb DEFAULT '"ldap"'; |] ) , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] , whenM (tableExists "user") $ [executeQQ| - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]'; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]'; |] ) , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|] @@ -199,6 +199,14 @@ customMigrations = Map.fromListWith (>>) UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key'; |] ) + , ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|] + , whenM (tableExists "sheet") $ + [executeQQ| + UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", ''); + UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points'); + UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points'); + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index e368419c4..2f7d3318a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -119,11 +119,11 @@ data SheetGrading = Points { maxPoints :: Points } | PassPoints { maxPoints, passingPoints :: Points } | PassBinary -- non-zero means passed - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel , sumEncoding = TaggedObject "type" "data" } ''SheetGrading derivePersistFieldJSON ''SheetGrading @@ -166,8 +166,8 @@ data SheetType deriving (Eq, Read, Show) deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece , sumEncoding = TaggedObject "type" "data" } ''SheetType derivePersistFieldJSON ''SheetType diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 3c9169c40..518bb7990 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -9,6 +9,8 @@ import TestImport import Control.Lens (review, preview) +import Data.Aeson (encode, decode) + instance Arbitrary Season where arbitrary = elements [minBound..maxBound] @@ -24,6 +26,27 @@ instance Arbitrary TermIdentifier where instance Arbitrary Pseudonym where arbitrary = Pseudonym <$> arbitraryBoundedIntegral +instance Arbitrary SheetGrading where + arbitrary = oneof + [ Points <$> arbitrary + , do + maxPoints <- getNonNegative <$> arbitrary + passingPoints <- (getNonNegative <$> arbitrary) `suchThat` (<= maxPoints) + return PassPoints{..} + , return PassBinary + ] + shrink = genericShrink + +instance Arbitrary SheetType where + arbitrary = oneof + [ return NotGraded + , Normal <$> arbitrary + , Bonus <$> arbitrary + , Informational <$> arbitrary + ] + shrink = genericShrink + + spec :: Spec spec = do describe "TermIdentifier" $ do @@ -41,6 +64,9 @@ spec = do \pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym it "encodes to Text injectively" . property $ \p1 p2 -> p1 /= p2 ==> ((/=) `on` review _PseudonymText) p1 p2 + describe "SheetType" $ do + it "has compatible encoding/decoding to/from JSON" . property $ + \sg -> decode (encode sg) == Just (sg :: SheetType) termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do