diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 45ced319f..a399a4c52 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -59,7 +59,6 @@ campusForm :: ( RenderMessage site FormMessage campusForm = CampusLogin <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing <*> areq passwordField (fslI MsgCampusPassword) Nothing - <* submitButton campusLogin :: forall site. ( YesodAuth site diff --git a/src/Foundation.hs b/src/Foundation.hs index 96d829240..b2ed47c49 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -26,8 +26,10 @@ import qualified Data.CaseInsensitive as CI import qualified Data.CryptoID as E import Data.ByteArray (convert) -import Crypto.Hash (Digest, SHAKE256) +import Crypto.Hash (Digest, SHAKE256, SHAKE128) import Crypto.Hash.Conduit (sinkHash) +import qualified Data.UUID as UUID +import qualified Data.Binary as Binary import qualified Data.ByteString.Base64.URL as Base64 (encode) @@ -2130,7 +2132,6 @@ instance YesodAuth UniWorX where [ UserLastAuthentication =. Just now | not isDummy ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate - studyTermCandidateIncidence <- liftIO getRandom let userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now @@ -2151,11 +2152,27 @@ instance YesodAuth UniWorX where fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures let - studyTermCandidates = do - studyTermCandidateName <- termNames - StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs - return StudyTermCandidate{..} - lift $ insertMany_ studyTermCandidates + studyTermCandidates = Set.fromList $ do + name <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs + return (key, name) + studyTermCandidateIncidence + = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") + . UUID.fromByteString + . fromStrict + . (convert :: Digest (SHAKE128 128) -> ByteString) + . runIdentity + $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash + + [E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate -> + E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence + + unless candidatesRecorded $ do + let + studyTermCandidates' = do + (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates + return StudyTermCandidate{..} + lift $ insertMany_ studyTermCandidates' lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] forM_ fs $ \f@StudyFeatures{..} -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e378a74d5..7faa02e29 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -123,7 +123,6 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) - <* submitButton return $ case result of FormSuccess sheetResult | errorMsgs <- validateSheet mr sheetResult @@ -787,7 +786,7 @@ postSCorrR = getSCorrR getSCorrR tid ssh csh shn = do Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn - ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton + ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) case res of FormFailure errs -> mapM_ (addMessage Error . toHtml) errs diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 4a1b72790..a9ddbcb7f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -216,7 +216,7 @@ postAdminUserR uuid = do let heading = [whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|] -- Delete Button needed in data-delete - (btnWgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) + (btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) let btnForm = wrapForm btnWgt def { formAction = Just $ SomeRoute $ AdminUserDeleteR uuid , formEncoding = btnEnctype @@ -231,7 +231,7 @@ postAdminUserR uuid = do postAdminUserDeleteR :: CryptoUUIDUser -> Handler Html postAdminUserDeleteR uuid = do uid <- decrypt uuid - ((btnResult,_), _) <- runFormPost (buttonForm :: Form ButtonDelete) + ((btnResult,_), _) <- runFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) case btnResult of (FormSuccess BtnDelete) -> do User{..} <- runDB $ get404 uid diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 550831f38..932044f62 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -138,20 +138,6 @@ linkButton lbl cls url = do |] --- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) -buttonForm :: (Button UniWorX a, Finite a) => Form a -buttonForm = identifyForm FIDbuttonForm buttonFormAux -- TODO: distinguish diffent buttons despite @disambiguateButtons@ - where - buttonFormAux csrf = do - (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF "" - return (res, [whamlet| - $newline never - #{csrf} - $forall bView <- fViews - ^{fvInput bView} - |]) - - ------------ -- Fields -- ------------ diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 7efe94bb7..4ebf3d1bb 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -179,8 +179,8 @@ data FormIdentifier | FIDCourseRegister | FIDuserRights | FIDcUserNote - | FIDbuttonForm | FIDAdminDemo + | FIDUserDelete deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -347,6 +347,17 @@ submitButtonView = do fieldView bField btnId "" mempty (Right BtnSubmit) False +buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) +buttonForm csrf = do + (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF "" + return (res, [whamlet| + $newline never + #{csrf} + $forall bView <- fViews + ^{fvInput bView} + |]) + + ------------------- -- Custom Fields -- ------------------- diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 60cf591d7..e1ddbb2bd 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -535,10 +535,10 @@ section { margin-top: 20px; padding-top: 20px; } -} -section:last-of-type { - border-bottom: none; + &:last-of-type { + border-bottom: none; + } } .pseudonym {