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

refactor(dbtable): optimize

Browse Source
This commit is contained in:
Gregor Kleen 2020-03-03 15:16:23 +01:00
parent 42089e17a1
commit 432a77f705
18 changed files with 140 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/CryptoID.hs
View File

@ -15,9 +15,9 @@ import Model
import CryptoID.TH import CryptoID.TH
import qualified Data.CryptoID as E import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt)
import Data.UUID.Cryptographic.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import System.FilePath.Cryptographic.ImplicitNamespace import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -28,6 +28,28 @@ import Data.Aeson.Encoding (text)
import Text.Blaze (ToMarkup(..)) import Text.Blaze (ToMarkup(..))
import qualified Data.CryptoID.Class.ImplicitNamespace as I
encrypt :: forall plaintext ciphertext m.
( I.HasCryptoID ciphertext plaintext m
, KnownSymbol (CryptoIDNamespace ciphertext plaintext)
, MonadHandler m
, Typeable ciphertext
, PathPiece plaintext
)
=> plaintext -> m (I.CryptoID ciphertext plaintext)
encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain
decrypt :: forall plaintext ciphertext m.
( I.HasCryptoID ciphertext plaintext m
, MonadHandler m
, Typeable plaintext
, PathPiece ciphertext
)
=> I.CryptoID ciphertext plaintext -> m plaintext
decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey

30
src/Foundation.hs
View File

@ -58,7 +58,7 @@ import Data.Conduit.List (sourceList)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Control.Monad.Except (MonadError(..), ExceptT) import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.State (execStateT) import Control.Monad.Trans.State (execStateT)
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo.Class (MonadMemo(..), for4) import Control.Monad.Memo.Class (MonadMemo(..), for4)
@ -448,11 +448,11 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
lift . validateToken mAuthId route isWrite =<< askTokenUnsafe lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
AdminHijackUserR cID -> exceptT return return $ do AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID uid <- decrypt cID
otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthNoEscalation r r -> $unsupportedAuthPredicate AuthNoEscalation r
@ -509,7 +509,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
return Authorized return Authorized
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- $cachedHereBinary (mAuthId) . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
@ -536,9 +536,9 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized return Authorized
tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isCorrector <- $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
@ -1036,14 +1036,14 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
-- participant is currently registered -- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant has at least one submission -- participant has at least one submission
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@ -1052,7 +1052,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is member of a submissionGroup -- participant is member of a submissionGroup
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
@ -1060,7 +1060,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a sheet corrector -- participant is a sheet corrector
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
@ -1068,7 +1068,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a tutorial user -- participant is a tutorial user
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
@ -1076,7 +1076,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is tutor for this course -- participant is tutor for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutor E.^. TutorUser E.==. E.val participant E.where_ $ tutor E.^. TutorUser E.==. E.val participant
@ -1084,7 +1084,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is lecturer for this course -- participant is lecturer for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
@ -1419,7 +1419,7 @@ instance Finite (ButtonClass UniWorX)
instance PathPiece (ButtonClass UniWorX) where instance PathPiece (ButtonClass UniWorX) where
toPathPiece BCIsButton = "btn" toPathPiece BCIsButton = "btn"
toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
fromPathPiece = finiteFromPathPiece fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
embedRenderMessage ''UniWorX ''ButtonSubmit id embedRenderMessage ''UniWorX ''ButtonSubmit id
instance Button UniWorX ButtonSubmit where instance Button UniWorX ButtonSubmit where

2
src/Handler/Admin/ErrorMessage.hs
View File

@ -6,8 +6,6 @@ import Import
import Handler.Utils import Handler.Utils
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
import Control.Monad.Trans.Except
getAdminErrMsgR, postAdminErrMsgR :: Handler Html getAdminErrMsgR, postAdminErrMsgR :: Handler Html
getAdminErrMsgR = postAdminErrMsgR getAdminErrMsgR = postAdminErrMsgR

8
src/Handler/Corrections.hs
View File

@ -137,7 +137,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
mkRoute = do mkRoute = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid ssh csh shn cid SubShowR return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|]) in anchorCellCM $cacheIdentHere mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|])
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId
@ -149,14 +149,14 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
ssh = course ^. _4 ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid link cid = CourseR tid ssh csh $ CUserR cid
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
anchorCellM (link <$> encrypt userId) $ case mPseudo of anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|] Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
@ -171,7 +171,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
in mconcat in mconcat
[ anchorCellM mkRoute $(widgetFile "widgets/rating/rating") [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
, writerCell $ do , writerCell $ do
let let
summary :: SheetTypeSummary summary :: SheetTypeSummary

8
src/Handler/Course/Application/List.hs
View File

@ -264,13 +264,13 @@ postCApplicationsR tid ssh csh = do
allocationLink :: Allocation -> SomeRoute UniWorX allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX) participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
participantLink uid = do participantLink uid = liftHandler $ do
cID <- encrypt uid cID <- encrypt uid
return . SomeRoute . CourseR tid ssh csh $ CUserR cID return . SomeRoute . CourseR tid ssh csh $ CUserR cID
applicationLink :: MonadCrypto m => CourseApplicationId -> m (SomeRoute UniWorX) applicationLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseApplicationId -> m (SomeRoute UniWorX)
applicationLink appId = do applicationLink appId = liftHandler $ do
cID <- encrypt appId cID <- encrypt appId
return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR

4
src/Handler/ExamOffice/Exam.hs
View File

@ -204,8 +204,8 @@ postEGradesR tid ssh csh examn = do
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
let let
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX) participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
participantLink partId = do participantLink partId = liftHandler $ do
cID <- encrypt partId cID <- encrypt partId
return . SomeRoute . CourseR tid ssh csh $ CUserR cID return . SomeRoute . CourseR tid ssh csh $ CUserR cID

2
src/Handler/Sheet.hs
View File

@ -30,8 +30,6 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
-- import qualified Database.Esqueleto.Internal.Sql as E -- import qualified Database.Esqueleto.Internal.Sql as E
import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map

3
src/Handler/Utils/Communication.hs
View File

@ -56,7 +56,8 @@ instance PathPiece RecipientCategory where
toPathPiece RecipientCustom = "custom" toPathPiece RecipientCustom = "custom"
toPathPiece (RecipientGroup g) = toPathPiece g toPathPiece (RecipientGroup g) = toPathPiece g
fromPathPiece = finiteFromPathPiece fromPathPiece "custom" = Just RecipientCustom
fromPathPiece t = RecipientGroup <$> fromPathPiece t
instance RenderMessage UniWorX RecipientCategory where instance RenderMessage UniWorX RecipientCategory where
renderMessage foundation ls = \case renderMessage foundation ls = \case

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

@ -36,8 +36,6 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Lazy as A
import Control.Monad.Except (ExceptT)
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Data.Time.Format (iso8601DateFormat) import Data.Time.Format (iso8601DateFormat)

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

@ -38,7 +38,6 @@ import qualified Data.Set as Set
import Data.Map ((!)) import Data.Map ((!))
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Writer.Class import Control.Monad.Writer.Class
import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Error.Class (MonadError(..))
@ -1083,6 +1082,8 @@ optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site ( YesodPersist site
, PersistQueryRead backend , PersistQueryRead backend
, HasCryptoUUID (Key a) (HandlerFor site) , HasCryptoUUID (Key a) (HandlerFor site)
, KnownSymbol (CryptoIDNamespace UUID (Key a))
, PathPiece (Key a)
, RenderMessage site msg , RenderMessage site msg
, YesodPersistBackend site ~ backend , YesodPersistBackend site ~ backend
, PersistRecordBackend a backend , PersistRecordBackend a backend

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

@ -35,6 +35,7 @@ module Handler.Utils.Table.Pagination
, anchorCell, anchorCell', anchorCellM, anchorCellM' , anchorCell, anchorCell', anchorCellM, anchorCellM'
, linkEitherCell, linkEitherCellM, linkEitherCellM' , linkEitherCell, linkEitherCellM, linkEitherCellM'
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
, cellTooltip , cellTooltip
, listCell , listCell
, formCell, DBFormResult(..), getDBFormResult , formCell, DBFormResult(..), getDBFormResult
@ -153,14 +154,8 @@ data SortDirection = SortAsc | SortDesc
instance Universe SortDirection instance Universe SortDirection
instance Finite SortDirection instance Finite SortDirection
instance PathPiece SortDirection where nullaryPathPiece ''SortDirection $ camelToPathPiece' 1
toPathPiece SortAsc = "asc" pathPieceJSON ''SortDirection
toPathPiece SortDesc = "desc"
fromPathPiece = finiteFromPathPiece
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''SortDirection
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy] sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t
@ -1291,6 +1286,7 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
<div .tooltip__content>_{msg} <div .tooltip__content>_{msg}
|] |]
-- | Always display widget; maybe a link if user is Authorized. -- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell` -- Also see variant `linkEmptyCell`
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
@ -1308,8 +1304,14 @@ anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget) anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellCM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget) anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a
maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget) maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget)
@ -1333,6 +1335,16 @@ linkEitherCellM' :: forall m url wgt wgt' a x.
=> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust) linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
linkEitherCellCM' :: forall m url wgt wgt' a x cache.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
, Binary cache
)
=> cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellCM' cache xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellCM' (Just . toStrict $ B.encode cache) (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
maybeLinkEitherCellM' :: forall m url wgt wgt' a x. maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
( HasRoute UniWorX url ( HasRoute UniWorX url
, ToWidget UniWorX wgt , ToWidget UniWorX wgt
@ -1340,7 +1352,16 @@ maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
, IsDBTable m a , IsDBTable m a
) )
=> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do maybeLinkEitherCellM' = maybeLinkEitherCellCM' Nothing
maybeLinkEitherCellCM' :: forall m url wgt wgt' a x.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
)
=> Maybe ByteString -> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
x' <- runMaybeT xM x' <- runMaybeT xM
case x' of case x' of
Just x -> do Just x -> do
@ -1348,17 +1369,15 @@ maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
widget, widgetUnauth :: Widget widget, widgetUnauth :: Widget
widget = toWidget $ x2widgetAuth x widget = toWidget $ x2widgetAuth x
widgetUnauth = toWidget . x2widgetUnauth $ Just x widgetUnauth = toWidget . x2widgetUnauth $ Just x
authResult <- liftHandler $ isAuthorized (urlRoute route) False authResult <- liftHandler . maybe id $cachedHereBinary mCache . hasReadAccessTo $ urlRoute route
linkUrl <- toTextUrl route linkUrl <- toTextUrl route
case authResult of if
Authorized -> $(widgetFile "table/cell/link") -- show allowed link | authResult -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> widgetUnauth -- show alternative widget | otherwise -> widgetUnauth
_otherwise -> do _otherwise -> do
toWidget $ x2widgetUnauth Nothing toWidget $ x2widgetUnauth Nothing
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
listCell xs mkCell = review dbCell . ([], ) $ do listCell xs mkCell = review dbCell . ([], ) $ do
cells <- forM xs $ cells <- forM xs $

6
src/Import/NoModel.hs
View File

@ -90,6 +90,10 @@ import Control.Monad.Trans.Writer.Lazy as Import
( writer, Writer, runWriter, mapWriter, execWriter ( writer, Writer, runWriter, mapWriter, execWriter
, WriterT(..), mapWriterT, execWriterT , WriterT(..), mapWriterT, execWriterT
) )
import Control.Monad.Trans.Except as Import
( except, Except, runExcept, mapExcept
, ExceptT(..), runExceptT, mapExceptT, throwE
)
import Control.Monad.Base as Import import Control.Monad.Base as Import
import Control.Monad.Catch as Import hiding (Handler(..)) import Control.Monad.Catch as Import hiding (Handler(..))
import Control.Monad.Trans.Control as Import hiding (embed) import Control.Monad.Trans.Control as Import hiding (embed)
@ -167,6 +171,8 @@ import Control.Arrow as Import (Kleisli(..))
import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString) import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString)
import Data.Encoding.UTF8 as Import (UTF8(UTF8)) import Data.Encoding.UTF8 as Import (UTF8(UTF8))
import GHC.TypeLits as Import (KnownSymbol)
import Control.Monad.Trans.RWS (RWST) import Control.Monad.Trans.RWS (RWST)

13
src/Model/Migration/Types.hs
View File

@ -10,6 +10,7 @@ import qualified Model as Current
import qualified Model.Types.TH.JSON as Current import qualified Model.Types.TH.JSON as Current
import Data.Universe import Data.Universe
import Data.Universe.TH
data SheetType data SheetType
@ -32,16 +33,8 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriveJSON defaultOptions ''UploadMode deriveJSON defaultOptions ''UploadMode
Current.derivePersistFieldJSON ''UploadMode Current.derivePersistFieldJSON ''UploadMode
instance Universe UploadMode where deriveFinite ''UploadMode
universe = NoUpload : (Upload <$> universe) finitePathPiece ''UploadMode ["no-upload", "no-unpack", "unpack"]
instance Finite UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
NoUpload -> "no-upload"
Upload True -> "unpack"
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions | CorrectorSubmissions

6
src/Model/Tokens.hs
View File

@ -39,6 +39,8 @@ import Data.Time.Clock.POSIX
import Data.Binary (Binary) import Data.Binary (Binary)
import qualified Data.CryptoID.Class.ImplicitNamespace as I
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
@ -96,7 +98,7 @@ tokenToJSON :: forall m.
-- --
-- Monadic context is needed because `AuthId`s are encrypted during encoding -- Monadic context is needed because `AuthId`s are encrypted during encoding
tokenToJSON BearerToken{..} = do tokenToJSON BearerToken{..} = do
cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m)))) cID <- either (return . Left) (fmap Right . I.encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
let stdPayload = Jose.JwtClaims let stdPayload = Jose.JwtClaims
{ jwtIss = Just $ toPathPiece tokenIssuedBy { jwtIss = Just $ toPathPiece tokenIssuedBy
, jwtSub = Nothing , jwtSub = Nothing
@ -128,7 +130,7 @@ tokenParseJSON :: forall site.
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'` -- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
tokenParseJSON v@(Object o) = do tokenParseJSON v@(Object o) = do
tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site))) tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority' tokenAuthority <- either (return . Left) (fmap Right . I.decrypt) tokenAuthority'
tokenRoutes <- lift $ o .:? "routes" tokenRoutes <- lift $ o .:? "routes"
tokenAddAuth <- lift $ o .:? "add-auth" tokenAddAuth <- lift $ o .:? "add-auth"

7
src/Model/Types/Sheet.hs
View File

@ -157,12 +157,7 @@ derivePersistField "SheetFileType"
instance Universe SheetFileType instance Universe SheetFileType
instance Finite SheetFileType instance Finite SheetFileType
instance PathPiece SheetFileType where finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"]
toPathPiece SheetExercise = "file"
toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking"
fromPathPiece = finiteFromPathPiece
sheetFile2markup :: SheetFileType -> Markup sheetFile2markup :: SheetFileType -> Markup
sheetFile2markup SheetExercise = iconSFTQuestion sheetFile2markup SheetExercise = iconSFTQuestion

4
src/Utils.hs
View File

@ -56,6 +56,7 @@ import Control.Monad.Morph (hoist)
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Instances () import Language.Haskell.TH.Instances ()
import Instances.TH.Lift () import Instances.TH.Lift ()
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
@ -916,6 +917,9 @@ encodedSecretBoxOpen ciphertext = do
cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
cachedByBinary k = cachedBy (toStrict $ Binary.encode k) cachedByBinary k = cachedBy (toStrict $ Binary.encode k)
cacheIdentHere :: Q Exp
cacheIdentHere = TH.lift =<< location
cachedHere :: Q Exp cachedHere :: Q Exp
cachedHere = do cachedHere = do
loc <- location loc <- location

54
src/Utils/PathPiece.hs
View File

@ -1,6 +1,5 @@
module Utils.PathPiece module Utils.PathPiece
( finiteFromPathPiece ( nullaryToPathPiece
, nullaryToPathPiece
, nullaryPathPiece, finitePathPiece , nullaryPathPiece, finitePathPiece
, splitCamel , splitCamel
, camelToPathPiece, camelToPathPiece' , camelToPathPiece, camelToPathPiece'
@ -17,9 +16,11 @@ import Data.Universe
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Char as Char import qualified Data.Char as Char
import Data.Map ((!), (!?)) import Data.Map ((!))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.HashMap.Strict as HashMap
import Numeric.Natural import Numeric.Natural
import Data.List (foldl) import Data.List (foldl)
@ -30,10 +31,17 @@ import qualified Data.Aeson.Types as Aeson
import Control.Monad.Fail import Control.Monad.Fail
finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of mkFiniteFromPathPiece finiteType = do
[x] -> Just x mapName <- newName $ "pathPieceMap" <> nameBase finiteType
_xs -> Nothing let
decs = sequence
[ pragInlD mapName NoInline FunLike AllPhases
, sigD mapName [t|HashMap Text $(conT finiteType)|]
, funD mapName
[ clause [] (normalB [e|HashMap.fromList $ map (toPathPiece &&& id) universeF|]) [] ]
]
(,) <$> decs <*> [e|flip HashMap.lookup $(varE mapName)|]
nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
@ -46,22 +54,26 @@ nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
letE [helperDec] $ varE helperName letE [helperDec] $ varE helperName
nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
nullaryPathPiece nullaryType mangle = nullaryPathPiece nullaryType mangle = do
pure <$> instanceD (cxt []) [t|PathPiece $(conT nullaryType)|] (finDecs, finExp) <- mkFiniteFromPathPiece nullaryType
[ funD 'toPathPiece sequence . (map return finDecs ++) . pure $
[ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ] instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
, funD 'fromPathPiece [ funD 'toPathPiece
[ clause [] (normalB [e|finiteFromPathPiece|]) [] ] [ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
] , funD 'fromPathPiece
[ clause [] (normalB $ return finExp) [] ]
]
finitePathPiece :: Name -> [Text] -> DecsQ finitePathPiece :: Name -> [Text] -> DecsQ
finitePathPiece finiteType verbs = finitePathPiece finiteType verbs = do
pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|] (finDecs, finExp) <- mkFiniteFromPathPiece finiteType
[ funD 'toPathPiece sequence . (map return finDecs ++) . pure $
[ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ] instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
, funD 'fromPathPiece [ funD 'toPathPiece
[ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ] [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
] , funD 'fromPathPiece
[ clause [] (normalB $ return finExp) [] ]
]
splitCamel :: Textual t => t -> [t] splitCamel :: Textual t => t -> [t]

2
test/Database/Fill.hs
View File

@ -935,7 +935,7 @@ fillDb = do
void . insertMany $ do void . insertMany $ do
uid <- manyUsers uid <- manyUsers
return $ CourseParticipant bs uid now Nothing Nothing return $ CourseParticipant bs uid now Nothing Nothing
forM_ [1..5] $ \shNr -> do forM_ [1..14] $ \shNr -> do
shId <- insert Sheet shId <- insert Sheet
{ sheetCourse = bs { sheetCourse = bs
, sheetName = CI.mk [st|Blatt #{tshow shNr}|] , sheetName = CI.mk [st|Blatt #{tshow shNr}|]