fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into 126-ubungsbetrieb-statistik-seiten-pro-kurs

Browse Source
This commit is contained in:
SJost 2018-12-07 11:39:47 +01:00
commit 59714bd3c7
26 changed files with 285 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
messages/uniworx/de.msg
View File

@ -72,6 +72,8 @@ CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gese
CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
CourseFilterSearch: Volltext-Suche
CourseFilterRegistered: Registriert
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@ -171,7 +173,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
@ -233,6 +235,7 @@ CorrUpload: Korrekturen hochladen
CorrSetCorrector: Korrektor zuweisen
CorrAutoSetCorrector: Korrekturen verteilen
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):

5
src/Data/CaseInsensitive/Instances.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.CaseInsensitive.Instances
@ -20,6 +21,8 @@ import Language.Haskell.TH.Syntax (Lift(..))
import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
import qualified Database.Esqueleto as E
instance PersistField (CI Text) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -37,6 +40,8 @@ instance PersistFieldSql (CI Text) where
instance PersistFieldSql (CI String) where
sqlType _ = SqlOther "citext"
instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a)
instance ToJSON a => ToJSON (CI a) where
toJSON = toJSON . CI.original

19
src/Data/Monoid/Instances.hs Normal file
View File

@ -0,0 +1,19 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Monoid.Instances
(
) where
import ClassyPrelude
import Data.Monoid
type instance Element (Dual a) = a
instance MonoPointed (Dual a)
type instance Element (Sum a) = a
instance MonoPointed (Sum a)
type instance Element (Product a) = a
instance MonoPointed (Product a)
type instance Element (First a) = a
instance MonoPointed (First a)
type instance Element (Last a) = a
instance MonoPointed (Last a)

31
src/Foundation.hs
View File

@ -454,7 +454,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
&& NTop systemMessageTo >= cTime
return Authorized
r -> $unsupportedAuthPredicate "time" r
r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@ -467,14 +467,14 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
return Authorized
r -> $unsupportedAuthPredicate "registered" r
r -> $unsupportedAuthPredicate AuthRegistered r
tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered)
return Authorized
r -> $unsupportedAuthPredicate "capacity" r
r -> $unsupportedAuthPredicate AuthCapacity r
tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
@ -482,41 +482,41 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ registered <= 0
return Authorized
r -> $unsupportedAuthPredicate "empty" r
r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree
return Authorized
r -> $unsupportedAuthPredicate "materials" r
r -> $unsupportedAuthPredicate AuthMaterials r
tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized
r -> $unsupportedAuthPredicate "owner" r
r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid
guard $ submissionRatingDone sub
return Authorized
r -> $unsupportedAuthPredicate "rated" r
r -> $unsupportedAuthPredicate AuthRated r
tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions
return Authorized
r -> $unsupportedAuthPredicate "user-submissions" r
r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized
r -> $unsupportedAuthPredicate "corrector-submissions" r
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID
@ -524,7 +524,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate "authentication" r
r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
@ -721,11 +721,12 @@ instance Yesod UniWorX where
UniWorX{appWidgetMemcached, appSettings} <- getYesod
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
touch = liftIO $ Memcached.touch expiry fileName mConn
add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
C.catchIf Memcached.isKeyNotFound touch $ \_ ->
C.handleIf Memcached.isKeyExists (\_ -> return ()) add
return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
return . Left $ pack absoluteLink
where
-- Generate a unique filename based on the content itself, this is used
-- for deduplication so a collision resistant hash function is required
@ -734,7 +735,9 @@ instance Yesod UniWorX where
--
-- Length of hash is 144 bits instead of MD5's 128, so as to avoid
-- padding after base64-conversion
fileName = (<> ("." <> encodeUtf8 ext))
fileName = (<.> unpack ext)
. unpack
. decodeUtf8
. Base64.encode
. (convert :: Digest (SHAKE256 144) -> ByteString)
. runIdentity

168
src/Handler/Corrections.hs
View File

@ -14,12 +14,13 @@ import Utils.Lens
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import Data.Map (Map, (!))
import qualified Data.Map as Map
import qualified Data.Text as Text
import Data.Semigroup (Sum(..))
import Data.Monoid (All(..))
-- import Data.Time
-- import qualified Data.Text as T
@ -46,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount)
import Data.List (genericLength)
import Control.Monad.Trans.Writer (WriterT(..), runWriter)
import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT)
import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Trans.RWS (RWST)
@ -275,6 +277,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
)
]
, dbtFilterUI = mempty
, dbtStyle = def
, dbtIdent = "corrections" :: Text
}
@ -668,81 +671,96 @@ postCorrectionsCreateR = do
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, (pss, invalids)) -> do
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
allDone <- fmap getAll . execWriterT $ do
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
tell . All $ null invalids
runDB $ do
Sheet{..} <- get404 sid
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
now <- liftIO getCurrentTime
let
sps' :: [[SheetPseudonym]]
duplicate :: Set Pseudonym
( sps'
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
known <- State.gets $ Map.member sheetPseudonymPseudonym
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
return $ bool (p :) id known ps
submissionPrototype = Submission
{ submissionSheet = sid
, submissionRatingPoints = Nothing
, submissionRatingComment = Nothing
, submissionRatingBy = Just uid
, submissionRatingAssigned = Just now
, submissionRatingTime = Nothing
}
unless (null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
E.&&. submission E.^. SubmissionSheet E.==. E.val sid
return submissionUser
unless (null existingSubUsers) $ do
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
forM_ sps'' $ \spGroup
-> let
sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
in case sheetGrouping of
Arbitrary maxSize -> do
subId <- insert submissionPrototype
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
WriterT . runDB . mapReaderT runWriterT $ do
Sheet{..} <- get404 sid
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
tell . All $ null unknown
now <- liftIO getCurrentTime
let
sps' :: [[SheetPseudonym]]
duplicate :: Set Pseudonym
( sps'
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
known <- State.gets $ Map.member sheetPseudonymPseudonym
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
return $ bool (p :) id known ps
submissionPrototype = Submission
{ submissionSheet = sid
, submissionRatingPoints = Nothing
, submissionRatingComment = Nothing
, submissionRatingBy = Just uid
, submissionRatingAssigned = Just now
, submissionRatingTime = Nothing
}
when (genericLength spGroup > maxSize) $
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
RegisteredGroups -> do
groups <- E.select . E.from $ \submissionGroup -> do
E.where_ . E.exists . E.from $ \submissionGroupUser ->
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
return $ submissionGroup E.^. SubmissionGroupId
if
| length (groups :: [E.Value SubmissionGroupId]) < 2
-> do
subId <- insert submissionPrototype
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
when (null groups) $
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
| otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
NoGroups -> do
subId <- insert submissionPrototype
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
when (length spGroup > 1) $
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
redirect CorrectionsGradeR
unless (null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
E.&&. submission E.^. SubmissionSheet E.==. E.val sid
return submissionUser
unless (null existingSubUsers) . mapReaderT lift $ do
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
forM_ sps'' $ \spGroup
-> let
sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
in case sheetGrouping of
Arbitrary maxSize -> do
subId <- insert submissionPrototype
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
when (genericLength spGroup > maxSize) $
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
RegisteredGroups -> do
let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
groups <- E.select . E.from $ \submissionGroup -> do
E.where_ . E.exists . E.from $ \submissionGroupUser ->
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
return $ submissionGroup E.^. SubmissionGroupId
groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
return $ submissionGroupUser E.^. SubmissionGroupUserUser
if
| [_] <- groups
, Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
-> do
subId <- insert submissionPrototype
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
{ submissionUserUser = sheetUser
, submissionUserSubmission = subId
}
when (null groups) $
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
| length groups < 2
-> do
forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
tell $ All False
| otherwise ->
addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
NoGroups -> do
subId <- insert submissionPrototype
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
when (length spGroup > 1) $
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
when allDone $
redirect CorrectionsGradeR
defaultLayout $

19
src/Handler/Course.hs
View File

@ -12,6 +12,8 @@ import qualified Data.Text as T
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
import Data.Monoid (Last(..))
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map as Map
@ -161,13 +163,27 @@ makeCourseTable whereClause colChoices psValidator = do
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
)
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> course2Registered muid tExpr E.==. E.val needle
)
, ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
)
]
, dbtFilterUI = mconcat
[ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing
, Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing
]
, dbtStyle = def
, dbtIdent = "courses" :: Text
}
getCourseListR :: Handler Html
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
getCourseListR = do
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ colCourseDescr
@ -182,7 +198,6 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI MsgCourseListTitle
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
$(widgetFile "courses")
getTermCurrentR :: Handler Html

10
src/Handler/Home.hs
View File

@ -97,6 +97,7 @@ homeAnonymous = do
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
] -}
, dbtFilterUI = mempty
, dbtStyle = def
, dbtIdent = "upcomingdeadlines" :: Text
}
@ -198,6 +199,7 @@ homeUser uid = do
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
] -}
, dbtFilterUI = mempty
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtIdent = "upcomingdeadlines" :: Text
}
@ -283,8 +285,12 @@ getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
let
blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
taForm authTag
| authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
| otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
$ AuthTagActive

5
src/Handler/Profile.hs
View File

@ -273,6 +273,7 @@ mkOwnedCoursesTable =
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
dbtFilterUI = mempty
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
@ -319,6 +320,7 @@ mkEnrolledCoursesTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
]
, dbtFilterUI = mempty
, dbtStyle = def
}
@ -396,6 +398,7 @@ mkSubmissionTable =
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
dbtFilterUI = mempty
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid
in dbTableWidget' validator DBTable{..}
@ -465,6 +468,7 @@ mkSubmissionGroupTable =
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
dbtFilterUI = mempty
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}
@ -538,6 +542,7 @@ mkCorrectionsTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
]
dbtFilterUI = mempty
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}

7
src/Handler/Sheet.hs
View File

@ -225,8 +225,8 @@ getSheetListR tid ssh csh = do
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
-- )
]
, dbtFilter = Map.fromList
[]
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtStyle = def
, dbtIdent = "sheets" :: Text
}
@ -294,7 +294,8 @@ getSShowR tid ssh csh shn = do
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
, dbtStyle = def
, dbtFilter = Map.empty
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtIdent = "files" :: Text
, dbtSorting = Map.fromList
[ ( "type"

3
src/Handler/Submission.hs
View File

@ -310,7 +310,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
, SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
)
]
, dbtFilter = Map.empty
, dbtFilter = mempty
, dbtFilterUI = mempty
}
mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid

9
src/Handler/SystemMessage.hs
View File

@ -178,12 +178,9 @@ postMessageListR = do
{ dbtSQLQuery
, dbtColonnade
, dbtProj
, dbtSorting = Map.fromList
[ -- TODO: from, to, authenticated, severity
]
, dbtFilter = Map.fromList
[
]
, dbtSorting = mempty -- TODO: from, to, authenticated, severity
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtStyle = def
, dbtIdent = "messages" :: Text
}

1
src/Handler/Term.hs
View File

@ -126,6 +126,7 @@ getTermShowR = do
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
)
]
, dbtFilterUI = mempty
, dbtStyle = def
, dbtIdent = "terms" :: Text
}

1
src/Handler/Users.hs
View File

@ -85,6 +85,7 @@ getUsersR = do
)
]
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtStyle = def
, dbtIdent = "users" :: Text
}

24
src/Handler/Utils/Form.hs
View File

@ -45,6 +45,9 @@ import Text.Read (readMaybe)
import Utils.Lens
import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Text (encodeToLazyText)
----------------------------
-- Buttons (new version ) --
----------------------------
@ -455,6 +458,27 @@ langField :: Bool -- ^ Only allow values from `appLanguages`
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
jsonField :: ( ToJSON a, FromJSON a
, MonadHandler m
, RenderMessage (HandlerSite m) UniWorXMessage
, RenderMessage (HandlerSite m) FormMessage
)
=> Bool {-^ Hidden? -}
-> Field m a
jsonField hide = Field{..}
where
inputType :: Text
inputType
| hide = "hidden"
| otherwise = "text"
fieldParse [v] [] = return . second Just . first (SomeMessage . MsgJSONFieldDecodeFailure) . eitherDecodeStrict' $ encodeUtf8 v
fieldParse [] [] = return $ Right Nothing
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
fieldView theId name attrs val isReq = liftWidgetT [whamlet|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|]
fieldEnctype = UrlEncoded
funcForm :: forall k v m.
( Finite k, Ord k

2
src/Handler/Utils/Rating.hs
View File

@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as Conduit
import Utils.Lens hiding ((<.>))
import Utils.Lens
instance HasResolution prec => Pretty (Fixed prec) where

2
src/Handler/Utils/SheetType.hs
View File

@ -5,7 +5,7 @@ module Handler.Utils.SheetType
import Import
import Data.Monoid (Sum(..))
import Utils.Lens hiding ((<.>))
import Utils.Lens
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
addBonusToPoints sts =

51
src/Handler/Utils/Table/Pagination.hs
View File

@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination
) where
import Handler.Utils.Table.Pagination.Types
import Handler.Utils.Form
import Utils
import Utils.Lens.TH
@ -228,6 +229,11 @@ data DBStyle = DBStyle
{ dbsEmptyStyle :: DBEmptyStyle
, dbsEmptyMessage :: UniWorXMessage
, dbsAttrs :: [(Text, Text)]
, dbsLayoutFilter :: Widget -- ^ Filter UI
-> Enctype
-> Text -- ^ Filter action (target uri)
-> Widget -- ^ Table
-> Widget
}
instance Default DBStyle where
@ -235,8 +241,12 @@ instance Default DBStyle where
{ dbsEmptyStyle = def
, dbsEmptyMessage = MsgNoTableContent
, dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
, dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
}
type FilterKey = CI Text
type SortingKey = CI Text
data DBTable m x = forall a r r' h i t.
( ToSortable h, Functor h
, E.SqlSelect a r
@ -246,8 +256,9 @@ data DBTable m x = forall a r r' h i t.
{ dbtSQLQuery :: t -> E.SqlQuery a
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
, dbtColonnade :: Colonnade h r' (DBCell m x)
, dbtSorting :: Map (CI Text) (SortColumn t)
, dbtFilter :: Map (CI Text) (FilterColumn t)
, dbtSorting :: Map SortingKey (SortColumn t)
, dbtFilter :: Map FilterKey (FilterColumn t)
, dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
, dbtStyle :: DBStyle
, dbtIdent :: i
}
@ -379,18 +390,31 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, fieldEnctype = UrlEncoded
}
piResult <- lift . runInputGetResult $ PaginationInput
piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
piInput <- lift . runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page")
piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
let filterPi
| FormSuccess PaginationInput{..} <- piPrevious <|> piInput
= def{ piSorting, piLimit }
| otherwise
= def
((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,)
<$> areq (jsonField True) "" (Just filterPi)
<*> dbtFilterUI
let
piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
let
(errs, PaginationSettings{..}) = case piPrevious <|> piResult of
(errs, PaginationSettings{..}) = case piResult of
FormSuccess pi
| not (piIsUnset pi)
-> runPSValidator dbtable $ Just pi
@ -398,7 +422,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
_ -> runPSValidator dbtable Nothing
paginationInput
| FormSuccess pi <- piPrevious <|> piResult
| FormSuccess pi <- piResult
, not $ piIsUnset pi
= pi
| otherwise
@ -419,18 +443,23 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
rowCount
| (E.Value n, _):_ <- rows' = n
| otherwise = 0
tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams
filterAction = tblLink
$ setParam (wIdent "page") Nothing
. Map.foldrWithKey (\k _ f -> setParam (wIdent $ CI.foldedCase k) Nothing . f) id dbtFilter
table' :: WriterT x m Widget
table' = do
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
widget <- sortableContent ^. cellContents
let
@ -456,7 +485,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return $(widgetFile "table/layout")
bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
@ -464,7 +493,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ]
dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-> DB (DBResult (HandlerT UniWorX IO) x)

1
src/Import/NoFoundation.hs
View File

@ -41,6 +41,7 @@ import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup)
import Data.Monoid.Instances as Import ()
import Control.Monad.Morph as Import (MFunctor(..))

14
src/Jobs.hs
View File

@ -134,6 +134,7 @@ execCrontab = evalStateT go HashMap.empty
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
refT <- liftIO getCurrentTime
settings <- getsYesod appSettings
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of
@ -141,7 +142,7 @@ execCrontab = evalStateT go HashMap.empty
Just crontab -> Just <$> do
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
case earliestJob prevExec crontab refT of
case earliestJob settings prevExec crontab refT of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
@ -189,6 +190,11 @@ execCrontab = evalStateT go HashMap.empty
acc :: NominalDiffTime
acc = 1e-3
debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime
debouncingAcc AppSettings{appNotificationRateLimit} = \case
JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit
_ -> acc
applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do
appInstance <- getsYesod appInstanceID
@ -197,8 +203,8 @@ execCrontab = evalStateT go HashMap.empty
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
where
go' (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev
@ -207,7 +213,7 @@ execCrontab = evalStateT go HashMap.empty
| otherwise
= Just (jobCtl, t)
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) acc now cron
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do

19
src/Utils.hs
View File

@ -63,6 +63,9 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Data.PKCS7 as PKCS7
import Data.Fixed (Centi)
import Data.Ratio ((%))
-----------
@ -87,7 +90,7 @@ guardAuthResult AuthenticationRequired = notAuthenticated
guardAuthResult (Unauthorized t) = permissionDenied t
guardAuthResult Authorized = return ()
data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route
deriving (Eq, Ord, Typeable, Show)
instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
@ -95,8 +98,8 @@ unsupportedAuthPredicate :: ExpQ
unsupportedAuthPredicate = do
logFunc <- logErrorS
[e| \tag route -> do
$(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
unauthorizedI (UnsupportedAuthPredicate tag route)
$(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
|]
@ -204,17 +207,15 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out
display = pack . show
-}
textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> pack (show rx) <> "%"
where
round' :: Double -> Int -- avoids annoying warning
round' = round
rx :: Double
rx = fromIntegral (round' $ 1000.0*x) / 10.0
rx :: Centi
rx = realToFrac (x * 100)
lz = if rx < 10.0 then "0" else ""
textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole)
textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole
stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounterCI = CI.map stepTextCounter

2
src/Utils/Form.hs
View File

@ -28,7 +28,7 @@ import Utils.Message
-------------------
-- | Use this type to pass information to the form template
data FormLayout = FormStandard
data FormLayout = FormStandard | FormDBTableFilter
renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do

2
src/Utils/Lens.hs
View File

@ -1,7 +1,7 @@
module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation
import Control.Lens as Utils.Lens
import Control.Lens as Utils.Lens hiding ((<.>))
import Control.Lens.Extras as Utils.Lens (is)
import Utils.Lens.TH as Utils.Lens (makeLenses_)

2
templates/standalone/modal.julius
View File

@ -76,7 +76,7 @@
var scriptClone = document.createElement('script');
if (scriptTag.text)
scriptClone.text = striptTag.text;
scriptClone.text = scriptTag.text;
if (scriptTag.hasAttributes()) {
var attrs = scriptTag.attributes;
for (var i = attrs.length - 1; i >= 0; i--) {

6
templates/table/layout-filter-default.hamlet Normal file
View File

@ -0,0 +1,6 @@
$newline never
<section>
<form method=GET action=#{filterAction} enctype=#{filterEnctype}>
^{filterWgdt}
<section>
^{scrolltable}

2
templates/widgets/form.hamlet
View File

@ -1,7 +1,7 @@
$newline never
#{fragment}
$case formLayout
$of FormStandard
$of _
$forall view <- views
$# TODO: add class 'form-group--submit' if this is the submit-button view
<div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>

10
test/Database.hs
View File

@ -24,6 +24,9 @@ import qualified Data.ByteString as BS
import Data.Time
import Utils.Lens (review)
import Control.Monad.Random.Class (MonadRandom(..))
data DBAction = DBClear
| DBTruncate
@ -151,7 +154,7 @@ fillDb = do
, userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def
}
void . insert $ User
tinaTester <- insert $ User
{ userIdent = "tester@campus.lmu.de"
, userAuthentication = AuthLDAP
, userMatrikelnummer = Just "999"
@ -312,6 +315,7 @@ 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]
sh1 <- insert Sheet
{ sheetCourse = pmo
, sheetName = "Blatt 1"
@ -328,6 +332,10 @@ fillDb = do
, sheetSolutionFrom = Nothing
}
void . insert $ SheetEdit jost now sh1
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
p <- liftIO getRandom
$logDebug (review _PseudonymText p)
void . insert $ SheetPseudonym sh1 p u
void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal
void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal
h102 <- insertFile "H10-2.hs"