From ccdb438862e43e4d0fd49193e180591f9b7b0abf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 30 Jan 2019 11:14:30 +0100 Subject: [PATCH 001/107] Initial work on MassInput --- messages/uniworx/de.msg | 3 +- package.yaml | 1 + src/Handler/Utils/Form/MassInput.hs | 117 ++++++++++++++++++++++++++++ 3 files changed, 120 insertions(+), 1 deletion(-) create mode 100644 src/Handler/Utils/Form/MassInput.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4f6f91a82..c638a4ba4 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -608,4 +608,5 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n " DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. -DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde \ No newline at end of file +DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde +MassInputUpdate: Formular aktualisieren diff --git a/package.yaml b/package.yaml index 46af6eab8..57b4b508d 100644 --- a/package.yaml +++ b/package.yaml @@ -114,6 +114,7 @@ dependencies: - memcached-binary - directory-tree - lifted-base + - lattices other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs new file mode 100644 index 000000000..36b7aea40 --- /dev/null +++ b/src/Handler/Utils/Form/MassInput.hs @@ -0,0 +1,117 @@ +module Handler.Utils.Form.MassInput + ( massInput + , BoxDimension(..), IsBoxCoord(..), Liveliness(..) + ) where + +import Import +import Utils.Form + +import Data.Aeson + +import Algebra.Lattice + +import Control.Lens hiding (universe) + +import Text.Blaze (Markup) + +import Data.List ((!!), elemIndex) +import qualified Data.Text as Text + + +data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n) + +class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where + boxDimensions :: [BoxDimension x] + boxOrigin :: x + +class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where + type BoxCoord a :: * + liveCoords :: Prism' (Set (BoxCoord a)) a + liveCoord :: BoxCoord a -> Prism' Bool a + + +data MassInputButton submit + = MassInputUpdate + | MassInputSubmit submit + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Bounded submit => Bounded (MassInputButton submit) where + minBound = MassInputUpdate + maxBound = MassInputSubmit maxBound + +instance (Eq submit, Finite submit) => Enum (MassInputButton submit) where + toEnum = (!!) universe + fromEnum = fromMaybe (error "fromEnum: value not found") . flip elemIndex universeF + +instance Finite submit => Universe (MassInputButton submit) where + universe = MassInputUpdate : map MassInputSubmit universeF +instance Finite submit => Finite (MassInputButton submit) + +instance PathPiece submit => PathPiece (MassInputButton submit) where + toPathPiece = \case + MassInputUpdate -> "update" + MassInputSubmit s -> "submit__" <> toPathPiece s + fromPathPiece t = inpUpdate <|> submit + where + inpUpdate = MassInputUpdate <$ guard (t == "update") + submit = do + submitT <- stripPrefix "submit__" t + MassInputSubmit <$> fromPathPiece submitT + +instance (Button UniWorX submit, Finite submit) => Button UniWorX (MassInputButton submit) where + label MassInputUpdate = [whamlet|_{MsgMassInputUpdate}|] + label (MassInputSubmit submit) = label submit + + btnValidate _ MassInputUpdate = False + btnValidate proxy (MassInputSubmit submit) = btnValidate proxy submit + + cssClass MassInputUpdate = BCDefault + cssClass (MassInputSubmit submit) = cssClass submit + + +data MassInputFieldName x + = MassInputAddDimension Natural + | MassInputDeleteCell x + | MassInputCell x Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance IsBoxCoord x => PathPiece (MassInputFieldName x) where + toPathPiece = \case + MassInputAddDimension dim -> "addField--" <> tshow dim + MassInputDeleteCell (toPathPiece -> coord) -> "delCell--" <> coord + MassInputCell (toPathPiece -> coord) name -> coord <> "__" <> name + + fromPathPiece t = addDimension <|> deleteCell <|> cell + where + addDimension = do + dim <- Text.stripPrefix "addField--" t >>= readMay + return $ MassInputAddDimension dim + deleteCell = do + coord <- Text.stripPrefix "delCell--" t >>= fromPathPiece + return $ MassInputDeleteCell coord + cell = do + (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t + coord <- fromPathPiece coordT + return $ MassInputCell coord name + +massInput :: forall handler cellData cellResult liveliness submit p. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , ToJSON cellData, FromJSON cellData + , Liveliness liveliness + , Button UniWorX submit, Finite submit + ) + => ( Natural -- ^ Zero-based dimension index + -> liveliness -- ^ Currently live positions + -> (Text -> Text) -- ^ Nudge deterministic field ids + -> (Markup -> MForm handler (FormResult (cellData, BoxCoord liveliness), Widget)) + ) -- ^ Generate a cell-addition widget + -> ( BoxCoord liveliness + -> cellData + -> (Text -> Text) -- ^ Nudge deterministic field ids + -> (Markup -> MForm handler (FormResult cellResult, Widget)) + ) -- ^ Cell-Widget + -> FieldSettings UniWorX + -> p submit + -> MForm handler (FormResult (Map (BoxCoord liveliness) cellResult), FieldView UniWorX) +massInput mkAddWidget mkCellWidget FieldSettings{..} _ = do + error "massInput: not implemented" From e9c69e6cfb729235612f2598db3aec758be30795 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 31 Jan 2019 11:43:32 +0100 Subject: [PATCH 002/107] Plan for MassInput-Controls being buttons --- messages/uniworx/de.msg | 4 +- src/Handler/Utils/Form/MassInput.hs | 115 +++++++++++++--------------- src/Import/NoFoundation.hs | 2 + src/Numeric/Natural/Instances.hs | 13 ++++ 4 files changed, 70 insertions(+), 64 deletions(-) create mode 100644 src/Numeric/Natural/Instances.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d24a09e5c..e6e4663c5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -611,4 +611,6 @@ DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde -MassInputUpdate: Formular aktualisieren + +MassInputAddDimension: Hinzufügen +MassInputDeleteCell: Entfernen diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 36b7aea40..c24770b61 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,6 +1,8 @@ module Handler.Utils.Form.MassInput ( massInput - , BoxDimension(..), IsBoxCoord(..), Liveliness(..) + , BoxDimension(..) + , IsBoxCoord(..), boxDimension + , Liveliness(..) ) where import Import @@ -14,15 +16,23 @@ import Control.Lens hiding (universe) import Text.Blaze (Markup) -import Data.List ((!!), elemIndex) import qualified Data.Text as Text +import Data.List (genericLength, genericIndex) + data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n) class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where boxDimensions :: [BoxDimension x] boxOrigin :: x + +boxDimension :: IsBoxCoord x => Natural -> Maybe (BoxDimension x) +boxDimension n + | n < genericLength dims = Just $ genericIndex dims n + | otherwise = Nothing + where + dims = boxDimensions class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where type BoxCoord a :: * @@ -30,75 +40,55 @@ class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemi liveCoord :: BoxCoord a -> Prism' Bool a -data MassInputButton submit - = MassInputUpdate - | MassInputSubmit submit - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Bounded submit => Bounded (MassInputButton submit) where - minBound = MassInputUpdate - maxBound = MassInputSubmit maxBound - -instance (Eq submit, Finite submit) => Enum (MassInputButton submit) where - toEnum = (!!) universe - fromEnum = fromMaybe (error "fromEnum: value not found") . flip elemIndex universeF - -instance Finite submit => Universe (MassInputButton submit) where - universe = MassInputUpdate : map MassInputSubmit universeF -instance Finite submit => Finite (MassInputButton submit) - -instance PathPiece submit => PathPiece (MassInputButton submit) where - toPathPiece = \case - MassInputUpdate -> "update" - MassInputSubmit s -> "submit__" <> toPathPiece s - fromPathPiece t = inpUpdate <|> submit - where - inpUpdate = MassInputUpdate <$ guard (t == "update") - submit = do - submitT <- stripPrefix "submit__" t - MassInputSubmit <$> fromPathPiece submitT - -instance (Button UniWorX submit, Finite submit) => Button UniWorX (MassInputButton submit) where - label MassInputUpdate = [whamlet|_{MsgMassInputUpdate}|] - label (MassInputSubmit submit) = label submit - - btnValidate _ MassInputUpdate = False - btnValidate proxy (MassInputSubmit submit) = btnValidate proxy submit - - cssClass MassInputUpdate = BCDefault - cssClass (MassInputSubmit submit) = cssClass submit - - -data MassInputFieldName x +data ButtonMassInput coord = MassInputAddDimension Natural - | MassInputDeleteCell x - | MassInputCell x Text + | MassInputDeleteCell coord deriving (Eq, Ord, Read, Show, Generic, Typeable) -instance IsBoxCoord x => PathPiece (MassInputFieldName x) where +instance PathPiece coord => PathPiece (ButtonMassInput coord) where + toPathPiece = \case + MassInputAddDimension n -> "add__" <> toPathPiece n + MassInputDeleteCell c -> "delete__" <> toPathPiece c + fromPathPiece t = addDim <|> delCell + where + addDim = do + nT <- stripPrefix "add__" t + MassInputAddDimension <$> fromPathPiece nT + delCell = do + coordT <- stripPrefix "delete__" t + MassInputDeleteCell <$> fromPathPiece coordT + +instance RenderMessage UniWorX (ButtonMassInput coord) where + renderMessage f ls = \case + MassInputAddDimension _ -> mr MsgMassInputAddDimension + MassInputDeleteCell _ -> mr MsgMassInputDeleteCell + where + mr = renderMessage f ls + +instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where + btnValidate _ _ = False + + btnClasses (MassInputAddDimension _) = [BCIsButton, BCDefault] + btnClasses (MassInputDeleteCell _) = [BCIsButton, BCWarning] + + +data MassInputFieldName coord + = MassInputCell coord Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where toPathPiece = \case - MassInputAddDimension dim -> "addField--" <> tshow dim - MassInputDeleteCell (toPathPiece -> coord) -> "delCell--" <> coord MassInputCell (toPathPiece -> coord) name -> coord <> "__" <> name - fromPathPiece t = addDimension <|> deleteCell <|> cell - where - addDimension = do - dim <- Text.stripPrefix "addField--" t >>= readMay - return $ MassInputAddDimension dim - deleteCell = do - coord <- Text.stripPrefix "delCell--" t >>= fromPathPiece - return $ MassInputDeleteCell coord - cell = do - (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t - coord <- fromPathPiece coordT - return $ MassInputCell coord name + fromPathPiece t = do + (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t + coord <- fromPathPiece coordT + return $ MassInputCell coord name -massInput :: forall handler cellData cellResult liveliness submit p. +massInput :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , Button UniWorX submit, Finite submit ) => ( Natural -- ^ Zero-based dimension index -> liveliness -- ^ Currently live positions @@ -111,7 +101,6 @@ massInput :: forall handler cellData cellResult liveliness submit p. -> (Markup -> MForm handler (FormResult cellResult, Widget)) ) -- ^ Cell-Widget -> FieldSettings UniWorX - -> p submit -> MForm handler (FormResult (Map (BoxCoord liveliness) cellResult), FieldView UniWorX) -massInput mkAddWidget mkCellWidget FieldSettings{..} _ = do +massInput mkAddWidget mkCellWidget FieldSettings{..} = do error "massInput: not implemented" diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 1f1220787..dbb01adf1 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -61,6 +61,8 @@ import Database.Esqueleto.Instances as Import () import Database.Persist.Sql.Instances as Import () import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) +import Numeric.Natural.Instances as Import () + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Numeric/Natural/Instances.hs b/src/Numeric/Natural/Instances.hs new file mode 100644 index 000000000..cb986f770 --- /dev/null +++ b/src/Numeric/Natural/Instances.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Numeric.Natural.Instances + ( + ) where + +import ClassyPrelude +import Numeric.Natural +import Web.PathPieces + +instance PathPiece Natural where + toPathPiece = tshow + fromPathPiece = readMay From c0edc87926cecb7f306e128b6c515accd717943f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Feb 2019 13:07:22 +0100 Subject: [PATCH 003/107] Start on implementation --- src/Handler/Utils/Form/MassInput.hs | 83 ++++++++++++++++++++++++----- src/Utils.hs | 6 +++ src/Utils/Form.hs | 4 +- 3 files changed, 77 insertions(+), 16 deletions(-) diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index c24770b61..f89991736 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -7,6 +7,7 @@ module Handler.Utils.Form.MassInput import Import import Utils.Form +import Handler.Utils.Form (secretJsonField) import Data.Aeson @@ -18,23 +19,28 @@ import Text.Blaze (Markup) import qualified Data.Text as Text +import qualified Data.Set as Set +import qualified Data.Map as Map import Data.List (genericLength, genericIndex) -data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n) +data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n) class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where boxDimensions :: [BoxDimension x] boxOrigin :: x -boxDimension :: IsBoxCoord x => Natural -> Maybe (BoxDimension x) +boxDimension :: IsBoxCoord x => Natural -> BoxDimension x boxDimension n - | n < genericLength dims = Just $ genericIndex dims n - | otherwise = Nothing + | n < genericLength dims = genericIndex dims n + | otherwise = error "boxDimension: insufficient dimensions" where dims = boxDimensions + +zeroDimension :: IsBoxCoord x => Natural -> x -> x +zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim -class (ToJSON a, FromJSON a, IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where +class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where type BoxCoord a :: * liveCoords :: Prism' (Set (BoxCoord a)) a liveCoord :: BoxCoord a -> Prism' Bool a @@ -73,17 +79,37 @@ instance PathPiece coord => Button UniWorX (ButtonMassInput coord) where data MassInputFieldName coord - = MassInputCell coord Text + = MassInputShape { miName :: Text } + | MassInputAddWidget { miName :: Text, miCoord :: coord, miAddWidgetField :: Text } + | MassInputCell { miName :: Text, miCoord :: coord, miCellField :: Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance IsBoxCoord coord => PathPiece (MassInputFieldName coord) where toPathPiece = \case - MassInputCell (toPathPiece -> coord) name -> coord <> "__" <> name + MassInputShape{..} -> [st|#{miName}__shape|] + MassInputAddWidget{..} -> [st|#{miName}__#{toPathPiece miCoord}__#{miAddWidgetField}|] + MassInputCell{..} -> [st|#{miName}__#{toPathPiece miCoord}__#{miCellField}|] fromPathPiece t = do - (coordT, Text.stripPrefix "__" -> Just name) <- return $ Text.breakOn "__" t - coord <- fromPathPiece coordT - return $ MassInputCell coord name + (miName, Text.stripPrefix "__" -> Just t') <- return $ Text.breakOn "__" t + choice + [ do + guard $ t' == "shape" + return MassInputShape{..} + , do + (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t' + miCoord <- fromPathPiece coordT + return MassInputAddWidget{..} + , do + (coordT, Text.stripPrefix "__" -> Just miCellField) <- return $ Text.breakOn "__" t' + miCoord <- fromPathPiece coordT + return MassInputCell{..} + ] + +data MassInputException = MassInputInvalidShape + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Exception MassInputException massInput :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX @@ -93,14 +119,43 @@ massInput :: forall handler cellData cellResult liveliness. => ( Natural -- ^ Zero-based dimension index -> liveliness -- ^ Currently live positions -> (Text -> Text) -- ^ Nudge deterministic field ids - -> (Markup -> MForm handler (FormResult (cellData, BoxCoord liveliness), Widget)) + -> (Markup -> MForm handler (FormResult (BoxCoord liveliness, cellData), Widget)) ) -- ^ Generate a cell-addition widget -> ( BoxCoord liveliness -> cellData + -> Maybe cellResult -> (Text -> Text) -- ^ Nudge deterministic field ids -> (Markup -> MForm handler (FormResult cellResult, Widget)) ) -- ^ Cell-Widget -> FieldSettings UniWorX - -> MForm handler (FormResult (Map (BoxCoord liveliness) cellResult), FieldView UniWorX) -massInput mkAddWidget mkCellWidget FieldSettings{..} = do - error "massInput: not implemented" + -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult)) + -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), Widget) +massInput _mkAddWidget mkCellWidget FieldSettings{..} initialResult = do + miName <- maybe newFormIdent return fsName + let + shapeName :: MassInputFieldName (BoxCoord liveliness) + shapeName = MassInputShape{..} + (shape', _shapeWdgt) <- mreq secretJsonField ("" & addName shapeName) $ fmap fst <$> initialResult + shape <- if + | FormSuccess s <- shape' -> return s + | Just (fmap fst -> iS) <- initialResult -> return iS + | Just iS <- Set.empty ^? liveCoords -> return iS + | otherwise -> throwM MassInputInvalidShape + cellResults <- forM shape $ \(miCoord, cData) -> do + let + nudgeCellName :: Text -> Text + nudgeCellName miCellField = toPathPiece MassInputCell{..} + (cData, ) <$> mkCellWidget miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty + liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords + let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult)) + result = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults + miWidget :: [BoxDimension (BoxCoord liveliness)] -> Widget + miWidget = miWidget' nudgeAddWidgetName 0 liveliness + nudgeAddWidgetName :: Text -> Text + nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..} + return (result, miWidget boxDimensions) + where + miWidget' :: (Text -> Text) -> Natural -> liveliness -> [BoxDimension (BoxCoord liveliness)] -> Widget + miWidget' nudge dimIx liveliness [] = mempty + miWidget' nudge dimIx liveliness (BoxDimension dim : remDims) + = error "not implemented" diff --git a/src/Utils.hs b/src/Utils.hs index 2990778dc..ed9e0ea57 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -508,6 +508,12 @@ mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b mconcatForM = flip mconcatMapM +----------------- +-- Alternative -- +----------------- + +choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a +choice = foldr (<|>) empty -------------- -- Sessions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6fab13a32..0a2487eec 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -108,8 +108,8 @@ addClass = addAttr "class" addClasses :: [Text] -> FieldSettings site -> FieldSettings site addClasses = addAttrs "class" -addName :: Text -> FieldSettings site -> FieldSettings site -addName nm fs = fs { fsName = Just nm } +addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site +addName nm fs = fs { fsName = Just $ toPathPiece nm } addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs } From c48e1e1981a1682618a2511983f91459a3e53763 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 27 Feb 2019 13:11:40 +0100 Subject: [PATCH 004/107] StudyFields start --- models/courses | 1 + models/users | 1 + src/Foundation.hs | 3 ++- 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/models/courses b/models/courses index 96bba0195..55c1daa86 100644 --- a/models/courses +++ b/models/courses @@ -38,6 +38,7 @@ CourseParticipant course CourseId user UserId registration UTCTime + field StudyFeaturesId Maybe UniqueParticipant user course CourseUserNote course CourseId diff --git a/models/users b/models/users index 5ac4a6a3c..94f1cb559 100644 --- a/models/users +++ b/models/users @@ -30,6 +30,7 @@ StudyFeatures field StudyTermsId type StudyFieldType semester Int + updated UTCTime default=now -- zuletzt als gültig gesehen -- UniqueUserSubject user degree field -- There exists a counterexample StudyDegree key Int diff --git a/src/Foundation.hs b/src/Foundation.hs index e4de524d2..45ef28c0d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2018,7 +2018,8 @@ instance YesodAuth UniWorX where return str fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - + -- TODO: just update StudyFeaturesUpdate in case of no-change + -- TODO: keep old is referenced in CourseParticipant lift $ deleteWhere [StudyFeaturesUser ==. userId] forM_ fs $ \StudyFeatures{..} -> do From 4f16efcb243e705f5eb4b1df87372fceb2fae90f Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 27 Feb 2019 14:27:58 +0100 Subject: [PATCH 005/107] Minor --- models/courses | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/courses b/models/courses index 55c1daa86..8ee384558 100644 --- a/models/courses +++ b/models/courses @@ -38,7 +38,7 @@ CourseParticipant course CourseId user UserId registration UTCTime - field StudyFeaturesId Maybe + field StudyFeaturesId Maybe UniqueParticipant user course CourseUserNote course CourseId From 5f7b134292a318232cad683aa1add37755a71182 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Feb 2019 17:29:17 +0100 Subject: [PATCH 006/107] Write StudyTermCandidates during login --- models/users | 9 +++- src/Database/Esqueleto/Utils.hs | 26 +++++++---- src/Database/Esqueleto/Utils/TH.hs | 48 +++++++++++++++++++++ src/Foundation.hs | 36 +++++++++++++--- src/Handler/Course.hs | 2 +- src/Handler/Utils/StudyFeatures.hs | 9 ++-- src/Handler/Utils/Table/Pagination.hs | 8 ++-- src/Handler/Utils/Table/Pagination/Types.hs | 41 ------------------ src/Model/Types.hs | 1 + 9 files changed, 112 insertions(+), 68 deletions(-) create mode 100644 src/Database/Esqueleto/Utils/TH.hs diff --git a/models/users b/models/users index 94f1cb559..59f9ecb6b 100644 --- a/models/users +++ b/models/users @@ -30,7 +30,9 @@ StudyFeatures field StudyTermsId type StudyFieldType semester Int - updated UTCTime default=now -- zuletzt als gültig gesehen + updated UTCTime default='NOW()' -- zuletzt als gültig gesehen + valid Bool default=true + UniqueStudyFeatures user degree field type semester -- UniqueUserSubject user degree field -- There exists a counterexample StudyDegree key Int @@ -42,3 +44,8 @@ StudyTerms shorthand Text Maybe name Text Maybe Primary key +StudyTermCandidate + incidence UUID + key Int + name Text + deriving Show Eq Ord \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 41464cc00..003b26168 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,8 +1,16 @@ -module Database.Esqueleto.Utils where +{-# OPTIONS_GHC -fno-warn-orphans #-} -import ClassyPrelude.Yesod hiding (isInfixOf, (||.)) -import Data.Foldable as F -import Database.Esqueleto as E +module Database.Esqueleto.Utils + ( true, false + , isInfixOf, hasInfix + , any, all + , SqlIn(..) + ) where + +import ClassyPrelude.Yesod hiding (isInfixOf, (||.), any, all) +import qualified Data.Foldable as F +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils.TH -- @@ -33,13 +41,13 @@ hasInfix = flip isInfixOf -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated) any :: Foldable f => - (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) -any test = F.foldr (\needle acc -> acc ||. test needle) false + (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) +any test = F.foldr (\needle acc -> acc E.||. test needle) false -- | Given a test and a set of values, check whether all succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated) all :: Foldable f => - (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) -all test = F.foldr (\needle acc -> acc &&. test needle) true - + (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) +all test = F.foldr (\needle acc -> acc E.&&. test needle) true +$(sqlInTuples [2..16]) diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs new file mode 100644 index 000000000..7ae382959 --- /dev/null +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -0,0 +1,48 @@ +module Database.Esqueleto.Utils.TH + ( SqlIn(..) + , sqlInTuple, sqlInTuples + ) where + +import ClassyPrelude + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) + +import Database.Persist (PersistField) + +import Language.Haskell.TH + +import Data.List (foldr1, foldl) + +class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where + sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) + +instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where + x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs) + +sqlInTuples :: [Int] -> DecsQ +sqlInTuples = mapM sqlInTuple + +sqlInTuple :: Int -> DecQ +sqlInTuple arity = do + tyVars <- replicateM arity $ newName "t" + vVs <- replicateM arity $ newName "v" + xVs <- replicateM arity $ newName "x" + xsV <- newName "xs" + + let + matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs) + tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars + + instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|] + [ funD 'sqlIn + [ clause [tupP $ map varP xVs, varP xsV] + ( guardedB + [ normalGE [e|null $(varE xsV)|] [e|E.val False|] + , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|] + ] + ) [] + ] + ] + + diff --git a/src/Foundation.hs b/src/Foundation.hs index 45ef28c0d..d98795969 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -50,6 +50,7 @@ import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -80,6 +81,8 @@ import Data.Bits (Bits(zeroBits)) import Network.Wai.Parse (lbsBackEnd) +import qualified Data.UUID.V4 as UUID + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -2007,9 +2010,11 @@ instance YesodAuth UniWorX where ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate + studyTermCandidateIncidence <- liftIO UUID.nextRandom + now <- liftIO getCurrentTime let - userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' + userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now userStudyFeatures' = do (k, v) <- ldapData guard $ k == Attr "dfnEduPersonFeaturesOfStudy" @@ -2017,16 +2022,33 @@ instance YesodAuth UniWorX where Right str <- return $ Text.decodeUtf8' v' return str - fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - -- TODO: just update StudyFeaturesUpdate in case of no-change - -- TODO: keep old is referenced in CourseParticipant - lift $ deleteWhere [StudyFeaturesUser ==. userId] + termNames = do + (k, v) <- ldapData + guard $ k == Attr "dfnEduPersonFieldOfStudyString" + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str - forM_ fs $ \StudyFeatures{..} -> do + fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures + + let + studyTermCandidates = Set.fromList $ do + studyTermCandidateName <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs + return StudyTermCandidate{..} + + lift . E.update $ \f -> do + E.set f [ StudyFeaturesValid E.=. E.false ] + E.where_ . E.not_ $ (f E.^. StudyFeaturesUser, f E.^. StudyFeaturesDegree, f E.^. StudyFeaturesField, f E.^. StudyFeaturesType, f E.^. StudyFeaturesSemester) + `E.sqlIn` map (\StudyFeatures{..} -> (E.Value studyFeaturesUser, E.Value studyFeaturesDegree, E.Value studyFeaturesField, E.Value studyFeaturesType, E.Value studyFeaturesSemester) ) fs + + lift . insertMany_ $ Set.toList studyTermCandidates + forM_ fs $ \f@StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - lift $ insertMany_ fs + void . lift $ insertUnique f + return $ Authenticated userId Nothing -> acceptExisting diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e635731b3..78ef16a73 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -320,7 +320,7 @@ postCRegisterR tid ssh csh = do addMessageI Info MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime - regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime + regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime Nothing -- TODO when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong _other -> return () -- TODO check this! diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 9dbce258a..880321e01 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -8,12 +8,12 @@ import Text.Parsec import Text.Parsec.Text -parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures] -parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) "" +parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures] +parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) "" -pStudyFeatures :: UserId -> Parser [StudyFeatures] -pStudyFeatures studyFeaturesUser = do +pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] +pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do studyFeaturesDegree <- StudyDegreeKey' <$> pKey void $ string "$$" @@ -29,6 +29,7 @@ pStudyFeatures studyFeaturesUser = do void $ char '!' studyFeaturesSemester <- decimal + let studyFeaturesValid = True return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 67e5a3f46..2b842d487 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -39,6 +39,7 @@ import Utils.Lens.TH import Import hiding (pi) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Language as E (From) @@ -89,9 +90,6 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode) import qualified Data.ByteString.Lazy as LBS -$(sqlInTuples [2..16]) - - data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortDirection = SortAsc | SortDesc @@ -370,7 +368,7 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) data DBTable m x = forall a r r' h i t k k'. ( ToSortable h, Functor h - , E.SqlSelect a r, SqlIn k k', DBTableKey k' + , E.SqlSelect a r, E.SqlIn k k', DBTableKey k' , PathPiece i, Eq i , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable @@ -642,7 +640,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> do E.limit l E.offset (psPage * l) - Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps + Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps _other -> return () Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 44648cf21..187c679a6 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -6,8 +6,6 @@ module Handler.Utils.Table.Pagination.Types , sortable , ToSortable(..) , SortableP(..) - , SqlIn(..) - , sqlInTuples , DBTableInvalid(..) ) where @@ -20,13 +18,6 @@ import Data.CaseInsensitive (CI) import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey) -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) - -import Language.Haskell.TH - -import Data.List (foldr1, foldl) - newtype FilterKey = FilterKey { _unFilterKey :: CI Text } deriving (Show, Read, Generic) @@ -67,38 +58,6 @@ instance ToSortable Headless where pSortable = Nothing -class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where - sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) - -instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where - x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs) - -sqlInTuples :: [Int] -> DecsQ -sqlInTuples = mapM sqlInTuple - -sqlInTuple :: Int -> DecQ -sqlInTuple arity = do - tyVars <- replicateM arity $ newName "t" - vVs <- replicateM arity $ newName "v" - xVs <- replicateM arity $ newName "x" - xsV <- newName "xs" - - let - matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs) - tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars - - instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|] - [ funD 'sqlIn - [ clause [tupP $ map varP xVs, varP xsV] - ( guardedB - [ normalGE [e|null $(varE xsV)|] [e|E.val False|] - , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|] - ] - ) [] - ] - ] - - data DBTableInvalid = DBTIRowsMissing Int deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 94655817d..d9cd98342 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -8,6 +8,7 @@ module Model.Types , module Numeric.Natural , module Mail , module Utils.DateTime + , module Data.UUID.Types ) where import ClassyPrelude From 6a53a89faa142f0112b88cfca6963b4057387fb0 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 27 Feb 2019 17:36:39 +0100 Subject: [PATCH 007/107] does not compile, course register from broken --- messages/uniworx/de.msg | 1 + src/CryptoID.hs | 1 + src/Handler/Course.hs | 19 ++++++++++----- src/Handler/Utils/Form.hs | 23 +++++++++++++++++++ src/Handler/Utils/StudyFeatures.hs | 4 ++-- src/Utils/Form.hs | 1 + .../register-form/register-form.hamlet | 1 + 7 files changed, 42 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 0f0344878..cd1425452 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -53,6 +53,7 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegisterOk: Sie wurden angemeldet CourseDeregisterOk: Sie wurden abgemeldet +CourseStudyFeature: Relevantes Hauptfach CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt. diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 58fa1a09a..899047c3b 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -36,6 +36,7 @@ decCryptoIDs [ ''SubmissionId , ''SheetId , ''SystemMessageId , ''SystemMessageTranslationId + , ''StudyFeaturesId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e635731b3..0ac01c4e9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -5,6 +5,7 @@ module Handler.Course where import Import import Utils.Lens +import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Table.Cells @@ -263,8 +264,8 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do - [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)] + (course,schoolName,participants,registration,lecturers) <- runDB . maybeT notFound $ do + [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse @@ -276,17 +277,19 @@ getCShowR tid ssh csh = do let numParticipants = E.sub_select . E.from $ \part -> do E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId return ( E.countRows :: E.SqlExpr (E.Value Int64)) - return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration) + return (course,school E.^. SchoolName, numParticipants, participant) + lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid return $ user E.^. UserDisplayName - return (course,schoolName,participants,registered,map E.unValue lecturers) + + return (course,schoolName,participants,registration,map E.unValue lecturers) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course - mRegAt <- traverse (formatTime SelFormatDateTime) registered - (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course + mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration + (regWidget, regEnctype) <- generateFormPost $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True siteLayout (toWgt $ courseName course) $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] @@ -294,11 +297,15 @@ getCShowR tid ssh csh = do registerForm :: Bool -> Maybe Text -> Form Bool +-- unfinished WIP: must take study features if registred and show as mforced field registerForm registered msecret extra = do (msecretRes', msecretView) <- case msecret of (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing _ -> return (Nothing,Nothing) + (sfRes' , sfView) <- if not registered then return (Nothing,Nothing) else + mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing + let widget = $(widgetFile "widgets/register-form/register-form") let msecretRes | Just res <- msecretRes' = Just <$> res | otherwise = FormSuccess Nothing diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2a568432e..840c0dbd2 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -214,6 +214,29 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName +-- | Select one of the user's primary courses +studyFeaturesPrimaryFieldFor :: UserId -> Field Handler StudyFeaturesId +studyFeaturesPrimaryFieldFor uid = selectField $ do + -- we wanted to use optionsPersistCryptoId, but we need a join here + rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do + E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId + E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId + E.where_ $ feature E.^. StudyFeaturesUser E.==. E.val uid + -- E.where_ $ feature E.^. StudyFeaturesValid E.==. E.val True -- TODO SJ REMOVE + E.where_ $ feature E.^. StudyFeaturesType E.==. E.val FieldPrimary + return (feature E.^. StudyFeaturesId, degree, field) + mkOptionList <$> mapM procOptions rawOptions + where + procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do + let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName) + stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName ) + cfid <- encrypt sfid + return Option + { optionDisplay = stname <> " (" <> dgname <> ")" + , optionInternalValue = sfid + , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId) + } + uploadModeField :: Field Handler UploadMode uploadModeField = selectField optionsFinite diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 9dbce258a..1de343aa7 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -11,13 +11,14 @@ import Text.Parsec.Text parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures] parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) "" - + pStudyFeatures :: UserId -> Parser [StudyFeatures] pStudyFeatures studyFeaturesUser = do studyFeaturesDegree <- StudyDegreeKey' <$> pKey void $ string "$$" let + studyFeaturesUpdated = error "undefined" --TODO SJ REMOVE pStudyFeature = do _ <- pKey -- Meaning unknown at this time void $ char '!' @@ -28,7 +29,6 @@ pStudyFeatures studyFeaturesUser = do studyFeaturesType <- pType void $ char '!' studyFeaturesSemester <- decimal - return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8c53501f8..b007b0cb3 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -194,6 +194,7 @@ addAutosubmit = addAttr "data-autosubmit" "" data FormIdentifier = FIDcourse + | FIDcourseRegister | FIDsheet | FIDsubmission | FIDsettings diff --git a/templates/widgets/register-form/register-form.hamlet b/templates/widgets/register-form/register-form.hamlet index a2dd97af9..6bb3388fb 100644 --- a/templates/widgets/register-form/register-form.hamlet +++ b/templates/widgets/register-form/register-form.hamlet @@ -3,5 +3,6 @@ $# extra protects us against CSRF $# Maybe display textField for passcode $maybe secretView <- msecretView ^{fvInput secretView} +$# Ask for associated primary field uf study, unless registered $# Always display register/deregister button ^{fvInput btnView} From 9ca91b5ec882d65b1ad6d3799ba176ac61f90162 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 27 Feb 2019 17:42:46 +0100 Subject: [PATCH 008/107] removed stubs for merge --- src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/StudyFeatures.hs | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 840c0dbd2..83c29a8c1 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -222,7 +222,7 @@ studyFeaturesPrimaryFieldFor uid = selectField $ do E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId E.where_ $ feature E.^. StudyFeaturesUser E.==. E.val uid - -- E.where_ $ feature E.^. StudyFeaturesValid E.==. E.val True -- TODO SJ REMOVE + E.where_ $ feature E.^. StudyFeaturesValid E.==. E.val True E.where_ $ feature E.^. StudyFeaturesType E.==. E.val FieldPrimary return (feature E.^. StudyFeaturesId, degree, field) mkOptionList <$> mapM procOptions rawOptions diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index d84e79499..d2903309c 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -18,7 +18,6 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do void $ string "$$" let - studyFeaturesUpdated = error "undefined" --TODO SJ REMOVE pStudyFeature = do _ <- pKey -- Meaning unknown at this time void $ char '!' @@ -33,7 +32,7 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do return StudyFeatures{..} pStudyFeature `sepBy1` char '#' - + pKey :: Parser Int pKey = decimal From 49c8ca56f52840b30af434d014823ce4fc2d642f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Feb 2019 17:42:57 +0100 Subject: [PATCH 009/107] Touch StudyFeaturesUpdated on each login --- src/Foundation.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index d98795969..8f3613943 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -50,7 +50,6 @@ import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -2036,18 +2035,13 @@ instance YesodAuth UniWorX where studyTermCandidateName <- termNames StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs return StudyTermCandidate{..} - - lift . E.update $ \f -> do - E.set f [ StudyFeaturesValid E.=. E.false ] - E.where_ . E.not_ $ (f E.^. StudyFeaturesUser, f E.^. StudyFeaturesDegree, f E.^. StudyFeaturesField, f E.^. StudyFeaturesType, f E.^. StudyFeaturesSemester) - `E.sqlIn` map (\StudyFeatures{..} -> (E.Value studyFeaturesUser, E.Value studyFeaturesDegree, E.Value studyFeaturesField, E.Value studyFeaturesType, E.Value studyFeaturesSemester) ) fs - lift . insertMany_ $ Set.toList studyTermCandidates + + lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] forM_ fs $ \f@StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - - void . lift $ insertUnique f + void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] return $ Authenticated userId Nothing -> acceptExisting From 4db9e5c18a6f4875312a34fa2d5fa3d879b7547f Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 28 Feb 2019 10:02:23 +0100 Subject: [PATCH 010/107] fillDB adjusted for StudyFeatues --- src/Handler/Course.hs | 4 +-- test/Database.hs | 71 +++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 71 insertions(+), 4 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 55d090092..2224dc20f 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -302,8 +302,8 @@ registerForm registered msecret extra = do (msecretRes', msecretView) <- case msecret of (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing _ -> return (Nothing,Nothing) - (sfRes' , sfView) <- if not registered then return (Nothing,Nothing) else - mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing + (_sfRes' , _sfView) <- if not registered then return (Nothing,Nothing) else + bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing let widget = $(widgetFile "widgets/register-form/register-form") diff --git a/test/Database.hs b/test/Database.hs index daef8d28a..c4d6ad8e1 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -198,7 +198,7 @@ fillDb = do , termActive = True } ifi <- insert' $ School "Institut für Informatik" "IfI" - mi <- insert' $ School "Institut für Mathematik" "MI" + mi <- insert' $ School "Institut für Mathematik" "MI" void . insert' $ UserAdmin gkleen ifi void . insert' $ UserAdmin gkleen mi void . insert' $ UserAdmin fhamann ifi @@ -210,13 +210,70 @@ fillDb = do let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88 + sdLAR = StudyDegreeKey' 33 + sdLAG = StudyDegreeKey' 35 repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) + repsert sdLAR $ StudyDegree 33 (Just "LAR") Nothing -- intentionally left unknown + repsert sdLAG $ StudyDegree 35 Nothing Nothing -- intentionally left unknown let sdInf = StudyTermsKey' 79 sdMath = StudyTermsKey' 105 + sdMedi = StudyTermsKey' 121 + sdPhys = StudyTermsKey' 128 repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik") repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut") + repsert sdMedi $ StudyTerms 121 (Just "MnfI") Nothing -- intentionally left unknown + repsert sdPhys $ StudyTerms 128 Nothing Nothing -- intentionally left unknown + sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here + maxMuster + sdBsc + sdInf + FieldPrimary + 2 + now + True + sfMMs <- insert $ StudyFeatures + maxMuster + sdBsc + sdMath + FieldSecondary + 2 + now + True + _sfTTa <- insert $ StudyFeatures + tinaTester + sdBsc + sdInf + FieldPrimary + 4 + now + False + sfTTb <- insert $ StudyFeatures + tinaTester + sdLAG + sdPhys + FieldPrimary + 1 + now + True + sfTTc <- insert $ StudyFeatures + tinaTester + sdLAR + sdMedi + FieldPrimary + 7 + now + True + _sfTTd <- insert $ StudyFeatures + tinaTester + sdMst + sdMath + FieldPrimary + 3 + now + True + -- FFP let nbrs :: [Int] nbrs = [1,2,3,27,7,1] @@ -256,6 +313,12 @@ fillDb = do insert_ $ SheetEdit gkleen now feste keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False insert_ $ SheetEdit gkleen now keine + void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf) + [(fhamann , Nothing) + ,(maxMuster , Just sfMMs) + ,(tinaTester, Just sfTTc) + ] + -- EIP eip <- insert' Course { courseName = "Einführung in die Programmierung" @@ -328,7 +391,11 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo - void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester] + void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf) + [(fhamann , Nothing) + ,(maxMuster , Just sfMMp) + ,(tinaTester, Just sfTTb) + ] sh1 <- insert Sheet { sheetCourse = pmo , sheetName = "Blatt 1" From ad02db27db435e9a4f843b871ca6282842343eea Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 28 Feb 2019 11:01:44 +0100 Subject: [PATCH 011/107] Keep track of userLastAuthentication --- messages/uniworx/de.msg | 2 ++ models/users | 1 + src/Foundation.hs | 26 ++++++++++++------- src/Handler/Course.hs | 4 +-- src/Handler/Profile.hs | 2 ++ src/Import/NoFoundation.hs | 3 +++ templates/profileData.hamlet | 6 +++++ .../register-form/register-form.hamlet | 2 ++ 8 files changed, 34 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index cd1425452..66404f49c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -253,8 +253,10 @@ Theme: Oberflächen Design Favoriten: Anzahl gespeicherter Favoriten Plugin: Plugin Ident: Identifikation +LastLogin: Letzter Login Settings: Individuelle Benutzereinstellungen SettingsUpdate: Einstellungen wurden gespeichert. +Never: Nie MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) diff --git a/models/users b/models/users index 59f9ecb6b..ff0c9a965 100644 --- a/models/users +++ b/models/users @@ -1,6 +1,7 @@ User json ident (CI Text) authentication AuthenticationMode + lastAuthentication UTCTime Maybe matrikelnummer Text Maybe email (CI Text) displayName Text diff --git a/src/Foundation.hs b/src/Foundation.hs index 8f3613943..fde6cf714 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -80,8 +80,6 @@ import Data.Bits (Bits(zeroBits)) import Network.Wai.Parse (lbsBackEnd) -import qualified Data.UUID.V4 as UUID - instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -1916,6 +1914,8 @@ instance YesodAuth UniWorX where $(widgetFile "login") authenticate Creds{..} = runDB $ do + now <- liftIO getCurrentTime + let userIdent = CI.mk credsIdent uAuth = UniqueAuthentication userIdent @@ -1943,7 +1943,12 @@ instance YesodAuth UniWorX where return $ ServerError "LDAP lookup failed" ] - acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + acceptExisting = do + res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + case res of + Authenticated uid + | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] + _other -> return res $logDebugS "auth" $ tshow Creds{..} UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod @@ -1962,6 +1967,7 @@ instance YesodAuth UniWorX where userAuthentication | isPWHash = error "PWHash should only work for users that are already known" | otherwise = AuthLDAP + userLastAuthentication = now <$ guard (not isDummy) userEmail <- if | Just [bs] <- userEmail' @@ -2002,15 +2008,15 @@ instance YesodAuth UniWorX where , userMailLanguages = def , .. } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserSurname =. userSurname - , UserEmail =. userEmail - ] + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , UserEmail =. userEmail + ] ++ + [ UserLastAuthentication =. Just now | not isDummy ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate - studyTermCandidateIncidence <- liftIO UUID.nextRandom - now <- liftIO getCurrentTime + studyTermCandidateIncidence <- liftIO getRandom let userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 55d090092..f97aecaa4 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -302,8 +302,8 @@ registerForm registered msecret extra = do (msecretRes', msecretView) <- case msecret of (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing _ -> return (Nothing,Nothing) - (sfRes' , sfView) <- if not registered then return (Nothing,Nothing) else - mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing + (_msfRes, msfView) <- if not registered then return (Nothing, Nothing) else + bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing let widget = $(widgetFile "widgets/register-form/register-form") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a57e1149c..5717bd357 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -248,6 +248,8 @@ getProfileDataR = do let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] + lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication + -- Delete Button (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) defaultLayout $ do diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 1f1220787..0c6b55264 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -61,6 +61,9 @@ import Database.Esqueleto.Instances as Import () import Database.Persist.Sql.Instances as Import () import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) +import System.Random as Import (Random) +import Control.Monad.Random.Class as Import (MonadRandom(..)) + import Control.Monad.Trans.RWS (RWST) diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 175f98f3d..3360b0afa 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -10,6 +10,12 @@
#{display userEmail}
_{MsgIdent}
#{display userIdent} +
_{MsgLastLogin} +
+ $maybe llogin <- lastLogin + #{llogin} + $nothing + _{MsgNever} $if not $ null admin_rights
Administrator
diff --git a/templates/widgets/register-form/register-form.hamlet b/templates/widgets/register-form/register-form.hamlet index 6bb3388fb..769c98c3b 100644 --- a/templates/widgets/register-form/register-form.hamlet +++ b/templates/widgets/register-form/register-form.hamlet @@ -4,5 +4,7 @@ $# Maybe display textField for passcode $maybe secretView <- msecretView ^{fvInput secretView} $# Ask for associated primary field uf study, unless registered +$maybe sfView <- msfView + ^{fvInput sfView} $# Always display register/deregister button ^{fvInput btnView} From 0745542867c5144fae70e43de82e759c1ded5fb7 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 28 Feb 2019 11:03:02 +0100 Subject: [PATCH 012/107] All mailto-links use single hamlet file now; added mailto for lecturers --- src/Handler/Course.hs | 6 +++--- src/Handler/Utils.hs | 26 ++++++++++++++++++++++++++ src/Handler/Utils/Table/Cells.hs | 3 ++- templates/adminUser.hamlet | 3 ++- templates/course.hamlet | 4 +++- templates/dsgvDisclaimer.hamlet | 3 +-- templates/imprint/de.hamlet | 14 ++++---------- templates/widgets/link-email.hamlet | 5 +++-- 8 files changed, 44 insertions(+), 20 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c5ded719d..89329ac7e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -12,7 +12,7 @@ import Handler.Utils.Course import Handler.Utils.Delete -- import Data.Time -import qualified Data.Text as T +-- import qualified Data.Text as T import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 @@ -280,8 +280,8 @@ getCShowR tid ssh csh = do lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid - return $ user E.^. UserDisplayName - return (course,schoolName,participants,registered,map E.unValue lecturers) + return $ (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail) + return (course,schoolName,participants,registered,lecturers) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index ca32ba574..8face7168 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -7,10 +7,14 @@ import Import import qualified Data.Text as T -- import qualified Data.Set (Set) import qualified Data.Set as Set +import Data.CaseInsensitive (CI, original) +-- import qualified Data.CaseInsensitive as CI import Language.Haskell.TH (Q, Exp) -- import Language.Haskell.TH.Datatype +import Text.Hamlet (shamletFile) + import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils @@ -39,9 +43,16 @@ tidFromText = fmap TermKey . maybeRight . termFromText simpleLink :: Widget -> Route UniWorX -> Widget simpleLink lbl url = [whamlet|^{lbl}|] +-- | toWidget-Version of @nameHtml@, for convenience nameWidget :: Text -> Text -> Widget nameWidget displayName surname = toWidget $ nameHtml displayName surname +-- | toWidget-Version of @nameEmailHtml@, for convenience +nameEmailWidget :: (CI Text) -> Text -> Text -> Widget +nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname + +-- | Show user's displayName, highlighting the surname if possible. +-- Otherwise appends the surname in parenthesis nameHtml :: Text -> Text -> Html nameHtml displayName surname | null surname = toHtml displayName @@ -59,6 +70,21 @@ nameHtml displayName surname |] [] -> error "Data.Text.splitOn returned empty list in violation of specification." +-- | Like nameHtml just show a users displayname with hightlighted surname, +-- but also wrap the name with a mailto-link +nameEmailHtml :: (CI Text) -> Text -> Text -> Html +nameEmailHtml email displayName surname = + wrapMailto email $ nameHtml displayName surname + +-- | Wrap mailto around given Html using single hamlet-file for consistency +wrapMailto :: (CI Text) -> Html -> Html +wrapMailto (original -> email) linkText + | null email = linkText + | otherwise = $(shamletFile "templates/widgets/link-email.hamlet") + +-- | Just show an email address in a standard way, for convenience inside hamlet files. +mailtoHtml :: (CI Text) -> Html +mailtoHtml email = wrapMailto email $ toHtml email warnTermDays :: TermId -> [Maybe UTCTime] -> DB () warnTermDays tid times = do diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 68bd0e9a3..dc86454dd 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -65,7 +65,8 @@ userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname emailCell :: IsDBTable m a => CI Text -> DBCell m a -emailCell userEmail = cell $(widgetFile "widgets/link-email") +emailCell email = cell $(widgetFile "widgets/link-email") + where linkText= toWgt email cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index 5909795a5..60d0d6b47 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -1,5 +1,6 @@

- #{userEmail} + $# Does not use link-email.hamlet, but should + ^{mailtoHtml userEmail}

^{formWidget} ^{submitButtonView} diff --git a/templates/course.hamlet b/templates/course.hamlet index 130fe7f0a..bccf46976 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -18,7 +18,9 @@
_{MsgLecturerFor}
- #{T.intercalate ", " lecturers} +