Merge branch 'master' into 'live'

Fix #243

Closes #243

See merge request !118

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

db.sh

@@ -1,6 +1,4 @@
-#!/usr/bin/env bash
+#!/usr/bin/env -S bash -xe
-
-set -xe
 
 stack build --fast --flag uniworx:library-only --flag uniworx:dev
 stack exec uniworxdb -- $@

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

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")

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|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|]
+    Left  route -> do
+      route' <- toTextUrl route
+      [whamlet|<a .btn ##{triggerId} href=#{route'}>^{modalTrigger}|]
     Right _     -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]

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 "type" TYPE jsonb USING "type"::jsonb;
-          ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
+          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');
+        |]
+    )
   ]
 
 

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
+  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , 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
+  { constructorTagModifier = camelToPathPiece
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece
   , sumEncoding = TaggedObject "type" "data"
   } ''SheetType
 derivePersistFieldJSON ''SheetType

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 --

templates/adminTest.hamlet

@@ -32,7 +32,7 @@
           ^{btnWdgt}
     <li><br>
       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")}
     <li>
       ^{modal "Email-Test" (Right emailWidget')}

templates/authpreds.hamlet

@@ -1,2 +1,4 @@
-<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype} :isModal:data-ajax-submit>
+<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype}>
+  $maybe referer <- mReferer
+    <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
   ^{authActiveWidget}

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