diff --git a/ChangeLog.md b/ChangeLog.md index 301b28c18..c921658a6 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 30.11.2018 + + Bugfix: Übungsblätter im "bestehen nach Punkten"-Modus werden wieder korrekt gespeichert + * Version 29.11.2018 Bugfix: Formulare innerhalb von Tabellen funktionieren nun auch nach Javascript-Seitenwechsel oder Ändern der Sortierung @@ -8,7 +12,6 @@ Verschiedene Verbesserungen für Korrektoren - * Version 19.10.2018 Benutzer können sich in der Testphase komplett selbst löschen diff --git a/db.sh b/db.sh index 28bd04d89..bb9685550 100755 --- a/db.sh +++ b/db.sh @@ -1,6 +1,4 @@ -#!/usr/bin/env bash - -set -xe +#!/usr/bin/env -S bash -xe stack build --fast --flag uniworx:library-only --flag uniworx:dev stack exec uniworxdb -- $@ diff --git a/src/Foundation.hs b/src/Foundation.hs index b6db48a8a..8577ae9fd 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -227,25 +227,6 @@ embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" < data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -class RedirectUrl site url => HasRoute site url where - urlRoute :: url -> Route site - -instance HasRoute site (Route site) where - urlRoute = id -instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where - urlRoute = view _1 -instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where - urlRoute = view _1 -instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where - urlRoute (a :#: _) = urlRoute a - -data SomeRoute site = forall url. HasRoute site url => SomeRoute url - -instance RedirectUrl site (SomeRoute site) where - toTextUrl (SomeRoute url) = toTextUrl url -instance HasRoute site (SomeRoute site) where - urlRoute (SomeRoute url) = urlRoute url - data MenuItem = MenuItem { menuItemLabel :: UniWorXMessage , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery @@ -601,7 +582,7 @@ evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route evalAccess route isWrite = do tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route - (result, (Set.toList -> deactivated)) <- runWriterT $ evalAuthTags tagActive dnf route isWrite + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite result <$ tellSessionJson SessionInactiveAuthTags deactivated evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult @@ -811,7 +792,8 @@ siteLayout headingOverride widget = do | otherwise -> do applySystemMessages authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags - forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR) + forM_ authTagPivots $ + \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) getMessages let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2a87a09e8..f4125de79 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -4,6 +4,7 @@ import Import import Handler.Utils import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Time hiding (formatTime) @@ -281,20 +282,24 @@ postHelpR = do getAuthPredsR, postAuthPredsR :: Handler Html getAuthPredsR = postAuthPredsR postAuthPredsR = do - AuthTagActive{..} <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagIsActive authTag) + let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True <* submitButton - formResultModal authActiveRes AuthPredsR $ \authTagActive -> do + mReferer <- runMaybeT $ do + param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) + MaybeT . return $ fromPathPiece param + formResult authActiveRes $ \authTagActive -> do setSessionJson SessionActiveAuthTags authTagActive - tell . pure =<< messageI Success MsgAuthPredsActiveChanged + modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) + addMessageI Success MsgAuthPredsActiveChanged + redirect $ fromMaybe AuthPredsR mReferer defaultLayout $ do setTitleI MsgAuthPredsActive - isModal <- hasCustomHeader HeaderIsModal $(widgetFile "authpreds") diff --git a/src/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index 14f8ce38c..89cb2062c 100644 --- a/src/Handler/Utils/Templates.hs +++ b/src/Handler/Utils/Templates.hs @@ -7,12 +7,14 @@ import Import.NoFoundation lipsum :: WidgetT site IO () lipsum = $(widgetFile "widgets/lipsum") -modal :: WidgetT site IO () -> Either (Route site) (WidgetT site IO ()) -> WidgetT site IO () +modal :: WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> WidgetT site IO () modal modalTrigger modalContent = do let modalDynamic = isLeft modalContent modalId <- newIdent triggerId <- newIdent $(widgetFile "widgets/modal") case modalContent of - Left route -> [whamlet|^{modalTrigger}|] + Left route -> do + route' <- toTextUrl route + [whamlet|^{modalTrigger}|] Right _ -> [whamlet|
^{modalTrigger}|] diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 1aa9fe36a..ac11d3241 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -93,8 +93,8 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|] , whenM (tableExists "sheet") $ -- Better JSON encoding [executeQQ| - ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json; - ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json; + ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb; + ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb; |] ) , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|] @@ -154,7 +154,7 @@ customMigrations = Map.fromListWith (>>) Just load -> update uid [SheetCorrectorLoad =. load] _other -> error $ "Could not parse Load: " <> show str [executeQQ| - ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json; + ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE jsonb USING "load"::jsonb; |] ) , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|] @@ -170,7 +170,7 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] , whenM (tableExists "sheet") $ [executeQQ| - ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }'; + ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }'; |] ) , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] @@ -179,13 +179,13 @@ customMigrations = Map.fromListWith (>>) [executeQQ| DELETE FROM "user" WHERE "plugin" <> 'LDAP'; ALTER TABLE "user" DROP COLUMN "plugin"; - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" json DEFAULT '"ldap"'; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" jsonb DEFAULT '"ldap"'; |] ) , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] , whenM (tableExists "user") $ [executeQQ| - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]'; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]'; |] ) , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|] @@ -199,6 +199,14 @@ customMigrations = Map.fromListWith (>>) UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key'; |] ) + , ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|] + , whenM (tableExists "sheet") $ + [executeQQ| + UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", ''); + UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points'); + UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points'); + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index e368419c4..4e592e279 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -119,11 +119,11 @@ data SheetGrading = Points { maxPoints :: Points } | PassPoints { maxPoints, passingPoints :: Points } | PassBinary -- non-zero means passed - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel , sumEncoding = TaggedObject "type" "data" } ''SheetGrading derivePersistFieldJSON ''SheetGrading @@ -163,11 +163,11 @@ data SheetType | Bonus { grading :: SheetGrading } | Informational { grading :: SheetGrading } | NotGraded - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece , sumEncoding = TaggedObject "type" "data" } ''SheetType derivePersistFieldJSON ''SheetType diff --git a/src/Utils.hs b/src/Utils.hs index 05e93753a..8965c0009 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -100,6 +100,25 @@ unsupportedAuthPredicate = do |] +class RedirectUrl site url => HasRoute site url where + urlRoute :: url -> Route site + +instance HasRoute site (Route site) where + urlRoute = id +instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where + urlRoute = view _1 +instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where + urlRoute = view _1 +instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where + urlRoute (a :#: _) = urlRoute a + +data SomeRoute site = forall url. HasRoute site url => SomeRoute url + +instance RedirectUrl site (SomeRoute site) where + toTextUrl (SomeRoute url) = toTextUrl url +instance HasRoute site (SomeRoute site) where + urlRoute (SomeRoute url) = urlRoute url + --------------------- -- Text and String -- diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 0693ea1cc..2cc3f24f3 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -32,7 +32,7 @@ ^{btnWdgt}

  • Modals: - ^{modal "Klick mich für Ajax-Test" (Left UsersR)} + ^{modal "Klick mich für Ajax-Test" (Left $ SomeRoute UsersR)} ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
  • ^{modal "Email-Test" (Right emailWidget')} diff --git a/templates/authpreds.hamlet b/templates/authpreds.hamlet index abb3042c3..d7430fbae 100644 --- a/templates/authpreds.hamlet +++ b/templates/authpreds.hamlet @@ -1,2 +1,4 @@ -
    + + $maybe referer <- mReferer + ^{authActiveWidget} diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 3c9169c40..518bb7990 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -9,6 +9,8 @@ import TestImport import Control.Lens (review, preview) +import Data.Aeson (encode, decode) + instance Arbitrary Season where arbitrary = elements [minBound..maxBound] @@ -24,6 +26,27 @@ instance Arbitrary TermIdentifier where instance Arbitrary Pseudonym where arbitrary = Pseudonym <$> arbitraryBoundedIntegral +instance Arbitrary SheetGrading where + arbitrary = oneof + [ Points <$> arbitrary + , do + maxPoints <- getNonNegative <$> arbitrary + passingPoints <- (getNonNegative <$> arbitrary) `suchThat` (<= maxPoints) + return PassPoints{..} + , return PassBinary + ] + shrink = genericShrink + +instance Arbitrary SheetType where + arbitrary = oneof + [ return NotGraded + , Normal <$> arbitrary + , Bonus <$> arbitrary + , Informational <$> arbitrary + ] + shrink = genericShrink + + spec :: Spec spec = do describe "TermIdentifier" $ do @@ -41,6 +64,9 @@ spec = do \pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym it "encodes to Text injectively" . property $ \p1 p2 -> p1 /= p2 ==> ((/=) `on` review _PseudonymText) p1 p2 + describe "SheetType" $ do + it "has compatible encoding/decoding to/from JSON" . property $ + \sg -> decode (encode sg) == Just (sg :: SheetType) termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do