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