diff --git a/package.yaml b/package.yaml index 60cff14a5..5cecac14d 100644 --- a/package.yaml +++ b/package.yaml @@ -20,7 +20,7 @@ dependencies: - classy-prelude-conduit >=0.10.2 - bytestring >=0.9 && <0.11 - text >=0.11 && <2.0 -- persistent >=2.0 && <2.8 +- persistent >=2.7.2 && <2.8 - persistent-postgresql >=2.1.1 && <2.8 - persistent-template >=2.0 && <2.8 - template-haskell diff --git a/src/Application.hs b/src/Application.hs index aa4685549..93bd35d76 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do (pgPoolSize appDatabaseConf) -- Perform database migration using our application's logging settings. - runLoggingT (runSqlPool (runMigration $ migrateAll) pool) logFunc + runLoggingT (runSqlPool migrateAll pool) logFunc -- Return the foundation return $ mkFoundation pool diff --git a/src/CryptoID.hs b/src/CryptoID.hs index c0739843f..61fd5559c 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -55,7 +55,7 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId - , ''CourseId + , ''SchoolId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fcfde2613..2e7cdb0fe 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -345,11 +345,10 @@ courseEditHandler isGet course = do addMessageI "danger" $ MsgCourseNewDupShort tid csh (FormSuccess res@( - CourseForm { cfCourseId = Just cID + CourseForm { cfCourseId = Just cid , cfShort = csh , cfTerm = tid })) -> do -- edit existing course - cid <- decrypt cID now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] success <- runDB $ do @@ -389,7 +388,7 @@ courseEditHandler isGet course = do data CourseForm = CourseForm - { cfCourseId :: Maybe CryptoUUIDCourse + { cfCourseId :: Maybe CourseId , cfName :: CourseName , cfDesc :: Maybe Html , cfLink :: Maybe Text @@ -406,9 +405,8 @@ data CourseForm = CourseForm courseToForm :: MonadCrypto m => Entity Course -> m CourseForm courseToForm (Entity cid Course{..}) = do - cfCourseId <- Just <$> encrypt cid return $ CourseForm - { cfCourseId + { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription , cfLink = courseLinkExternal @@ -425,14 +423,15 @@ courseToForm (Entity cid Course{..}) = do newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm template = identForm FIDcourse $ \html -> do - -- mopt hiddenField - -- cidKey <- getsYesod appCryptoIDKey - -- courseId <- runMaybeT $ do - -- cid <- cfCourseId template - -- UUID.encrypt cidKey cid + userSchools <- liftHandlerT . runDB $ do + userId <- liftHandlerT requireAuthId + (fmap concat . sequence) + [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] + , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] + ] + let schoolField = selectField $ fmap entityKey <$> optionsPersistCryptoId [SchoolId <-. userSchools] [Asc SchoolName] schoolName (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm - -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? - <$> aopt hiddenField "courseId" (cfCourseId <$> template) + <$> pure (cfCourseId =<< template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) <*> aopt htmlField (fslI MsgCourseDescription & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) @@ -476,9 +475,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do |] ) _ -> (result, widget) --- where --- cid :: Maybe CourseId --- cid = join $ cfCourseId <$> template validateCourse :: CourseForm -> [Text] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 7600f1d8e..f405a6dd7 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -220,16 +220,6 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} --termField: see Utils.Term -schoolField :: Field Handler SchoolId -schoolField = selectField schools - where - schools = optionsPersistKey [] [Asc SchoolName] schoolName - -schoolEntField :: Field Handler (Entity School) -schoolEntField = selectField schools - where - schools = optionsPersist [] [Asc SchoolName] schoolName - zipFileField :: Bool -- ^ Unpack zips? -> Field Handler (Source Handler File) zipFileField doUnpack = Field{..} @@ -376,14 +366,14 @@ optionsPersistCryptoId :: forall site backend a msg. => [Filter a] -> [SelectOpt a] -> (a -> msg) - -> HandlerT site IO (OptionList (Key a)) + -> HandlerT site IO (OptionList (Entity a)) optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e - return $ map (\(cId, Entity key value) -> Option + return $ map (\(cId, e@(Entity key value)) -> Option { optionDisplay = mr (toDisplay value) - , optionInternalValue = key + , optionInternalValue = e , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 5f0353d8b..252e9f8ac 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,8 +3,10 @@ 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 import Yesod.Auth as Import diff --git a/src/Model.hs b/src/Model.hs index 9bff65c56..10fc4733e 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -18,8 +18,6 @@ module Model import ClassyPrelude.Yesod import Database.Persist.Quasi -import Database.Persist.Postgresql (migrateEnableExtension) -import Database.Persist.Sql (Migration) -- import Data.Time -- import Data.ByteString import Model.Types @@ -31,17 +29,12 @@ import Data.CaseInsensitive (CI) -- You can find more information on persistent and how to declare entities -- at: -- http://www.yesodweb.com/book/persistent/ -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"] +share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] $(persistFileWith lowerCaseSettings "models") -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) -migrateAll :: Migration -migrateAll = do - migrateEnableExtension "citext" - migrateAll' - data PWEntry = PWEntry { pwUser :: User , pwHash :: Text diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs new file mode 100644 index 000000000..98652d070 --- /dev/null +++ b/src/Model/Migration.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Model.Migration + ( migrateAll + ) where + +import ClassyPrelude.Yesod + +import Model +import Model.Migration.Version +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Set (Set) +import qualified Data.Set as Set + +import Database.Persist.Sql +import Database.Persist.Postgresql + + +-- Database versions must follow https://pvp.haskell.org: +-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) +-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) + +-- Note that only one automatic migration is done (after all manual migrations). +-- Manual migrations can therefore not rely on non-breaking changes being applied when they are executed (i.e. columns existing, that were added as non-breaking changes after InitialVersion) +-- If that is inconvenient a custom migration between minor version numbers can be formulated using `migration`, `runMigration`, and manually defined `EntityDef`s so as to use persistent's automatic migration system + +-- Database versions must be marked with git tags: +-- The first commit corresponding to a new database version x.x.x must be tagged dbx.x.x +-- Tags should be annotated with a description of the changes affecting the database. +-- +-- Example: +-- $ git tag -a db0.0.0 -m "Simplified format of UserTheme" +-- +-- Doing so creates sort of parallel commit history tracking changes to the database schema + + +share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] + [persistLowerCase| + AppliedMigration json + from MigrationVersion + to Version + time UTCTime + UniqueAppliedMigration from + Primary from to + deriving Show Eq Ord + |] + +migrateAll :: MonadIO m => ReaderT SqlBackend m () +migrateAll = do + runMigration $ do + -- Manual migrations to go to InitialVersion below: + migrateEnableExtension "citext" + + migrateDBVersioning + + appliedMigrations <- map entityKey <$> selectList [] [] + let + missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations + doCustomMigration acc desc migration = acc <* do + let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc + appliedMigrationTime <- liftIO getCurrentTime + migration + insert AppliedMigration{..} + -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey + Map.foldlWithKey doCustomMigration (return ()) missingMigrations + + runMigration migrateAll' + + +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 + ) + , ( 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/Migration/Version.hs b/src/Model/Migration/Version.hs new file mode 100644 index 000000000..37bbd8f3f --- /dev/null +++ b/src/Model/Migration/Version.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Migration.Version + ( MigrationVersion(..) + , version, migrationVersion + , module Data.Version + ) where + +import ClassyPrelude.Yesod + +import Database.Persist.Sql +import Text.ParserCombinators.ReadP +import Data.Maybe (fromJust) + +import Data.Version + +import Data.Aeson.TH + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax (Lift) +import qualified Language.Haskell.TH.Syntax as TH (lift) + +import Data.Data (Data) + + +deriving instance Lift Version + + +data MigrationVersion = InitialVersion | MigrationVersion Version + deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift) + +deriveJSON defaultOptions + { constructorTagModifier = toLower . fromJust . stripSuffix "Version" + , sumEncoding = UntaggedValue + } ''MigrationVersion + +instance PersistField MigrationVersion where + toPersistValue InitialVersion = PersistText "initial" + toPersistValue (MigrationVersion v) = PersistText . pack $ showVersion v + + fromPersistValue (PersistText t) + | t == "initial" = return InitialVersion + | otherwise = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of + [x] -> Right $ MigrationVersion x + [] -> Left "No parse" + _ -> Left "Ambiguous parse" + fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x + +instance PersistFieldSql MigrationVersion where + sqlType _ = SqlString + + +instance PersistField Version where + toPersistValue = PersistText . pack . showVersion + + fromPersistValue (PersistText t) = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of + [x] -> Right x + [] -> Left "No parse" + _ -> Left "Ambiguous parse" + fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x + +instance PersistFieldSql Version where + sqlType _ = SqlString + + +version, migrationVersion :: QuasiQuoter +version = QuasiQuoter{..} + where + quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of + [x] -> x + [] -> error "No parse" + _ -> error "Ambiguous parse" + quotePat = error "version cannot be used as pattern" + quoteType = error "version cannot be used as type" + quoteDec = error "version cannot be used as declaration" +migrationVersion = QuasiQuoter{..} + where + quoteExp "initial" = TH.lift InitialVersion + quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of + [x] -> MigrationVersion x + [] -> error "No parse" + _ -> error "Ambiguous parse" + quotePat = error "version cannot be used as pattern" + quoteType = error "version cannot be used as type" + quoteDec = error "version cannot be used as declaration" diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 64e4efe2c..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) @@ -345,22 +346,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 } 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" + |] diff --git a/stack.yaml b/stack.yaml index 82f2e0c30..8f93444f8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,4 +34,6 @@ extra-deps: - system-locale-0.3.0.0 + - persistent-2.7.3.1 + resolver: lts-10.5