Merge branch 'master' into 'live'
Fix #243 Closes #243 See merge request !118
This commit is contained in:
Gregor Kleen
commit
b69ff58bca
@ -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
|
||||
|
||||
4
db.sh
4
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 -- $@
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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}|]
|
||||
|
||||
@ -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');
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
19
src/Utils.hs
19
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 --
|
||||
|
||||
@ -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')}
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user