From 7671d68592fb4937144223dd8883b19150548634 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 13 Aug 2018 14:46:08 +0200
Subject: [PATCH] Better database encoding of JSON values

---
 src/Import/NoFoundation.hs |  3 ++-
 src/Model/Migration.hs     |  6 ++++++
 src/Model/Types.hs         |  7 ++++---
 src/Model/Types/JSON.hs    | 30 ++++++++++++++++++++++++++++++
 4 files changed, 42 insertions(+), 4 deletions(-)
 create mode 100644 src/Model/Types/JSON.hs

diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index c4eb77f32..252e9f8ac 100644
--- a/src/Import/NoFoundation.hs
+++ b/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
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index dd8e77baf..98652d070 100644
--- a/src/Model/Migration.hs
+++ b/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;
+      |]
+    )
   ]
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index fd861b860..21d89735e 100644
--- a/src/Model/Types.hs
+++ b/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)
diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs
new file mode 100644
index 000000000..8517ac011
--- /dev/null
+++ b/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"
+  |]