Minor merge

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

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

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

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
+    userSchools <- liftHandlerT . runDB $ do
-    --     cidKey <- getsYesod appCryptoIDKey
+      userId <- liftHandlerT requireAuthId
-    --     courseId <- runMaybeT $ do
+      (fmap concat . sequence)
-    --         cid <- cfCourseId template
+        [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
-    --         UUID.encrypt cidKey cid
+        , 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?
+      <$> pure (cfCourseId =<< template)
-      <$> aopt hiddenField "courseId"             (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]

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
 

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

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

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;
+      |]
+    )
+  ]

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"

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
+derivePersistField "Theme"
-  sqlType _ = SqlString
 
 
 newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }

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"
+  |]

stack.yaml

@@ -34,4 +34,6 @@ extra-deps:
 
   - system-locale-0.3.0.0
 
+  - persistent-2.7.3.1
+
 resolver: lts-10.5