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

Fix warnings

Browse Source
This commit is contained in:
Gregor Kleen 2018-11-01 22:06:00 +01:00
parent 73a00e5731
commit 9ccc2e3149
39 changed files with 331 additions and 400 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
package.yaml
View File

@ -156,24 +156,35 @@ default-extensions:
- BinaryLiterals - BinaryLiterals
- PolyKinds - PolyKinds
ghc-options: when:
- -Wall - condition: flag(pedantic)
- -fwarn-tabs 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 # The library contains all of our application code. The executable
# defined below is just a thin wrapper. # defined below is just a thin wrapper.
library: library:
source-dirs: src source-dirs: src
when: when:
- condition: (flag(dev)) || (flag(library-only)) - condition: (flag(dev)) || (flag(library-only))
then: then:
ghc-options: ghc-options:
- -O0 - -O0
- -ddump-splices - -ddump-splices
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT
else: else:
ghc-options: ghc-options:
- -O2 - -O2
# Runnable executable for our application # Runnable executable for our application
executables: executables:
@ -219,3 +230,7 @@ flags:
description: Turn on development settings, like auto-reload templates. description: Turn on development settings, like auto-reload templates.
manual: false manual: false
default: false default: false
pedantic:
description: Be very pedantic about warnings and errors
manual: true
default: true

6
routes
View File

@ -50,8 +50,8 @@
!/term/#TermId TermCourseListR GET !free !/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/school SchoolListR GET /school SchoolListR GET !development
/school/#SchoolId SchoolShowR GET /school/#SchoolId SchoolShowR GET !development
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation
@ -64,7 +64,7 @@
/edit CEditR GET POST /edit CEditR GET POST
/delete CDeleteR GET POST !lecturerANDempty /delete CDeleteR GET POST !lecturerANDempty
/users CUsersR GET /users CUsersR GET
/user/#CryptoUUIDUser CUserR GET /user/#CryptoUUIDUser CUserR GET !development
/correctors CHiWisR GET /correctors CHiWisR GET
/subs CCorrectionsR GET POST /subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials /ex SheetListR GET !registered !materials

111
src/Cron.hs
View File

@ -1,5 +1,6 @@
module Cron module Cron
( CronNextMatch(..) ( evalCronMatch
, CronNextMatch(..)
, nextCronMatch , nextCronMatch
, module Cron.Types , module Cron.Types
) where ) where
@ -18,11 +19,7 @@ import Data.Ratio ((%))
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.List.NonEmpty (NonEmpty(..)) import Utils.Lens hiding (from, to)
import qualified Data.List.NonEmpty as NonEmpty
import Utils.Lens.TH
import Control.Lens
data CronDate = CronDate data CronDate = CronDate
@ -38,7 +35,7 @@ makeLenses_ ''CronDate
evalCronMatch :: CronMatch -> Natural -> Bool evalCronMatch :: CronMatch -> Natural -> Bool
evalCronMatch CronMatchAny _ = True evalCronMatch CronMatchAny _ = True
evalCronMatch CronMatchNone _ = False 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 (CronMatchStep step) x = (x `mod` step) == 0
evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to
evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x
@ -115,7 +112,7 @@ genMatch :: Int -- ^ Period
-> [Natural] -> [Natural]
genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..] genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
genMatch _ _ _ CronMatchNone = [] 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 genMatch p m st (CronMatchStep step) = do
start <- [st..st + step] start <- [st..st + step]
guard $ (start `mod` step) == 0 guard $ (start `mod` step) == 0
@ -135,9 +132,9 @@ genMatch p m st (CronMatchIntersect aGen bGen)
mergeAnd [] _ = [] mergeAnd [] _ = []
mergeAnd _ [] = [] mergeAnd _ [] = []
mergeAnd (a:as) (b:bs) mergeAnd (a:as) (b:bs)
| a < b = mergeAnd as (b:bs) | a < b = mergeAnd as (b:bs)
| a == b = a : mergeAnd as bs | a == b = a : mergeAnd as bs
| a > b = mergeAnd (a:as) bs | otherwise = mergeAnd (a:as) bs
genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other 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 other CronMatchNone) = genMatch p m st other
genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny 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 [] bs = bs
merge as [] = as merge as [] = as
merge (a:as) (b:bs) merge (a:as) (b:bs)
| a < b = a : merge as (b:bs) | a < b = a : merge as (b:bs)
| a == b = a : merge as bs | a == b = a : merge as bs
| a > b = b : merge (a:as) bs | otherwise = b : merge (a:as) bs
nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
-> Maybe UTCTime -- ^ Time of last execution of the job -> Maybe UTCTime -- ^ Time of last execution of the job
@ -166,7 +163,6 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
| otherwise -> MatchNone | otherwise -> MatchNone
MatchNone -> nextMatch MatchNone -> nextMatch
where where
nextMatch = nextCronMatch' tz mPrev now c
notAfter notAfter
| Right c' <- cronNotAfter | Right c' <- cronNotAfter
, Just ref <- notAfterRef , Just ref <- notAfterRef
@ -178,34 +174,34 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
notAfterRef notAfterRef
| Just prevT <- mPrev = Just prevT | Just prevT <- mPrev = Just prevT
| otherwise = case execRef' now False cronInitial of | otherwise = case execRef' now False cronInitial of
MatchAsap -> error "execRef' should not return MatchAsap"
MatchAt t -> Just t MatchAt t -> Just t
MatchNone -> Nothing MatchNone -> Nothing
nextMatch = case mPrev of
nextCronMatch' tz mPrev now c@Cron{..} Nothing
| isNothing mPrev -> execRef now False cronInitial
= execRef now False cronInitial Just prevT
| Just prevT <- mPrev -> case cronRepeat of
= case cronRepeat of CronRepeatOnChange
CronRepeatOnChange | not $ matchesCron tz Nothing prevT c
| not $ matchesCron tz Nothing prevT c -> let
-> let cutoffTime = addUTCTime cronRateLimit prevT
cutoffTime = addUTCTime cronRateLimit prevT in case execRef now False cronInitial of
in case execRef now False cronInitial of MatchAsap
MatchAsap | now < cutoffTime -> MatchAt cutoffTime
| now < cutoffTime -> MatchAt cutoffTime MatchAt ts
MatchAt ts | ts < cutoffTime -> MatchAt cutoffTime
| ts < cutoffTime -> MatchAt cutoffTime other -> other
other -> other CronRepeatScheduled cronNext
CronRepeatScheduled cronNext -> case cronNext of
-> case cronNext of CronAsap
CronAsap | addUTCTime cronRateLimit prevT <= now
| addUTCTime cronRateLimit prevT <= now -> MatchAsap
-> MatchAsap | otherwise
| otherwise -> MatchAt $ addUTCTime cronRateLimit prevT
-> MatchAt $ addUTCTime cronRateLimit prevT _other
cronNext -> execRef (addUTCTime cronRateLimit prevT) True cronNext
-> execRef (addUTCTime cronRateLimit prevT) True cronNext _other -> MatchNone
_other -> MatchNone
execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
MatchAt t MatchAt t
@ -219,19 +215,26 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
| otherwise -> MatchNone | otherwise -> MatchNone
CronCalendar{..} -> listToMatch $ do CronCalendar{..} -> listToMatch $ do
let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
cronYear <- genMatch 400 False cdYear cronYear
cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear mCronYear <- genMatch 400 False cdYear cronYear
cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
cronMonth <- genMatch 12 True cdMonth cronMonth mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth mCronMonth <- genMatch 12 True cdMonth cronMonth
cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
cronHour <- genMatch 24 True cdHour cronHour mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
cronMinute <- genMatch 60 True cdMinute cronMinute mCronHour <- genMatch 24 True cdHour cronHour
cronSecond <- genMatch 60 True cdSecond cronSecond mCronMinute <- genMatch 60 True cdMinute cronMinute
guard $ consistentCronDate CronDate{..} mCronSecond <- genMatch 60 True cdSecond cronSecond
localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) guard $ consistentCronDate CronDate
let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) { 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{..} return $ localTimeToUTCTZ tz LocalTime{..}
CronNotScheduled -> MatchNone CronNotScheduled -> MatchNone

76
src/Foundation.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
module Foundation where module Foundation where
@ -10,20 +11,18 @@ import Text.Jasmine (minifym)
import qualified Web.ClientSession as ClientSession import qualified Web.ClientSession as ClientSession
import Yesod.Auth.Message import Yesod.Auth.Message
import Yesod.Auth.Dummy
import Auth.LDAP import Auth.LDAP
import Auth.PWHash import Auth.PWHash
import Auth.Dummy import Auth.Dummy
import Jobs.Types 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.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
import qualified Data.CryptoID as E import qualified Data.CryptoID as E
@ -40,12 +39,10 @@ import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Data.List (foldr1) import Data.List (foldr1)
import qualified Data.List as List
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Map (Map, (!?)) import Data.Map (Map, (!?))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.List (findIndex)
import Data.Monoid (Any(..)) 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.Reader (runReader, mapReaderT)
import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Trans.Writer (WriterT(..))
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch (handleAll)
import qualified Control.Monad.Catch as C import qualified Control.Monad.Catch as C
import System.FilePath
import Handler.Utils.Templates
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Control.Lens import Control.Lens
import Utils
import Utils.Form import Utils.Form
import Utils.Lens
import Utils.SystemMessage import Utils.SystemMessage
import Data.Aeson hiding (Error, Success) import Data.Aeson hiding (Error, Success)
import Data.Aeson.TH
import qualified Data.Yaml as Yaml
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
@ -147,9 +136,11 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils
type MailM a = MailT (HandlerT UniWorX IO) a type MailM a = MailT (HandlerT UniWorX IO) a
-- Pattern Synonyms for convenience -- Pattern Synonyms for convenience
pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX
pattern CSheetR tid ssh csh shn ptn pattern CSheetR tid ssh csh shn ptn
= CourseR tid ssh csh (SheetR 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 pattern CSubmissionR tid ssh csh shn cid ptn
= CSheetR tid ssh csh shn (SubmissionR cid ptn) = CSheetR tid ssh csh shn (SubmissionR cid ptn)
@ -212,9 +203,10 @@ instance RenderMessage UniWorX Load where
newtype MsgLanguage = MsgLanguage Lang newtype MsgLanguage = MsgLanguage Lang
deriving (Eq, Ord, Show, Read) deriving (Eq, Ord, Show, Read)
instance RenderMessage UniWorX MsgLanguage where instance RenderMessage UniWorX MsgLanguage where
renderMessage foundation ls (MsgLanguage lang) renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang'))
| lang == "de-DE" = mr MsgGermanGermany | ["de", "DE"] <- lang' = mr MsgGermanGermany
| "de" `isPrefixOf` lang = mr MsgGerman | ("de" : _) <- lang' = mr MsgGerman
| otherwise = lang
where where
mr = renderMessage foundation ls mr = renderMessage foundation ls
@ -280,8 +272,8 @@ orAR _ _ AuthenticationRequired = AuthenticationRequired
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
-- and -- and
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
andAR _ reason@(Unauthorized x) _ = reason andAR _ reason@(Unauthorized _) _ = reason
andAR _ _ reason@(Unauthorized x) = reason andAR _ _ reason@(Unauthorized _) = reason
andAR _ Authorized other = other andAR _ Authorized other = other
andAR _ AuthenticationRequired _ = AuthenticationRequired andAR _ AuthenticationRequired _ = AuthenticationRequired
@ -338,6 +330,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
allow <- appAllowDeprecated . appSettings <$> getYesod allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow 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 ,("lecturer", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@ -406,7 +406,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do 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 cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= 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 MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime && NTop systemMessageTo >= cTime
@ -617,14 +617,14 @@ instance Yesod UniWorX where
errPage = case err of errPage = case err of
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|] NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
InternalError err -> encrypted err [whamlet|<p .errMsg>#{err}|] InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
InvalidArgs errs -> [whamlet| InvalidArgs errs -> [whamlet|
<ul> <ul>
$forall err <- errs $forall err' <- errs
<li .errMsg>#{err} <li .errMsg>#{err'}
|] |]
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|] NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
PermissionDenied err -> [whamlet|<p .errMsg>#{err}|] PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do
toWidget toWidget
@ -746,8 +746,8 @@ siteLayout headingOverride widget = do
asidenav = $(widgetFile "widgets/asidenav") asidenav = $(widgetFile "widgets/asidenav")
contentHeadline :: Maybe Widget contentHeadline :: Maybe Widget
contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute) contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute)
breadcrumbs :: Widget breadcrumbsWgt :: Widget
breadcrumbs = $(widgetFile "widgets/breadcrumbs") breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs")
pageactionprime :: Widget pageactionprime :: Widget
pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
-- functions to determine if there are page-actions (primary or secondary) -- functions to determine if there are page-actions (primary or secondary)
@ -786,11 +786,13 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .|
where where
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
cID <- encrypt smId cID <- encrypt smId
void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
let sessionKey = "sm-" <> tshow (ciphertext cID) 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 () setSessionJson sessionKey ()
(SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
(_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
let let
(summary, content) = case smTrans of (summary, content) = case smTrans of
Nothing -> (systemMessageSummary, systemMessageContent) Nothing -> (systemMessageSummary, systemMessageContent)
@ -1177,11 +1179,12 @@ pageActions (CorrectionsR) =
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = runDB $ do , menuItemAccessCallback' = runDB $ do
uid <- liftHandlerT requireAuthId 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.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
return E.countRows return E.countRows
return $ (count :: Int) /= 0 return $ (corrCount :: Int) /= 0
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Korrekturen eintragen" { menuItemLabel = "Korrekturen eintragen"
@ -1206,11 +1209,12 @@ pageActions (CorrectionsGradeR) =
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = runDB $ do , menuItemAccessCallback' = runDB $ do
uid <- liftHandlerT requireAuthId 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.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
return E.countRows return E.countRows
return $ (count :: Int) /= 0 return $ (corrCount :: Int) /= 0
} }
] ]
pageActions _ = [] pageActions _ = []
@ -1287,7 +1291,7 @@ pageHeading (CSheetR tid ssh csh shn SEditR)
= Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SDelR) pageHeading (CSheetR tid ssh csh shn SDelR)
= Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn = 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 = Just $ i18nHeading $ MsgSubmissionsSheet shn
pageHeading (CSheetR tid ssh csh shn SubmissionNewR) pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
= Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn = 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) pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
= Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -- (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 = Just $ i18nHeading $ MsgCorrectorsHead shn
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
@ -1542,7 +1546,7 @@ instance YesodMail UniWorX where
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
withResource pool act withResource pool act
mailT ctx mail = defMailT ctx $ do mailT ctx mail = defMailT ctx $ do
setMailObjectId void setMailObjectId
setDateCurrent setDateCurrent
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"

70
src/Handler/Corrections.hs
View File

@ -24,7 +24,7 @@ import Data.Semigroup (Sum(..))
-- import qualified Data.Text as T -- import qualified Data.Text as T
-- import Data.Function ((&)) -- import Data.Function ((&))
-- --
import Colonnade hiding (fromMaybe, singleton, bool) -- import Colonnade hiding (fromMaybe, singleton, bool)
-- import Yesod.Colonnade -- import Yesod.Colonnade
-- --
-- import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.UUID.Cryptographic as UUID
@ -40,25 +40,19 @@ import qualified Database.Esqueleto as E
import Web.PathPieces import Web.PathPieces
import Text.Hamlet (ihamletFile) import Text.Hamlet (ihamletFile)
import Text.Blaze.Html (preEscapedToHtml)
import Database.Persist.Sql (updateWhereCount) import Database.Persist.Sql (updateWhereCount)
import Data.List (genericLength) import Data.List (genericLength)
import Data.CaseInsensitive (CI) import Control.Monad.Trans.Writer (WriterT(..), runWriter)
import qualified Data.CaseInsensitive as CI
import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.RWS (RWST) 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 qualified Control.Monad.State.Class as State
import Data.Foldable (foldrM) import Data.Foldable (foldrM)
import Data.Traversable (for)
@ -131,16 +125,16 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
tid = course ^. _3 tid = course ^. _3
ssh = course ^. _4 ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid 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 anchorCellM (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|] Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|]
in 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 :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> 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) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
when (not $ null unassigned) $ do when (not $ null unassigned) $ do
(assigned, unassigned) <- assignSubmissions shid (Just unassigned) (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
when (not $ null assigned) $ when (not $ null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
when (not $ null unassigned) $ do when (not $ null stillUnassigned) $ do
mr <- (toHtml . ) <$> getMessageRender 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) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute redirect currentRoute
@ -501,19 +495,17 @@ postCorrectionR tid ssh csh shn cid = do
case corrResult of case corrResult of
FormMissing -> return () FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (rated, ratingPoints, ratingComment) -> do FormSuccess (rated, ratingPoints', ratingComment') -> do
runDBJobs $ do runDBJobs $ do
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
Submission{submissionRatingTime} <- getJust sub
update sub [ SubmissionRatingBy =. (uid <$ guard rated) update sub [ SubmissionRatingBy =. (uid <$ guard rated)
-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload -- 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? -- , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
, SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints , SubmissionRatingPoints =. ratingPoints'
, SubmissionRatingComment =. ratingComment , SubmissionRatingComment =. ratingComment'
] ]
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
@ -527,10 +519,10 @@ postCorrectionR tid ssh csh shn cid = do
case uploadResult of case uploadResult of
FormMissing -> return () FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess fileSource -> do FormSuccess fileUploads -> do
uid <- requireAuthId 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 addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@ -612,10 +604,9 @@ postCorrectionsCreateR = do
FormMissing -> return () FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, pss) -> do FormSuccess (sid, pss) -> do
now <- liftIO getCurrentTime
runDB $ do runDB $ do
Sheet{..} <- get404 sid 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 forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
@ -664,23 +655,18 @@ postCorrectionsCreateR = do
E.where_ . E.exists . E.from $ \submissionGroupUser -> E.where_ . E.exists . E.from $ \submissionGroupUser ->
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
return $ submissionGroup E.^. SubmissionGroupId return $ submissionGroup E.^. SubmissionGroupId
case (groups :: [E.Value SubmissionGroupId]) of if
[x] -> do | length (groups :: [E.Value SubmissionGroupId]) < 2
subId <- insert submission -> do
void . insert $ SubmissionEdit uid now subId subId <- insert submission
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser { submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId , submissionUserSubmission = subId
} }
[] -> do when (null groups) $
subId <- insert submission addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
void . insert $ SubmissionEdit uid now subId | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
_ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
NoGroups NoGroups
| [SheetPseudonym{sheetPseudonymUser}] <- spGroup | [SheetPseudonym{sheetPseudonymUser}] <- spGroup
-> do -> do
@ -704,15 +690,15 @@ postCorrectionsCreateR = do
defaultLayout $ do defaultLayout $ do
$(widgetFile "corrections-create") $(widgetFile "corrections-create")
where where
partition :: [[Either a b]] -> ([[b]], [a]) partitionEithers' :: [[Either a b]] -> ([[b]], [a])
partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]]) textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws) textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
= let = let
invalid :: [Text] invalid :: [Text]
valid :: [[Pseudonym]] 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 in case invalid of
(i:_) -> return . Left $ MsgInvalidPseudonym i (i:_) -> return . Left $ MsgInvalidPseudonym i
[] -> return $ Right valid [] -> return $ Right valid

56
src/Handler/Course.hs
View File

@ -2,9 +2,7 @@ module Handler.Course where
import Import hiding (catMaybes) import Import hiding (catMaybes)
import Control.Lens
import Utils.Lens import Utils.Lens
import Utils.TH
-- import Utils.DB -- import Utils.DB
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
@ -20,20 +18,15 @@ import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Colonnade hiding (fromMaybe,bool)
-- import Yesod.Colonnade
import qualified Database.Esqueleto as E 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. -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|#{display courseName}|] [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 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing (i18nCell MsgCourseDescription) colDescription = sortable Nothing (i18nCell MsgCourseDescription)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
case courseDescription of case courseDescription of
Nothing -> mempty Nothing -> mempty
(Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr) (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr)
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) 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}|] ) ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
( case courseDescription of ( case courseDescription of
Nothing -> mempty Nothing -> mempty
@ -70,7 +63,7 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm) colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|] anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) 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 :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
maybe mempty timeCell courseRegisterFrom maybe mempty timeCell courseRegisterFrom
-- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget maybe mempty timeCell courseRegisterTo
colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers) 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 Nothing -> MsgCourseMembersCount currentParticipants
Just max -> MsgCourseMembersCountLimited currentParticipants max Just limit -> MsgCourseMembersCountLimited currentParticipants limit
colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) 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) 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) >> FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
noTemplateAction noTemplateAction
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
uid <- requireAuthId
oldCourses <- runDB $ do oldCourses <- runDB $ do
E.select $ E.from $ \course -> do E.select $ E.from $ \course -> do
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid 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 -- | Course Creation and Editing
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing), -- | 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! -- | 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 :: Bool -> Maybe CourseForm -> Handler Html -- FIXME: _isGet is not used
courseEditHandler isGet mbCourseForm = do courseEditHandler _isGet mbCourseForm = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
case result of case result of
@ -451,7 +443,7 @@ courseEditHandler isGet mbCourseForm = do
old <- get cid old <- get cid
case old of case old of
Nothing -> addMessageI Error MsgInvalidInput $> False Nothing -> addMessageI Error MsgInvalidInput $> False
(Just oldCourse) -> do (Just _) -> do
updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
Course { courseName = cfName res Course { courseName = cfName res
, courseDescription = cfDesc res , courseDescription = cfDesc res
@ -598,18 +590,24 @@ validateCourse (CourseForm{..}) =
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html 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 :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR tid ssh csh uuid = do getCUserR _tid _ssh _csh uCId = do
uid <- decrypt uuid -- 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 User{..} <- runDB $ get404 uid
defaultLayout $ defaultLayout $ -- TODO
[whamlet| [whamlet|
<h1>TODO <p>^{nameWidget userDisplayName userSurname}
<h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
|] |]
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCHiWisR tid ssh csh = undefined -- TODO getCHiWisR = error "CHiWisR: Not implemented"

1
src/Handler/Home.hs
View File

@ -8,7 +8,6 @@ import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8') import Data.Text.Encoding (decodeUtf8')
import Data.Time hiding (formatTime) import Data.Time hiding (formatTime)
import Data.Universe
import Data.Universe.Helpers import Data.Universe.Helpers
import Network.Wai (requestHeaderReferer) import Network.Wai (requestHeaderReferer)

32
src/Handler/School.hs
View File

@ -2,37 +2,9 @@ module Handler.School where
import Import 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 :: Handler Html
getSchoolListR = do getSchoolListR = error "getSchoolListR: Not implemented"
-- muid <- maybeAuthId
defaultLayout $ do
[whamlet|TODO: Liste aller Institute |] -- TODO
getSchoolShowR :: SchoolId -> Handler Html getSchoolShowR :: SchoolId -> Handler Html
getSchoolShowR ssh = do -- TODO getSchoolShowR = error "getSchoolShowR: Not implemented"
-- muid <- maybeAuthId
defaultLayout $ do
[whamlet|TODO: Informationen zu einem Institut |] -- TODO

56
src/Handler/Sheet.hs
View File

@ -31,7 +31,7 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
-- import qualified Data.List as List -- 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 import Network.Mime
@ -39,8 +39,7 @@ import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Map (Map, (!), (!?)) import Data.Map (Map, (!?))
import qualified Data.Map as Map
import Data.Monoid (Sum(..), Any(..)) import Data.Monoid (Sum(..), Any(..))
@ -54,10 +53,6 @@ import Control.Monad.Random.Class (MonadRandom(..))
import Utils.Sql import Utils.Sql
instance Eq (Unique Sheet) where
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
cid1 == cid2 && name1 == name2
{- {-
* Implement Handlers * Implement Handlers
* Implement Breadcrumbs in Foundation * Implement Breadcrumbs in Foundation
@ -182,8 +177,8 @@ getSheetListR tid ssh csh = do
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid let mkCid = encrypt sid
mkRoute = do mkRoute = do
cid <- mkCid cid' <- mkCid
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
, sortable Nothing -- (Just "percent") , sortable Nothing -- (Just "percent")
@ -218,7 +213,7 @@ getSheetListR tid ssh csh = do
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
) )
, ( "rating" , ( "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? -- GitLab Issue $143: HOW TO SORT?
-- , ( "percent" -- , ( "percent"
@ -254,9 +249,7 @@ instance Button UniWorX ButtonGeneratePseudonym where
-- Show single sheet -- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do getSShowR tid ssh csh shn = do
entSheet <- runDB $ fetchSheet tid ssh csh shn Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
let sheet = entityVal entSheet
sid = entityKey entSheet
-- without Colonnade -- without Colonnade
-- fileNameTypes <- runDB $ E.select $ E.from $ -- fileNameTypes <- runDB $ E.select $ E.from $
-- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- \(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 -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade -- 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 -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) 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 -- 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) E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
-- return desired columns -- return desired columns
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) [ 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)) , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
(\(E.Value fName,_,_) -> str2widget fName) (CSheetR tid ssh csh shn (SFileR fType fName))
(str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
] ]
let psValidator = def let psValidator = def
@ -297,13 +291,13 @@ getSShowR tid ssh csh shn = do
, dbtIdent = "files" :: Text , dbtIdent = "files" :: Text
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "type" [ ( "type"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType , SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
) )
, ( "path" , ( "path"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
) )
, ( "time" , ( "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 solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow") $(widgetFile "sheetShow")
postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSPseudonymR = postSPseudonymR getSPseudonymR = postSPseudonymR
postSPseudonymR tid ssh csh shn = do postSPseudonymR tid ssh csh shn = do
uid <- requireAuthId uid <- requireAuthId
@ -373,7 +367,6 @@ getSFileR tid ssh csh shn typ title = do
) )
-- return desired columns -- return desired columns
return $ (file E.^. FileTitle, file E.^. FileContent) return $ (file E.^. FileTitle, file E.^. FileContent)
let mimeType = defaultMimeLookup $ pack title
case results of case results of
[(E.Value fileTitle, E.Value fileContent)] [(E.Value fileTitle, E.Value fileContent)]
| Just fileContent' <- fileContent -> do | Just fileContent' <- fileContent -> do
@ -426,12 +419,10 @@ postSheetNewR = getSheetNewR
getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid ssh csh shn = do getSEditR tid ssh csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do (Entity sid Sheet{..}, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid ssh csh shn ent <- fetchSheet tid ssh csh shn
fti <- getFtIdMap $ entityKey ent fti <- getFtIdMap $ entityKey ent
return (ent, fti) return (ent, fti)
let sid = entityKey sheetEnt
let oldSheet@(Sheet {..}) = entityVal sheetEnt
let template = Just $ SheetForm let template = Just $ SheetForm
{ sfName = sheetName { sfName = sheetName
, sfDescription = sheetDescription , sfDescription = sheetDescription
@ -530,7 +521,6 @@ getSDelR tid ssh csh shn = do
submissionno <- runDB $ do submissionno <- runDB $ do
sid <- fetchSheetId tid ssh csh shn sid <- fetchSheetId tid ssh csh shn
count [SubmissionSheet ==. sid] count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelHead tid ssh csh shn
let formText = Just $ MsgSheetDelText submissionno let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid ssh csh shn SDelR let actionUrl = CSheetR tid ssh csh shn SDelR
defaultLayout $ do defaultLayout $ do
@ -605,7 +595,7 @@ correctorForm shid = do
let let
guardNonDeleted :: UserId -> Handler (Maybe UserId) guardNonDeleted :: UserId -> Handler (Maybe UserId)
guardNonDeleted uid = do guardNonDeleted uid = do
cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del" deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
return $ bool Just (const Nothing) (isJust deleted) uid return $ bool Just (const Nothing) (isJust deleted) uid
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
@ -627,7 +617,7 @@ correctorForm shid = do
let let
tutorField :: Field Handler [UserEmail] tutorField :: Field Handler [UserEmail]
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField 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 listIdent <- newIdent
userId <- handlerToWidget requireAuthId 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 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 let
constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
constructFields (uid, uname, (state, Load{..})) = do constructFields (uid, uname, (state, Load{..})) = do
cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
let let
fs name = "" fs name = ""
{ fsName = Just $ tshow ciphertext <> "-" <> name { fsName = Just $ tshow ciphertext <> "-" <> name
@ -722,7 +712,7 @@ correctorForm shid = do
{ fvLabel = text $ mr MsgCorrectors { fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing , fvTooltip = Nothing
, fvId = "" , 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 , fvErrors = Nothing
, fvRequired = True , fvRequired = True
} }
@ -747,9 +737,9 @@ getSCorrR tid ssh csh shn = do
case res of case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess res -> runDB $ do FormSuccess res' -> runDB $ do
deleteWhere [SheetCorrectorSheet ==. shid] deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res insertMany_ $ Set.toList res'
addMessageI Success MsgCorrectorsUpdated addMessageI Success MsgCorrectorsUpdated
FormMissing -> return () FormMissing -> return ()

17
src/Handler/Submission.hs
View File

@ -19,7 +19,6 @@ import Network.Mime
import Data.Monoid (Any(..)) import Data.Monoid (Any(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
-- import qualified Data.Maybe -- import qualified Data.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
@ -51,11 +50,11 @@ import System.FilePath
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
let let
fileUpload = case uploadMode of fileUploadForm = case uploadMode of
NoUpload -> pure Nothing NoUpload -> pure Nothing
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) 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 $ (,) flip (renderAForm FormStandard) html $ (,)
<$> fileUpload <$> fileUploadForm
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy <*> (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 | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies | 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) void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
unless (shid == shid') $
invalidArgsI [MsgSubmissionWrongSheet]
-- fetch buddies from current submission -- fetch buddies from current submission
(Any isOwner, buddies) <- do (Any isOwner, buddies) <- do
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> 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 case res' of
(FormSuccess (mFiles,(setFromList -> adhocIds))) -> do (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
now <- liftIO $ getCurrentTime
smid <- do smid <- do
smid <- case (mFiles, msmid) of smid <- case (mFiles, msmid) of
(Nothing, Just smid) -- no new files, existing submission partners updated (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 , dbtIdent = "files" :: Text
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "path" [ ( "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" , ( "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 , 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 -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
return f return f
let fileName = Text.pack $ takeFileName path
case results of case results of
[Entity _ File{ fileContent = Just c, fileTitle }] -> do [Entity _ File{ fileContent = Just c, fileTitle }] -> do
whenM downloadFiles $ whenM downloadFiles $
@ -367,7 +366,7 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
rating <- lift $ getRating submissionID rating <- lift $ getRating submissionID
let let
fileSource = case sfType of fileSelect = case sfType of
SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
@ -376,7 +375,7 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
_ -> submissionFileSource submissionID _ -> submissionFileSource submissionID
fileSource' = do fileSource' = do
fileSource .| Conduit.map entityVal fileSelect .| Conduit.map entityVal
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
maybe (return ()) (yieldM . ratingFile cID) rating maybe (return ()) (yieldM . ratingFile cID) rating

39
src/Handler/SystemMessage.hs
View File

@ -68,23 +68,9 @@ postMessageR cID = do
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
<* submitButton <* submitButton
formResult modifyRes $ \SystemMessage{..} -> do formResult modifyRes $ modifySystemMessage smId
runDB $ update smId
[ SystemMessageFrom =. systemMessageFrom
, SystemMessageTo =. systemMessageTo
, SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
, SystemMessageSeverity =. systemMessageSeverity
, SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
, SystemMessageContent =. systemMessageContent
, SystemMessageSummary =. systemMessageSummary
]
addMessageI Success MsgSystemMessageEditSuccess
redirect $ MessageR cID
formResult addTransRes $ \smt -> do formResult addTransRes addTranslation
runDB . void . insert $ smt
addMessageI Success MsgSystemMessageAddTranslationSuccess
redirect $ MessageR cID
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of
[BtnDelete'] -> do [BtnDelete'] -> do
@ -127,7 +113,24 @@ postMessageR cID = do
defaultLayout $ do defaultLayout $ do
$(widgetFile "system-message") $(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) type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation)
@ -223,8 +226,8 @@ postMessageListR = do
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ] runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
$(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet") $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
redirect MessageListR redirect MessageListR
FormSuccess (_, selection) FormSuccess (_, _selection) -- prop> null _selection
| null selection -> addMessageI Error MsgSystemMessageEmptySelection -> addMessageI Error MsgSystemMessageEmptySelection
((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing

6
src/Handler/Term.hs
View File

@ -60,9 +60,9 @@ getTermShowR = do
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
provideRep $ do provideRep $ do
let colonnadeTerms = widgetColonnade $ mconcat let colonnadeTerms = widgetColonnade $ mconcat
[ sortable Nothing "Kürzel" $ [ sortable Nothing "Kürzel" $ \(Entity tid _, _) -> anchorCell
anchorCell' (\(Entity tid _, _) -> TermCourseListR tid) (TermCourseListR tid)
(\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|]) [whamlet|#{toPathPiece tid}|]
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termLectureStart >>= toWidget cell $ formatTime SelFormatDate termLectureStart >>= toWidget
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->

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

@ -20,8 +20,6 @@ import qualified Data.Time.Format as Time
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Mail
utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime :: UTCTime -> LocalTime
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ utcToLocalTime = TZ.utcToLocalTimeTZ appTZ

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

@ -6,16 +6,12 @@ module Handler.Utils.Form
import Utils.Form import Utils.Form
import Handler.Utils.Form.Types import Handler.Utils.Form.Types
import Handler.Utils.Templates
import Handler.Utils.DateTime import Handler.Utils.DateTime
import qualified Data.Time as Time
import Import hiding (cons) import Import hiding (cons)
import qualified Data.Char as Char import qualified Data.Char as Char
import Data.String (IsString(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
@ -32,10 +28,8 @@ import Handler.Utils.Zip
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
import Data.Set (Set) 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.Map as Map
@ -287,7 +281,7 @@ multiFileField permittedFiles' = Field{..}
mapM_ handleFile files .| C.map Right mapM_ handleFile files .| C.map Right
where where
doUnpack = unpackZips `elem` vals doUnpack = unpackZips `elem` vals
fieldView fieldId fieldName attrs val req = do fieldView fieldId fieldName _attrs val req = do
pVals <- handlerToWidget permittedFiles' pVals <- handlerToWidget permittedFiles'
sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
let let
@ -507,7 +501,7 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
pairs <- runDB $ selectList filts ords pairs <- runDB $ selectList filts ords
cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e 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) { optionDisplay = mr (toDisplay value)
, optionInternalValue = e , optionInternalValue = e
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) , 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 mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
widgets <- mapM mToWidget results widgets <- mapM mToWidget results
let actionWidgets = Map.foldrWithKey accWidget [] widgets let actionWidgets = Map.foldrWithKey accWidget [] widgets
accWidget act Nothing = id accWidget _act Nothing = id
accWidget act (Just w) = cons $(widgetFile "widgets/multiAction") accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
actionResults = Map.map fst results actionResults = Map.map fst results
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect")) return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))

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

@ -4,7 +4,7 @@ module Handler.Utils.Mail
, addFileDB , addFileDB
) where ) where
import Import hiding ((.=)) import Import
import Utils.Lens hiding (snoc) import Utils.Lens hiding (snoc)

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

@ -149,10 +149,10 @@ parseRating :: MonadThrow m => File -> m Rating'
parseRating File{ fileContent = Just input, .. } = do parseRating File{ fileContent = Just input, .. } = do
inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
let let
(headerLines', commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
(reverse -> ratingLines, reverse -> headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
ratingLines' = filter (rating `Text.isInfixOf`) ratingLines ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
sep = "Beginn der Kommentare" commentSep = "Beginn der Kommentare"
sep' = Text.pack $ replicate 40 '=' sep' = Text.pack $ replicate 40 '='
rating = "Bewertung:" rating = "Bewertung:"
comment' <- case commentLines of comment' <- case commentLines of
@ -162,7 +162,7 @@ parseRating File{ fileContent = Just input, .. } = do
ratingComment ratingComment
| Text.null comment' = Nothing | Text.null comment' = Nothing
| otherwise = Just comment' | otherwise = Just comment'
ratingLine' <- case ratingLines of ratingLine' <- case ratingLines' of
[l] -> return l [l] -> return l
_ -> throw RatingMultiple _ -> throw RatingMultiple
let let

45
src/Handler/Utils/Submission.hs
View File

@ -9,13 +9,11 @@ module Handler.Utils.Submission
, submissionMatchesSheet , submissionMatchesSheet
) where ) where
import Import hiding ((.=), joinPath) import Import hiding (joinPath)
import Jobs import Jobs
import Prelude (lcm) import Prelude (lcm)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import Control.Lens
import Control.Lens.Extras (is)
import Utils.Lens import Utils.Lens
import Control.Monad.State hiding (forM_, mapM_,foldM) import Control.Monad.State hiding (forM_, mapM_,foldM)
@ -29,15 +27,12 @@ import Data.Maybe ()
import qualified Data.List as List import qualified Data.List as List
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Map (Map, (!?)) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Ratio import Data.Ratio
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Monoid (Monoid, Any(..), Sum(..)) import Data.Monoid (Monoid, Any(..), Sum(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@ -49,7 +44,6 @@ import Handler.Utils.Submission.TH
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Data.Conduit
import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.List as Conduit
import Data.Conduit.ResumableSink import Data.Conduit.ResumableSink
@ -76,7 +70,7 @@ assignSubmissions sid restriction = do
Sheet{..} <- getJust sid Sheet{..} <- getJust sid
correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
let 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 corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
corrsProp = filter hasPositiveLoad correctors corrsProp = filter hasPositiveLoad correctors
countsToLoad' :: UserId -> Bool countsToLoad' :: UserId -> Bool
@ -118,7 +112,7 @@ assignSubmissions sid restriction = do
let let
prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do 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 guard $ maybe True (not isByTutorial ||) byTutorial
let proportion let proportion
| CorrectorExcused <- sheetCorrectorState = 0 | CorrectorExcused <- sheetCorrectorState = 0
@ -311,9 +305,9 @@ extractRatingsMsg :: ( MonadHandler m
) => Conduit File m SubmissionContent ) => Conduit File m SubmissionContent
extractRatingsMsg = do extractRatingsMsg = do
ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
let ignored :: Set (Either CryptoFileNameSubmission FilePath) let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
ignored = Right `Set.map` ignored' ignoredFiles = Right `Set.map` ignored'
unless (null ignored) $ do unless (null ignoredFiles) $ do
mr <- (toHtml . ) <$> getMessageRender mr <- (toHtml . ) <$> getMessageRender
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
@ -346,20 +340,19 @@ sinkSubmission userId mExists isUpdate = do
return sId return sId
Right sId -> return sId Right sId -> return sId
sId <$ sinkSubmission' sId isUpdate sId <$ sinkSubmission' sId
where where
tell = modify . mappend tellSt = modify . mappend
sinkSubmission' :: SubmissionId sinkSubmission' :: SubmissionId
-> Bool -- ^ Is this a correction
-> Sink SubmissionContent (YesodJobDB UniWorX) () -> 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 Left file@(File{..}) -> do
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
alreadySeen <- gets (Set.member fileTitle . sinkFilenames) alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
when alreadySeen . throwM $ DuplicateFileTitle fileTitle 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 otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
@ -411,7 +404,7 @@ sinkSubmission userId mExists isUpdate = do
alreadySeen <- gets $ getAny . sinkSeenRating alreadySeen <- gets $ getAny . sinkSeenRating
when alreadySeen $ throwM DuplicateRating when alreadySeen $ throwM DuplicateRating
tell $ mempty{ sinkSeenRating = Any True } tellSt $ mempty{ sinkSeenRating = Any True }
unless isUpdate $ throwM RatingWithoutUpdate unless isUpdate $ throwM RatingWithoutUpdate
@ -459,10 +452,10 @@ sinkSubmission userId mExists isUpdate = do
False -> lift . insert_ $ SubmissionEdit userId now submissionId False -> lift . insert_ $ SubmissionEdit userId now submissionId
True -> do True -> do
Submission{submissionRatingTime} <- lift $ getJust submissionId 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 ] lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
-- TODO: Should submissionRatingAssigned change here if userId changes? -- TODO: Should submissionRatingAssigned change here if userId changes?
tell $ mempty{ sinkSubmissionTouched = Any True } tellSt $ mempty{ sinkSubmissionTouched = Any True }
finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
finalize SubmissionSinkState{..} = do finalize SubmissionSinkState{..} = do
@ -515,9 +508,9 @@ sinkSubmission userId mExists isUpdate = do
data SubmissionMultiSinkException data SubmissionMultiSinkException
= SubmissionSinkException = SubmissionSinkException
{ submissionSinkId :: CryptoFileNameSubmission { _submissionSinkId :: CryptoFileNameSubmission
, submissionSinkFedFile :: Maybe FilePath , _submissionSinkFedFile :: Maybe FilePath
, submissionSinkException :: SubmissionSinkException , _submissionSinkException :: SubmissionSinkException
} }
deriving (Typeable, Show) deriving (Typeable, Show)
@ -559,7 +552,7 @@ sinkMultiSubmission userId isUpdate = do
case sink' of case sink' of
Left _ -> error "sinkSubmission returned prematurely" Left _ -> error "sinkSubmission returned prematurely"
Right nSink -> modify $ Map.insert sId nSink 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 v@(Right (sId, _)) -> do
cID <- encrypt sId cID <- encrypt sId
$logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
@ -586,7 +579,7 @@ sinkMultiSubmission userId isUpdate = do
cID <- encrypt sId cID <- encrypt sId
handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
lift . feed sId $ Left f{ fileTitle = fileTitle' } lift . feed sId $ Left f{ fileTitle = fileTitle' }
when (not $ null ignored) $ do when (not $ null ignoredFiles) $ do
mr <- (toHtml .) <$> getMessageRender mr <- (toHtml .) <$> getMessageRender
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do

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

@ -27,13 +27,10 @@ module Handler.Utils.Table.Pagination
import Handler.Utils.Table.Pagination.Types import Handler.Utils.Table.Pagination.Types
import Utils.Lens.TH import Utils.Lens.TH
import Import import Import hiding (pi)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Database.Esqueleto.Internal.Language as E (From) 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 import qualified Data.Binary.Builder as Builder
@ -42,8 +39,8 @@ import qualified Network.Wai as Wai
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.RWS hiding ((<>), mapM_, forM_)
import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.Writer hiding ((<>), mapM_, forM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT) import Control.Monad.Reader (ReaderT(..), mapReaderT)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
@ -52,8 +49,6 @@ import Data.Foldable (Foldable(foldMap))
import Data.Map (Map, (!)) import Data.Map (Map, (!))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Profunctor (lmap)
import Colonnade hiding (bool, fromMaybe, singleton) import Colonnade hiding (bool, fromMaybe, singleton)
import qualified Colonnade (singleton) import qualified Colonnade (singleton)
import Colonnade.Encode import Colonnade.Encode
@ -64,8 +59,6 @@ import Data.Ratio ((%))
import Control.Lens import Control.Lens
import Data.Proxy
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } 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 where
(input, ($ []) -> is') = go (mempty, id) is (input, ($ []) -> is') = go (mempty, id) is
go acc [] = acc go acc [] = acc
go (acc, is') (i:is) go (acc, is3) (i:is2)
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
| otherwise = go (acc, is' . (i:)) is | otherwise = go (acc, is3 . (i:)) is2
data PaginationSettings = PaginationSettings data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)] { psSorting :: [(CI Text, SortDirection)]
@ -181,26 +174,26 @@ instance Default (PSValidator m x) where
asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s }) asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x 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 where
injectDefault x = case x >>= piFilter of injectDefault x = case x >>= piFilter of
Just _ -> id Just _ -> id
Nothing -> set (_2._psFilter) psFilter Nothing -> set (_2._psFilter) psFilter
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x 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 where
injectDefault x = case x >>= piSorting of injectDefault x = case x >>= piSorting of
Just _ -> id Just _ -> id
Nothing -> set (_2._psSorting) psSorting Nothing -> set (_2._psSorting) psSorting
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x 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 where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p } restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x 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 where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } 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)) -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf dbHandler _ f form = return $ \csrf -> over _2 f <$> form csrf
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- 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)) -- 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] , d <- [SortAsc, SortDesc]
, let t' = CI.foldedCase t <> "-" <> toPathPiece d , let t' = CI.foldedCase t <> "-" <> toPathPiece d
] ]
(_, defPS) = runPSValidator dbtable Nothing
wIdent n wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n | not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n | otherwise = n
@ -352,7 +344,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
| otherwise = dbsAttrs | otherwise = dbsAttrs
multiTextField = Field multiTextField = Field
{ fieldParse = \ts _ -> return . Right $ Just ts { fieldParse = \ts _ -> return . Right $ Just ts
, fieldView = undefined , fieldView = error "multiTextField: should not be rendered"
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@ -373,7 +365,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
(errs, PaginationSettings{..}) = case psResult of (errs, PaginationSettings{..}) = case psResult of
FormSuccess pi FormSuccess pi
| not (piIsUnset pi) -> runPSValidator dbtable $ Just 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 _ -> runPSValidator dbtable Nothing
psSorting' = map (first (dbtSorting !)) psSorting psSorting' = map (first (dbtSorting !)) psSorting
sqlQuery' = E.from $ \t -> dbtSQLQuery t 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 wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
widget <- cell ^. cellContents widget <- cell' ^. cellContents
let attrs = cell ^. cellAttrs let attrs = cell' ^. cellAttrs
return $(widgetFile "table/cell/body") return $(widgetFile "table/cell/body")
let table = $(widgetFile "table/colonnade") let table = $(widgetFile "table/colonnade")
@ -480,7 +472,7 @@ tickmarkCell True = textCell (tickmark :: Text)
tickmarkCell False = mempty tickmarkCell False = mempty
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a 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 where
tipWdgt = [whamlet| tipWdgt = [whamlet|
<div .js-tooltip> <div .js-tooltip>

4
src/Handler/Utils/Templates.hs
View File

@ -14,5 +14,5 @@ modal modalTrigger modalContent = do
triggerId <- newIdent triggerId <- newIdent
$(widgetFile "widgets/modal") $(widgetFile "widgets/modal")
case modalContent of case modalContent of
Left route -> [whamlet|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|] Left route -> [whamlet|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|]
Right content -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|] Right _ -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]

11
src/Jobs.hs
View File

@ -34,16 +34,15 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Foldable (foldrM) import Data.Foldable (foldrM)
import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, mapStateT) import Control.Monad.Trans.State (evalStateT, mapStateT)
import qualified Control.Monad.State.Class as State import qualified Control.Monad.State.Class as State
import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate, release) import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate, release)
import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger import Control.Monad.Logger
@ -134,7 +133,7 @@ execCrontab = evalStateT go HashMap.empty
| otherwise = lift $ delete leId | otherwise = lift $ delete leId
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
now <- liftIO getCurrentTime refT <- liftIO getCurrentTime
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of case crontab' of
@ -142,7 +141,7 @@ execCrontab = evalStateT go HashMap.empty
Just crontab -> Just <$> do Just crontab -> Just <$> do
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get prevExec <- State.get
case earliestJob prevExec crontab now of case earliestJob prevExec crontab refT of
Nothing -> liftBase retry Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x) Just x -> return (crontab, x)
@ -160,7 +159,7 @@ execCrontab = evalStateT go HashMap.empty
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of case jobCtl of
JobCtlQueue job -> do JobCtlQueue job -> do
lift . lift $ upsertBy void . lift . lift $ upsertBy
(UniqueCronLastExec $ toJSON job) (UniqueCronLastExec $ toJSON job)
CronLastExec CronLastExec
{ cronLastExecJob = toJSON job { cronLastExecJob = toJSON job

2
src/Jobs/Handler/HelpRequest.hs
View File

@ -2,7 +2,7 @@ module Jobs.Handler.HelpRequest
( dispatchJobHelpRequest ( dispatchJobHelpRequest
) where ) where
import Import hiding ((.=)) import Import
import Text.Hamlet import Text.Hamlet
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI

7
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -1,10 +1,11 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.CorrectionsAssigned module Jobs.Handler.SendNotification.CorrectionsAssigned
( dispatchNotificationCorrectionsAssigned ( dispatchNotificationCorrectionsAssigned
) where ) where
import Import import Import
import Utils.Lens
import Handler.Utils.Mail import Handler.Utils.Mail
import Text.Hamlet import Text.Hamlet
@ -25,10 +26,6 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
MsgRenderer mr <- getMailMsgRenderer MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
addAlternatives $ do addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet") let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")

3
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -1,10 +1,11 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.SheetActive module Jobs.Handler.SendNotification.SheetActive
( dispatchNotificationSheetActive ( dispatchNotificationSheetActive
) where ) where
import Import import Import
import Utils.Lens
import Handler.Utils.Mail import Handler.Utils.Mail
import Text.Hamlet import Text.Hamlet

3
src/Jobs/Handler/SendNotification/SheetInactive.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.SheetInactive module Jobs.Handler.SendNotification.SheetInactive
( dispatchNotificationSheetSoonInactive ( dispatchNotificationSheetSoonInactive
, dispatchNotificationSheetInactive , dispatchNotificationSheetInactive
@ -5,7 +7,6 @@ module Jobs.Handler.SendNotification.SheetInactive
import Import import Import
import Utils.Lens
import Handler.Utils.Mail import Handler.Utils.Mail
import Text.Hamlet import Text.Hamlet

2
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.SubmissionRated module Jobs.Handler.SendNotification.SubmissionRated
( dispatchNotificationSubmissionRated ( dispatchNotificationSubmissionRated
) where ) where

1
src/Jobs/Queue.hs
View File

@ -17,7 +17,6 @@ import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Control.Monad.Random (evalRand, mkStdGen, uniform) import Control.Monad.Random (evalRand, mkStdGen, uniform)

26
src/Mail.hs
View File

@ -32,14 +32,13 @@ module Mail
) where ) where
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender) import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
import qualified ClassyPrelude.Yesod as Yesod (getMessageRender)
import Network.Mail.Mime hiding (addPart, addAttachment) import Network.Mail.Mime hiding (addPart, addAttachment)
import qualified Network.Mail.Mime as Mime (addPart) import qualified Network.Mail.Mime as Mime (addPart)
import Data.Monoid (Last(..)) import Data.Monoid (Last(..))
import Control.Monad.Trans.RWS (RWST(..), execRWST) import Control.Monad.Trans.RWS (RWST(..))
import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT) import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
import Control.Monad.Trans.Writer (execWriter, Writer) import Control.Monad.Trans.Writer (execWriter, Writer)
import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify) import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
import Control.Monad.Fail import Control.Monad.Fail
@ -50,8 +49,6 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Data.Sequence (Seq) import Data.Sequence (Seq)
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Data (Data)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
@ -59,15 +56,13 @@ import qualified Data.Text as Text
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import Data.Hashable
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Utils (MsgRendererS(..)) import Utils (MsgRendererS(..))
import Utils.Lens.TH import Utils.Lens.TH
import Control.Lens import Control.Lens hiding (from)
import Text.Blaze.Renderer.Utf8 import Text.Blaze.Renderer.Utf8
@ -84,7 +79,6 @@ import Network.BSD (getHostName)
import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime) import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
import Data.Time.LocalTime (ZonedTime(..)) import Data.Time.LocalTime (ZonedTime(..))
import Data.Time.Format
import Network.HaskellNet.SMTP (SMTPConnection) import Network.HaskellNet.SMTP (SMTPConnection)
import qualified Network.HaskellNet.SMTP as SMTP import qualified Network.HaskellNet.SMTP as SMTP
@ -96,7 +90,6 @@ import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Aeson (Options(..)) import Data.Aeson (Options(..))
import Data.Aeson.TH import Data.Aeson.TH
import Utils (MsgRendererS(..))
import Utils.PathPiece (splitCamel) import Utils.PathPiece (splitCamel)
import Utils.DateTime import Utils.DateTime
@ -108,7 +101,7 @@ makeLenses_ ''Mail
makeLenses_ ''Part makeLenses_ ''Part
newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a } newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
, MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
, MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
@ -250,11 +243,11 @@ defMailT :: ( MonadHandler m
) => MailContext ) => MailContext
-> MailT m a -> MailT m a
-> m a -> m a
defMailT ls (MailT mail) = do defMailT ls (MailT mailC) = do
fromAddress <- defaultFromAddress fromAddress <- defaultFromAddress
(ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress) (ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
mail' <- liftIO $ LBS.toStrict <$> renderMail' mail mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
$logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail' -- $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
ret <$ case smtpData of ret <$ case smtpData of
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
MailSmtpData{ smtpRecipients } MailSmtpData{ smtpRecipients }
@ -457,12 +450,13 @@ setMailSmtpData = do
if if
| Verp{..} <- verpMode | Verp{..} <- verpMode
, [recp] <- Set.toList recps , [recp] <- Set.toList recps
-> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat -> let (user, domain) = Text.breakOn "@" from
verp = mconcat
[ user [ user
, Text.singleton verpSeparator , Text.singleton verpSeparator
, Text.replace "@" (Text.singleton verpAtReplacement) recp , Text.replace "@" (Text.singleton verpAtReplacement) recp
, domain , domain
] ]
in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp } in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
| otherwise | otherwise
-> tell $ mempty { smtpEnvelopeFrom = Last $ Just from } -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }

2
src/Model.hs
View File

@ -14,7 +14,6 @@ import Model.Types
import Cron.Types import Cron.Types
import Data.Aeson (Value) import Data.Aeson (Value)
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.CaseInsensitive.Instances () import Data.CaseInsensitive.Instances ()
@ -31,6 +30,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course) deriving instance Eq (Unique Course)
deriving instance Eq (Unique Sheet)
submissionRatingDone :: Submission -> Bool submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingTime submissionRatingDone Submission{..} = isJust submissionRatingTime

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

@ -1,11 +1,7 @@
module Model.Migration.Types where module Model.Migration.Types where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
import qualified Data.Aeson as Aeson import Data.Aeson.TH (deriveJSON, defaultOptions)
import qualified Data.Aeson.Types as Aeson
import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
import Database.Persist.Sql import Database.Persist.Sql
import qualified Model as Current import qualified Model as Current
@ -30,4 +26,4 @@ sheetType NotGraded = Current.NotGraded
deriveJSON defaultOptions ''SheetType deriveJSON defaultOptions ''SheetType
Current.derivePersistFieldJSON ''SheetType Current.derivePersistFieldJSON ''SheetType

10
src/Model/Types/JSON.hs
View File

@ -16,10 +16,10 @@ import Language.Haskell.TH.Datatype
derivePersistFieldJSON :: Name -> DecsQ derivePersistFieldJSON :: Name -> DecsQ
derivePersistFieldJSON n = do derivePersistFieldJSON tName = do
DatatypeInfo{..} <- reifyDatatype n DatatypeInfo{..} <- reifyDatatype tName
vars <- forM datatypeVars (const $ newName "a") vars <- forM datatypeVars (const $ newName "a")
let t = foldl (\t n -> t `appT` varT n) (conT n) vars let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
iCxt iCxt
| null vars = cxt [] | null vars = cxt []
| otherwise = cxt [[t|ToJSON|] `appT` t, [t|FromJSON|] `appT` t] | otherwise = cxt [[t|ToJSON|] `appT` t, [t|FromJSON|] `appT` t]
@ -39,8 +39,8 @@ derivePersistFieldJSON n = do
bs <- newName "bs" bs <- newName "bs"
clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) [] clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
, do , do
t <- newName "t" text <- newName "text"
clause [[p|PersistText $(varP t)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE t)|]) [] clause [[p|PersistText $(varP text)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE text)|]) []
, clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) [] , clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) []
] ]
] ]

2
src/Utils/Lens.hs
View File

@ -2,7 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation import Import.NoFoundation
import Control.Lens as Utils.Lens import Control.Lens as Utils.Lens
import Utils.Lens.TH import Utils.Lens.TH as Utils.Lens (makeLenses_)
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..)) import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))

2
templates/correction-user.hamlet
View File

@ -3,7 +3,7 @@
<tr .table__row> <tr .table__row>
<th .table__th>_{MsgSubmission} <th .table__th>_{MsgSubmission}
<td .table__td>#{display cid} <td .table__td>#{display cid}
$maybe Entity _ User{..} <- corrector $maybe Entity _ User{userDisplayName} <- corrector
<tr .table__row> <tr .table__row>
<th .table__th>_{MsgRatingBy} <th .table__th>_{MsgRatingBy}
<td .table__td>#{display userDisplayName} <td .table__td>#{display userDisplayName}

2
templates/default-layout.hamlet
View File

@ -10,7 +10,7 @@
<!-- breadcrumbs --> <!-- breadcrumbs -->
$if not $ Just HomeR == mcurrentRoute $if not $ Just HomeR == mcurrentRoute
^{breadcrumbs} ^{breadcrumbsWgt}
<div .main__content-body> <div .main__content-body>

2
templates/login.hamlet
View File

@ -1,4 +1,4 @@
$forall AuthPlugin{..} <- plugins $forall AuthPlugin{apName, apLogin} <- plugins
$if apName == "LDAP" $if apName == "LDAP"
<section> <section>
<h2>_{MsgLDAPLoginTitle} <h2>_{MsgLDAPLoginTitle}

2
templates/mail/submissionRated.hamlet
View File

@ -23,7 +23,7 @@ $newline never
<dd> <dd>
<a href=@{CSubmissionR tid ssh csh shn csid SubShowR}> <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
#{display csid} #{display csid}
$maybe User{..} <- corrector $maybe User{userDisplayName} <- corrector
<dt> <dt>
_{MsgRatingBy} _{MsgRatingBy}
<dd> <dd>

2
templates/mail/support.hamlet
View File

@ -12,7 +12,7 @@ $newline never
$of Left Nothing $of Left Nothing
$of Right Nothing $of Right Nothing
<dt>Ungültige UserId erhalten! <dt>Ungültige UserId erhalten!
$of Right (Just (Entity _ User{..})) $of Right (Just (Entity _ User{userDisplayName, userSurname, userIdent, userEmail, userMatrikelnummer, userMailLanguages}))
<dt>Name <dt>Name
<dd>^{const (const (nameHtml userDisplayName userSurname))} <dd>^{const (const (nameHtml userDisplayName userSurname))}
<dt>Identifikation <dt>Identifikation

2
templates/messages/submissionFilesIgnored.hamlet
View File

@ -1,6 +1,6 @@
_{MsgSubmissionFilesIgnored} _{MsgSubmissionFilesIgnored}
<ul> <ul>
$forall ident <- ignored $forall ident <- ignoredFiles
$case ident $case ident
$of Right fileTitle $of Right fileTitle
<li style="font-family: monospace">#{fileTitle} <li style="font-family: monospace">#{fileTitle}

14
templates/widgets/asidenav.hamlet
View File

@ -1,16 +1,12 @@
$newline never $newline never
<aside .main__aside> <aside .main__aside>
<div .asidenav> <div .asidenav>
$forall tid@TermIdentifier{..} <- favouriteTerms $forall tid <- favouriteTerms
<div .asidenav__box.js-show-hide> <div .asidenav__box.js-show-hide>
<h3 .asidenav__box-title.js-show-hide__toggle data-sh-index="#{display season}-#{year}"> <h3 .asidenav__box-title.js-show-hide__toggle data-sh-index="#{termToText tid}">
$case season _{ShortTermIdentifier tid}
$of Winter
_{MsgWinterTermShort year}
$of Summer
_{MsgSummerTermShort year}
<ul .asidenav__list.js-show-hide__target.list--iconless> <ul .asidenav__list.js-show-hide__target.list--iconless>
$forall (Course{..}, courseRoute, pageActions) <- favouriteTerm tid $forall (Course{courseShorthand, courseName}, courseRoute, pageActions) <- favouriteTerm tid
<li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active> <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
<a .asidenav__link-wrapper href=@{courseRoute}> <a .asidenav__link-wrapper href=@{courseRoute}>
<div .asidenav__link-shorthand>#{courseShorthand} <div .asidenav__link-shorthand>#{courseShorthand}
@ -18,7 +14,7 @@ $newline never
<ul .asidenav__nested-list.list--iconless> <ul .asidenav__nested-list.list--iconless>
$forall action <- pageActions $forall action <- pageActions
$case action $case action
$of PageActionPrime (MenuItem{..}) $of PageActionPrime (MenuItem{menuItemRoute, menuItemLabel})
<li .asidenav__nested-list-item> <li .asidenav__nested-list-item>
<a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel} <a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel}
$of _ $of _

2
templates/widgets/rating.hamlet
View File

@ -6,7 +6,7 @@ $maybe points <- submissionRatingPoints
$case grading $case grading
$of Points{..} $of Points{..}
_{MsgAchievedOf points maxPoints} _{MsgAchievedOf points maxPoints}
$of PassPoints{..} $of PassPoints{}
$if fromMaybe False (gradingPassed grading points) $if fromMaybe False (gradingPassed grading points)
_{MsgPassed} _{MsgPassed}
$else $else