Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

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

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
+            studyTermCandidates = Set.fromList $ do
-              studyTermCandidateName <- termNames
+              name <- termNames
-              StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs
+              StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
-              return StudyTermCandidate{..}
+              return (key, name)
-          lift $ insertMany_ studyTermCandidates
+            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

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

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

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

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

templates/default-layout.lucius

@@ -535,10 +535,10 @@ section {
         margin-top: 20px;
         padding-top: 20px;
     }
-}
 
-section:last-of-type {
+    &:last-of-type {
-    border-bottom: none;
+        border-bottom: none;
+    }
 }
 
 .pseudonym {