fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix #243

Browse Source
This commit is contained in:
Gregor Kleen 2018-11-30 21:53:17 +01:00
parent 5e911d22bc
commit 733b289bf9
4 changed files with 46 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
db.sh
View File

@ -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 -- $@

20
src/Model/Migration.hs
View File

@ -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');
|]
)
]

10
src/Model/Types.hs
View File

@ -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

26
test/Model/TypesSpec.hs
View File

@ -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