diff --git a/package.yaml b/package.yaml index 820a16e46..0820ca9d3 100644 --- a/package.yaml +++ b/package.yaml @@ -156,24 +156,35 @@ default-extensions: - BinaryLiterals - PolyKinds -ghc-options: - - -Wall - - -fwarn-tabs +when: + - condition: flag(pedantic) + then: + ghc-options: + - -Wall + - -Werror + - -fwarn-tabs + - -fno-warn-type-defaults + - -fno-warn-partial-type-signatures + else: + ghc-options: + - -Wall + - -fno-warn-type-defaults + - -fno-warn-partial-type-signatures # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: source-dirs: src when: - - condition: (flag(dev)) || (flag(library-only)) - then: - ghc-options: - - -O0 - - -ddump-splices - cpp-options: -DDEVELOPMENT - else: - ghc-options: - - -O2 + - condition: (flag(dev)) || (flag(library-only)) + then: + ghc-options: + - -O0 + - -ddump-splices + cpp-options: -DDEVELOPMENT + else: + ghc-options: + - -O2 # Runnable executable for our application executables: @@ -219,3 +230,7 @@ flags: description: Turn on development settings, like auto-reload templates. manual: false default: false + pedantic: + description: Be very pedantic about warnings and errors + manual: true + default: true diff --git a/routes b/routes index 17a653125..f953da2e5 100644 --- a/routes +++ b/routes @@ -50,8 +50,8 @@ !/term/#TermId TermCourseListR GET !free !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET -/school/#SchoolId SchoolShowR GET +/school SchoolListR GET !development +/school/#SchoolId SchoolShowR GET !development -- For Pattern Synonyms see Foundation @@ -64,7 +64,7 @@ /edit CEditR GET POST /delete CDeleteR GET POST !lecturerANDempty /users CUsersR GET - /user/#CryptoUUIDUser CUserR GET + /user/#CryptoUUIDUser CUserR GET !development /correctors CHiWisR GET /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials diff --git a/src/Cron.hs b/src/Cron.hs index cb2d9a338..600eb873c 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -1,5 +1,6 @@ module Cron - ( CronNextMatch(..) + ( evalCronMatch + , CronNextMatch(..) , nextCronMatch , module Cron.Types ) where @@ -18,11 +19,7 @@ import Data.Ratio ((%)) import qualified Data.Set as Set -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty - -import Utils.Lens.TH -import Control.Lens +import Utils.Lens hiding (from, to) data CronDate = CronDate @@ -38,7 +35,7 @@ makeLenses_ ''CronDate evalCronMatch :: CronMatch -> Natural -> Bool evalCronMatch CronMatchAny _ = True evalCronMatch CronMatchNone _ = False -evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set +evalCronMatch (CronMatchSome xs) x = Set.member x $ toNullable xs evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0 evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x @@ -115,7 +112,7 @@ genMatch :: Int -- ^ Period -> [Natural] genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..] genMatch _ _ _ CronMatchNone = [] -genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set +genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs genMatch p m st (CronMatchStep step) = do start <- [st..st + step] guard $ (start `mod` step) == 0 @@ -135,9 +132,9 @@ genMatch p m st (CronMatchIntersect aGen bGen) mergeAnd [] _ = [] mergeAnd _ [] = [] mergeAnd (a:as) (b:bs) - | a < b = mergeAnd as (b:bs) - | a == b = a : mergeAnd as bs - | a > b = mergeAnd (a:as) bs + | a < b = mergeAnd as (b:bs) + | a == b = a : mergeAnd as bs + | otherwise = mergeAnd (a:as) bs genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny @@ -147,9 +144,9 @@ genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMa merge [] bs = bs merge as [] = as merge (a:as) (b:bs) - | a < b = a : merge as (b:bs) - | a == b = a : merge as bs - | a > b = b : merge (a:as) bs + | a < b = a : merge as (b:bs) + | a == b = a : merge as bs + | otherwise = b : merge (a:as) bs nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry -> Maybe UTCTime -- ^ Time of last execution of the job @@ -166,7 +163,6 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of | otherwise -> MatchNone MatchNone -> nextMatch where - nextMatch = nextCronMatch' tz mPrev now c notAfter | Right c' <- cronNotAfter , Just ref <- notAfterRef @@ -178,34 +174,34 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of notAfterRef | Just prevT <- mPrev = Just prevT | otherwise = case execRef' now False cronInitial of + MatchAsap -> error "execRef' should not return MatchAsap" MatchAt t -> Just t MatchNone -> Nothing - - nextCronMatch' tz mPrev now c@Cron{..} - | isNothing mPrev - = execRef now False cronInitial - | Just prevT <- mPrev - = case cronRepeat of - CronRepeatOnChange - | not $ matchesCron tz Nothing prevT c - -> let - cutoffTime = addUTCTime cronRateLimit prevT - in case execRef now False cronInitial of - MatchAsap - | now < cutoffTime -> MatchAt cutoffTime - MatchAt ts - | ts < cutoffTime -> MatchAt cutoffTime - other -> other - CronRepeatScheduled cronNext - -> case cronNext of - CronAsap - | addUTCTime cronRateLimit prevT <= now - -> MatchAsap - | otherwise - -> MatchAt $ addUTCTime cronRateLimit prevT - cronNext - -> execRef (addUTCTime cronRateLimit prevT) True cronNext - _other -> MatchNone + nextMatch = case mPrev of + Nothing + -> execRef now False cronInitial + Just prevT + -> case cronRepeat of + CronRepeatOnChange + | not $ matchesCron tz Nothing prevT c + -> let + cutoffTime = addUTCTime cronRateLimit prevT + in case execRef now False cronInitial of + MatchAsap + | now < cutoffTime -> MatchAt cutoffTime + MatchAt ts + | ts < cutoffTime -> MatchAt cutoffTime + other -> other + CronRepeatScheduled cronNext + -> case cronNext of + CronAsap + | addUTCTime cronRateLimit prevT <= now + -> MatchAsap + | otherwise + -> MatchAt $ addUTCTime cronRateLimit prevT + _other + -> execRef (addUTCTime cronRateLimit prevT) True cronNext + _other -> MatchNone execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of MatchAt t @@ -219,19 +215,26 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of | otherwise -> MatchNone CronCalendar{..} -> listToMatch $ do let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref - cronYear <- genMatch 400 False cdYear cronYear - cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear - cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear - cronMonth <- genMatch 12 True cdMonth cronMonth - cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth - cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth - cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek - cronHour <- genMatch 24 True cdHour cronHour - cronMinute <- genMatch 60 True cdMinute cronMinute - cronSecond <- genMatch 60 True cdSecond cronSecond - guard $ consistentCronDate CronDate{..} - localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) - let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) + + mCronYear <- genMatch 400 False cdYear cronYear + mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear + mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear + mCronMonth <- genMatch 12 True cdMonth cronMonth + mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth + mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth + mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek + mCronHour <- genMatch 24 True cdHour cronHour + mCronMinute <- genMatch 60 True cdMinute cronMinute + mCronSecond <- genMatch 60 True cdSecond cronSecond + guard $ consistentCronDate CronDate + { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth + , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond + , cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth + , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek + } + + localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth) + let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond) return $ localTimeToUTCTZ tz LocalTime{..} CronNotScheduled -> MatchNone diff --git a/src/Foundation.hs b/src/Foundation.hs index 4cb048b8d..ca40aa24a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto module Foundation where @@ -10,20 +11,18 @@ import Text.Jasmine (minifym) import qualified Web.ClientSession as ClientSession import Yesod.Auth.Message -import Yesod.Auth.Dummy import Auth.LDAP import Auth.PWHash import Auth.Dummy import Jobs.Types -import qualified Network.Wai as W (requestMethod, pathInfo) +import qualified Network.Wai as W (pathInfo) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as TE import qualified Data.CryptoID as E @@ -40,12 +39,10 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.List (foldr1) -import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map -import Data.List (findIndex) import Data.Monoid (Any(..)) @@ -61,22 +58,14 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Catch (handleAll) import qualified Control.Monad.Catch as C -import System.FilePath - -import Handler.Utils.Templates import Handler.Utils.StudyFeatures import Control.Lens -import Utils import Utils.Form -import Utils.Lens import Utils.SystemMessage import Data.Aeson hiding (Error, Success) -import Data.Aeson.TH -import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) @@ -147,9 +136,11 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerT UniWorX IO) a -- Pattern Synonyms for convenience +pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) +pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -212,9 +203,10 @@ instance RenderMessage UniWorX Load where newtype MsgLanguage = MsgLanguage Lang deriving (Eq, Ord, Show, Read) instance RenderMessage UniWorX MsgLanguage where - renderMessage foundation ls (MsgLanguage lang) - | lang == "de-DE" = mr MsgGermanGermany - | "de" `isPrefixOf` lang = mr MsgGerman + renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang')) + | ["de", "DE"] <- lang' = mr MsgGermanGermany + | ("de" : _) <- lang' = mr MsgGerman + | otherwise = lang where mr = renderMessage foundation ls @@ -280,8 +272,8 @@ orAR _ _ AuthenticationRequired = AuthenticationRequired orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y -- and andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y -andAR _ reason@(Unauthorized x) _ = reason -andAR _ _ reason@(Unauthorized x) = reason +andAR _ reason@(Unauthorized _) _ = reason +andAR _ _ reason@(Unauthorized _) = reason andAR _ Authorized other = other andAR _ AuthenticationRequired _ = AuthenticationRequired @@ -338,6 +330,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req allow <- appAllowDeprecated . appSettings <$> getYesod return $ bool (Unauthorized "Deprecated Route") Authorized allow ) + ,("development", APHandler $ \r _ -> do + $logWarnS "AccessControl" ("route in development: " <> tshow r) +#ifdef DEVELOPMENT + return Authorized +#else + return $ Unauthorized "Route under development" +#endif + ) ,("lecturer", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -406,7 +406,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do - Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop courseRegisterFrom <= cTime && NTop courseRegisterTo >= cTime @@ -414,7 +414,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID - SystemMessage{..} <- MaybeT $ get smId + SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime && NTop systemMessageTo >= cTime @@ -617,14 +617,14 @@ instance Yesod UniWorX where errPage = case err of NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|] - InternalError err -> encrypted err [whamlet|
#{err}|] + InternalError err' -> encrypted err' [whamlet|
#{err'}|] InvalidArgs errs -> [whamlet|
_{MsgErrorResponseNotAuthenticated}|] - PermissionDenied err -> [whamlet|
#{err}|] + PermissionDenied err' -> [whamlet|
#{err'}|] BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do toWidget @@ -746,8 +746,8 @@ siteLayout headingOverride widget = do asidenav = $(widgetFile "widgets/asidenav") contentHeadline :: Maybe Widget contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute) - breadcrumbs :: Widget - breadcrumbs = $(widgetFile "widgets/breadcrumbs") + breadcrumbsWgt :: Widget + breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now -- functions to determine if there are page-actions (primary or secondary) @@ -786,11 +786,13 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do cID <- encrypt smId + void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + let sessionKey = "sm-" <> tshow (ciphertext cID) - assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False - assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())) + _ <- assertM isNothing $ lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ()) setSessionJson sessionKey () - (SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId + + (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId let (summary, content) = case smTrans of Nothing -> (systemMessageSummary, systemMessageContent) @@ -1177,11 +1179,12 @@ pageActions (CorrectionsR) = , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId - [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + [E.Value corrCount] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid return E.countRows - return $ (count :: Int) /= 0 + return $ (corrCount :: Int) /= 0 } , PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen eintragen" @@ -1206,11 +1209,12 @@ pageActions (CorrectionsGradeR) = , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId - [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + [E.Value corrCount] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid return E.countRows - return $ (count :: Int) /= 0 + return $ (corrCount :: Int) /= 0 } ] pageActions _ = [] @@ -1287,7 +1291,7 @@ pageHeading (CSheetR tid ssh csh shn SEditR) = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SDelR) = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn -pageHeading (CSheetR tid ssh csh shn SSubsR) +pageHeading (CSheetR _tid _ssh _csh shn SSubsR) = Just $ i18nHeading $ MsgSubmissionsSheet shn pageHeading (CSheetR tid ssh csh shn SubmissionNewR) = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn @@ -1299,7 +1303,7 @@ pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -pageHeading (CSheetR tid ssh csh shn SCorrR) +pageHeading (CSheetR _tid _ssh _csh shn SCorrR) = Just $ i18nHeading $ MsgCorrectorsHead shn -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads @@ -1542,7 +1546,7 @@ instance YesodMail UniWorX where pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do - setMailObjectId + void setMailObjectId setDateCurrent replaceMailHeader "Auto-Submitted" $ Just "auto-generated" diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9e2285d40..44c32bb50 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -24,7 +24,7 @@ import Data.Semigroup (Sum(..)) -- import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade hiding (fromMaybe, singleton, bool) +-- import Colonnade hiding (fromMaybe, singleton, bool) -- import Yesod.Colonnade -- -- import qualified Data.UUID.Cryptographic as UUID @@ -40,25 +40,19 @@ import qualified Database.Esqueleto as E import Web.PathPieces import Text.Hamlet (ihamletFile) -import Text.Blaze.Html (preEscapedToHtml) import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI - -import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter) -import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.Writer (WriterT(..), runWriter) import Control.Monad.Trans.RWS (RWST) -import Control.Monad.Trans.State (State, StateT(..), runState) +import Control.Monad.Trans.State (State, runState) import qualified Control.Monad.State.Class as State import Data.Foldable (foldrM) -import Data.Traversable (for) @@ -131,16 +125,16 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp tid = course ^. _3 ssh = course ^. _4 link cid = CourseR tid ssh csh $ CUserR cid - cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> + protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> anchorCellM (link <$> encrypt userId) $ case mPseudo of Nothing -> nameWidget userDisplayName userSurname Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|] - in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let - cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) - in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) + in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> @@ -344,12 +338,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) when (not $ null unassigned) $ do - (assigned, unassigned) <- assignSubmissions shid (Just unassigned) + (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned) when (not $ null assigned) $ addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) - when (not $ null unassigned) $ do + when (not $ null stillUnassigned) $ do mr <- (toHtml . ) <$> getMessageRender - unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) + unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute @@ -501,19 +495,17 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (rated, ratingPoints, ratingComment) -> do + FormSuccess (rated, ratingPoints', ratingComment') -> do runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - - Submission{submissionRatingTime} <- getJust sub update sub [ SubmissionRatingBy =. (uid <$ guard rated) -- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload -- , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes? , SubmissionRatingTime =. (now <$ guard rated) - , SubmissionRatingPoints =. ratingPoints - , SubmissionRatingComment =. ratingComment + , SubmissionRatingPoints =. ratingPoints' + , SubmissionRatingComment =. ratingComment' ] addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated @@ -527,10 +519,10 @@ postCorrectionR tid ssh csh shn cid = do case uploadResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess fileSource -> do + FormSuccess fileUploads -> do uid <- requireAuthId - runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -612,10 +604,9 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, pss) -> do - now <- liftIO getCurrentTime runDB $ do Sheet{..} <- get404 sid - (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) + (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText now <- liftIO getCurrentTime let @@ -664,23 +655,18 @@ postCorrectionsCreateR = do E.where_ . E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) return $ submissionGroup E.^. SubmissionGroupId - case (groups :: [E.Value SubmissionGroupId]) of - [x] -> do - subId <- insert submission - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + if + | length (groups :: [E.Value SubmissionGroupId]) < 2 + -> do + subId <- insert submission + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } - [] -> do - subId <- insert submission - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc - _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc + when (null groups) $ + addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc + | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc NoGroups | [SheetPseudonym{sheetPseudonymUser}] <- spGroup -> do @@ -704,15 +690,15 @@ postCorrectionsCreateR = do defaultLayout $ do $(widgetFile "corrections-create") where - partition :: [[Either a b]] -> ([[b]], [a]) - partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) + partitionEithers' :: [[Either a b]] -> ([[b]], [a]) + partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]]) textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws) = let invalid :: [Text] valid :: [[Pseudonym]] - (valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws + (valid, invalid) = partitionEithers' $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws in case invalid of (i:_) -> return . Left $ MsgInvalidPseudonym i [] -> return $ Right valid diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c9262a2b6..89b6a9e86 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -2,9 +2,7 @@ module Handler.Course where import Import hiding (catMaybes) -import Control.Lens import Utils.Lens -import Utils.TH -- import Utils.DB import Handler.Utils import Handler.Utils.Table.Cells @@ -20,20 +18,15 @@ import qualified Data.Map as Map import qualified Data.CaseInsensitive as CI - -import Colonnade hiding (fromMaybe,bool) --- import Yesod.Colonnade - import qualified Database.Esqueleto as E -import qualified Data.UUID.Cryptographic as UUID -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] @@ -44,19 +37,19 @@ colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription = sortable Nothing (i18nCell MsgCourseDescription) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> case courseDescription of Nothing -> mempty (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) ( case courseDescription of Nothing -> mempty @@ -70,7 +63,7 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|] colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) @@ -85,24 +78,24 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty timeCell courseRegisterFrom -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> - cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> + maybe mempty timeCell courseRegisterTo colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of + $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of Nothing -> MsgCourseMembersCount currentParticipants - Just max -> MsgCourseMembersCountLimited currentParticipants max + Just limit -> MsgCourseMembersCountLimited currentParticipants limit colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered, _) } -> tickmarkCell registered + $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) @@ -326,7 +319,6 @@ getCourseNewR = do FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >> noTemplateAction FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do - uid <- requireAuthId oldCourses <- runDB $ do E.select $ E.from $ \course -> do whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid @@ -403,8 +395,8 @@ postCDeleteR = error "TODO: implement getCDeleteR" -- | Course Creation and Editing -- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing), -- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons! -courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html -courseEditHandler isGet mbCourseForm = do +courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html -- FIXME: _isGet is not used +courseEditHandler _isGet mbCourseForm = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm case result of @@ -451,7 +443,7 @@ courseEditHandler isGet mbCourseForm = do old <- get cid case old of Nothing -> addMessageI Error MsgInvalidInput $> False - (Just oldCourse) -> do + (Just _) -> do updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have Course { courseName = cfName res , courseDescription = cfDesc res @@ -598,18 +590,24 @@ validateCourse (CourseForm{..}) = getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCUsersR tid ssh csh = undefined -- TODO +getCUsersR = error "CUsersR: Not implemented" getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html -getCUserR tid ssh csh uuid = do - uid <- decrypt uuid +getCUserR _tid _ssh _csh uCId = do + -- Needs authorization check: + -- + -- - User is current member of course + -- - User has submitted in course + -- - User is member of registered group for course + -- - User is corrector for course (?) + -- - User is lecturer for course (?) + uid <- decrypt uCId User{..} <- runDB $ get404 uid - defaultLayout $ + defaultLayout $ -- TODO [whamlet| -
^{nameWidget userDisplayName userSurname} |] getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCHiWisR tid ssh csh = undefined -- TODO +getCHiWisR = error "CHiWisR: Not implemented" diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 8c93c4a17..03b0d3843 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -8,7 +8,6 @@ import qualified Data.Map as Map import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8') import Data.Time hiding (formatTime) -import Data.Universe import Data.Universe.Helpers import Network.Wai (requestHeaderReferer) diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 92f0d2ec0..9dad647e0 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -2,37 +2,9 @@ module Handler.School where import Import --- import Control.Lens --- import Utils.Lens --- import Utils.TH --- import Handler.Utils --- import Handler.Utils.Table.Cells --- --- -- import Data.Time --- import qualified Data.Text as T --- import Data.Function ((&)) --- -- import Yesod.Form.Bootstrap3 --- --- import qualified Data.Set as Set --- import qualified Data.Map as Map --- --- import Colonnade hiding (fromMaybe,bool) --- --- import qualified Database.Esqueleto as E --- --- import qualified Data.UUID.Cryptographic as UUID - - getSchoolListR :: Handler Html -getSchoolListR = do - -- muid <- maybeAuthId - defaultLayout $ do - [whamlet|TODO: Liste aller Institute |] -- TODO - +getSchoolListR = error "getSchoolListR: Not implemented" getSchoolShowR :: SchoolId -> Handler Html -getSchoolShowR ssh = do -- TODO - -- muid <- maybeAuthId - defaultLayout $ do - [whamlet|TODO: Informationen zu einem Institut |] -- TODO +getSchoolShowR = error "getSchoolShowR: Not implemented" diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 0a25a30a6..582344a3f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -31,7 +31,7 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT) -- import qualified Data.List as List -import Control.Monad.Trans.Except (ExceptT(..), runExceptT, mapExceptT, throwE) +import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE) import Network.Mime @@ -39,8 +39,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Map (Map, (!), (!?)) -import qualified Data.Map as Map +import Data.Map (Map, (!?)) import Data.Monoid (Sum(..), Any(..)) @@ -54,10 +53,6 @@ import Control.Monad.Random.Class (MonadRandom(..)) import Utils.Sql -instance Eq (Unique Sheet) where - (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = - cid1 == cid2 && name1 == name2 - {- * Implement Handlers * Implement Breadcrumbs in Foundation @@ -182,8 +177,8 @@ getSheetListR tid ssh csh = do (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid mkRoute = do - cid <- mkCid - return $ CSubmissionR tid ssh csh sheetName cid CorrectionR + cid' <- mkCid + return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) , sortable Nothing -- (Just "percent") @@ -218,7 +213,7 @@ getSheetListR tid ssh csh = do , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo ) , ( "rating" - , SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints + , SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints ) -- GitLab Issue $143: HOW TO SORT? -- , ( "percent" @@ -254,9 +249,7 @@ instance Button UniWorX ButtonGeneratePseudonym where -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do - entSheet <- runDB $ fetchSheet tid ssh csh shn - let sheet = entityVal entSheet - sid = entityKey entSheet + Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn -- without Colonnade -- fileNameTypes <- runDB $ E.select $ E.from $ -- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do @@ -270,19 +263,20 @@ getSShowR tid ssh csh shn = do -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes -- with Colonnade - let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do + let fileData (sheet' `E.InnerJoin` sheetFile `E.InnerJoin` file) = do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) - E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) + E.on (sheetFile E.^. SheetFileSheet E.==. sheet' E.^. SheetId) -- filter to requested file - E.where_ $ sheet E.^. SheetId E.==. E.val sid + E.where_ $ sheet' E.^. SheetId E.==. E.val sid E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) - , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName)) - (\(E.Value fName,_,_) -> str2widget fName) + , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell + (CSheetR tid ssh csh shn (SFileR fType fName)) + (str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def @@ -297,13 +291,13 @@ getSShowR tid ssh csh shn = do , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" - , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType + , SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType ) , ( "path" - , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle + , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) , ( "time" - , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified + , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) ] } @@ -329,7 +323,7 @@ getSShowR tid ssh csh shn = do solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet $(widgetFile "sheetShow") -postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent +getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSPseudonymR = postSPseudonymR postSPseudonymR tid ssh csh shn = do uid <- requireAuthId @@ -373,7 +367,6 @@ getSFileR tid ssh csh shn typ title = do ) -- return desired columns return $ (file E.^. FileTitle, file E.^. FileContent) - let mimeType = defaultMimeLookup $ pack title case results of [(E.Value fileTitle, E.Value fileContent)] | Just fileContent' <- fileContent -> do @@ -426,12 +419,10 @@ postSheetNewR = getSheetNewR getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSEditR tid ssh csh shn = do - (sheetEnt, sheetFileIds) <- runDB $ do + (Entity sid Sheet{..}, sheetFileIds) <- runDB $ do ent <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent return (ent, fti) - let sid = entityKey sheetEnt - let oldSheet@(Sheet {..}) = entityVal sheetEnt let template = Just $ SheetForm { sfName = sheetName , sfDescription = sheetDescription @@ -530,7 +521,6 @@ getSDelR tid ssh csh shn = do submissionno <- runDB $ do sid <- fetchSheetId tid ssh csh shn count [SubmissionSheet ==. sid] - let formTitle = MsgSheetDelHead tid ssh csh shn let formText = Just $ MsgSheetDelText submissionno let actionUrl = CSheetR tid ssh csh shn SDelR defaultLayout $ do @@ -605,7 +595,7 @@ correctorForm shid = do let guardNonDeleted :: UserId -> Handler (Maybe UserId) guardNonDeleted uid = do - cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser + CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del" return $ bool Just (const Nothing) (isJust deleted) uid formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) @@ -627,7 +617,7 @@ correctorForm shid = do let tutorField :: Field Handler [UserEmail] tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField - { fieldView = \theId name attrs val isReq -> asWidgetT $ do + { fieldView = \theId name attrs _val isReq -> asWidgetT $ do listIdent <- newIdent userId <- handlerToWidget requireAuthId previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do @@ -667,7 +657,7 @@ correctorForm shid = do let constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm constructFields (uid, uname, (state, Load{..})) = do - cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser + CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser let fs name = "" { fsName = Just $ tshow ciphertext <> "-" <> name @@ -722,7 +712,7 @@ correctorForm shid = do { fvLabel = text $ mr MsgCorrectors , fvTooltip = Nothing , fvId = "" - , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions + , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions' , fvErrors = Nothing , fvRequired = True } @@ -747,9 +737,9 @@ getSCorrR tid ssh csh shn = do case res of FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess res -> runDB $ do + FormSuccess res' -> runDB $ do deleteWhere [SheetCorrectorSheet ==. shid] - insertMany_ $ Set.toList res + insertMany_ $ Set.toList res' addMessageI Success MsgCorrectorsUpdated FormMissing -> return () diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 25cac807d..7c3b0d3ba 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -19,7 +19,6 @@ import Network.Mime import Data.Monoid (Any(..)) import Data.Maybe (fromJust) -- import qualified Data.Maybe -import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.CaseInsensitive (CI) @@ -51,11 +50,11 @@ import System.FilePath makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do let - fileUpload = case uploadMode of + fileUploadForm = case uploadMode of NoUpload -> pure Nothing (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing flip (renderAForm FormStandard) html $ (,) - <$> fileUpload + <$> fileUploadForm <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies @@ -138,6 +137,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) shid' <- submissionSheet <$> get404 smid + unless (shid == shid') $ + invalidArgsI [MsgSubmissionWrongSheet] -- fetch buddies from current submission (Any isOwner, buddies) <- do submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do @@ -212,7 +213,6 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do case res' of (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do - now <- liftIO $ getCurrentTime smid <- do smid <- case (mFiles, msmid) of (Nothing, Just smid) -- no new files, existing submission partners updated @@ -298,10 +298,10 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "path" - , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] + , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] ) , ( "time" - , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) + , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) ) ] , dbtFilter = Map.empty @@ -341,7 +341,6 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 return f - let fileName = Text.pack $ takeFileName path case results of [Entity _ File{ fileContent = Just c, fileTitle }] -> do whenM downloadFiles $ @@ -367,7 +366,7 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do rating <- lift $ getRating submissionID let - fileSource = case sfType of + fileSelect = case sfType of SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID @@ -376,7 +375,7 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do _ -> submissionFileSource submissionID fileSource' = do - fileSource .| Conduit.map entityVal + fileSelect .| Conduit.map entityVal when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 487b79331..647d1e273 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -68,23 +68,9 @@ postMessageR cID = do <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing <* submitButton - formResult modifyRes $ \SystemMessage{..} -> do - runDB $ update smId - [ SystemMessageFrom =. systemMessageFrom - , SystemMessageTo =. systemMessageTo - , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly - , SystemMessageSeverity =. systemMessageSeverity - , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage - , SystemMessageContent =. systemMessageContent - , SystemMessageSummary =. systemMessageSummary - ] - addMessageI Success MsgSystemMessageEditSuccess - redirect $ MessageR cID + formResult modifyRes $ modifySystemMessage smId - formResult addTransRes $ \smt -> do - runDB . void . insert $ smt - addMessageI Success MsgSystemMessageAddTranslationSuccess - redirect $ MessageR cID + formResult addTransRes addTranslation forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of [BtnDelete'] -> do @@ -127,7 +113,24 @@ postMessageR cID = do defaultLayout $ do $(widgetFile "system-message") + where + modifySystemMessage smId SystemMessage{..} = do + runDB $ update smId + [ SystemMessageFrom =. systemMessageFrom + , SystemMessageTo =. systemMessageTo + , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly + , SystemMessageSeverity =. systemMessageSeverity + , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage + , SystemMessageContent =. systemMessageContent + , SystemMessageSummary =. systemMessageSummary + ] + addMessageI Success MsgSystemMessageEditSuccess + redirect $ MessageR cID + addTranslation translation = do + runDB . void $ insert translation + addMessageI Success MsgSystemMessageAddTranslationSuccess + redirect $ MessageR cID type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation) @@ -223,8 +226,8 @@ postMessageListR = do runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ] $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet") redirect MessageListR - FormSuccess (_, selection) - | null selection -> addMessageI Error MsgSystemMessageEmptySelection + FormSuccess (_, _selection) -- prop> null _selection + -> addMessageI Error MsgSystemMessageEmptySelection ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 611a4cc9a..8507168e7 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -60,9 +60,9 @@ getTermShowR = do provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do let colonnadeTerms = widgetColonnade $ mconcat - [ sortable Nothing "Kürzel" $ - anchorCell' (\(Entity tid _, _) -> TermCourseListR tid) - (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|]) + [ sortable Nothing "Kürzel" $ \(Entity tid _, _) -> anchorCell + (TermCourseListR tid) + [whamlet|#{toPathPiece tid}|] , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) -> cell $ formatTime SelFormatDate termLectureStart >>= toWidget , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index dcacedadb..f5db92758 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -20,8 +20,6 @@ import qualified Data.Time.Format as Time import Data.Set (Set) import qualified Data.Set as Set -import Mail - utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime = TZ.utcToLocalTimeTZ appTZ diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc3d146fc..bdf9490d9 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -6,16 +6,12 @@ module Handler.Utils.Form import Utils.Form import Handler.Utils.Form.Types -import Handler.Utils.Templates import Handler.Utils.DateTime -import qualified Data.Time as Time import Import hiding (cons) import qualified Data.Char as Char -import Data.String (IsString(..)) -import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Foldable as Foldable @@ -32,10 +28,8 @@ import Handler.Utils.Zip import qualified Data.Conduit.List as C import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E import Data.Set (Set) -import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map @@ -287,7 +281,7 @@ multiFileField permittedFiles' = Field{..} mapM_ handleFile files .| C.map Right where doUnpack = unpackZips `elem` vals - fieldView fieldId fieldName attrs val req = do + fieldView fieldId fieldName _attrs val req = do pVals <- handlerToWidget permittedFiles' sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts let @@ -507,7 +501,7 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e - return $ map (\(cId, e@(Entity key value)) -> Option + return $ map (\(cId, e@(Entity _key value)) -> Option { optionDisplay = mr (toDisplay value) , optionInternalValue = e , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) @@ -575,7 +569,7 @@ multiAction acts defAction = do mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty widgets <- mapM mToWidget results let actionWidgets = Map.foldrWithKey accWidget [] widgets - accWidget act Nothing = id + accWidget _act Nothing = id accWidget act (Just w) = cons $(widgetFile "widgets/multiAction") actionResults = Map.map fst results return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect")) diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 4ade0952d..5c35dd4aa 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -4,7 +4,7 @@ module Handler.Utils.Mail , addFileDB ) where -import Import hiding ((.=)) +import Import import Utils.Lens hiding (snoc) diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index b5438b299..dc8bbc8dd 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -149,10 +149,10 @@ parseRating :: MonadThrow m => File -> m Rating' parseRating File{ fileContent = Just input, .. } = do inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input let - (headerLines', commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText - (reverse -> ratingLines, reverse -> headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' + (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText + (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' ratingLines' = filter (rating `Text.isInfixOf`) ratingLines - sep = "Beginn der Kommentare" + commentSep = "Beginn der Kommentare" sep' = Text.pack $ replicate 40 '=' rating = "Bewertung:" comment' <- case commentLines of @@ -162,7 +162,7 @@ parseRating File{ fileContent = Just input, .. } = do ratingComment | Text.null comment' = Nothing | otherwise = Just comment' - ratingLine' <- case ratingLines of + ratingLine' <- case ratingLines' of [l] -> return l _ -> throw RatingMultiple let diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 78f836f46..e6cbe3c37 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -9,13 +9,11 @@ module Handler.Utils.Submission , submissionMatchesSheet ) where -import Import hiding ((.=), joinPath) +import Import hiding (joinPath) import Jobs import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) -import Control.Lens -import Control.Lens.Extras (is) import Utils.Lens import Control.Monad.State hiding (forM_, mapM_,foldM) @@ -29,15 +27,12 @@ import Data.Maybe () import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map, (!?)) +import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Text as Text import Data.Ratio -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI - import Data.Monoid (Monoid, Any(..), Sum(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) @@ -49,7 +44,6 @@ import Handler.Utils.Submission.TH import qualified Database.Esqueleto as E -import Data.Conduit import qualified Data.Conduit.List as Conduit import Data.Conduit.ResumableSink @@ -76,7 +70,7 @@ assignSubmissions sid restriction = do Sheet{..} <- getJust sid correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] let - byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] + -- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto corrsProp = filter hasPositiveLoad correctors countsToLoad' :: UserId -> Bool @@ -118,7 +112,7 @@ assignSubmissions sid restriction = do let prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do - (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs + (Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs guard $ maybe True (not isByTutorial ||) byTutorial let proportion | CorrectorExcused <- sheetCorrectorState = 0 @@ -311,9 +305,9 @@ extractRatingsMsg :: ( MonadHandler m ) => Conduit File m SubmissionContent extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings - let ignored :: Set (Either CryptoFileNameSubmission FilePath) - ignored = Right `Set.map` ignored' - unless (null ignored) $ do + let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath) + ignoredFiles = Right `Set.map` ignored' + unless (null ignoredFiles) $ do mr <- (toHtml . ) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) @@ -346,20 +340,19 @@ sinkSubmission userId mExists isUpdate = do return sId Right sId -> return sId - sId <$ sinkSubmission' sId isUpdate + sId <$ sinkSubmission' sId where - tell = modify . mappend + tellSt = modify . mappend sinkSubmission' :: SubmissionId - -> Bool -- ^ Is this a correction -> Sink SubmissionContent (YesodJobDB UniWorX) () - sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case + sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) alreadySeen <- gets (Set.member fileTitle . sinkFilenames) when alreadySeen . throwM $ DuplicateFileTitle fileTitle - tell $ mempty{ sinkFilenames = Set.singleton fileTitle } + tellSt $ mempty{ sinkFilenames = Set.singleton fileTitle } otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId @@ -411,7 +404,7 @@ sinkSubmission userId mExists isUpdate = do alreadySeen <- gets $ getAny . sinkSeenRating when alreadySeen $ throwM DuplicateRating - tell $ mempty{ sinkSeenRating = Any True } + tellSt $ mempty{ sinkSeenRating = Any True } unless isUpdate $ throwM RatingWithoutUpdate @@ -459,10 +452,10 @@ sinkSubmission userId mExists isUpdate = do False -> lift . insert_ $ SubmissionEdit userId now submissionId True -> do Submission{submissionRatingTime} <- lift $ getJust submissionId - when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True } + when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] -- TODO: Should submissionRatingAssigned change here if userId changes? - tell $ mempty{ sinkSubmissionTouched = Any True } + tellSt $ mempty{ sinkSubmissionTouched = Any True } finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize SubmissionSinkState{..} = do @@ -515,9 +508,9 @@ sinkSubmission userId mExists isUpdate = do data SubmissionMultiSinkException = SubmissionSinkException - { submissionSinkId :: CryptoFileNameSubmission - , submissionSinkFedFile :: Maybe FilePath - , submissionSinkException :: SubmissionSinkException + { _submissionSinkId :: CryptoFileNameSubmission + , _submissionSinkFedFile :: Maybe FilePath + , _submissionSinkException :: SubmissionSinkException } deriving (Typeable, Show) @@ -559,7 +552,7 @@ sinkMultiSubmission userId isUpdate = do case sink' of Left _ -> error "sinkSubmission returned prematurely" Right nSink -> modify $ Map.insert sId nSink - (sinks, ignored) <- execRWSLC () Map.empty . awaitForever $ \case + (sinks, ignoredFiles) <- execRWSLC () Map.empty . awaitForever $ \case v@(Right (sId, _)) -> do cID <- encrypt sId $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID @@ -586,7 +579,7 @@ sinkMultiSubmission userId isUpdate = do cID <- encrypt sId handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ lift . feed sId $ Left f{ fileTitle = fileTitle' } - when (not $ null ignored) $ do + when (not $ 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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index f36fba523..550aca3ca 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -27,13 +27,10 @@ module Handler.Utils.Table.Pagination import Handler.Utils.Table.Pagination.Types import Utils.Lens.TH -import Import +import Import hiding (pi) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Language as E (From) -import Text.Blaze (Attribute) -import qualified Text.Blaze.Html5.Attributes as Html5 -import qualified Text.Blaze.Html5 as Html5 import qualified Data.Binary.Builder as Builder @@ -42,8 +39,8 @@ import qualified Network.Wai as Wai import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) -import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_) +import Control.Monad.RWS hiding ((<>), mapM_, forM_) +import Control.Monad.Writer hiding ((<>), mapM_, forM_) import Control.Monad.Reader (ReaderT(..), mapReaderT) import Control.Monad.Trans.Maybe @@ -52,8 +49,6 @@ import Data.Foldable (Foldable(foldMap)) import Data.Map (Map, (!)) import qualified Data.Map as Map -import Data.Profunctor (lmap) - import Colonnade hiding (bool, fromMaybe, singleton) import qualified Colonnade (singleton) import Colonnade.Encode @@ -64,8 +59,6 @@ import Data.Ratio ((%)) import Control.Lens -import Data.Proxy - data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } @@ -103,9 +96,9 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon where (input, ($ []) -> is') = go (mempty, id) is go acc [] = acc - go (acc, is') (i:is) - | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is - | otherwise = go (acc, is' . (i:)) is + go (acc, is3) (i:is2) + | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2 + | otherwise = go (acc, is3 . (i:)) is2 data PaginationSettings = PaginationSettings { psSorting :: [(CI Text, SortDirection)] @@ -181,26 +174,26 @@ instance Default (PSValidator m x) where asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s }) defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x -defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable +defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' where injectDefault x = case x >>= piFilter of Just _ -> id Nothing -> set (_2._psFilter) psFilter defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x -defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable +defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable' where injectDefault x = case x >>= piSorting of Just _ -> id Nothing -> set (_2._psSorting) psSorting restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x -restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps +restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps where restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p } restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x -restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps +restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps where restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } @@ -319,8 +312,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) - dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost - dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf + dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost + dbHandler _ f form = return $ \csrf -> over _2 f <$> form csrf -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) @@ -343,7 +336,6 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), , d <- [SortAsc, SortDesc] , let t' = CI.foldedCase t <> "-" <> toPathPiece d ] - (_, defPS) = runPSValidator dbtable Nothing wIdent n | not $ null dbtIdent = dbtIdent <> "-" <> n | otherwise = n @@ -352,7 +344,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), | otherwise = dbsAttrs multiTextField = Field { fieldParse = \ts _ -> return . Right $ Just ts - , fieldView = undefined + , fieldView = error "multiTextField: should not be rendered" , fieldEnctype = UrlEncoded } @@ -373,7 +365,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), (errs, PaginationSettings{..}) = case psResult of FormSuccess pi | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi - FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing + FormFailure errs' -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing _ -> runPSValidator dbtable Nothing psSorting' = map (first (dbtSorting !)) psSorting sqlQuery' = E.from $ \t -> dbtSQLQuery t @@ -417,9 +409,9 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable - wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do - widget <- cell ^. cellContents - let attrs = cell ^. cellAttrs + wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do + widget <- cell' ^. cellContents + let attrs = cell' ^. cellAttrs return $(widgetFile "table/cell/body") let table = $(widgetFile "table/colonnade") @@ -480,7 +472,7 @@ tickmarkCell True = textCell (tickmark :: Text) tickmarkCell False = mempty cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a -cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt) +cellTooltip msg = cellContents.mapped %~ (<> tipWdgt) where tipWdgt = [whamlet|