diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index f1468b647..dd8e77baf 100644 --- a/src/Model/Migration.hs +++ b/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 + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 64e4efe2c..fd861b860 100644 --- a/src/Model/Types.hs +++ b/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 }