Simplify format of UserTheme

src/Model/Migration.hs

@@ -14,7 +14,6 @@ import ClassyPrelude.Yesod
 
 import Model
 import Model.Migration.Version
-import Data.Version
 import Data.Map (Map)
 import qualified Data.Map as Map
 
@@ -78,5 +77,12 @@ migrateAll = do
 
 customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
 customMigrations = Map.fromListWith (>>)
-  [
+  [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
+    , do -- New theme format
+        userThemes <- [sqlQQ| SELECT @{UserId}, @{UserTheme} FROM ^{User}; |]
+        forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
+          Just v
+            | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
+          other -> error $ "Could not parse theme: " <> show other
+    )
   ]

src/Model/Types.hs

@@ -345,22 +345,8 @@ instance PathPiece Theme where
   fromPathPiece = finiteFromPathPiece
 
 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
-  
--- derivePersistFieldJSON "Theme" -- Preferred Version
--- Backwards-compatibility until database versioning is implemented (#120):
-instance PersistField Theme where
-  toPersistValue = PersistText . ("theme--" <>) . toPathPiece
-  fromPersistValue (PersistText t) = do
-    pp <- case Text.stripPrefix "theme--" t of
-      Just pp -> return pp
-      Nothing -> Left "Expected 'theme--'-Prefix"
-    case fromPathPiece pp of
-      Just th -> return th
-      Nothing -> Left "Could not parse PathPiece"
-  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
 
-instance PersistFieldSql Theme where
-  sqlType _ = SqlString
+derivePersistField "Theme"
 
 
 newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }