Merge branch 'version-bumps' into 'master'
Version bumps to GHC 8.10.x See merge request uni2work/uni2work!20
This commit is contained in:
Gregor Kleen
commit
a0412b073b
@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral
|
||||
|
||||
|
||||
instance PathPiece DiffTime where
|
||||
toPathPiece = toPathPiece . MkFixed @E12 . diffTimeToPicoseconds
|
||||
toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds
|
||||
fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps
|
||||
|
||||
|
||||
|
||||
@ -253,7 +253,7 @@ executables:
|
||||
uniworx:
|
||||
main: main.hs
|
||||
source-dirs: app
|
||||
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T"
|
||||
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
dependencies:
|
||||
- uniworx
|
||||
when:
|
||||
@ -278,7 +278,7 @@ executables:
|
||||
ghc-options:
|
||||
- -main-is Load
|
||||
- -threaded
|
||||
- -rtsopts "-with-rtsopts=-N -T"
|
||||
- -rtsopts "-with-rtsopts=-N -T -xn"
|
||||
source-dirs: load
|
||||
dependencies:
|
||||
- uniworx
|
||||
@ -313,8 +313,7 @@ tests:
|
||||
ghc-options:
|
||||
- -fno-warn-orphans
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
- -rtsopts "-with-rtsopts=-N -xn"
|
||||
hlint:
|
||||
main: Hlint.hs
|
||||
other-modules: []
|
||||
|
||||
@ -101,6 +101,8 @@ import qualified Network.Minio as Minio
|
||||
|
||||
import Web.ServerSession.Core (StorageException(..))
|
||||
|
||||
import GHC.RTS.Flags (getRTSFlags)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
import Handler.News
|
||||
@ -200,6 +202,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
runAppLoggingT tempFoundation $ do
|
||||
$logInfoS "InstanceID" $ UUID.toText appInstanceID
|
||||
$logDebugS "Configuration" $ tshow appSettings'
|
||||
$logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
|
||||
|
||||
smtpPool <- for appSmtpConf $ \c -> do
|
||||
$logDebugS "setup" "SMTP-Pool"
|
||||
|
||||
@ -77,8 +77,8 @@ instance ToWidget site a => ToWidget site (CI a) where
|
||||
instance RenderMessage site a => RenderMessage site (CI a) where
|
||||
renderMessage f ls msg = renderMessage f ls $ CI.original msg
|
||||
|
||||
instance Lift t => Lift (CI t) where
|
||||
lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
|
||||
instance (CI.FoldCase t, Lift t) => Lift (CI t) where
|
||||
liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||]
|
||||
|
||||
|
||||
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
||||
|
||||
@ -46,7 +46,7 @@ sqlInTuple arity = do
|
||||
xsV <- newName "xs"
|
||||
|
||||
let
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs)
|
||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
|
||||
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
||||
|
||||
instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
||||
|
||||
@ -24,7 +24,7 @@ persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
|
||||
persistDirectoryWith settings dir = do
|
||||
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
|
||||
fn <- MaybeT . return . fromNullable $ takeFileName fp
|
||||
guard . not $ head fn == '.'
|
||||
guard $ head fn /= '.'
|
||||
guard . not $ head fn == '#' && last fn == '#'
|
||||
|
||||
lift $ do
|
||||
|
||||
@ -15,7 +15,8 @@ import Foundation.Routes as Foundation
|
||||
|
||||
|
||||
import Import.NoFoundation hiding (embedFile)
|
||||
import Database.Persist.Sql (runSqlPool)
|
||||
import Database.Persist.Sql
|
||||
( runSqlPool, transactionUndo, SqlReadBackend(..) )
|
||||
import Text.Hamlet (hamletFile)
|
||||
|
||||
import Yesod.Auth.Message
|
||||
@ -106,7 +107,6 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
||||
import Web.Cookie
|
||||
|
||||
import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild))
|
||||
import Database.Persist.Sql (transactionUndo, SqlReadBackend(..))
|
||||
|
||||
import qualified Control.Retry as Retry
|
||||
import GHC.IO.Exception (IOErrorType(OtherError))
|
||||
@ -651,7 +651,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
|
||||
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
Submission{..} <- MaybeT . lift $ get sid
|
||||
guard $ maybe False (== authId) submissionRatingBy
|
||||
guard $ Just authId == submissionRatingBy
|
||||
return Authorized
|
||||
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -746,20 +746,6 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
||||
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
||||
|
||||
case allocation of
|
||||
Nothing -> return ()
|
||||
Just Allocation{..} -> do
|
||||
cTime <- liftIO getCurrentTime
|
||||
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
|
||||
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
|
||||
|
||||
return Authorized
|
||||
|
||||
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
|
||||
@ -783,7 +769,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
-> guard $ visible
|
||||
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
||||
ERegisterOccR occn -> do
|
||||
occId <- (>>= hoistMaybe) . $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
||||
occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
||||
if
|
||||
| (registration >>= examRegistrationOccurrence . entityVal) == Just occId
|
||||
-> guard $ visible
|
||||
@ -920,7 +906,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= cTime
|
||||
&& NTop systemMessageTo >= cTime
|
||||
return Authorized
|
||||
@ -928,7 +914,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= cTime
|
||||
&& NTop systemMessageTo >= cTime
|
||||
return Authorized
|
||||
@ -936,7 +922,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
|
||||
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
guard $ NTop courseNewsVisibleFrom <= cTime
|
||||
return Authorized
|
||||
|
||||
@ -1247,7 +1233,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
when onlyActive $
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
-- participant has at least one submission
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
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 $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
@ -1257,7 +1243,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is member of a submissionGroup
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
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 $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
||||
@ -1274,7 +1260,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is a tutorial user
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
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 $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
@ -1306,7 +1292,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant has an exam result for this course
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
|
||||
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
@ -1315,7 +1301,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is registered for an exam for this course
|
||||
when (not onlyActive) $
|
||||
unless onlyActive $
|
||||
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
@ -1323,8 +1309,6 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
|
||||
return ()
|
||||
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
|
||||
uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
@ -1666,8 +1650,8 @@ wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
|
||||
=> [(AuthTag, Bool)] -- ^ Assumptions
|
||||
-> Route UniWorX
|
||||
-> m Bool
|
||||
wouldHaveReadAccessToIff assumptions route = and2M (fmap not $ hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
|
||||
wouldHaveWriteAccessToIff assumptions route = and2M (fmap not $ hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route
|
||||
wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
|
||||
wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route
|
||||
|
||||
-- | Conditional redirect that hides the URL if the user is not authorized for the route
|
||||
redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
|
||||
@ -1728,10 +1712,10 @@ instance Yesod UniWorX where
|
||||
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
@ -1764,7 +1748,7 @@ instance Yesod UniWorX where
|
||||
notForBearer' (SessionBackend load)
|
||||
= let load' req
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just) $ map W.extractBearerAuth aHdrs
|
||||
, any (is _Just . W.extractBearerAuth) aHdrs
|
||||
= return (mempty, const $ return [])
|
||||
| otherwise
|
||||
= load req
|
||||
@ -1993,7 +1977,7 @@ updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
updateFavourites cData = void . runMaybeT $ do
|
||||
$logDebugS "updateFavourites" "Updating favourites"
|
||||
|
||||
now <- liftIO $ getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- MaybeT $ liftHandler maybeAuthId
|
||||
mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
User{userMaxFavourites} <- MaybeT $ get uid
|
||||
@ -2207,7 +2191,7 @@ siteLayout' headingOverride widget = do
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
in $(widgetFile "widgets/navbar/item")
|
||||
NavPageActionPrimary{ navLink = navLink@NavLink{..}, .. }
|
||||
NavPageActionPrimary{ navLink = navLink@NavLink{..} }
|
||||
-> let pWidget
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
@ -2226,7 +2210,7 @@ siteLayout' headingOverride widget = do
|
||||
sWidgets = navChildren'
|
||||
& map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
|
||||
in $(widgetFile "widgets/pageaction/primary-wrapper")
|
||||
NavPageActionSecondary{ navLink = navLink@NavLink{..}, .. }
|
||||
NavPageActionSecondary{ navLink = navLink@NavLink{..} }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
@ -2514,7 +2498,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
|
||||
mr <- getMessageRender
|
||||
Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
|
||||
ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
|
||||
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
|
||||
cid <- decrypt cID
|
||||
@ -3692,14 +3676,13 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return
|
||||
case muid of
|
||||
Nothing -> return False
|
||||
(Just uid) -> do
|
||||
ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
||||
runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return ok
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = navQuick NavQuickViewPageActionSecondary
|
||||
, navForceActive = False
|
||||
@ -4513,19 +4496,19 @@ pageHeading UsersR
|
||||
= Just $ i18nHeading MsgUsers
|
||||
pageHeading (AdminUserR _)
|
||||
= Just $ i18nHeading MsgAdminUserHeading
|
||||
pageHeading (AdminTestR)
|
||||
= Just $ [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading (AdminErrMsgR)
|
||||
pageHeading AdminTestR
|
||||
= Just [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading AdminErrMsgR
|
||||
= Just $ i18nHeading MsgErrMsgHeading
|
||||
|
||||
pageHeading (InfoR)
|
||||
pageHeading InfoR
|
||||
= Just $ i18nHeading MsgInfoHeading
|
||||
pageHeading (LegalR)
|
||||
pageHeading LegalR
|
||||
= Just $ i18nHeading MsgLegalHeading
|
||||
pageHeading (VersionR)
|
||||
pageHeading VersionR
|
||||
= Just $ i18nHeading MsgVersionHeading
|
||||
|
||||
pageHeading (HelpR)
|
||||
pageHeading HelpR
|
||||
= Just $ i18nHeading MsgHelpRequest
|
||||
|
||||
pageHeading ProfileR
|
||||
@ -4548,8 +4531,8 @@ pageHeading (TermSchoolCourseListR tid ssh)
|
||||
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
|
||||
i18nHeading $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading (CourseListR)
|
||||
= Just $ i18nHeading $ MsgCourseListTitle
|
||||
pageHeading CourseListR
|
||||
= Just $ i18nHeading MsgCourseListTitle
|
||||
pageHeading CourseNewR
|
||||
= Just $ i18nHeading MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
@ -4661,25 +4644,25 @@ routeNormalizers =
|
||||
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
|
||||
ncSheet = maybeOrig $ \route -> do
|
||||
CSheetR tid ssh csh shn _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
|
||||
caseChanged shn sheetName
|
||||
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
|
||||
ncMaterial = maybeOrig $ \route -> do
|
||||
CMaterialR tid ssh csh mnm _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
|
||||
caseChanged mnm materialName
|
||||
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
|
||||
ncTutorial = maybeOrig $ \route -> do
|
||||
CTutorialR tid ssh csh tutn _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
|
||||
caseChanged tutn tutorialName
|
||||
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
|
||||
ncExam = maybeOrig $ \route -> do
|
||||
CExamR tid ssh csh examn _ <- return route
|
||||
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
|
||||
caseChanged examn examName
|
||||
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
|
||||
@ -4748,7 +4731,7 @@ runSqlPoolRetry action pool = do
|
||||
runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
|
||||
runDBRead action = do
|
||||
$logDebugS "YesodPersist" "runDBRead"
|
||||
runSqlPoolRetry (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod
|
||||
runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist UniWorX where
|
||||
@ -4762,7 +4745,7 @@ instance YesodPersist UniWorX where
|
||||
| dryRun = action <* transactionUndo
|
||||
| otherwise = action
|
||||
|
||||
runSqlPoolRetry action' =<< appConnPool <$> getYesod
|
||||
runSqlPoolRetry action' . appConnPool =<< getYesod
|
||||
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = do
|
||||
@ -4992,7 +4975,7 @@ upsertCampusUser plugin ldapData = do
|
||||
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
||||
let matchingFeatures = case knownParents of
|
||||
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
||||
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||
if
|
||||
@ -5051,12 +5034,12 @@ upsertCampusUser plugin ldapData = do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||
oldFs <- selectKeysList
|
||||
([ StudyFeaturesUser ==. studyFeaturesUser
|
||||
[ StudyFeaturesUser ==. studyFeaturesUser
|
||||
, StudyFeaturesDegree ==. studyFeaturesDegree
|
||||
, StudyFeaturesField ==. studyFeaturesField
|
||||
, StudyFeaturesType ==. studyFeaturesType
|
||||
, StudyFeaturesSemester ==. studyFeaturesSemester
|
||||
])
|
||||
]
|
||||
[]
|
||||
case oldFs of
|
||||
[oldF] -> update oldF
|
||||
@ -5073,7 +5056,7 @@ upsertCampusUser plugin ldapData = do
|
||||
associateUserSchoolsByTerms userId
|
||||
|
||||
let
|
||||
userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSchoolAssociation
|
||||
@ -5086,7 +5069,7 @@ upsertCampusUser plugin ldapData = do
|
||||
forM_ ss $ \frag -> void . runMaybeT $ do
|
||||
let
|
||||
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
||||
infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
|
||||
infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
|
||||
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
||||
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
||||
return schoolLdap
|
||||
@ -5221,7 +5204,7 @@ instance YesodAuth UniWorX where
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||
UniWorX{..} <- getYesod
|
||||
|
||||
flip catches excHandlers $ case appLdapPool of
|
||||
Just ldapPool
|
||||
@ -5232,7 +5215,7 @@ instance YesodAuth UniWorX where
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
|
||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
|
||||
@ -47,8 +47,8 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
|
||||
modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
|
||||
|
||||
return $ TestDownloadOptions
|
||||
<$> pure randomSeed
|
||||
<*> maxSizeRes
|
||||
randomSeed
|
||||
<$> maxSizeRes
|
||||
<*> pure (2^20)
|
||||
<*> modeRes
|
||||
|
||||
|
||||
@ -64,7 +64,7 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception ApplicationFormException
|
||||
|
||||
applicationForm :: (Maybe AllocationId)
|
||||
applicationForm :: Maybe AllocationId
|
||||
-> CourseId
|
||||
-> UserId
|
||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||
@ -75,7 +75,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||
course <- getJust cid
|
||||
(fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
(fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||
@ -105,7 +105,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
|
||||
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
|
||||
(True , True , True , Nothing)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
|
||||
-> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
|
||||
(True , True , True , Just _ )
|
||||
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
|
||||
(True , True , False, _ )
|
||||
@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
|
||||
filesLinkView <- if
|
||||
| fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
-> let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
-> return Nothing
|
||||
|
||||
filesWarningView <- if
|
||||
| fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
| Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
@ -174,15 +174,15 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
in if
|
||||
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
|
||||
-> return $ (FormSuccess Nothing, Nothing)
|
||||
-> return (FormSuccess Nothing, Nothing)
|
||||
| otherwise
|
||||
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
||||
|
||||
(vetoRes, vetoView) <- if
|
||||
| afmLecturer
|
||||
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
|
||||
-> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
|
||||
| otherwise
|
||||
-> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
|
||||
-> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
|
||||
|
||||
(pointsRes, pointsView) <- if
|
||||
| afmLecturer
|
||||
@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
, courseApplicationRatingTime = guardOn rated now
|
||||
}
|
||||
|
||||
runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
|
||||
audit $ TransactionCourseApplicationEdit cid uid appId
|
||||
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
|
||||
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
|
||||
|
||||
@ -139,7 +139,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
addView' = $(widgetFile "course/lecturerMassInput/add")
|
||||
return (addRes'', addView')
|
||||
|
||||
@ -199,10 +199,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
|
||||
_allIOtherCases -> do
|
||||
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
||||
return ( Just (Just now)
|
||||
, (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
||||
return ( Just $ Just now
|
||||
, Just . toMidnight . termStart . entityVal <$> mbLastTerm
|
||||
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
|
||||
, Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
|
||||
)
|
||||
|
||||
let
|
||||
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
||||
@ -243,7 +244,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
|
||||
let
|
||||
userAdmin = not $ null adminSchools
|
||||
mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
|
||||
mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
|
||||
|
||||
allocationForm' =
|
||||
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
||||
@ -265,8 +266,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
|
||||
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
(cfCourseId =<< template)
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
||||
@ -333,7 +334,7 @@ validateCourse = do
|
||||
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
||||
$ NTop cfRegFrom <= NTop cfRegTo
|
||||
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
||||
$ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
|
||||
$ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
|
||||
unless userAdmin $
|
||||
guardValidation MsgCourseUserMustBeLecturer
|
||||
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
||||
@ -538,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
|
||||
let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
|
||||
|
||||
upsertAllocationCourse cid $ cfAllocation res
|
||||
|
||||
@ -556,7 +557,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
|
||||
upsertAllocationCourse cid cfAllocation = do
|
||||
now <- liftIO getCurrentTime
|
||||
Course{..} <- getJust cid
|
||||
Course{} <- getJust cid
|
||||
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
||||
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
||||
userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
|
||||
|
||||
@ -33,8 +33,8 @@ postCNEditR tid ssh csh cID = do
|
||||
, courseNewsSummary = cnfSummary
|
||||
, courseNewsLastEdit = now
|
||||
}
|
||||
let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ]
|
||||
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
|
||||
let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
|
||||
in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
|
||||
addMessageI Success MsgCourseNewsEdited
|
||||
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
|
||||
|
||||
|
||||
@ -92,11 +92,11 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
|
||||
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
||||
res <- act -- insertUnique
|
||||
|
||||
@ -118,7 +118,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
|
||||
when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
|
||||
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
|
||||
let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -136,7 +136,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
|]
|
||||
in void $ wforced filesLinkField (fslI filesMsg) Nothing
|
||||
|
||||
when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
|
||||
|
||||
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
@ -288,7 +288,7 @@ deregisterParticipant :: UserId -> CourseId -> DB ()
|
||||
deregisterParticipant uid cid = do
|
||||
deleteApplications uid cid
|
||||
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
|
||||
forM_ part $ \(Entity partId CourseParticipant{..}) -> do
|
||||
forM_ part $ \(Entity partId CourseParticipant{}) -> do
|
||||
update partId [CourseParticipantState =. CourseParticipantInactive False]
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
|
||||
@ -112,9 +112,8 @@ getCShowR tid ssh csh = do
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||
|
||||
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
|
||||
<$> pure alloc
|
||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
|
||||
<$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
regForm <- if
|
||||
| is _Just mbAid -> do
|
||||
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
||||
|
||||
@ -115,7 +115,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
|
||||
, formSubmit = FormAutoSubmit
|
||||
, formAnchor = Just registrationFieldFrag
|
||||
}
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
|
||||
formResult regFieldRes $ \courseParticipantField' -> do
|
||||
lift . runDB $ do
|
||||
update pId [ CourseParticipantField =. courseParticipantField' ]
|
||||
|
||||
@ -199,7 +199,7 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
|
||||
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
|
||||
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
|
||||
Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
|
||||
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points
|
||||
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
|
||||
_other -> mempty
|
||||
|
||||
|
||||
@ -404,33 +404,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ sortUserEmail queryUser
|
||||
, single $ sortUserMatriclenr queryUser
|
||||
, sortUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
, single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
E.subSelectMaybe . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||
, single ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
||||
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
||||
return . E.min_ $ tutorial E.^. TutorialName
|
||||
)
|
||||
, single $ ("exams" , SortColumn $ queryUser >>> \user ->
|
||||
, single ("exams" , SortColumn $ queryUser >>> \user ->
|
||||
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||
return . E.min_ $ exam E.^. ExamName
|
||||
)
|
||||
, single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||
, single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
||||
, mconcat
|
||||
[ single ( SortingKey $ "sheet-" <> sheetName
|
||||
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -450,28 +450,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ fltrUserMatriclenr queryUser
|
||||
, single $ fltrUserNameEmail queryUser
|
||||
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single $ ("field" , FilterColumn $ E.anyFilter
|
||||
, single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single ("field" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
||||
] )
|
||||
, single $ ("degree" , FilterColumn $ E.anyFilter
|
||||
, single ("degree" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||
] )
|
||||
, single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
, single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
||||
)
|
||||
, single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
, single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
@ -480,15 +480,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
)
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||
, single $ ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
|
||||
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
|
||||
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
)
|
||||
, single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
||||
, single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
||||
, single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
|
||||
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
|
||||
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
)
|
||||
]
|
||||
where single = uncurry Map.singleton
|
||||
dbtFilterUI mPrev = mconcat $
|
||||
@ -652,7 +652,7 @@ postCUsersR tid ssh csh = do
|
||||
hasExams = not $ null exams
|
||||
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
|
||||
examOccActs = examOccurrencesPerExam
|
||||
& (map (bimap entityKey hoistMaybe))
|
||||
& map (bimap entityKey hoistMaybe)
|
||||
& Map.fromListWith (<>)
|
||||
& imap (\k v -> case v of
|
||||
[] -> pure (k, Nothing)
|
||||
|
||||
@ -113,7 +113,7 @@ postECorrectR tid ssh csh examn = do
|
||||
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
response <- runDB . exceptT (<$ transactionUndo) return $ do
|
||||
Entity eId Exam{..} <- lift $ fetchExam tid ssh csh examn
|
||||
Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
|
||||
euid <- traverse decrypt ciqUser
|
||||
|
||||
guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $
|
||||
|
||||
@ -96,7 +96,7 @@ examForm template html = do
|
||||
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
||||
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
||||
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
||||
<*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
<* aformSection MsgExamFormParts
|
||||
@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let
|
||||
addRes'
|
||||
| otherwise
|
||||
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||
, not $ Set.null existing
|
||||
@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
|
||||
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
||||
let
|
||||
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
|
||||
| any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
|
||||
| any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
|
||||
-> FormFailure [mr MsgExamPartAlreadyExists]
|
||||
| otherwise -> FormSuccess $ pure newDat
|
||||
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
||||
@ -336,10 +336,10 @@ validateExam = do
|
||||
|
||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
|
||||
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||||
guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
|
||||
guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
|
||||
@ -81,10 +81,9 @@ mkExamTable (Entity cid Course{..}) = do
|
||||
|
||||
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamListR tid ssh csh = do
|
||||
(Entity _ Course{..}, examTable) <- runDB $ do
|
||||
examTable <- runDB $ do
|
||||
c <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
(_, examTable) <- mkExamTable c
|
||||
return (c, examTable)
|
||||
view _2 <$> mkExamTable c
|
||||
|
||||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
|
||||
|
||||
@ -36,9 +36,9 @@ instance Button UniWorX ButtonExamRegister where
|
||||
|
||||
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
postERegisterR tid ssh csh examn = do
|
||||
Entity uid User{..} <- requireAuth
|
||||
uid <- requireAuthId
|
||||
|
||||
Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
|
||||
Entity eId Exam{} <- runDB $ fetchExam tid ssh csh examn
|
||||
|
||||
((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister]
|
||||
|
||||
@ -63,11 +63,11 @@ postERegisterR tid ssh csh examn = do
|
||||
|
||||
postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html
|
||||
postERegisterOccR tid ssh csh examn occn = do
|
||||
Entity uid User{..} <- requireAuth
|
||||
(Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do
|
||||
eexam@(Entity eId _) <- fetchExam tid ssh csh examn
|
||||
occ <- getBy404 $ UniqueExamOccurrence eId occn
|
||||
return (eexam, occ)
|
||||
uid <- requireAuthId
|
||||
(eId, occId) <- runDB $ do
|
||||
Entity eId _ <- fetchExam tid ssh csh examn
|
||||
occ <- getKeyBy404 $ UniqueExamOccurrence eId occn
|
||||
return (eId, occ)
|
||||
|
||||
((btnResult, _), _) <- runFormPost buttonForm
|
||||
|
||||
|
||||
@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
sumRegisteredCount = sumOf (folded . _3) occurrences
|
||||
|
||||
noBonus = fromMaybe False $ do
|
||||
noBonus = (Just True ==) $ do
|
||||
guardM $ bonusOnlyPassed <$> examBonusRule
|
||||
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
|
||||
sumPoints = fmap getSum . mconcat $ catMaybes
|
||||
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
|
||||
@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
|
||||
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
|
||||
|
||||
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
|
||||
$(widgetFile "exam-show")
|
||||
|
||||
@ -597,7 +597,7 @@ postEUsersR tid ssh csh examn = do
|
||||
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
|
||||
when (is _Just examGradingRule) $
|
||||
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
|
||||
when (not $ null examParts) $
|
||||
unless (null examParts) $
|
||||
tell =<< optionsF [ ExamUserSetPartResult ]
|
||||
when doBonus $
|
||||
tell =<< optionsF [ ExamUserSetBonus ]
|
||||
@ -651,7 +651,7 @@ postEUsersR tid ssh csh examn = do
|
||||
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
||||
yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
|
||||
when (newFeatures /= oldFeatures) $
|
||||
@ -693,7 +693,7 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
|
||||
newResults = sequence (csvEUserExamPartResults dbCsvNew)
|
||||
<|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
|
||||
<|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
|
||||
|
||||
newBonus, oldBonus :: Maybe Points
|
||||
newBonus = join (csvEUserBonus dbCsvNew)
|
||||
|
||||
@ -75,7 +75,7 @@ queryIsSynced now office = to . runReader $ do
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
|
||||
E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
|
||||
E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
|
||||
open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed'
|
||||
open examClosed' = E.maybe E.true (E.>. E.val now) examClosed'
|
||||
return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
|
||||
|
||||
|
||||
@ -150,11 +150,9 @@ getEOExamsR = do
|
||||
|
||||
case (exam, course, externalExam) of
|
||||
(Just exam', Just course', Nothing) ->
|
||||
(,,)
|
||||
<$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Nothing, Nothing, Just externalExam') ->
|
||||
(,,)
|
||||
<$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
(Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
|
||||
_other -> return $ error "Got exam & externalExam in same result"
|
||||
|
||||
|
||||
|
||||
@ -78,7 +78,7 @@ postEOFieldsR = do
|
||||
oldFields <- runDB $ do
|
||||
fields <- E.select . E.from $ \examOfficeField -> do
|
||||
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
|
||||
return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
||||
return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
|
||||
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
|
||||
|
||||
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
|
||||
|
||||
@ -86,7 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
, sheetAutoDistribute = sfAutoDistribute
|
||||
, sheetAnonymousCorrection = sfAnonymousCorrection
|
||||
, sheetRequireExamRegistration = sfRequireExamRegistration
|
||||
, sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF
|
||||
, sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
|
||||
runConduit $
|
||||
maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
|
||||
.| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF)
|
||||
.| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF)
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
@ -127,7 +127,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
return True
|
||||
when saveOkay $
|
||||
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
||||
(FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
||||
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
||||
|
||||
@ -97,7 +97,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
||||
<*> correctorForm (maybe mempty sfCorrectors template)
|
||||
where
|
||||
makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
|
||||
makeSheetPersonalisedFilesForm template' = do
|
||||
@ -162,7 +162,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
||||
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
|
||||
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads
|
||||
|
||||
|
||||
let
|
||||
@ -173,7 +173,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
return user
|
||||
|
||||
miAdd :: ListPosition
|
||||
@ -199,7 +199,7 @@ correctorForm loads' = wFormToAForm $ do
|
||||
miCell _ userIdent initRes nudge csrf = do
|
||||
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
||||
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
let
|
||||
res :: FormResult (CorrectorState, Load)
|
||||
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
||||
|
||||
@ -69,7 +69,7 @@ getSheetListR tid ssh csh = do
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
(Just (Entity sid Submission{})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid' <- mkCid
|
||||
|
||||
@ -11,6 +11,8 @@ import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient)
|
||||
import qualified Data.Binary as Binary (encode)
|
||||
import qualified Crypto.KDF.HKDF as HKDF
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
data StorageKeyType
|
||||
= SKTExamCorrect
|
||||
|
||||
@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case results of
|
||||
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
||||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||||
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
|
||||
pointsForm = case sheetType of
|
||||
NotGraded
|
||||
-> pure Nothing
|
||||
|
||||
@ -104,7 +104,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
submittorsForm' = maybeT submittorsForm $ do
|
||||
restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
|
||||
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
|
||||
submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
||||
submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
|
||||
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
|
||||
|
||||
|
||||
@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
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
|
||||
guard $ Just (Right uid) /= dat !? delPos || isJust msmid
|
||||
|
||||
miDeleteList dat delPos
|
||||
|
||||
@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
|
||||
corrector <- fmap join $ traverse getEntity submissionRatingBy
|
||||
corrector <- join <$> traverse getEntity submissionRatingBy
|
||||
|
||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
|
||||
|
||||
|
||||
@ -122,7 +122,7 @@ colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnad
|
||||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } ->
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } ->
|
||||
let
|
||||
csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
@ -136,8 +136,8 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
|
||||
| otherwise -> mempty
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
|
||||
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
|
||||
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
| otherwise -> mempty
|
||||
|
||||
@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
|
||||
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
||||
NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
|
||||
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
@ -201,7 +201,7 @@ colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (Form
|
||||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
|
||||
|
||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
@ -398,11 +398,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
|
||||
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
|
||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in any (\c -> c `isInfixOf` cid) criteria'
|
||||
in any (`isInfixOf` cid) criteria'
|
||||
)
|
||||
]
|
||||
, dbtFilterUI = fromMaybe mempty dbtFilterUI
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
|
||||
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
|
||||
, dbtParams
|
||||
, dbtIdent = "corrections" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
-- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
||||
-- return (tableRes, statistics)
|
||||
|
||||
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||
let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||
<&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
|
||||
|
||||
formResult actionRes $ \case
|
||||
@ -610,7 +610,7 @@ assignAction selId = ( CorrSetCorrector
|
||||
|
||||
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
|
||||
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
|
||||
E.distinct $ return user
|
||||
|
||||
|
||||
@ -57,9 +57,8 @@ postMessageR cID = do
|
||||
runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
|
||||
$ (,)
|
||||
<$> fmap (Entity tId)
|
||||
( SystemMessageTranslation
|
||||
<$> pure systemMessageTranslationMessage
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||
( SystemMessageTranslation systemMessageTranslationMessage
|
||||
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
|
||||
<*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
|
||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
|
||||
)
|
||||
@ -71,9 +70,8 @@ postMessageR cID = do
|
||||
& filter (\l -> none (`langMatches` l) $ Map.keys ts')
|
||||
|
||||
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
|
||||
$ SystemMessageTranslation
|
||||
<$> pure smId
|
||||
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||
$ SystemMessageTranslation smId
|
||||
<$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
|
||||
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
|
||||
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
|
||||
|
||||
|
||||
@ -43,7 +43,7 @@ tutorialForm cid template html = do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser . Just $ tutUserSuggestions uid) (fslI MsgTutorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let
|
||||
addRes'
|
||||
| otherwise
|
||||
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||
, not $ Set.null existing
|
||||
|
||||
@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCTutorialListR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
let
|
||||
|
||||
@ -16,7 +16,7 @@ import Handler.Tutorial.TutorInvite
|
||||
getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCTutorialNewR = postCTutorialNewR
|
||||
postCTutorialNewR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
|
||||
|
||||
|
||||
@ -74,7 +74,7 @@ getUsersR = postUsersR
|
||||
postUsersR = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let
|
||||
dbtColonnade = mconcat $
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
|
||||
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
(AdminUserR <$> encrypt uid)
|
||||
@ -233,7 +233,7 @@ postUsersR = do
|
||||
formResult allUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
addMessageI Success $ MsgSynchroniseLdapAllUsersQueued
|
||||
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||
redirect UsersR
|
||||
let allUsersWgt' = wrapForm allUsersWgt def
|
||||
{ formSubmit = FormNoSubmit
|
||||
@ -569,7 +569,7 @@ functionInvitationConfig = InvitationConfig{..}
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
|
||||
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
@ -19,7 +19,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
import qualified Control.Monad.State.Class as State (get, modify')
|
||||
|
||||
import Data.List (genericLength, elemIndex)
|
||||
import Data.List (genericLength)
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Vector.Lens (vector)
|
||||
import qualified Data.Set as Set
|
||||
@ -201,7 +201,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
|
||||
withNumericGrade :: Rational -> Rational
|
||||
withNumericGrade
|
||||
| Just grade' <- grade
|
||||
= let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||
= let numberGrade' = maybe (error "non-passing grade") fromIntegral (elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||
passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
|
||||
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
|
||||
in (+) numericGrade
|
||||
@ -244,7 +244,7 @@ doAllocation :: AllocationId
|
||||
-> DB ()
|
||||
doAllocation allocId now regs =
|
||||
forM_ regs $ \(uid, cid) -> do
|
||||
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
void $ upsert
|
||||
(CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. now
|
||||
|
||||
@ -151,7 +151,7 @@ encodeCsv hdr = do
|
||||
| otherwise
|
||||
= encodeLazyByteString enc . decodeLazyByteString UTF8
|
||||
where enc = csvOpts ^. _csvFormat . _csvEncoding
|
||||
fmap (encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy . recode'
|
||||
C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr
|
||||
|
||||
timestampCsv :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
|
||||
@ -175,7 +175,7 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM
|
||||
]
|
||||
, do
|
||||
guard $ uncurry (/=) amPm
|
||||
guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm]
|
||||
guard . not $ all (all Char.isLower) [fst amPm, snd amPm]
|
||||
Just
|
||||
[ DateTimeFormat "%I:%M %P"
|
||||
, DateTimeFormat "%I:%M:%S %P"
|
||||
|
||||
@ -367,7 +367,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
wordMap = Map.fromListWith (+) wordLengths
|
||||
|
||||
wordIx :: Iso' wordId Int
|
||||
wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords
|
||||
wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords
|
||||
in ix'
|
||||
)
|
||||
(collapsedWords Array.!)
|
||||
@ -477,7 +477,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
||||
bestOption = case rule of
|
||||
ExamRoomSurname -> do
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
|
||||
-- traceM $ show cost
|
||||
return res
|
||||
ExamRoomMatriculation -> do
|
||||
|
||||
@ -34,7 +34,7 @@ sourceFile FileReference{..} = do
|
||||
-> maybeT (throwM SourceFilesContentUnavailable) $ do
|
||||
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
|
||||
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
|
||||
fmap Just . (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
|
||||
fmap Just . hoistMaybe <=< runAppMinio . runMaybeT $ do
|
||||
objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
|
||||
lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
|
||||
| fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent
|
||||
|
||||
@ -22,7 +22,7 @@ import Handler.Utils.I18n
|
||||
import Handler.Utils.Files
|
||||
|
||||
import Import
|
||||
import Data.Char (chr, ord)
|
||||
import Data.Char ( chr, ord, isDigit )
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -55,8 +55,6 @@ import Data.Aeson.Text (encodeToLazyText)
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import Data.Text.Lens (unpacked)
|
||||
|
||||
import Data.Char (isDigit)
|
||||
import Text.Blaze (toMarkup)
|
||||
|
||||
import Handler.Utils.Form.MassInput
|
||||
@ -64,6 +62,8 @@ import Handler.Utils.Form.MassInput
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
----------------------------
|
||||
-- Buttons (new version ) --
|
||||
@ -257,7 +257,7 @@ multiActionField :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiActionField minp acts (actField, actExternal, actMessage) fs@FieldSettings{..} defAction csrf = do
|
||||
multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do
|
||||
(actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction
|
||||
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
|
||||
|
||||
@ -285,15 +285,15 @@ multiActionOpts' :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
|
||||
multiActionOpts' minp acts mActsOpts fs defAction csrf = do
|
||||
actsOpts <- liftHandler mActsOpts
|
||||
let actsOpts' = OptionList
|
||||
{ olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
|
||||
, olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
|
||||
, olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts
|
||||
}
|
||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
|
||||
|
||||
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
||||
actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
||||
actExternal = fmap optionExternalValue . actOption
|
||||
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
||||
|
||||
@ -397,13 +397,13 @@ explainedMultiAction' :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
explainedMultiAction' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
|
||||
explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
|
||||
(actsOpts, actsReadExternal) <- liftHandler mActsOpts
|
||||
let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
|
||||
actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal
|
||||
actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal
|
||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
|
||||
|
||||
actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
||||
actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
||||
actExternal = fmap optionExternalValue . actOption
|
||||
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
||||
|
||||
@ -463,7 +463,7 @@ pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
|
||||
pointsField = pointsFieldMinMax (Just 0) Nothing
|
||||
|
||||
pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
|
||||
pointsFieldMax limit = pointsFieldMinMax (Just 0) limit
|
||||
pointsFieldMax = pointsFieldMinMax (Just 0)
|
||||
|
||||
pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
|
||||
pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
|
||||
@ -795,7 +795,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
|
||||
|
||||
let errors
|
||||
| anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
|
||||
| FormSuccess bounds' <- sequence $ map (view _1) bounds
|
||||
| FormSuccess bounds' <- mapM (view _1) bounds
|
||||
, not $ monotone bounds'
|
||||
= [mr MsgPointsMustBeMonotonic]
|
||||
| otherwise
|
||||
@ -967,7 +967,7 @@ genericFileField mkOpts = Field{..}
|
||||
.| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
|
||||
.| C.filter (\(fTitle, _) ->
|
||||
fieldMultiple
|
||||
|| ( (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals)
|
||||
|| ( bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals)
|
||||
&& null files
|
||||
)
|
||||
)
|
||||
@ -1091,7 +1091,7 @@ fileUploadForm isReq mkFs = \case
|
||||
UploadAny{..}
|
||||
-> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
|
||||
UploadSpecific{..}
|
||||
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
|
||||
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles)
|
||||
where
|
||||
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
|
||||
specificFileForm spec@UploadSpecificFile{..}
|
||||
@ -1445,7 +1445,7 @@ examOccurrenceField :: ( MonadHandler m
|
||||
=> ExamId
|
||||
-> Field m ExamOccurrenceId
|
||||
examOccurrenceField eid
|
||||
= hoistField liftHandler . selectField . (fmap $ fmap entityKey)
|
||||
= hoistField liftHandler . selectField . fmap (fmap entityKey)
|
||||
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
|
||||
|
||||
|
||||
@ -1553,7 +1553,7 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
whenIsJust suggestions $ \suggestions' -> do
|
||||
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
||||
user <- suggestions'
|
||||
return $ ( E.case_
|
||||
return ( E.case_
|
||||
[ E.when_ (unique UserDisplayEmail user)
|
||||
E.then_ (user E.^. UserDisplayEmail)
|
||||
, E.when_ (unique UserEmail user)
|
||||
@ -1768,7 +1768,7 @@ examField :: forall m.
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId
|
||||
examField optMsg cId = hoistField liftHandler . selectField' optMsg . (fmap $ fmap entityKey) $
|
||||
examField optMsg cId = hoistField liftHandler . selectField' optMsg . fmap (fmap entityKey) $
|
||||
optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName
|
||||
|
||||
|
||||
|
||||
@ -37,6 +37,8 @@ import Text.Hamlet (hamletFile)
|
||||
|
||||
import Algebra.Lattice.Ordered (Ordered(..))
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
$(mapM tupleBoxCoord [2..4])
|
||||
|
||||
@ -149,7 +151,7 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
|
||||
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
|
||||
|
||||
|
||||
type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> (BoxCoord liveliness) -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
||||
type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> BoxCoord liveliness -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
|
||||
|
||||
|
||||
miDeleteList :: MassInputDelete ListLength
|
||||
@ -330,9 +332,9 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
guard $ isn't _FormMissing btnRes
|
||||
res
|
||||
miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
|
||||
addRes'' <- miAdd' & mapped . _Just . _1 %~ wBtnRes
|
||||
addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
|
||||
addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
|
||||
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
|
||||
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
|
||||
case remDims of
|
||||
[] -> return dimRes'
|
||||
((_, BoxDimension dim) : _) -> do
|
||||
@ -373,7 +375,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
|
||||
delShapeUpdate
|
||||
| [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
|
||||
| otherwise = Nothing
|
||||
delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate
|
||||
delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
|
||||
|
||||
|
||||
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
|
||||
@ -490,7 +492,7 @@ massInputList :: forall handler cellResult ident msg.
|
||||
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
|
||||
massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
|
||||
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
|
||||
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
|
||||
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
|
||||
, miCell = \pos () iRes nudge csrf ->
|
||||
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
|
||||
, miDelete = miDeleteList
|
||||
@ -544,7 +546,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
|
||||
miAdd :: ListPosition -> Natural
|
||||
-> (Text -> Text) -> FieldView UniWorX
|
||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
||||
miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
|
||||
|
||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||
@ -622,7 +624,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
|
||||
miAdd :: ListPosition -> Natural
|
||||
-> (Text -> Text) -> FieldView UniWorX
|
||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
||||
miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
|
||||
|
||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||
|
||||
@ -30,7 +30,7 @@ tupleBoxCoord tupleDim = do
|
||||
|
||||
instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
|
||||
[ funD 'boxDimensions
|
||||
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
|
||||
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) $ map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(fieldLenses !! field) . dim) boxDimensions|]) [0..pred tupleDim]) []
|
||||
]
|
||||
, funD 'boxOrigin
|
||||
[ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
|
||||
|
||||
@ -58,7 +58,7 @@ i18nWidgetFilesAvailable' basename = do
|
||||
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
|
||||
fileKinds :: Map Text [Text]
|
||||
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
|
||||
toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds'
|
||||
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
|
||||
|
||||
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
|
||||
|
||||
|
||||
@ -274,7 +274,7 @@ sourceInvitations :: forall junction m backend.
|
||||
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
||||
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
||||
where
|
||||
decode (Entity _ (Invitation{invitationEmail, invitationData}))
|
||||
decode (Entity _ Invitation{invitationEmail, invitationData})
|
||||
= case fromJSON invitationData of
|
||||
JSON.Success dbData -> return (invitationEmail, dbData)
|
||||
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
|
||||
|
||||
@ -389,9 +389,9 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lif
|
||||
Nothing -> do
|
||||
startAct <- liftIO newEmptyTMVarIO
|
||||
act' <- async $ do
|
||||
$logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
|
||||
$logDebugS "liftAsyncTimeout" "Waiting for confirmation..."
|
||||
atomically $ takeTMVar startAct
|
||||
$logDebugS "liftAsyncTimeout" $ "Confirmed."
|
||||
$logDebugS "liftAsyncTimeout" "Confirmed."
|
||||
act
|
||||
act'' <- atomically $ do
|
||||
hm <- readTVar memcachedAsync
|
||||
|
||||
@ -31,7 +31,7 @@ import qualified Data.Char as Char
|
||||
|
||||
|
||||
validateRating :: SheetType -> Rating' -> [RatingValidityException]
|
||||
validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
|
||||
validateRating ratingSheetType Rating'{ ratingPoints=Just rp }
|
||||
| rp < 0
|
||||
= [RatingNegative]
|
||||
| NotGraded <- ratingSheetType
|
||||
@ -93,7 +93,7 @@ ratingFile :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> CryptoFileNameSubmission -> Rating -> m File
|
||||
ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
|
||||
ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do
|
||||
mr'@(MsgRenderer mr) <- getMsgRenderer
|
||||
dtFmt <- getDateTimeFormatter
|
||||
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
|
||||
|
||||
@ -29,8 +29,6 @@ import qualified Data.YAML.Event as YAML.Event
|
||||
import qualified Data.YAML.Token as YAML (Encoding(..))
|
||||
import Data.YAML.Aeson () -- ToYAML Value
|
||||
|
||||
import Data.List (elemIndex)
|
||||
|
||||
import Control.Monad.Trans.State.Lazy (evalState)
|
||||
|
||||
import qualified System.FilePath.Cryptographic as Explicit
|
||||
|
||||
@ -169,7 +169,7 @@ planSubmissions sid restriction = do
|
||||
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
|
||||
oldSubmissionData = Map.withoutKeys submissionData targetSubmissions
|
||||
|
||||
whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing ->
|
||||
whenIsJust (fromNullable . (`Set.difference` targetSubmissions) =<< restriction) $ \missing ->
|
||||
throwM $ SubmissionsNotFound missing
|
||||
|
||||
let
|
||||
@ -236,7 +236,7 @@ planSubmissions sid restriction = do
|
||||
| otherwise
|
||||
= Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
|
||||
|
||||
when (not $ null acceptableCorrectors) $ do
|
||||
unless (null acceptableCorrectors) $ do
|
||||
deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
|
||||
let
|
||||
bestCorrectors :: Set UserId
|
||||
@ -320,7 +320,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
|
||||
let
|
||||
fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
|
||||
fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
@ -574,7 +574,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
sinkSubmission' :: SubmissionId
|
||||
-> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
|
||||
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||||
Left file@(FileReference{..}) -> do
|
||||
Left file@FileReference{..} -> do
|
||||
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
|
||||
|
||||
alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
|
||||
@ -591,7 +591,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
, submissionFileIsUpdate sf == isUpdate
|
||||
]
|
||||
underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
|
||||
, submissionFileIsUpdate sf == False
|
||||
, not (submissionFileIsUpdate sf)
|
||||
]
|
||||
anyChanges
|
||||
| not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
|
||||
@ -658,7 +658,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
--
|
||||
-- 'fileModified' is simply stored and never inspected while
|
||||
-- 'submissionChanged' is always set to @now@.
|
||||
let anyChanges = any (\f -> f submission submission') $
|
||||
let anyChanges = any (\f -> f submission submission')
|
||||
[ (/=) `on` submissionRatingPoints
|
||||
, (/=) `on` submissionRatingComment
|
||||
, (/=) `on` submissionRatingDone
|
||||
@ -675,7 +675,7 @@ sinkSubmission userId mExists isUpdate = do
|
||||
when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
|
||||
tellSt mempty { sinkSubmissionNotifyRating = Any True }
|
||||
lift $ replace submissionId submission'
|
||||
sheetId <- lift $ getSheetId
|
||||
sheetId <- lift getSheetId
|
||||
lift $ audit $ TransactionSubmissionEdit submissionId sheetId
|
||||
where
|
||||
a /~ b = not $ a ~~ b
|
||||
@ -699,14 +699,14 @@ sinkSubmission userId mExists isUpdate = do
|
||||
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
|
||||
touchSubmission = do
|
||||
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
||||
when (not alreadyTouched) $ do
|
||||
unless alreadyTouched $ do
|
||||
now <- liftIO getCurrentTime
|
||||
case isUpdate of
|
||||
False -> lift . insert_ $ SubmissionEdit userId now submissionId
|
||||
True -> do
|
||||
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
||||
when (is _Just submissionRatingTime) $
|
||||
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
||||
if
|
||||
| isUpdate -> do
|
||||
Submission{submissionRatingTime} <- lift $ getJust submissionId
|
||||
when (is _Just submissionRatingTime) $
|
||||
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
|
||||
| otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
|
||||
tellSt $ mempty{ sinkSubmissionTouched = Any True }
|
||||
|
||||
getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
|
||||
@ -720,15 +720,36 @@ sinkSubmission userId mExists isUpdate = do
|
||||
finalize SubmissionSinkState{..} = do
|
||||
missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
|
||||
when (not isUpdate) $
|
||||
unless isUpdate $
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
|
||||
E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||||
|
||||
return sf
|
||||
|
||||
case isUpdate of
|
||||
False -> do
|
||||
if
|
||||
| isUpdate -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
|
||||
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
||||
|
||||
if
|
||||
| not shadowing -> do
|
||||
delete sfId
|
||||
audit $ TransactionSubmissionFileDelete sfId submissionId
|
||||
| submissionFileIsUpdate -> do
|
||||
update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
||||
audit $ TransactionSubmissionFileEdit sfId submissionId
|
||||
| otherwise -> do
|
||||
now <- liftIO getCurrentTime
|
||||
sfId' <- insert $ SubmissionFile
|
||||
{ submissionFileSubmission = submissionId
|
||||
, submissionFileTitle
|
||||
, submissionFileModified = now
|
||||
, submissionFileContent = Nothing
|
||||
, submissionFileIsUpdate = True
|
||||
, submissionFileIsDeletion = True
|
||||
}
|
||||
audit $ TransactionSubmissionFileEdit sfId' submissionId
|
||||
| otherwise -> do
|
||||
shadowed <- selectKeysList
|
||||
[ SubmissionFileSubmission ==. submissionId
|
||||
, SubmissionFileIsUpdate ==. False
|
||||
@ -737,27 +758,6 @@ sinkSubmission userId mExists isUpdate = do
|
||||
forM_ shadowed $ \sfId' -> do
|
||||
delete sfId'
|
||||
audit $ TransactionSubmissionFileDelete sfId' submissionId
|
||||
True -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
|
||||
shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
|
||||
|
||||
if
|
||||
| not shadowing -> do
|
||||
delete sfId
|
||||
audit $ TransactionSubmissionFileDelete sfId submissionId
|
||||
| submissionFileIsUpdate -> do
|
||||
update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
|
||||
audit $ TransactionSubmissionFileEdit sfId submissionId
|
||||
| otherwise -> do
|
||||
now <- liftIO getCurrentTime
|
||||
sfId' <- insert $ SubmissionFile
|
||||
{ submissionFileSubmission = submissionId
|
||||
, submissionFileTitle
|
||||
, submissionFileModified = now
|
||||
, submissionFileContent = Nothing
|
||||
, submissionFileIsUpdate = True
|
||||
, submissionFileIsDeletion = True
|
||||
}
|
||||
audit $ TransactionSubmissionFileEdit sfId' submissionId
|
||||
|
||||
if
|
||||
| isUpdate
|
||||
@ -833,7 +833,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
| otherwise = return Nothing
|
||||
Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
|
||||
return (msId, fp)
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
||||
(msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
|
||||
case msId of
|
||||
Nothing -> do
|
||||
$logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
|
||||
@ -842,7 +842,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
cID <- encrypt sId
|
||||
lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
|
||||
feed sId $ Left f{ fileReferenceTitle = fileTitle' }
|
||||
when (not $ null ignoredFiles) $ do
|
||||
unless (null ignoredFiles) $ do
|
||||
mr <- (toHtml .) <$> getMessageRender
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
|
||||
@ -903,7 +903,7 @@ submissionDeleteRoute drRecords = DeleteRoute
|
||||
uid <- maybeAuthId
|
||||
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
|
||||
if
|
||||
| length subUsers >= 1
|
||||
| not $ null subUsers
|
||||
, maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
|
||||
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
|
||||
| otherwise
|
||||
|
||||
@ -302,8 +302,8 @@ sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryN
|
||||
colApplicationId :: OpticColonnade CourseApplicationId
|
||||
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
|
||||
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
|
||||
header = Sortable Nothing $ i18nCell MsgCourseApplicationId
|
||||
body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId
|
||||
|
||||
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
||||
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
||||
|
||||
@ -92,7 +92,7 @@ import Colonnade.Encode hiding (row)
|
||||
|
||||
import Text.Hamlet (hamletFile)
|
||||
|
||||
import Data.List (elemIndex, inits)
|
||||
import Data.List (inits)
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
@ -450,7 +450,7 @@ instance Traversable DBRow where
|
||||
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
|
||||
instance Default (PSValidator m x) where
|
||||
def = PSValidator $ \DBTable{..} -> \case
|
||||
def = PSValidator $ \DBTable{} -> \case
|
||||
Nothing -> def
|
||||
Just pi -> swap . (\act -> execRWS act pi def) $ do
|
||||
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
|
||||
|
||||
@ -106,11 +106,11 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
|
||||
for ldapData $ upsertCampusUser UpsertCampusUser
|
||||
|
||||
if
|
||||
| x@(Entity pid _) : [] <- users'
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
| [x@(Entity pid _)] <- users'
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
-> return $ Just pid
|
||||
| x@(Entity pid _) : x' : _ <- users'
|
||||
, fromMaybe False (matchesMatriculation x) || didLdap
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
, GT <- x `closeness` x'
|
||||
-> return $ Just pid
|
||||
| not didLdap
|
||||
|
||||
@ -60,6 +60,7 @@ import GHC.Exts as Import (IsList)
|
||||
import Data.Ix as Import (Ix)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List as Import (elemIndex)
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Min(..), Max(..))
|
||||
@ -78,6 +79,8 @@ import Database.Persist.Sql as Import (SqlReadBackend, SqlReadT, SqlWriteT, IsSq
|
||||
|
||||
import Ldap.Client.Pool as Import
|
||||
|
||||
import Control.Monad as Import (zipWithM)
|
||||
|
||||
import System.Random as Import (Random(..))
|
||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||
|
||||
|
||||
@ -493,7 +493,7 @@ jLocked jId act = do
|
||||
liftIO . atomically $ writeTVar hasLock True
|
||||
return val
|
||||
|
||||
unlock = whenM (liftIO . atomically $ readTVar hasLock) $
|
||||
unlock = whenM (readTVarIO hasLock) $
|
||||
runDB . setSerializable $
|
||||
update jId [ QueuedJobLockInstance =. Nothing
|
||||
, QueuedJobLockTime =. Nothing
|
||||
|
||||
@ -27,7 +27,7 @@ import qualified Database.Esqueleto as E
|
||||
determineCrontab :: DB (Crontab JobCtl)
|
||||
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
|
||||
determineCrontab = execWriterT $ do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
|
||||
|
||||
case appJobFlushInterval of
|
||||
Just interval -> tell $ HashMap.singleton
|
||||
@ -354,7 +354,7 @@ determineCrontab = execWriterT $ do
|
||||
|
||||
|
||||
let
|
||||
externalExamJobs (Entity nExternalExam ExternalExam{..}) = do
|
||||
externalExamJobs nExternalExam = do
|
||||
newestResult <- lift . E.select . E.from $ \externalExamResult -> do
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
|
||||
return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
|
||||
@ -371,7 +371,7 @@ determineCrontab = execWriterT $ do
|
||||
}
|
||||
_other -> return ()
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalExamJobs
|
||||
runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
|
||||
|
||||
let
|
||||
allocationJobs (Entity nAllocation Allocation{..}) = do
|
||||
|
||||
@ -20,7 +20,7 @@ import qualified Data.Text as Text
|
||||
|
||||
dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler ()
|
||||
dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do
|
||||
(Course{..}, Sheet{..}, Submission{..}, initiator, coSubmittors) <- liftHandler . runDB $ do
|
||||
(Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do
|
||||
submission <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
@ -55,7 +55,7 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai
|
||||
|
||||
dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler ()
|
||||
dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do
|
||||
(User{..}, Course{..}, Sheet{..}, Submission{..}, coSubmittors) <- liftHandler . runDB $ do
|
||||
(User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do
|
||||
submission <- getJust nSubmission
|
||||
sheet <- belongsToJust submissionSheet submission
|
||||
course <- belongsToJust sheetCourse sheet
|
||||
|
||||
@ -38,7 +38,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
|
||||
|
||||
dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
|
||||
dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
UniWorX{..} <- getYesod
|
||||
case appLdapPool of
|
||||
Just ldapPool ->
|
||||
runDB . void . runMaybeT . handleExc $ do
|
||||
|
||||
@ -231,7 +231,7 @@ instance Exception MailException
|
||||
|
||||
class Yesod site => YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
|
||||
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
||||
|
||||
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
mailObjectIdDomain = pack <$> liftIO getHostName
|
||||
|
||||
@ -105,17 +105,17 @@ requiresMigration :: forall m.
|
||||
=> ReaderT SqlBackend m Bool
|
||||
requiresMigration = mapReaderT (exceptT return return) $ do
|
||||
initial <- either id (map snd) <$> parseMigration initialMigration
|
||||
when (not $ null initial) $ do
|
||||
unless (null initial) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " initial
|
||||
throwError True
|
||||
|
||||
customs <- mapReaderT lift $ getMissingMigrations @_ @m
|
||||
when (not $ Map.null customs) $ do
|
||||
unless (Map.null customs) $ do
|
||||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||||
throwError True
|
||||
|
||||
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
||||
when (not $ null automatic) $ do
|
||||
unless (null automatic) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " automatic
|
||||
throwError True
|
||||
|
||||
@ -188,7 +188,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
other -> error $ "Could not parse theme: " <> show other
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
|
||||
, whenM (tableExists "sheet") $ -- Better JSON encoding
|
||||
, whenM (tableExists "sheet") -- Better JSON encoding
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
|
||||
ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
|
||||
@ -265,13 +265,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
_other -> error "Empty userDisplayName found"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
||||
, whenM (tableExists "sheet") $
|
||||
, whenM (tableExists "sheet")
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
|
||||
, whenM (columnExists "user" "plugin") $
|
||||
, whenM (columnExists "user" "plugin")
|
||||
-- <> is standard sql for /=
|
||||
[executeQQ|
|
||||
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
|
||||
@ -280,7 +280,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
|
||||
, whenM (tableExists "user") $
|
||||
, whenM (tableExists "user")
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
|
||||
|]
|
||||
@ -291,13 +291,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
|
||||
, whenM (tableExists "cluster_config") $
|
||||
, whenM (tableExists "cluster_config")
|
||||
[executeQQ|
|
||||
UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|]
|
||||
, whenM (tableExists "sheet") $
|
||||
, whenM (tableExists "sheet")
|
||||
[executeQQ|
|
||||
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
|
||||
UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
|
||||
@ -315,10 +315,10 @@ customMigrations = Map.fromListWith (>>)
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
|
||||
, do
|
||||
whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
|
||||
whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
|
||||
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
|
||||
@ -388,7 +388,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
|
||||
|]
|
||||
|
||||
whenM (tableExists "user") $
|
||||
whenM (tableExists "user")
|
||||
[executeQQ|
|
||||
UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
|
||||
|]
|
||||
@ -572,13 +572,13 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|]
|
||||
, whenM (tableExists "exam") $
|
||||
, whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
|
||||
, whenM (tableExists "course_favourite") $
|
||||
, whenM (tableExists "course_favourite")
|
||||
[executeQQ|
|
||||
ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
|
||||
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
||||
@ -596,7 +596,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
_other -> error "Cannot reconstruct course_participant.allocated"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
|
||||
, whenM (tableExists "allocation") $
|
||||
, whenM (tableExists "allocation")
|
||||
[executeQQ|
|
||||
CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL);
|
||||
INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null));
|
||||
@ -605,7 +605,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
|
||||
, whenM (tableExists "user") $
|
||||
, whenM (tableExists "user")
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN "languages" jsonb;
|
||||
UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
|
||||
@ -617,7 +617,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
tableDropEmpty "exam_part_corrector"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
|
||||
, whenM (tableExists "study_features") $
|
||||
, whenM (tableExists "study_features")
|
||||
[executeQQ|
|
||||
ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
|
||||
UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
|
||||
@ -625,7 +625,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|]
|
||||
, whenM (tableExists "exam") $
|
||||
, whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
|
||||
ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
|
||||
@ -640,7 +640,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|]
|
||||
, whenM (tableExists "exam") $
|
||||
, whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
|
||||
UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
||||
@ -650,7 +650,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|]
|
||||
, whenM (tableExists "external_exam") $
|
||||
, whenM (tableExists "external_exam")
|
||||
[executeQQ|
|
||||
ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
|
||||
UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
|
||||
@ -849,7 +849,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log";
|
||||
|]
|
||||
|
||||
whenM (tableExists "session_file") $
|
||||
whenM (tableExists "session_file")
|
||||
[executeQQ|
|
||||
ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
|
||||
UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");
|
||||
|
||||
@ -59,6 +59,8 @@ import qualified Data.Foldable
|
||||
|
||||
import Data.Aeson (genericToJSON, genericParseJSON)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
data ExamResult' res = ExamAttended { examResult :: res }
|
||||
| ExamNoShow
|
||||
@ -170,7 +172,7 @@ derivePersistFieldJSON ''ExamOccurrenceRule
|
||||
makePrisms ''ExamOccurrenceRule
|
||||
|
||||
examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
|
||||
examOccurrenceRuleAutomatic x = or $ map ($ x)
|
||||
examOccurrenceRuleAutomatic x = any ($ x)
|
||||
[ is _ExamRoomSurname
|
||||
, is _ExamRoomMatriculation
|
||||
, is _ExamRoomRandom
|
||||
|
||||
@ -161,7 +161,7 @@ instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
|
||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
||||
|
||||
instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
|
||||
toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
|
||||
toPathPiece = Text.unwords . map (Text.intercalate "AND" . map toPathPiece . otoList) . otoList . dnfTerms
|
||||
fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
|
||||
|
||||
type AuthLiteral = PredLiteral AuthTag
|
||||
|
||||
@ -21,7 +21,7 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
import Data.List (elemIndex, genericIndex)
|
||||
import Data.List (genericIndex)
|
||||
import Data.Bits
|
||||
import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
@ -118,7 +118,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
|
||||
|
||||
pseudonymWords :: Fold Text PseudonymWord
|
||||
pseudonymWords = folding
|
||||
$ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||
$ \(CI.mk -> input) -> maybe [] (map (view _2)) . listToMaybe . groupBy ((==) `on` view _1) . sortOn (view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||
where
|
||||
distance = damerauLevenshtein `on` CI.foldedCase
|
||||
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
||||
|
||||
@ -420,7 +420,7 @@ instance FromJSON AppSettings where
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
|
||||
[ not $ null connectHost
|
||||
, numConnection > 0
|
||||
, connectionIdleTime >= 0
|
||||
|
||||
@ -142,7 +142,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do
|
||||
[ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) []
|
||||
| fName <- Set.toList fileNames
|
||||
]
|
||||
, funD 'fromPathMultiPiece $
|
||||
, funD 'fromPathMultiPiece
|
||||
[ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
|
||||
]
|
||||
]
|
||||
|
||||
14
src/Utils.hs
14
src/Utils.hs
@ -51,6 +51,7 @@ import Control.Lens as Utils (none)
|
||||
import Control.Lens.Extras (is)
|
||||
import Data.Set.Lens
|
||||
|
||||
import Control.Monad (zipWithM)
|
||||
import Control.Arrow as Utils ((>>>))
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
@ -154,8 +155,8 @@ maybeAttribute a c (Just v) = [(a,c v)]
|
||||
|
||||
|
||||
newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
|
||||
deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
|
||||
|
||||
instance ToContent PrettyValue where
|
||||
toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
|
||||
@ -169,8 +170,8 @@ toPrettyJSON = PrettyValue . toJSON
|
||||
|
||||
|
||||
newtype YamlValue = YamlValue { unYamlValue :: Value }
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data)
|
||||
deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
|
||||
deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
|
||||
deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
|
||||
|
||||
instance ToContent YamlValue where
|
||||
toContent = toContent . Yaml.encode
|
||||
@ -723,7 +724,7 @@ shortCircuitM sc binOp mx my = do
|
||||
x <- mx
|
||||
if
|
||||
| sc x -> return x
|
||||
| otherwise -> binOp <$> pure x <*> my
|
||||
| otherwise -> binOp x <$> my
|
||||
|
||||
|
||||
guardM :: MonadPlus m => m Bool -> m ()
|
||||
@ -1193,8 +1194,7 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
|
||||
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
|
||||
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
|
||||
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
|
||||
fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
|
||||
zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
||||
fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
||||
where
|
||||
uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
|
||||
uc = unsafeCoerce
|
||||
|
||||
@ -20,7 +20,7 @@ import Control.Monad.Writer (tell)
|
||||
|
||||
import Control.Monad.ST
|
||||
|
||||
import Data.List ((!!), elemIndex)
|
||||
import Data.List ((!!))
|
||||
|
||||
|
||||
type CourseIndex = Int
|
||||
@ -127,11 +127,11 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
|
||||
(newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||
|
||||
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
|
||||
isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
|
||||
isUnstableWith cn' (stO, cnO) = Just True == (do
|
||||
c' <- matchingCourse st cn'
|
||||
rMe <- courseRating c' (st, cn')
|
||||
rOther <- courseRating c' (stO, cnO)
|
||||
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))
|
||||
return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO)))
|
||||
|
||||
if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
|
||||
-> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
|
||||
|
||||
@ -46,7 +46,7 @@ getKeyBy404 u = getKeyBy u >>= maybe notFound return
|
||||
|
||||
getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
|
||||
=> Key val -> ReaderT backend m (Entity val)
|
||||
getEntity404 k = Entity <$> pure k <*> get404 k
|
||||
getEntity404 k = Entity k <$> get404 k
|
||||
|
||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
|
||||
@ -718,9 +718,9 @@ selectField' optMsg mkOpts = Field{..}
|
||||
let
|
||||
rendered = case val of
|
||||
Left _ -> ""
|
||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
||||
Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions
|
||||
|
||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
||||
isSel Nothing = rendered `notElem` map optionExternalValue olOptions
|
||||
isSel (Just opt) = rendered == optionExternalValue opt
|
||||
[whamlet|
|
||||
$newline never
|
||||
@ -757,9 +757,9 @@ radioField' optMsg mkOpts = Field{..}
|
||||
let
|
||||
rendered = case val of
|
||||
Left _ -> ""
|
||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
||||
Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions
|
||||
|
||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
||||
isSel Nothing = rendered `notElem` map optionExternalValue olOptions
|
||||
isSel (Just opt) = rendered == optionExternalValue opt
|
||||
[whamlet|
|
||||
$newline never
|
||||
@ -800,9 +800,9 @@ radioGroupField optMsg mkOpts = Field{..}
|
||||
let
|
||||
rendered = case val of
|
||||
Left _ -> ""
|
||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
||||
Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions
|
||||
|
||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
||||
isSel Nothing = rendered `notElem` map optionExternalValue olOptions
|
||||
isSel (Just opt) = rendered == optionExternalValue opt
|
||||
[whamlet|
|
||||
$newline never
|
||||
@ -885,9 +885,7 @@ renderFieldViews :: ( RenderMessage site AFormMessage
|
||||
)
|
||||
=> FormLayout -> [FieldView site] -> WidgetT site IO ()
|
||||
renderFieldViews layout
|
||||
= join
|
||||
. fmap (view _1)
|
||||
. generateFormPost
|
||||
= view _1 <=< generateFormPost
|
||||
. lmap (const mempty)
|
||||
. renderWForm layout
|
||||
. (FormSuccess () <$)
|
||||
@ -1168,21 +1166,21 @@ mreq :: forall m a.
|
||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||
)
|
||||
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> MForm m (FormResult a, FieldView (HandlerSite m))
|
||||
mreq f fs@FieldSettings{..} mdef = mreqMsg f fs (ValueRequired fsLabel) mdef
|
||||
mreq f fs@FieldSettings{..} = mreqMsg f fs $ ValueRequired fsLabel
|
||||
|
||||
wreq :: forall m a.
|
||||
( MonadHandler m
|
||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||
)
|
||||
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> WForm m (FormResult a)
|
||||
wreq f fs@FieldSettings{..} mdef = wreqMsg f fs (ValueRequired fsLabel) mdef
|
||||
wreq f fs@FieldSettings{..} = wreqMsg f fs $ ValueRequired fsLabel
|
||||
|
||||
areq :: forall m a.
|
||||
( MonadHandler m
|
||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||
)
|
||||
=> Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> AForm m a
|
||||
areq f fs@FieldSettings{..} mdef = areqMsg f fs (ValueRequired fsLabel) mdef
|
||||
areq f fs@FieldSettings{..} = areqMsg f fs $ ValueRequired fsLabel
|
||||
|
||||
|
||||
mforced :: (site ~ HandlerSite m, MonadHandler m)
|
||||
|
||||
@ -24,6 +24,8 @@ import qualified Network.HTTP.Types as HTTP
|
||||
|
||||
import Yesod.Core.Types (HandlerData(..), GHState(..))
|
||||
|
||||
{-# ANN module ("HLint: ignore Use even" :: String) #-}
|
||||
|
||||
|
||||
histogramBuckets :: Rational -- ^ min
|
||||
-> Rational -- ^ max
|
||||
|
||||
@ -50,7 +50,7 @@ normalizeOccurrences initial
|
||||
| otherwise
|
||||
= Nothing
|
||||
merge _ = Nothing
|
||||
merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a
|
||||
merges <- views _occurrencesScheduled $ mapMaybe (\b -> (b, ) <$> merge b) . Set.toList . Set.delete a
|
||||
case merges of
|
||||
[] -> return ()
|
||||
((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
|
||||
|
||||
@ -71,10 +71,10 @@ curryN :: Int -> ExpQ
|
||||
curryN n = do
|
||||
fn <- newName "foo"
|
||||
xs <- replicateM n $ newName "x"
|
||||
let pat = map VarP (fn:xs)
|
||||
let tup = TupE (map VarE xs)
|
||||
let rhs = AppE (VarE fn) tup
|
||||
return $ LamE pat rhs
|
||||
let pat = map varP (fn:xs)
|
||||
let tup = tupE (map varE xs)
|
||||
let rhs = appE (varE fn) tup
|
||||
lamE pat rhs
|
||||
|
||||
uncurryN :: Int -> ExpQ
|
||||
uncurryN n = do
|
||||
|
||||
@ -111,7 +111,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql
|
||||
runTransactionM MemcachedSqlStorage{..} = flip runSqlPool mcdSqlConnPool
|
||||
|
||||
getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do
|
||||
encSession <- catchIfExceptT (\_ -> Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
||||
encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
||||
|
||||
guardExceptT (BS.length encSession >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
||||
Just MemcachedSqlStorageAEADCiphertextTooShort
|
||||
@ -137,7 +137,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql
|
||||
deleteSession MemcachedSqlStorage{..} sessId
|
||||
= liftIO . handleIf Memcached.isKeyNotFound (const $ return ()) $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
||||
|
||||
deleteAllSessionsOfAuthId MemcachedSqlStorage{..} authId = do
|
||||
deleteAllSessionsOfAuthId MemcachedSqlStorage{} authId = do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
( MemcachedSessionExpiration authId now )
|
||||
@ -161,7 +161,7 @@ replaceSession' isReplace s@MemcachedSqlStorage{..} seNewSession@(review memcach
|
||||
whenIsJust mOld $ \seExistingSession ->
|
||||
throwM @_ @(StorageException (MemcachedSqlStorage sess)) $ SessionAlreadyExists{..}
|
||||
|
||||
nonce <- liftIO $ AEAD.newNonce
|
||||
nonce <- liftIO AEAD.newNonce
|
||||
let encSession = Saltine.encode nonce <> AEAD.aead mcdSqlMemcachedKey nonce encoded encSessId
|
||||
encSessId = LBS.toStrict $ Binary.encode sessId
|
||||
handleFailure
|
||||
|
||||
@ -57,6 +57,7 @@ newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a }
|
||||
, MonadIO
|
||||
, MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
|
||||
, MonadResource, MonadHandler, MonadWidget
|
||||
, MonadUnliftIO
|
||||
)
|
||||
deriving newtype ( MFunctor, MMonad, MonadTrans )
|
||||
|
||||
@ -67,9 +68,6 @@ instance MonadReader r m => MonadReader r (CachedMemoT k v m) where
|
||||
reader = CachedMemoT . lift . reader
|
||||
local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act
|
||||
|
||||
instance MonadUnliftIO m => MonadUnliftIO (CachedMemoT k v m) where
|
||||
askUnliftIO = (\UnliftIO{..} -> UnliftIO $ \(CachedMemoT f) -> unliftIO f) <$> CachedMemoT askUnliftIO
|
||||
|
||||
|
||||
-- | Uses `cachedBy` with a `Binary`-encoded @k@
|
||||
instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
|
||||
|
||||
153
stack.yaml
153
stack.yaml
@ -35,92 +35,123 @@ extra-deps:
|
||||
subdirs:
|
||||
- colonnade
|
||||
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
|
||||
commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f
|
||||
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
|
||||
|
||||
|
||||
# - colonnade-1.2.0.2
|
||||
- hsass-0.8.0
|
||||
- hlibsass-0.1.8.1
|
||||
- tz-0.1.3.3
|
||||
# # - colonnade-1.2.0.2
|
||||
# - hsass-0.8.0
|
||||
# - hlibsass-0.1.8.1
|
||||
# - tz-0.1.3.3
|
||||
|
||||
# - zip-stream-0.2.0.1
|
||||
# # - zip-stream-0.2.0.1
|
||||
|
||||
- uuid-crypto-1.4.0.0
|
||||
- filepath-crypto-0.1.0.0
|
||||
- cryptoids-0.5.1.0
|
||||
- cryptoids-types-1.0.0
|
||||
- cryptoids-class-0.0.0
|
||||
# - uuid-crypto-1.4.0.0
|
||||
# - filepath-crypto-0.1.0.0
|
||||
# - cryptoids-0.5.1.0
|
||||
# - cryptoids-types-1.0.0
|
||||
# - cryptoids-class-0.0.0
|
||||
|
||||
- system-locale-0.3.0.0
|
||||
# - system-locale-0.3.0.0
|
||||
|
||||
- hlint-test-0.1.0.0
|
||||
# - hlint-test-0.1.0.0
|
||||
|
||||
- pkcs7-1.0.0.1
|
||||
# - pkcs7-1.0.0.1
|
||||
|
||||
- systemd-2.2.0
|
||||
# - systemd-2.2.0
|
||||
|
||||
# - directory-1.3.4.0
|
||||
# # - directory-1.3.4.0
|
||||
|
||||
# - HaXml-1.25.5
|
||||
# # - HaXml-1.25.5
|
||||
|
||||
# - persistent-2.10.4
|
||||
# - persistent-postgresql-2.10.1
|
||||
# - persistent-template-2.7.3
|
||||
# - esqueleto-3.2.3
|
||||
# # - persistent-2.10.4
|
||||
# # - persistent-postgresql-2.10.1
|
||||
# # - persistent-template-2.7.3
|
||||
# # - esqueleto-3.2.3
|
||||
|
||||
- sandi-0.5
|
||||
- storable-endian-0.2.6
|
||||
# - universe-1.2
|
||||
# - universe-base-1.1.1
|
||||
# - universe-reverse-instances-1.1
|
||||
# - unliftio-pool-0.2.1.0
|
||||
# - universe-instances-extended-1.1.1
|
||||
# - universe-some-1.2
|
||||
# - some-1.0.0.3
|
||||
# - sandi-0.5
|
||||
# - storable-endian-0.2.6
|
||||
# # - universe-1.2
|
||||
# # - universe-base-1.1.1
|
||||
# # - universe-reverse-instances-1.1
|
||||
# # - unliftio-pool-0.2.1.0
|
||||
# # - universe-instances-extended-1.1.1
|
||||
# # - universe-some-1.2
|
||||
# # - some-1.0.0.3
|
||||
|
||||
# - network-bsd-2.8.1.0
|
||||
# # - network-bsd-2.8.1.0
|
||||
|
||||
# - persistent-qq-2.9.1
|
||||
# # - persistent-qq-2.9.1
|
||||
|
||||
# - process-1.6.5.1
|
||||
# # - process-1.6.5.1
|
||||
|
||||
# - generic-lens-1.2.0.0
|
||||
# # - generic-lens-1.2.0.0
|
||||
|
||||
- prometheus-metrics-ghc-1.0.1
|
||||
- wai-middleware-prometheus-1.0.0
|
||||
# - prometheus-metrics-ghc-1.0.1
|
||||
# - wai-middleware-prometheus-1.0.0
|
||||
|
||||
# - extended-reals-0.2.3.0
|
||||
# # - extended-reals-0.2.3.0
|
||||
|
||||
- pandoc-2.9.2
|
||||
- doclayout-0.3
|
||||
- doctemplates-0.8.1
|
||||
# - emojis-0.1
|
||||
# - hslua-module-system-0.2.1
|
||||
# - ipynb-0.1
|
||||
# - jira-wiki-markup-1.0.0
|
||||
# - HsYAML-0.2.1.0
|
||||
# - cmark-gfm-0.2.1
|
||||
# - haddock-library-1.8.0
|
||||
# - pandoc-types-1.20
|
||||
# - skylighting-0.8.3.2
|
||||
# - skylighting-core-0.8.3.2
|
||||
# - texmath-0.12.0.1
|
||||
# - pandoc-2.9.2
|
||||
# - doclayout-0.3
|
||||
# - doctemplates-0.8.1
|
||||
# # - emojis-0.1
|
||||
# # - hslua-module-system-0.2.1
|
||||
# # - ipynb-0.1
|
||||
# # - jira-wiki-markup-1.0.0
|
||||
# # - HsYAML-0.2.1.0
|
||||
# # - cmark-gfm-0.2.1
|
||||
# # - haddock-library-1.8.0
|
||||
# # - pandoc-types-1.20
|
||||
# # - skylighting-0.8.3.2
|
||||
# # - skylighting-core-0.8.3.2
|
||||
# # - texmath-0.12.0.1
|
||||
|
||||
- binary-instances-1
|
||||
# - binary-instances-1
|
||||
|
||||
- acid-state-0.16.0
|
||||
# - acid-state-0.16.0
|
||||
|
||||
- unidecode-0.1.0.4
|
||||
# - unidecode-0.1.0.4
|
||||
|
||||
- token-bucket-0.1.0.1
|
||||
# - token-bucket-0.1.0.1
|
||||
|
||||
- normaldistribution-1.1.0.3
|
||||
# - normaldistribution-1.1.0.3
|
||||
|
||||
- unordered-containers-0.2.11.0
|
||||
# - unordered-containers-0.2.11.0
|
||||
|
||||
- base64-bytestring-1.1.0.0
|
||||
- base32-0.2.0.0
|
||||
- ghc-byteorder-4.11.0.0.10
|
||||
# - base64-bytestring-1.1.0.0
|
||||
|
||||
resolver: lts-15.12
|
||||
- acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
- bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
|
||||
- byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
|
||||
- bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863
|
||||
- commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
|
||||
- commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
|
||||
- commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167
|
||||
- contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757
|
||||
- cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570
|
||||
- cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
|
||||
- cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
|
||||
- filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
|
||||
- hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565
|
||||
- hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899
|
||||
- ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742
|
||||
- natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411
|
||||
- normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160
|
||||
- pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933
|
||||
- pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
|
||||
- primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843
|
||||
- primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
|
||||
- prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233
|
||||
- run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883
|
||||
- sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
|
||||
- system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
|
||||
- token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
|
||||
- tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088
|
||||
- tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
|
||||
- unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
|
||||
- uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
|
||||
- wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
||||
- hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
|
||||
resolver: nightly-2020-08-08
|
||||
allow-newer: true
|
||||
|
||||
310
stack.yaml.lock
310
stack.yaml.lock
@ -158,211 +158,239 @@ packages:
|
||||
version: 1.5.2
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
|
||||
pantry-tree:
|
||||
size: 4517
|
||||
sha256: ef7c5960da571c6cb41337b0bd30740bac92b4781b375be704093fdadd17330d
|
||||
commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f
|
||||
size: 4560
|
||||
sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc
|
||||
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
|
||||
original:
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
|
||||
commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f
|
||||
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
|
||||
- completed:
|
||||
hackage: hsass-0.8.0@sha256:82d55fb2a10342accbc4fe80d263163f40a138d8636e275aa31ffa81b14abf01,2792
|
||||
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
pantry-tree:
|
||||
size: 1448
|
||||
sha256: dc39ed0207b8b22d2713054421dbd5452baa9704df75bedf17f04f97a29f3d9a
|
||||
size: 13678
|
||||
sha256: d57bcb2ad5e01fe7424abbcf9e58cf943027b5c4a8496d93625c57b6e1272274
|
||||
original:
|
||||
hackage: hsass-0.8.0
|
||||
hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
|
||||
- completed:
|
||||
hackage: hlibsass-0.1.8.1@sha256:7005d0f3fee66e776300117f6bf31583bf310f58df6d7f552c8811bd406abfc8,2564
|
||||
hackage: bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
|
||||
pantry-tree:
|
||||
size: 8441
|
||||
sha256: c3c1fe56c35eed093772b9900d7038287b829d67960c6f96a82c9dc46b203db0
|
||||
size: 844
|
||||
sha256: 5e6fd3de57a4d44257fb475433633939459e0294fafe79b21ff67aeb93a81591
|
||||
original:
|
||||
hackage: hlibsass-0.1.8.1
|
||||
hackage: bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
|
||||
- completed:
|
||||
hackage: tz-0.1.3.3@sha256:b9de0c1b10825460ff14a237209a8bf7747f47979601d35621276556bf63d2ca,5086
|
||||
hackage: byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
|
||||
pantry-tree:
|
||||
size: 1180
|
||||
sha256: ae6af45f3dba5a478ea9cc77c718f955fcc5c96f2dc0f4ede34c4a15a3e85ac1
|
||||
size: 1095
|
||||
sha256: 9ada4e1c418e8d9029edefdf664c64ff419ed1f02564e5a0dd28dd03e1e716a6
|
||||
original:
|
||||
hackage: tz-0.1.3.3
|
||||
hackage: byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
|
||||
- completed:
|
||||
hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
|
||||
hackage: bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863
|
||||
pantry-tree:
|
||||
size: 364
|
||||
sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48
|
||||
size: 1185
|
||||
sha256: 3396c1b29577cff2491382d0b144fe586c75987e9ad28bc0cadbc88a97ee7315
|
||||
original:
|
||||
hackage: uuid-crypto-1.4.0.0
|
||||
hackage: bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863
|
||||
- completed:
|
||||
hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
|
||||
hackage: commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
|
||||
pantry-tree:
|
||||
size: 623
|
||||
sha256: bce236365ebdc6e5c46f740876a6fb5ad688e8ee3b305933822ab027e5b5fd86
|
||||
size: 1346
|
||||
sha256: 991da6da60804286b9ea23a1522e18ceeabddfdf416787231db9fd047c163f53
|
||||
original:
|
||||
hackage: filepath-crypto-0.1.0.0
|
||||
hackage: commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
|
||||
- completed:
|
||||
hackage: commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
|
||||
pantry-tree:
|
||||
size: 2927
|
||||
sha256: 89e1ee05938d558834c397a3a22cdacc755a1941c144f4c1f3daf8a1ede943ce
|
||||
original:
|
||||
hackage: commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
|
||||
- completed:
|
||||
hackage: commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167
|
||||
pantry-tree:
|
||||
size: 326
|
||||
sha256: aa88fb10bd382b8d942b51b2ad0b94f52a72a4e37c8085abc5c380964c7eeb7c
|
||||
original:
|
||||
hackage: commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167
|
||||
- completed:
|
||||
hackage: contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757
|
||||
pantry-tree:
|
||||
size: 442
|
||||
sha256: 39ee8ba3b4725ed1057429cd1f613275bfecbc618f289559203bebb1ff4a259e
|
||||
original:
|
||||
hackage: contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757
|
||||
- completed:
|
||||
hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570
|
||||
pantry-tree:
|
||||
size: 513
|
||||
sha256: 563e8d2b616ec3e0e7984d6b069095b6c3959065c0bb047fc8dd5809711a3e6b
|
||||
original:
|
||||
hackage: cryptoids-0.5.1.0
|
||||
- completed:
|
||||
hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
|
||||
pantry-tree:
|
||||
size: 268
|
||||
sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404
|
||||
original:
|
||||
hackage: cryptoids-types-1.0.0
|
||||
hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570
|
||||
- completed:
|
||||
hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
|
||||
pantry-tree:
|
||||
size: 359
|
||||
sha256: 6a5af7c785c230501fa6088ecf963c7de7463ab75b3f646510612f17dff69744
|
||||
original:
|
||||
hackage: cryptoids-class-0.0.0
|
||||
hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
|
||||
- completed:
|
||||
hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
|
||||
hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
|
||||
pantry-tree:
|
||||
size: 446
|
||||
sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373
|
||||
size: 268
|
||||
sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404
|
||||
original:
|
||||
hackage: system-locale-0.3.0.0
|
||||
hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
|
||||
- completed:
|
||||
hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
|
||||
pantry-tree:
|
||||
size: 442
|
||||
sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea
|
||||
size: 623
|
||||
sha256: bce236365ebdc6e5c46f740876a6fb5ad688e8ee3b305933822ab027e5b5fd86
|
||||
original:
|
||||
hackage: hlint-test-0.1.0.0
|
||||
hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593
|
||||
- completed:
|
||||
hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
|
||||
hackage: hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565
|
||||
pantry-tree:
|
||||
size: 316
|
||||
sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c
|
||||
size: 11229
|
||||
sha256: 39b62f1f3f30c5a9e12f9c6a040d6863edb5ce81951452e649152a18145ee1bc
|
||||
original:
|
||||
hackage: pkcs7-1.0.0.1
|
||||
hackage: hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565
|
||||
- completed:
|
||||
hackage: systemd-2.2.0@sha256:a41399ad921e3c90bb04219a66821631c17c94326961f9b6c71542abb042375f,1477
|
||||
hackage: hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899
|
||||
pantry-tree:
|
||||
size: 520
|
||||
sha256: 188d4e07a62653b24091dc25c0222deb7a95037630d17a13327d269391050b7d
|
||||
size: 1448
|
||||
sha256: b25aeb947cb4e0b550f8a6f226d06503ef0edcb54712ad9cdd4fb2b05bf16c7c
|
||||
original:
|
||||
hackage: systemd-2.2.0
|
||||
hackage: hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899
|
||||
- completed:
|
||||
hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
|
||||
hackage: ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742
|
||||
pantry-tree:
|
||||
size: 3455
|
||||
sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350
|
||||
size: 1437
|
||||
sha256: c60e78361b92eebfa341027377787e39de5a16218ab605456cf4cf1de5f58b2a
|
||||
original:
|
||||
hackage: sandi-0.5
|
||||
hackage: ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742
|
||||
- completed:
|
||||
hackage: storable-endian-0.2.6@sha256:cae7aac2bfe6037660b2cf294891867e69bcd74e739a3b3ea759e9ad99d6c889,801
|
||||
hackage: natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411
|
||||
pantry-tree:
|
||||
size: 223
|
||||
sha256: 6a8e43727f9b146238d4064fffc39d629f06622106922487fea922ec73aaee1e
|
||||
size: 716
|
||||
sha256: e1e5b16f53fe2a7378d38dcae5069dcc1c6e37f8e1473f091ae1f7d788b1c688
|
||||
original:
|
||||
hackage: storable-endian-0.2.6
|
||||
- completed:
|
||||
hackage: prometheus-metrics-ghc-1.0.1@sha256:d12cd520cbedff91bd193e0192056474723e953e69cdf817fb79494d110df390,1231
|
||||
pantry-tree:
|
||||
size: 293
|
||||
sha256: b412f2835ee5791a7f4f634c416227b70bae50511666d9f68683e5e21b5c2821
|
||||
original:
|
||||
hackage: prometheus-metrics-ghc-1.0.1
|
||||
- completed:
|
||||
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
||||
pantry-tree:
|
||||
size: 307
|
||||
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
|
||||
original:
|
||||
hackage: wai-middleware-prometheus-1.0.0
|
||||
- completed:
|
||||
hackage: pandoc-2.9.2@sha256:fa04b214c79328a4519093a5e82fe961a21179539165b98773a6f8bfb66bc662,36181
|
||||
pantry-tree:
|
||||
size: 88080
|
||||
sha256: 95eeae57b3d00eb7fa1accacab31e032f4d535c8c2cb992891a20d694eb00339
|
||||
original:
|
||||
hackage: pandoc-2.9.2
|
||||
- completed:
|
||||
hackage: doclayout-0.3@sha256:06c03875b1645e6ab835c40f9b73fd959b6c4232c01d06f07debedfae46723f2,2059
|
||||
pantry-tree:
|
||||
size: 425
|
||||
sha256: ed2fc2dd826fbba67cb8018979be437b215735fab90dcc49ad30b296f7005eed
|
||||
original:
|
||||
hackage: doclayout-0.3
|
||||
- completed:
|
||||
hackage: doctemplates-0.8.1@sha256:be34c3210d9ebbba1c10100e30d8c3ba3b6c34653ec2ed15f09e5d05055aa37d,3111
|
||||
pantry-tree:
|
||||
size: 2303
|
||||
sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913
|
||||
original:
|
||||
hackage: doctemplates-0.8.1
|
||||
- completed:
|
||||
hackage: binary-instances-1@sha256:b17565598b8df3241f9b46fa8e3a3368ecc8e3f2eb175d7c28f319042a6f5c79,2613
|
||||
pantry-tree:
|
||||
size: 1035
|
||||
sha256: 938ffc6990cac12681c657f7afa93737eecf335e6f0212d8c0b7c1ea3e0f40f4
|
||||
original:
|
||||
hackage: binary-instances-1
|
||||
- completed:
|
||||
hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190
|
||||
pantry-tree:
|
||||
size: 13678
|
||||
sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
|
||||
original:
|
||||
hackage: acid-state-0.16.0
|
||||
- completed:
|
||||
hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
|
||||
pantry-tree:
|
||||
size: 492
|
||||
sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283
|
||||
original:
|
||||
hackage: unidecode-0.1.0.4
|
||||
- completed:
|
||||
hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
|
||||
pantry-tree:
|
||||
size: 399
|
||||
sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa
|
||||
original:
|
||||
hackage: token-bucket-0.1.0.1
|
||||
hackage: natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411
|
||||
- completed:
|
||||
hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160
|
||||
pantry-tree:
|
||||
size: 269
|
||||
sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c
|
||||
original:
|
||||
hackage: normaldistribution-1.1.0.3
|
||||
hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160
|
||||
- completed:
|
||||
hackage: unordered-containers-0.2.11.0@sha256:ba70b8a9d7eebc2034bf92e5690b2dd71200e76aa9f3f93e0b6be3f27f244d18,4998
|
||||
hackage: pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933
|
||||
pantry-tree:
|
||||
size: 1416
|
||||
sha256: d9b83f62373f509a441223f22f12e22e39b38ef3275dfca7c190a4795bebfed5
|
||||
size: 89646
|
||||
sha256: 08c8b20356152b9ee8161bacafda2dc1bed13d7db4cbf38ab040c1977b2d28d5
|
||||
original:
|
||||
hackage: unordered-containers-0.2.11.0
|
||||
hackage: pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933
|
||||
- completed:
|
||||
hackage: base64-bytestring-1.1.0.0@sha256:190264fef9e65d9085f00ccda419137096d1dc94777c58272bc96821dc7f37c3,2334
|
||||
hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
|
||||
pantry-tree:
|
||||
size: 850
|
||||
sha256: 9ade5b5911df97c37b249b84f123297049f19578cae171c647bf47683633427c
|
||||
size: 316
|
||||
sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c
|
||||
original:
|
||||
hackage: base64-bytestring-1.1.0.0
|
||||
hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
|
||||
- completed:
|
||||
hackage: base32-0.2.0.0@sha256:459f0ba6412d58adf1d6ab68d5dc68afddc9f65c69ad564c0a9643d5d8a7e96e,2608
|
||||
hackage: primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843
|
||||
pantry-tree:
|
||||
size: 1935
|
||||
sha256: 10c0a5a0a1d4c40b41f0190cf80b114fb527caf7458feec819d87ccfe41317cb
|
||||
size: 368
|
||||
sha256: 6dbc2fbfd70920a1de5a76d3715506edc0895c81a2f7b856d3abb027865d4605
|
||||
original:
|
||||
hackage: base32-0.2.0.0
|
||||
hackage: primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843
|
||||
- completed:
|
||||
hackage: ghc-byteorder-4.11.0.0.10@sha256:5ee4a907279bfec27b0f9de7b8fba4cecfd34395a0235a7784494de70ad4e98f,1535
|
||||
hackage: primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
|
||||
pantry-tree:
|
||||
size: 169
|
||||
sha256: 54a4636f72c3b9eff7f081714cb1a7b809fc1f3b2e239caaf0d65d79aa9cb56f
|
||||
size: 420
|
||||
sha256: c882dca2a96b98d02b0d21875b651edb11ac67d90e736c0de7a92c410a19eb7f
|
||||
original:
|
||||
hackage: ghc-byteorder-4.11.0.0.10
|
||||
hackage: primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
|
||||
- completed:
|
||||
hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233
|
||||
pantry-tree:
|
||||
size: 293
|
||||
sha256: 0732085a4148b269bbc15eeb7ab422e65ac287878a42a7388a7b6e140ec740e5
|
||||
original:
|
||||
hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233
|
||||
- completed:
|
||||
hackage: run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883
|
||||
pantry-tree:
|
||||
size: 269
|
||||
sha256: 06d5d7ecf185a26c15e48cda6c30e8865dae715c528a31466701272fae36d822
|
||||
original:
|
||||
hackage: run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883
|
||||
- completed:
|
||||
hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
|
||||
pantry-tree:
|
||||
size: 3455
|
||||
sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350
|
||||
original:
|
||||
hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
|
||||
- completed:
|
||||
hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
|
||||
pantry-tree:
|
||||
size: 446
|
||||
sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373
|
||||
original:
|
||||
hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
|
||||
- completed:
|
||||
hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
|
||||
pantry-tree:
|
||||
size: 399
|
||||
sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa
|
||||
original:
|
||||
hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899
|
||||
- completed:
|
||||
hackage: tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088
|
||||
pantry-tree:
|
||||
size: 320
|
||||
sha256: 57009cc671ed8e43738be3bf7b1392461ad086083df633a2f4f9c7206a14a79c
|
||||
original:
|
||||
hackage: tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088
|
||||
- completed:
|
||||
hackage: tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
|
||||
pantry-tree:
|
||||
size: 1179
|
||||
sha256: f6b8517eaaf3588afd1b3025fe6874a1ffff611001a803a26094c9cb40bc33f6
|
||||
original:
|
||||
hackage: tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
|
||||
- completed:
|
||||
hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
|
||||
pantry-tree:
|
||||
size: 492
|
||||
sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283
|
||||
original:
|
||||
hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
|
||||
- completed:
|
||||
hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
|
||||
pantry-tree:
|
||||
size: 364
|
||||
sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48
|
||||
original:
|
||||
hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
|
||||
- completed:
|
||||
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
||||
pantry-tree:
|
||||
size: 307
|
||||
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
|
||||
original:
|
||||
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
|
||||
- completed:
|
||||
hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
pantry-tree:
|
||||
size: 442
|
||||
sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea
|
||||
original:
|
||||
hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 494635
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/12.yaml
|
||||
sha256: a71c4293d8f461f455ff0d9815dfe4ab2f1adacd7e0bbc9a218f46ced8c4929a
|
||||
original: lts-15.12
|
||||
size: 524392
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/8.yaml
|
||||
sha256: 21b78cd42414558e6e381666a51ab92b405f969ab1d675137fd55ef557edc9a4
|
||||
original: nightly-2020-08-08
|
||||
|
||||
@ -43,7 +43,7 @@ insertFile residual fileTitle = do
|
||||
|
||||
fillDb :: DB ()
|
||||
fillDb = do
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)
|
||||
|
||||
Reference in New Issue
Block a user