Fix #243

db.sh

@@ -1,6 +1,4 @@
-#!/usr/bin/env bash
+#!/usr/bin/env -S bash -xe
-
-set -xe
 
 stack build --fast --flag uniworx:library-only --flag uniworx:dev
 stack exec uniworxdb -- $@

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 "type" TYPE jsonb USING "type"::jsonb;
-          ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
+          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');
+        |]
+    )
   ]
 
 

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
+  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , 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
+  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece
   , sumEncoding = TaggedObject "type" "data"
   } ''SheetType
 derivePersistFieldJSON ''SheetType

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