Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Steffen Jost
commit
be7ae9c979
@ -198,11 +198,13 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
|
||||
SubmissionMember n@Int: Mitabgebende(r) ##{display n}
|
||||
SubmissionMembers: Abgebende
|
||||
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
SubmissionFiles: Abgegebene Dateien
|
||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionUsersEmpty: Es kann keine Abgabe ohne Abgebende erstellt werden
|
||||
SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) eingetragen
|
||||
|
||||
SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
|
||||
SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}
|
||||
@ -508,6 +510,7 @@ BothSubmissions: Abgabe direkt & extern mit Pseudonym
|
||||
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
|
||||
|
||||
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
|
||||
SubmissionReplace: Abgabe ersetzen
|
||||
|
||||
AdminFeaturesHeading: Studiengänge
|
||||
StudyTerms: Studiengänge
|
||||
@ -586,6 +589,8 @@ MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@S
|
||||
|
||||
MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
|
||||
|
||||
MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
|
||||
|
||||
SheetGrading: Bewertung
|
||||
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
|
||||
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
|
||||
@ -863,6 +868,11 @@ TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #
|
||||
TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
|
||||
TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
|
||||
|
||||
SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen
|
||||
SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt
|
||||
SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
|
||||
SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein.
|
||||
|
||||
InvitationAction: Aktion
|
||||
InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
|
||||
InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
|
||||
|
||||
1
routes
1
routes
@ -107,6 +107,7 @@
|
||||
/delete SubDelR GET POST !ownerANDtime
|
||||
/assign SAssignR GET POST !lecturerANDtime
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
/invite SInviteR GET POST !ownerANDtime
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
|
||||
|
||||
@ -155,6 +155,11 @@ instance HasAppSettings UniWorX where
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
deriving instance Generic CourseR
|
||||
deriving instance Generic SheetR
|
||||
deriving instance Generic SubmissionR
|
||||
deriving instance Generic MaterialR
|
||||
deriving instance Generic TutorialR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
@ -503,13 +508,19 @@ validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo valid
|
||||
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
|
||||
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
||||
|
||||
let
|
||||
-- Prevent infinite loops
|
||||
noTokenAuth :: AuthDNF -> AuthDNF
|
||||
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
||||
|
||||
authorityVal <- do
|
||||
dnf <- either throwM return $ routeAuthTags route
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite
|
||||
guardExceptT (is _Authorized authorityVal) authorityVal
|
||||
|
||||
whenIsJust tokenAddAuth $ \addDNF -> do
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
|
||||
$logDebugS "validateToken" $ tshow addDNF
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
|
||||
guardExceptT (is _Authorized additionalVal) additionalVal
|
||||
|
||||
return Authorized
|
||||
@ -2108,6 +2119,14 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuSubmissionNew
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
|
||||
[ MenuItem
|
||||
@ -2409,7 +2428,9 @@ routeNormalizers =
|
||||
-- How to run database actions.
|
||||
instance YesodPersist UniWorX where
|
||||
type YesodPersistBackend UniWorX = SqlBackend
|
||||
runDB action = runSqlPool action =<< appConnPool <$> getYesod
|
||||
runDB action = do
|
||||
$logDebugS "YesodPersist" "runDB"
|
||||
runSqlPool action =<< appConnPool <$> getYesod
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
|
||||
|
||||
@ -191,12 +191,10 @@ postAdminTestR = do
|
||||
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
||||
return (intRes, toWidget csrf >> fvInput intView)
|
||||
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
||||
deleteCell :: ListLength -- ^ Current shape
|
||||
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
||||
deleteCell l pos
|
||||
| l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
||||
| otherwise = return Map.empty
|
||||
deleteCell = miDeleteList
|
||||
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
||||
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
||||
|
||||
@ -686,14 +686,14 @@ instance FromJSON (InvitationDBData Lecturer) where
|
||||
|
||||
instance ToJSON (InvitationTokenData Lecturer) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData Lecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
lecturerInvitationConfig :: InvitationConfig Lecturer
|
||||
lecturerInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
@ -802,7 +802,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: ListLength -- ^ Current shape
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
|
||||
@ -712,7 +712,7 @@ correctorForm shid = wFormToAForm $ do
|
||||
return (res, $(widgetFile "sheetCorrectors/cell"))
|
||||
|
||||
|
||||
miDelete :: ListLength
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId)
|
||||
-> ListPosition
|
||||
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
@ -821,14 +821,14 @@ instance FromJSON (InvitationDBData SheetCorrector) where
|
||||
|
||||
instance ToJSON (InvitationTokenData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
correctorInvitationConfig :: InvitationConfig SheetCorrector
|
||||
correctorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Sheet{..} _ = do
|
||||
invitationRoute (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
|
||||
invitationResolveFor = do
|
||||
|
||||
@ -1,15 +1,21 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Submission where
|
||||
|
||||
import Import
|
||||
|
||||
import Jobs
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Network.Mime
|
||||
|
||||
@ -22,9 +28,6 @@ import Data.Maybe (fromJust)
|
||||
-- import qualified Data.Maybe
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
|
||||
|
||||
@ -33,12 +36,16 @@ import qualified Data.Conduit.List as Conduit
|
||||
|
||||
-- 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 Data.Bifunctor
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
-- import Colonnade hiding (bool, fromMaybe)
|
||||
-- import qualified Yesod.Colonnade as Yesod
|
||||
-- import qualified Text.Blaze.Html5.Attributes as HA
|
||||
@ -48,30 +55,203 @@ import System.FilePath
|
||||
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
|
||||
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
|
||||
let
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload -> pure Nothing
|
||||
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> fileUploadForm
|
||||
<*> ( (:|)
|
||||
-- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
|
||||
<$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
| g <- [2..(fromIntegral groupNr)]
|
||||
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
||||
])
|
||||
)
|
||||
where
|
||||
(groupNr, editableBuddies)
|
||||
| Arbitrary{..} <- grouping = (maxParticipants, True)
|
||||
| RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
|
||||
| otherwise = (0, False)
|
||||
instance IsInvitableJunction SubmissionUser where
|
||||
type InvitationFor SubmissionUser = Submission
|
||||
data InvitableJunction SubmissionUser = JunctionSubmissionUser
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData SubmissionUser = InvDBDataSubmissionUser
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
||||
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
|
||||
_InvitableJunction = iso
|
||||
(\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser))
|
||||
(\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..})
|
||||
|
||||
instance ToJSON (InvitableJunction SubmissionUser) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction SubmissionUser) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData SubmissionUser) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData SubmissionUser) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToJSON (InvitationTokenData SubmissionUser) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData SubmissionUser) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
submissionUserInvitationConfig :: InvitationConfig SubmissionUser
|
||||
submissionUserInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity subId Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
cID <- encrypt subId
|
||||
return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
|
||||
subId <- decrypt cID
|
||||
bool notFound (return subId) =<< existsKey subId
|
||||
invitationSubject Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
|
||||
invitationTokenConfig Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
|
||||
let itExpiresAt = Nothing
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ = pure JunctionSubmissionUser
|
||||
invitationSuccessMsg Submission{..} _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
|
||||
invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
cID <- encrypt submissionUserSubmission
|
||||
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
|
||||
|
||||
|
||||
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
|
||||
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
|
||||
<$> fileUploadForm
|
||||
<*> wFormToAForm submittorsForm
|
||||
where
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload
|
||||
-> pure Nothing
|
||||
(Upload unpackZips)
|
||||
-> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
|
||||
miCell' :: Markup -> Either UserEmail UserId -> Widget
|
||||
miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
|
||||
miCell' csrf (Right uid) = do
|
||||
User{..} <- liftHandlerT . runDB $ getJust uid
|
||||
$(widgetFile "widgets/massinput/submissionUsers/cellKnown")
|
||||
|
||||
miLayout :: ListLength
|
||||
-> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state
|
||||
-> Map ListPosition Widget -- ^ Cell widgets
|
||||
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
||||
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "submittors"
|
||||
|
||||
courseUsers :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do
|
||||
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return user
|
||||
|
||||
addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Bool -> Field m (Set (Either UserEmail UserId))
|
||||
addField isAdmin = multiUserField True $ courseUsers <$ guard isAdmin
|
||||
|
||||
addFieldSettings, submittorSettings :: FieldSettings UniWorX
|
||||
addFieldSettings = fslI MsgSubmissionMembers
|
||||
submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip
|
||||
|
||||
miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
|
||||
|
||||
submittorsForm
|
||||
| isLecturer = do-- Form is being used by lecturer; allow Everything™
|
||||
let
|
||||
miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
||||
miAdd nudge btn csrf = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
(addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing
|
||||
let addRes' = addRes <&> \newData oldData -> if
|
||||
| existing <- newData `Set.intersection` Set.fromList oldData
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgSubmissionUserAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess $ Set.toList newData
|
||||
return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
|
||||
|
||||
mRoute <- getCurrentRoute
|
||||
submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers)
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return $ submittors >>= \submittors' -> if
|
||||
| null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
|
||||
| otherwise -> FormSuccess $ Set.fromList submittors'
|
||||
| otherwise = do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
mRoute <- getCurrentRoute
|
||||
|
||||
let
|
||||
maxSize
|
||||
| Arbitrary{..} <- grouping = Just maxParticipants
|
||||
| otherwise = Nothing
|
||||
mayEdit = is _Arbitrary grouping
|
||||
|
||||
miAdd :: ListPosition
|
||||
-> Natural
|
||||
-> (Text -> Text)
|
||||
-> FieldView UniWorX
|
||||
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ nudge btn = Just $ \csrf -> do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
(addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing
|
||||
let addRes' = addRes <&> \newData oldData -> if
|
||||
| existing <- newData `Set.intersection` setOf folded oldData
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgSubmissionUserAlreadyAdded]
|
||||
| otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData
|
||||
in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData
|
||||
return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
|
||||
|
||||
miCell :: ListPosition
|
||||
-> Either UserEmail UserId
|
||||
-> Maybe ()
|
||||
-> (Text -> Text)
|
||||
-> Form ()
|
||||
miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat)
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId)
|
||||
-> ListPosition
|
||||
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
||||
miDelete dat delPos = do
|
||||
guard mayEdit
|
||||
guard $ Map.size dat > 1
|
||||
|
||||
-- User may drop from submission only if it already exists; no directly creating submissions for other people
|
||||
guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid
|
||||
|
||||
miDeleteList dat delPos
|
||||
|
||||
miAllowAdd :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Bool
|
||||
miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize
|
||||
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction = miButtonAction' mRoute
|
||||
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
|
||||
postProcess = setOf $ folded . _1
|
||||
fmap postProcess <$> massInputW MassInput{..} submittorSettings True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers)
|
||||
|
||||
|
||||
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionNewR = postSubmissionNewR
|
||||
@ -100,13 +280,14 @@ getSubmissionOwnR tid ssh csh shn = do
|
||||
|
||||
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
|
||||
submissionHelper tid ssh csh shn mcid = do
|
||||
(Entity uid userData) <- requireAuth
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
|
||||
Just actionUrl <- getCurrentRoute
|
||||
|
||||
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
||||
(Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do
|
||||
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
|
||||
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
||||
case msmid of
|
||||
Nothing -> do
|
||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -132,8 +313,8 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return $ user E.^. UserEmail
|
||||
return (csheet, map E.unValue buddies, [])
|
||||
return $ user E.^. UserId
|
||||
return (csheet, Set.fromList $ map (Right . E.unValue) buddies, [], maySubmit, isLecturer, not isLecturer)
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI Info MsgSubmissionAlreadyExists
|
||||
@ -146,15 +327,18 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
invalidArgsI [MsgSubmissionWrongSheet]
|
||||
-- fetch buddies from current submission
|
||||
(Any isOwner, buddies) <- do
|
||||
submitters <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return (user E.^. UserId, user E.^. UserEmail)
|
||||
let breakUserFromBuddies (E.Value userID, E.Value email)
|
||||
| uid == userID = (Any True , [])
|
||||
| otherwise = (Any False, [email])
|
||||
return $ foldMap breakUserFromBuddies submitters
|
||||
return $ user E.^. UserId
|
||||
let breakUserFromBuddies (E.Value userID)
|
||||
| uid == userID = (Any True , mempty )
|
||||
| otherwise = (mempty , Set.singleton $ Right userID)
|
||||
|
||||
invites <- sourceInvitationsList smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
|
||||
|
||||
return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
|
||||
|
||||
lastEdits <- do
|
||||
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
||||
@ -167,38 +351,38 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
else E.nothing
|
||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
return (csheet,buddies,lastEdits)
|
||||
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
|
||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
|
||||
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
|
||||
let formWidget = wrapForm formWidget' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
|
||||
mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
|
||||
res' <- case res of
|
||||
FormMissing -> return FormMissing
|
||||
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
||||
-- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students)
|
||||
(FormSuccess (mFiles,_submitter:|[])) -> return $ FormSuccess (mFiles,[]) -- Type change
|
||||
(FormSuccess (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members
|
||||
| Arbitrary{..} <- sheetGrouping -> do
|
||||
(FormSuccess res'@(_, groupMembers))
|
||||
| Set.null groupMembers -> return $ FormSuccess res'
|
||||
| Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
|
||||
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
|
||||
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
|
||||
let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
|
||||
prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
|
||||
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
||||
participants <- fmap prep . E.select . E.from $ \user -> do
|
||||
E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
|
||||
E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds
|
||||
let
|
||||
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
|
||||
isParticipant = E.exists . E.from $ \courseParticipant -> do
|
||||
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
|
||||
return $ E.countRows E.>. E.val (0 :: Int64)
|
||||
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||
hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
||||
case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
|
||||
Nothing -> return ()
|
||||
Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
|
||||
return $ E.countRows E.>. E.val (0 :: Int64)
|
||||
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
|
||||
|
||||
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
|
||||
@ -207,22 +391,22 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
let
|
||||
failmsgs = (concat :: [[Text]] -> [Text])
|
||||
[ flip Map.foldMapWithKey participants $ \email -> \case
|
||||
Nothing -> pure . mr $ MsgEMailUnknown email
|
||||
-- Nothing -> pure . mr $ MsgEMailUnknown email
|
||||
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
|
||||
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
|
||||
_other -> mempty
|
||||
, case fromIntegral (length participants) `compare` maxParticipants of
|
||||
, case fromIntegral (Map.size participants) `compare` maxParticipants of
|
||||
LT -> mempty
|
||||
_ -> pure $ mr MsgTooManyParticipants
|
||||
]
|
||||
return $ if null failmsgs
|
||||
then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
|
||||
then FormSuccess res'
|
||||
else FormFailure failmsgs
|
||||
| otherwise -> return $ FormFailure ["Mismatching number of group participants"]
|
||||
|
||||
|
||||
case res' of
|
||||
(FormSuccess (mFiles, setFromList -> adhocIds)) -> do
|
||||
(FormSuccess (mFiles, adhocMembers)) -> do
|
||||
smid <- do
|
||||
smid <- case (mFiles, msmid) of
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
@ -238,19 +422,24 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
, submissionRatingAssigned = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
||||
let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
|
||||
-- remove obsolete old entries
|
||||
deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
|
||||
-- maybe add current users
|
||||
forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
|
||||
subUsers <- if
|
||||
| isLecturer -> return adhocMembers
|
||||
| otherwise -> do
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
||||
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
||||
return $ groupUids `Set.union` adhocMembers
|
||||
let (subEmails, subUids) = partitionEithers $ Set.toList subUsers
|
||||
|
||||
deleteWhere [SubmissionUserSubmission ==. smid]
|
||||
deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails]
|
||||
insertMany_ $ map (flip SubmissionUser smid) subUids
|
||||
sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails
|
||||
return smid
|
||||
cID <- encrypt smid
|
||||
return $ Just cID
|
||||
@ -327,6 +516,10 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
|
||||
$(widgetFile "submission")
|
||||
|
||||
getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getSInviteR = postSInviteR
|
||||
postSInviteR = invitationR submissionUserInvitationConfig
|
||||
|
||||
|
||||
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
|
||||
|
||||
@ -227,14 +227,14 @@ instance FromJSON (InvitationDBData Tutor) where
|
||||
|
||||
instance ToJSON (InvitationTokenData Tutor) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData Tutor) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
tutorInvitationConfig :: InvitationConfig Tutor
|
||||
tutorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Tutorial{..} _ = do
|
||||
invitationRoute (Entity _ Tutorial{..}) _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
|
||||
invitationResolveFor = do
|
||||
|
||||
@ -162,7 +162,7 @@ commR CommunicationRoute{..} = do
|
||||
hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
|
||||
categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
|
||||
$(widgetFile "widgets/communication/recipientLayout")
|
||||
miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
|
||||
miDelete :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
|
||||
-- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
|
||||
miDelete _ _ = mzero
|
||||
miIdent :: Text
|
||||
|
||||
@ -8,7 +8,7 @@ module Handler.Utils.Form.MassInput
|
||||
, module Handler.Utils.Form.MassInput.Liveliness
|
||||
, massInputA, massInputW
|
||||
, massInputList
|
||||
, massInputAccum, massInputAccumA
|
||||
, massInputAccum, massInputAccumA, massInputAccumW
|
||||
, ListLength(..), ListPosition(..), miDeleteList
|
||||
, EnumLiveliness(..), EnumPosition(..)
|
||||
, MapLiveliness(..)
|
||||
@ -144,10 +144,11 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
|
||||
|
||||
|
||||
|
||||
miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
|
||||
miDeleteList l pos
|
||||
miDeleteList :: Applicative m => Map ListPosition a -> ListPosition -> m (Map ListPosition ListPosition)
|
||||
miDeleteList dat pos
|
||||
-- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
||||
| l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
|
||||
| Just l <- preview liveCoords $ Map.keysSet dat :: Maybe ListLength
|
||||
, l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
|
||||
| otherwise = pure Map.empty
|
||||
|
||||
data ButtonMassInput coord
|
||||
@ -245,7 +246,7 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i =>
|
||||
-> Maybe cellResult -- Initial result from Argument to @massInput@
|
||||
-> (Text -> Text) -- Nudge deterministic field ids
|
||||
-> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell
|
||||
, miDelete :: liveliness
|
||||
, miDelete :: Map (BoxCoord liveliness) cellData
|
||||
-> BoxCoord liveliness
|
||||
-> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
|
||||
, miAllowAdd :: BoxCoord liveliness
|
||||
@ -349,13 +350,12 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
addedShape <- if
|
||||
| Just s <- addShape -> return s
|
||||
| otherwise -> return sentShape'
|
||||
addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness
|
||||
|
||||
let
|
||||
delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
|
||||
delForm miCoord = do
|
||||
(delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
|
||||
shapeUpdate <- miDelete addedLiveliness miCoord
|
||||
shapeUpdate <- miDelete addedShape miCoord
|
||||
guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
|
||||
return (shapeUpdate <$ assertM (is _Just) delRes, delView)
|
||||
|
||||
@ -545,6 +545,24 @@ massInputAccumA :: forall handler cellData ident.
|
||||
massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
|
||||
= formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
|
||||
|
||||
massInputAccumW :: forall handler cellData ident.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, MonadLogger handler
|
||||
, ToJSON cellData, FromJSON cellData
|
||||
, PathPiece ident
|
||||
)
|
||||
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
|
||||
-> (cellData -> Widget)
|
||||
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
||||
-> MassInputLayout ListLength cellData ()
|
||||
-> ident
|
||||
-> FieldSettings UniWorX
|
||||
-> Bool
|
||||
-> Maybe [cellData]
|
||||
-> WForm handler (FormResult [cellData])
|
||||
massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
|
||||
= mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
|
||||
|
||||
|
||||
massInputA :: forall handler cellData cellResult liveliness.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
|
||||
@ -113,7 +113,7 @@ invRef = toJSON . InvRef @junction
|
||||
--
|
||||
-- It is advisable to define this once per `junction` in a global constant
|
||||
data InvitationConfig junction = InvitationConfig
|
||||
{ invitationRoute :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
|
||||
{ invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
|
||||
-- ^ Which route calls `invitationR` for this kind of invitation?
|
||||
, invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction))
|
||||
-- ^ Monadically resolve `InvitationFor` during `inviteR`
|
||||
@ -200,7 +200,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
|
||||
fRec <- get404 fid
|
||||
|
||||
jInviter <- liftHandlerT requireAuthId
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute fRec dat
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat
|
||||
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
|
||||
@ -27,8 +27,8 @@ requireBearerToken = liftHandlerT $ do
|
||||
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
|
||||
return token
|
||||
|
||||
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a)
|
||||
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a)
|
||||
currentTokenRestrictions = runMaybeT $ do
|
||||
token <- MaybeT maybeBearerToken
|
||||
token <- requireBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ preview (_tokenRestrictionIx route) token
|
||||
|
||||
@ -49,7 +49,7 @@ import GHC.Generics as Import (Generic)
|
||||
import GHC.Exts as Import (IsList)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..))
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
|
||||
@ -557,7 +557,7 @@ derivePersistField "Theme"
|
||||
|
||||
|
||||
newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
|
||||
deriving (Show, Read, Eq)
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
|
||||
instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
|
||||
fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
|
||||
@ -832,8 +832,7 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
|
||||
instance Hashable a => Hashable (PredLiteral a)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, sumEncoding = ObjectWithSingleField
|
||||
, unwrapUnaryRecords = True
|
||||
, sumEncoding = TaggedObject "val" "var"
|
||||
} ''PredLiteral
|
||||
|
||||
instance PathPiece a => PathPiece (PredLiteral a) where
|
||||
|
||||
@ -77,6 +77,8 @@ import Network.Wai (requestMethod)
|
||||
|
||||
import Data.Time.Clock
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
|
||||
{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
|
||||
|
||||
|
||||
@ -382,6 +384,9 @@ partitionWith f (x:xs) = case f x of
|
||||
Right c -> (bs, c:cs)
|
||||
where (bs,cs) = partitionWith f xs
|
||||
|
||||
nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
|
||||
nonEmpty' = maybe empty pure . nonEmpty
|
||||
|
||||
----------
|
||||
-- Sets --
|
||||
----------
|
||||
@ -391,7 +396,8 @@ setIntersections :: Ord a => [Set a] -> Set a
|
||||
setIntersections [] = Set.empty
|
||||
setIntersections (h:t) = foldl' Set.intersection h t
|
||||
|
||||
|
||||
setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
|
||||
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
|
||||
@ -630,6 +630,10 @@ aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
|
||||
((a, vs), ints, enctype) <- lift f
|
||||
writer ((a, ints, enctype), vs)
|
||||
|
||||
infixl 4 `fmapAForm`
|
||||
|
||||
fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
|
||||
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints
|
||||
|
||||
---------------------------------------------
|
||||
-- Special variants of @mopt@, @mreq@, ... --
|
||||
|
||||
@ -27,6 +27,9 @@ _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l
|
||||
_InnerJoinRight :: Lens' (E.InnerJoin l r) r
|
||||
_InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
|
||||
|
||||
_nullable :: MonoFoldable mono => Prism' mono (NonNull mono)
|
||||
_nullable = prism' toNullable fromNullable
|
||||
|
||||
|
||||
-----------------------------------
|
||||
-- Lens Definitions for our Types
|
||||
@ -80,6 +83,8 @@ makeLenses_ ''SheetGrading
|
||||
|
||||
makeLenses_ ''SheetType
|
||||
|
||||
makePrisms ''SheetGroup
|
||||
|
||||
makePrisms ''AuthResult
|
||||
|
||||
makePrisms ''FormResult
|
||||
@ -112,6 +117,8 @@ makePrisms ''OccurenceException
|
||||
|
||||
makeLenses_ ''Occurences
|
||||
|
||||
makeLenses_ ''PredDNF
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
@ -116,12 +116,14 @@
|
||||
var requestBody = serializeForm(submitButton, enctype);
|
||||
|
||||
if (requestFn && requestBody) {
|
||||
var headers = {'Mass-Input-Shortcircuit': massInputId};
|
||||
|
||||
if (enctype !== 'multipart/form-data')
|
||||
headers['Content-Type'] = enctype;
|
||||
|
||||
requestFn(
|
||||
url,
|
||||
{
|
||||
'Content-Type': enctype,
|
||||
'Mass-Input-Shortcircuit': massInputId,
|
||||
},
|
||||
headers,
|
||||
requestBody,
|
||||
).then(function(response) {
|
||||
return response.text();
|
||||
|
||||
@ -22,7 +22,9 @@ $maybe cID <- mcid
|
||||
$nothing
|
||||
<li>#{display time}
|
||||
|
||||
|
||||
$if maySubmit
|
||||
<section>
|
||||
^{formWidget}
|
||||
$if maySubmit
|
||||
<section>
|
||||
<h2>_{MsgSubmissionReplace}
|
||||
^{formWidget}
|
||||
$nothing
|
||||
^{formWidget}
|
||||
|
||||
6
templates/widgets/massinput/submissionUsers/add.hamlet
Normal file
6
templates/widgets/massinput/submissionUsers/add.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
#{csrf}
|
||||
^{fvInput addView}
|
||||
<td>
|
||||
^{fvInput btn}
|
||||
@ -0,0 +1,10 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
<span style="font-family: monospace">
|
||||
#{email}
|
||||
<td>
|
||||
<div .tooltip>
|
||||
<div .tooltip__handle>
|
||||
<div .tooltip__content>
|
||||
_{MsgEmailInvitationWarning}
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
#{csrf}
|
||||
^{nameEmailWidget userEmail userDisplayName userSurname}
|
||||
13
templates/widgets/massinput/submissionUsers/layout.hamlet
Normal file
13
templates/widgets/massinput/submissionUsers/layout.hamlet
Normal file
@ -0,0 +1,13 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
$maybe delButton <- delButtons !? coord
|
||||
^{fvInput delButton}
|
||||
$maybe addWdgt <- addWdgts !? (0, 0)
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
^{addWdgt}
|
||||
58
test/FoundationSpec.hs
Normal file
58
test/FoundationSpec.hs
Normal file
@ -0,0 +1,58 @@
|
||||
module FoundationSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import ModelSpec ()
|
||||
|
||||
import qualified Data.CryptoID as CID
|
||||
import Yesod.EmbeddedStatic
|
||||
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
|
||||
instance Arbitrary (Route Auth) where
|
||||
arbitrary = oneof
|
||||
[ return CheckR
|
||||
, return LoginR
|
||||
, return LogoutR
|
||||
, PluginR <$> arbitrary <*> arbitrary
|
||||
]
|
||||
|
||||
instance Arbitrary (Route EmbeddedStatic) where
|
||||
arbitrary = embeddedResourceR <$> arbitrary <*> arbitrary
|
||||
|
||||
instance Arbitrary CourseR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SheetR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SubmissionR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary MaterialR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary TutorialR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (Route UniWorX) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary a => Arbitrary (CID.CryptoID ns a) where
|
||||
arbitrary = CID.CryptoID <$> arbitrary
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
parallel $
|
||||
lawsCheckHspec (Proxy @(Route UniWorX))
|
||||
[ eqLaws, hashableLaws, jsonLaws, jsonKeyLaws, pathPieceLaws ]
|
||||
@ -148,6 +148,10 @@ instance Arbitrary AuthenticationMode where
|
||||
instance Arbitrary LecturerType where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary a => Arbitrary (ZIPArchiveName a) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
|
||||
spec :: Spec
|
||||
@ -211,6 +215,8 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @LecturerType)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text)))
|
||||
[ eqLaws, ordLaws, showReadLaws, pathPieceLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
|
||||
17
test/Test/QuickCheck/Classes/Binary.hs
Normal file
17
test/Test/QuickCheck/Classes/Binary.hs
Normal file
@ -0,0 +1,17 @@
|
||||
module Test.QuickCheck.Classes.Binary
|
||||
( binaryLaws
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Classes
|
||||
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Binary
|
||||
import Data.Binary.Put
|
||||
|
||||
binaryLaws :: forall a. (Arbitrary a, Binary a, Eq a, Show a) => Proxy a -> Laws
|
||||
binaryLaws _ = Laws "Binary"
|
||||
[ ("Partial Isomorphism", property $ \(a :: a) -> decode (encode a) == Just a)
|
||||
, ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as))
|
||||
]
|
||||
@ -26,6 +26,7 @@ import Test.QuickCheck.Classes.Hashable as X
|
||||
import Test.QuickCheck.Classes.JSON as X
|
||||
import Test.QuickCheck.Classes.HttpApiData as X
|
||||
import Test.QuickCheck.Classes.Universe as X
|
||||
import Test.QuickCheck.Classes.Binary as X
|
||||
import Data.Proxy as X
|
||||
import Data.UUID as X (UUID)
|
||||
import System.IO as X (hPrint, hPutStrLn, stderr)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user