Better database encoding of JSON values

src/Import/NoFoundation.hs

@@ -3,8 +3,9 @@ module Import.NoFoundation
     ( module Import
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON)
 import Model                  as Import
+import Model.Types.JSON       as Import
 import Model.Migration        as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import

src/Model/Migration.hs

@@ -85,4 +85,10 @@ customMigrations = Map.fromListWith (>>)
             | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
           other -> error $ "Could not parse theme: " <> show other
     )
+  , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
+    , [executeQQ| -- Better JSON encoding
+        ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json;
+        ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
+      |]
+    )
   ]

src/Model/Types.hs

@@ -26,7 +26,8 @@ import Data.Universe.Helpers
 
 import Text.Read (readMaybe)
 
-import Database.Persist.TH
+import Database.Persist.TH hiding (derivePersistFieldJSON)
+import Model.Types.JSON
 import Database.Persist.Class
 import Database.Persist.Sql
 
@@ -78,7 +79,7 @@ instance DisplayAble SheetType where
   display (NotGraded)  = "Unbewertet"
 
 deriveJSON defaultOptions ''SheetType
-derivePersistFieldJSON "SheetType"
+derivePersistFieldJSON ''SheetType
 
 data SheetTypeSummary = SheetTypeSummary
   { sumBonusPoints  :: Sum Points
@@ -107,7 +108,7 @@ data SheetGroup
   | NoGroups
   deriving (Show, Read, Eq)
 deriveJSON defaultOptions ''SheetGroup
-derivePersistFieldJSON "SheetGroup"
+derivePersistFieldJSON ''SheetGroup
 
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)

src/Model/Types/JSON.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+
+module Model.Types.JSON
+  ( derivePersistFieldJSON
+  ) where
+
+import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Database.Persist.Sql
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding as Text
+
+import qualified Data.Aeson as JSON
+
+import Language.Haskell.TH
+
+
+derivePersistFieldJSON :: Name -> DecsQ
+derivePersistFieldJSON n = [d|
+    instance PersistField $(conT n) where
+      toPersistValue = PersistDbSpecific . LBS.toStrict . JSON.encode
+      fromPersistValue (PersistDbSpecific bs) = first pack $ JSON.eitherDecodeStrict' bs
+      fromPersistValue (PersistByteString bs) = first pack $ JSON.eitherDecodeStrict' bs
+      fromPersistValue (PersistText       t ) = first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 t
+      fromPersistValue _ = Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
+
+    instance PersistFieldSql $(conT n) where
+      sqlType _ = SqlOther "json"
+  |]