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

Merge branch 'master' into 'live'

Browse Source 
#225

Closes #225

See merge request !90
This commit is contained in:
Gregor Kleen 2018-11-03 22:59:17 +01:00
commit d654310120
79 changed files with 1222 additions and 1199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.hlint.yaml Normal file
View File

@ -0,0 +1,14 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
- ignore: { name: "Parse error" }
- ignore: { name: "Reduce duplication" }
- ignore: { name: "Use ||" }
- ignore: { name: "Use &&" }
- ignore: { name: "Use ++" }
- arguments:
- -XQuasiQuotes
- -XTemplateHaskell
- -j

4
hlint/Hlint.hs Normal file
View File

@ -0,0 +1,4 @@
{-# OPTIONS_GHC
-F -pgmF hlint-test
-optF src
#-}

4
models
View File

@ -11,7 +11,7 @@ User json
dateFormat DateTimeFormat "default='%d.%m.%Y'"
timeFormat DateTimeFormat "default='%R'"
downloadFiles Bool default=false
mailLanguages MailLanguages "default='[]'"
mailLanguages MailLanguages default='[]'
notificationSettings NotificationSettings
UniqueAuthentication ident
UniqueEmail email
@ -139,7 +139,7 @@ File
title FilePath
content ByteString Maybe -- Nothing iff this is a directory
modified UTCTime
deriving Show Eq
deriving Show Eq Generic
Submission
sheet SheetId
ratingPoints Points Maybe -- "Just" does not mean done

286
package.yaml
View File

@ -2,114 +2,111 @@ name: uniworx
version: "0.0.0"
dependencies:
# Due to a bug in GHC 8.0.1, we block its usage
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
# version 1.0 had a bug in reexporting Handler, causing trouble
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
- foreign-store
- yesod >=1.4.3 && <1.5
- yesod-core >=1.4.30 && <1.5
- yesod-auth >=1.4.0 && <1.5
- yesod-static >=1.4.0.3 && <1.6
- yesod-form >=1.4.0 && <1.5
- classy-prelude >=0.10.2
- classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11
- text >=0.11 && <2.0
- persistent >=2.7.2 && <2.8
- persistent-postgresql >=2.1.1 && <2.8
- persistent-template >=2.0 && <2.8
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9
- http-conduit >=2.1 && <2.3
- directory >=1.1 && <1.4
- warp >=3.0 && <3.3
- data-default
- aeson >=0.6 && <1.3
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- cryptonite
- cryptonite-conduit
- saltine
- base64-bytestring
- memory
- http-api-data
- profunctors
- colonnade >=1.1.1
- yesod-colonnade >=1.1.0
- blaze-markup
- zip-stream
- filepath
- transformers
- wl-pprint-text
- uuid-types
- path-pieces
- uuid-crypto
- filepath-crypto
- cryptoids-types
- cryptoids
- cryptoids-class
- binary
- cereal
- mtl
- sandi
- esqueleto
- mime-types
- generic-deriving
- blaze-html
- conduit-resumablesink >=0.2
- parsec
- uuid
- exceptions
- stm
- stm-chans
- stm-conduit
- lens
- MonadRandom
- email-validate
- scientific
- tz
- system-locale
- th-lift-instances
- gitrev
- Glob
- ldap-client
- connection
- universe
- universe-base
- random
- random-shuffle
- th-abstraction
- HaskellNet
- HaskellNet-SSL
- network
- resource-pool
- mime-mail
- hashable
- aeson-pretty
- resourcet
- postgresql-simple
- word24
- mmorph
- clientsession
# Due to a bug in GHC 8.0.1, we block its usage
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
# version 1.0 had a bug in reexporting Handler, causing trouble
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
- foreign-store
- yesod >=1.4.3 && <1.5
- yesod-core >=1.4.30 && <1.5
- yesod-auth >=1.4.0 && <1.5
- yesod-static >=1.4.0.3 && <1.6
- yesod-form >=1.4.0 && <1.5
- classy-prelude >=0.10.2
- classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11
- text >=0.11 && <2.0
- persistent >=2.7.2 && <2.8
- persistent-postgresql >=2.1.1 && <2.8
- persistent-template >=2.0 && <2.8
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9
- http-conduit >=2.1 && <2.3
- directory >=1.1 && <1.4
- warp >=3.0 && <3.3
- data-default
- aeson >=0.6 && <1.3
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- cryptonite
- cryptonite-conduit
- saltine
- base64-bytestring
- memory
- http-api-data
- profunctors
- colonnade >=1.1.1
- yesod-colonnade >=1.1.0
- blaze-markup
- zip-stream
- filepath
- transformers
- wl-pprint-text
- uuid-types
- path-pieces
- uuid-crypto
- filepath-crypto
- cryptoids-types
- cryptoids
- cryptoids-class
- binary
- cereal
- mtl
- sandi
- esqueleto
- mime-types
- generic-deriving
- blaze-html
- conduit-resumablesink >=0.2
- parsec
- uuid
- exceptions
- stm
- stm-chans
- stm-conduit
- lens
- MonadRandom
- email-validate
- scientific
- tz
- system-locale
- th-lift-instances
- gitrev
- Glob
- ldap-client
- connection
- universe
- universe-base
- random
- random-shuffle
- th-abstraction
- HaskellNet
- HaskellNet-SSL
- network
- resource-pool
- mime-mail
- hashable
- aeson-pretty
- resourcet
- postgresql-simple
- word24
- mmorph
- clientsession
other-extensions:
- GeneralizedNewtypeDeriving
@ -159,24 +156,31 @@ default-extensions:
- BinaryLiterals
- PolyKinds
ghc-options:
- -Wall
- -fno-warn-type-defaults
- -fno-warn-partial-type-signatures
when:
- condition: flag(pedantic)
ghc-options:
- -Werror
- -fwarn-tabs
# 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:
- -Wall
- -fwarn-tabs
- -O0
- -ddump-splices
cpp-options: -DDEVELOPMENT
else:
ghc-options:
- -Wall
- -fwarn-tabs
- -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:
@ -184,28 +188,36 @@ executables:
main: main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- uniworx
- uniworx
when:
- condition: flag(library-only)
buildable: false
- condition: flag(library-only)
buildable: false
# Test suite
tests:
test:
yesod:
main: Spec.hs
source-dirs: test
ghc-options: -Wall
dependencies:
- uniworx
- hspec >=2.0.0
- QuickCheck
- yesod-test
- conduit-extra
- quickcheck-instances
- uniworx
- hspec >=2.0.0
- QuickCheck
- yesod-test
- conduit-extra
- quickcheck-instances
hlint:
main: Hlint.hs
other-modules: []
source-dirs: hlint
dependencies:
- hlint-test
when:
- condition: "!flag(pedantic)"
buildable: false
# Define flags used by "yesod devel" to make compilation faster
flags:
@ -217,3 +229,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

8
routes
View File

@ -34,7 +34,7 @@
/ HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only
/admin/test AdminTestR GET POST
/admin/user/#CryptoUUIDUser AdminUserR GET
/admin/user/#CryptoUUIDUser AdminUserR GET !development
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
/admin/errMsg AdminErrMsgR GET POST
/info VersionR GET !free
@ -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

2
shell.nix
View File

@ -22,7 +22,7 @@ let
'';
override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]);
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = ''
export PROMPT_INFO="${oldAttrs.name}"

21
src/Application.hs
View File

@ -30,9 +30,11 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
import System.Log.FastLogger (defaultBufSize, newStderrLoggerSet,
toLogStr)
import qualified Data.Map.Strict as Map
import Foreign.Store
import qualified Data.UUID as UUID
@ -94,22 +96,20 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation appSettings@(AppSettings{..}) = do
makeFoundation appSettings@AppSettings{..} = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- newManager
appLogger <- liftIO $ do
tgetter <- newTimeCache "%Y-%m-%d %T %z"
loggerSet <- newStdoutLoggerSet defaultBufSize
loggerSet <- newStderrLoggerSet defaultBufSize
return $ Yesod.Logger loggerSet tgetter
appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
(appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
chan <- newBroadcastTMChan
recvChan <- dupTMChan chan
return (chan, recvChan)
appJobCtl <- liftIO $ newTVarIO Map.empty
appCronThread <- liftIO newEmptyTMVarIO
appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
@ -149,7 +149,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
handleJobs recvChans foundation
handleJobs foundation
-- Return the foundation
return foundation
@ -208,7 +208,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
applyAuth SmtpAuthConf{..} conn = withLogging $ do
$logDebugS "SMTP" "Doing authentication"
authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
when (not authSuccess) $ do
unless authSuccess $
fail "SMTP authentication failed"
return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
@ -322,8 +322,7 @@ getApplicationRepl = do
return (getPort wsettings, foundation, app1)
shutdownApp :: MonadIO m => UniWorX -> m ()
shutdownApp UniWorX{..} = do
liftIO . atomically $ mapM_ closeTMChan appJobCtl
shutdownApp = stopJobCtl
---------------------------------------------

111
src/Cron.hs
View File

@ -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

2
src/CryptoID.hs
View File

@ -9,7 +9,7 @@ module CryptoID
import CryptoID.TH
import ClassyPrelude hiding (fromString)
import ClassyPrelude
import Model
import qualified Data.CryptoID as E

2
src/Data/Universe/Instances/Reverse/JSON.hs
View File

@ -24,4 +24,4 @@ instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a
vMap <- parseJSON val :: Parser (HashMap a b)
unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
fail "Not all required keys found"
return $ (vMap !)
return (vMap !)

81
src/Foundation.hs
View File

@ -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)
@ -118,7 +107,8 @@ data UniWorX = UniWorX
, appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey
, appInstanceID :: InstanceId
, appJobCtl :: [TMChan JobCtl]
, appJobCtl :: TVar (Map ThreadId (TMChan JobCtl))
, appCronThread :: TMVar (ReleaseKey, ThreadId)
, appErrorMsgKey :: SecretBox.Key
, appSessionKey :: ClientSession.Key
}
@ -146,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)
@ -211,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
@ -230,7 +223,7 @@ embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>)
newtype SheetTypeComplete = SheetTypeComplete SheetType
instance RenderMessage UniWorX (SheetTypeComplete) where
renderMessage foundation ls (SheetTypeComplete st) = case st of
renderMessage foundation ls (SheetTypeComplete sheetType) = case sheetType of
NotGraded -> mr NotGraded
other -> mr (grading other) <> ", " <> mr other
where
@ -288,8 +281,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
@ -346,6 +339,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
@ -414,7 +415,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
@ -422,7 +423,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
@ -625,14 +626,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
@ -754,8 +755,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)
@ -794,11 +795,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)
@ -1185,11 +1188,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"
@ -1214,11 +1218,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 _ = []
@ -1295,7 +1300,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
@ -1307,7 +1312,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
@ -1550,7 +1555,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"

6
src/Handler/Admin.hs
View File

@ -92,7 +92,7 @@ postAdminTestR = do
^{emailWidget}
|]
defaultLayout $ do
defaultLayout $
-- setTitle "Uni2work Admin Testpage"
$(widgetFile "adminTest")
@ -101,7 +101,7 @@ getAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR uuid = do
uid <- decrypt uuid
User{..} <- runDB $ get404 uid
defaultLayout $
defaultLayout
[whamlet|
<h1>TODO
<h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
@ -130,7 +130,7 @@ postAdminErrMsgR = do
either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
defaultLayout $
defaultLayout
[whamlet|
$maybe t <- plaintext
<pre style="white-space:pre-wrap; font-family:monospace">

108
src/Handler/Corrections.hs
View File

@ -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, _, _) } ->
@ -213,9 +207,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
E.orderBy [E.asc $ user E.^. UserId]
return (user, pseudonym E.?. SheetPseudonymPseudonym)
let
submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors
submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
dbTable psValidator $ DBTable
dbTable psValidator DBTable
{ dbtSQLQuery
, dbtColonnade
, dbtProj
@ -240,7 +234,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
)
, ( "assignedtime"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
)
)
]
, dbtFilter = Map.fromList
[ ( "term"
@ -290,7 +284,7 @@ correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
(actionRes, action) <- multiAction actions Nothing
return ((,) <$> actionRes <*> selectionRes, table <> action)
@ -307,12 +301,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
now <- liftIO getCurrentTime
runDB $ do
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
when (not $ null alreadyAssigned) $ do
unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
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
unless (null unassigned) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
[ SubmissionRatingBy =. Just uid
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
@ -341,18 +335,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
subs <- mapM decrypt $ Set.toList subs'
runDB $ do
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
when (not $ null alreadyAssigned) $ do
unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
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)
when (not $ null assigned) $
unless (null unassigned) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
unless (null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
when (not $ null unassigned) $ do
unless (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
@ -491,7 +485,7 @@ postCorrectionR tid ssh csh shn cid = do
NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl")
(Just $ submissionRatingPoints)
(Just submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
@ -506,19 +500,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
@ -532,10 +524,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
@ -556,7 +548,7 @@ getCorrectionUserR tid ssh csh shn cid = do
mr <- getMessageRender
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
sheetTypeDesc = mr sheetType
defaultLayout $ do
defaultLayout $
$(widgetFile "correction-user")
_ -> notFound
@ -582,7 +574,7 @@ postCorrectionsUploadR = do
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
defaultLayout $ do
defaultLayout $
$(widgetFile "corrections-upload")
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
@ -595,7 +587,7 @@ postCorrectionsCreateR = do
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
mkOptList opts = do
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
@ -617,10 +609,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
@ -640,12 +631,12 @@ postCorrectionsCreateR = do
, submissionRatingAssigned = Just now
, submissionRatingTime = Nothing
}
when (not $ null duplicate)
unless (null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
existingSubUsers <- E.select . E.from $ \submissionUser -> do
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
return submissionUser
when (not $ null existingSubUsers) $ do
unless (null existingSubUsers) $ do
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
@ -669,23 +660,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
@ -706,18 +692,18 @@ postCorrectionsCreateR = do
redirect CorrectionsGradeR
defaultLayout $ do
defaultLayout $
$(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
@ -749,7 +735,7 @@ postCorrectionsGradeR = do
cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i
(((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm
((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
case tableRes of
FormMissing -> return ()
@ -765,9 +751,9 @@ postCorrectionsGradeR = do
, SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. now <$ guard rated
]
| otherwise -> return $ Nothing
| otherwise -> return Nothing
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
defaultLayout $ do
defaultLayout $
$(widgetFile "corrections-grade")

153
src/Handler/Course.hs
View File

@ -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)
@ -112,7 +105,7 @@ course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \co
return (E.countRows :: E.SqlExpr (E.Value Int64))
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> do
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
@ -129,7 +122,7 @@ makeCourseTable whereClause colChoices psValidator = do
return (course, participants, registered, school)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
dbTable psValidator $ DBTable
dbTable psValidator DBTable
{ dbtSQLQuery
, dbtColonnade = colChoices
, dbtProj
@ -141,7 +134,7 @@ makeCourseTable whereClause colChoices psValidator = do
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
, ( "participants", SortColumn $ course2Participants )
, ( "participants", SortColumn course2Participants )
, ( "registered", SortColumn $ course2Registered muid)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
@ -213,9 +206,9 @@ getTermSchoolCourseListR tid ssh = do
, colParticipants
, maybe mempty (const colRegistered) muid
]
whereClause = \(course, _, _) ->
course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
whereClause (course, _, _) =
course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def
& defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator
@ -237,7 +230,7 @@ getTermCourseListR tid = do
, colParticipants
, maybe mempty (const colRegistered) muid
]
whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
validator = def
& defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator
@ -261,21 +254,21 @@ getCShowR tid ssh csh = do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName
return $ (courseEnt,dependent,E.unValue <$> lecturers)
return (courseEnt,dependent,E.unValue <$> lecturers)
let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do
setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course")
registerForm :: Bool -> Maybe Text -> Form Bool
registerForm registered msecret extra = do
(msecretRes', msecretView) <- case msecret of
(Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
(Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
_ -> return (Nothing,Nothing)
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/registerForm")
@ -289,7 +282,7 @@ postCRegisterR tid ssh csh = do
aid <- requireAuthId
(cid, course, registered) <- runDB $ do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
registered <- isJust <$> getBy (UniqueParticipant aid cid)
return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
case regResult of
@ -298,11 +291,11 @@ postCRegisterR tid ssh csh = do
runDB $ deleteBy $ UniqueParticipant aid cid
addMessageI Info MsgCourseDeregisterOk
| codeOk -> do
actTime <- liftIO $ getCurrentTime
actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
| otherwise -> addMessageI Warning MsgCourseSecretWrong
(_other) -> return () -- TODO check this!
_other -> return () -- TODO check this!
redirect $ CourseR tid ssh csh CShowR
@ -323,21 +316,20 @@ getCourseNewR = do
let noTemplateAction = courseEditHandler True Nothing
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more!
FormMissing -> noTemplateAction
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
noTemplateAction
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
uid <- requireAuthId
oldCourses <- runDB $ do
oldCourses <- runDB $
E.select $ E.from $ \course -> do
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
let lecturersCourse =
E.exists $ E.from $ \lecturer -> do
E.exists $ E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool =
E.exists $ E.from $ \user -> do
E.exists $ E.from $ \user ->
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
let courseCreated c =
@ -351,7 +343,7 @@ getCourseNewR = do
return course
template <- case listToMaybe oldCourses of
(Just oldTemplate) ->
let newTemplate = (courseToForm oldTemplate) in
let newTemplate = courseToForm oldTemplate in
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@ -363,7 +355,7 @@ getCourseNewR = do
(tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid True existsKey
<*> ifMaybeM mbSsh True existsKey
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
<*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
@ -403,19 +395,19 @@ 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
(FormSuccess res@(
CourseForm { cfCourseId = Nothing
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
})) -> do -- create new course
(FormSuccess res@CourseForm
{ cfCourseId = Nothing
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
}) -> do -- create new course
now <- liftIO getCurrentTime
insertOkay <- runDB $ insertUnique $ Course
insertOkay <- runDB $ insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
@ -439,34 +431,33 @@ courseEditHandler isGet mbCourseForm = do
Nothing ->
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
(FormSuccess res@(
CourseForm { cfCourseId = Just cid
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
})) -> do -- edit existing course
(FormSuccess res@CourseForm
{ cfCourseId = Just cid
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
}) -> do -- edit existing course
now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|]
success <- runDB $ do
old <- get cid
case old of
Nothing -> addMessageI Error MsgInvalidInput $> False
(Just oldCourse) -> do
updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
Course { courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res -- dangerous
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
)
(Just _) -> do
updOkay <- myReplaceUnique cid Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res -- dangerous
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
@ -476,7 +467,7 @@ courseEditHandler isGet mbCourseForm = do
when success $ redirect $ CourseR tid ssh csh CShowR
(FormFailure _) -> addMessageI Warning MsgInvalidInput
(FormMissing) -> return ()
FormMissing -> return ()
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
defaultLayout $ do
setTitleI MsgCourseEditTitle
@ -578,7 +569,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
validateCourse :: CourseForm -> [Text]
validateCourse (CourseForm{..}) =
validateCourse CourseForm{..} =
[ msg | (False, msg) <-
[
( NTop cfRegFrom <= NTop cfRegTo
@ -598,18 +589,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"

48
src/Handler/Home.hs
View File

@ -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)
@ -56,43 +55,44 @@ homeAnonymous = do
let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course))
tableData course = do
E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
)
return course
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat
[ -- dbRow
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
textCell $ display $ courseTerm course
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
textCell $ display $ courseSchool course
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
let tid = courseTerm course
ssh = courseSchool course
csh = courseShorthand course
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
]
((), courseTable) <- dbTable def $ DBTable
((), courseTable) <- dbTable def DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = colonnade
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "term"
, SortColumn $ \(course) -> course E.^. CourseTerm
, SortColumn $ \course -> course E.^. CourseTerm
)
, ( "school"
, SortColumn $ \(course) -> course E.^. CourseSchool
, SortColumn $ \course -> course E.^. CourseSchool
)
, ( "course"
, SortColumn $ \(course) -> course E.^. CourseShorthand
, SortColumn $ \course -> course E.^. CourseShorthand
)
, ( "deadline"
, SortColumn $ \(course) -> course E.^. CourseRegisterTo
, SortColumn $ \course -> course E.^. CourseRegisterTo
)
]
, dbtFilter = mempty {- [ ( "term"
@ -106,7 +106,7 @@ homeAnonymous = do
}
-- let features = $(widgetFile "featureList")
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
defaultLayout $ do
defaultLayout
-- $(widgetFile "dsgvDisclaimer")
$(widgetFile "home")
@ -126,7 +126,7 @@ homeUser uid = do
, E.SqlExpr (E.Value (Maybe SubmissionId)))
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
E.&&. (E.just $ E.val uid) E.==. subuser E.?. SubmissionUserUser
E.&&. E.just (E.val uid) E.==. subuser E.?. SubmissionUserUser
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
@ -164,14 +164,14 @@ homeUser uid = do
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (i18nCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
case mbsid of
Nothing -> mempty
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark
]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
((), sheetTable) <- dbTable validator $ DBTable
((), sheetTable) <- dbTable validator DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = colonnade
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
@ -206,7 +206,7 @@ homeUser uid = do
, dbtIdent = "upcomingdeadlines" :: Text
}
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
defaultLayout $ do
defaultLayout $
-- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser")
-- $(widgetFile "dsgvDisclaimer")
@ -276,12 +276,14 @@ postHelpR = do
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
case res of
FormSuccess (HelpForm{..}) -> do
FormSuccess HelpForm{..} -> do
now <- liftIO getCurrentTime
queueJob' $ JobHelpRequest { jSender = hfUserId
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer }
queueJob' JobHelpRequest
{ jSender = hfUserId
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer
}
-- redirect $ HelpR
addMessageI Success MsgHelpSent
return ()

177
src/Handler/Profile.hs
View File

@ -67,7 +67,7 @@ getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR
postProfileR = do
(uid, User{..}) <- requireAuthPair
let settingsTemplate = Just $ SettingsForm
let settingsTemplate = Just SettingsForm
{ stgMaxFavourties = userMaxFavourites
, stgTheme = userTheme
, stgDateTime = userDateTimeFormat
@ -92,13 +92,13 @@ postProfileR = do
-- prune Favourites to user-defined size
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime
, OffsetBy $ stgMaxFavourties
, OffsetBy stgMaxFavourties
]
mapM_ delete oldFavs
addMessageI Info $ MsgSettingsUpdate
addMessageI Info MsgSettingsUpdate
redirect ProfileR -- TODO: them change does not happen without redirect
(FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
(FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
_ -> return ()
let formText = Nothing :: Maybe UniWorXMessage
@ -109,7 +109,7 @@ postProfileR = do
postProfileDataR :: Handler Html
postProfileDataR = do
((btnResult,_), _) <- runFormPost $ buttonForm
((btnResult,_), _) <- runFormPost buttonForm
case btnResult of
(FormSuccess BtnDelete) -> do
(uid, User{..}) <- requireAuthPair
@ -119,7 +119,7 @@ postProfileDataR = do
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-- addMessageI Success $ MsgDeleteUser deletedSubmissions
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
defaultLayout $ do
defaultLayout
$(widgetFile "deletedUser")
(FormSuccess BtnAbort ) -> do
@ -156,72 +156,76 @@ deleteUser duid = do
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
E.&&. (whereBuddies numBuddies)
E.&&. whereBuddies numBuddies
return $ submission E.^. SubmissionId
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
getSubmissionFiles subId = E.select $ E.from $ \file -> do
E.where_ $ E.exists $ E.from $ \submissionFile -> do
E.where_ $ E.exists $ E.from $ \submissionFile ->
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
return $ file E.^. FileId
deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
E.where_ $ E.exists $ E.from $ \subGroupUser -> do
E.where_ $ E.exists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
E.where_ $ E.notExists $ E.from $ \subGroupUser -> do
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
E.where_ $ E.notExists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
getProfileDataR :: Handler Html
getProfileDataR :: Handler Html
getProfileDataR = do
(uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
E.select
( E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
E.select
( E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
E.select
( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return ( ( studydegree E.^. StudyDegreeName
, studydegree E.^. StudyDegreeKey
)
, ( studyterms E.^. StudyTermsName
, studyterms E.^. StudyTermsKey
)
, studyfeat E.^. StudyFeaturesType
, studyfeat E.^. StudyFeaturesSemester)
)
E.select
( E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return ( ( studydegree E.^. StudyDegreeName
, studydegree E.^. StudyDegreeKey
)
, ( studyterms E.^. StudyTermsName
, studyterms E.^. StudyTermsKey
)
, studyfeat E.^. StudyFeaturesType
, studyfeat E.^. StudyFeaturesSemester)
)
-- Tabelle mit eigenen Kursen
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
enrolledCoursesTable <- mkEnrolledCoursesTable uid
-- Tabelle mit allen Klausuren und Noten
examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen
@ -229,42 +233,14 @@ getProfileDataR = do
-- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid
-- Tabelle mit allen eigenen Tutorials
ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
-- TODO: move this into a Message and/or Widget-File
let delWdgt = [whamlet|
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
<h2>
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
<div .container>
Während der Testphase von Uni2work können Sie hiermit
Ihren Account bei Uni2work vollständig löschen.
Mit Ihrem Campus-Account können Sie sich aber danach
jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
<div .container>
Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
wenn die Dateien ausschließlich Ihnen zugeordnet sind.
Dateien aus Gruppenabgaben werden also erst dann gelöscht,
wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
<div .container>
<em>Achtung:
Auch abgegebene Hausübungen werden gelöscht!
Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
auch nicht mehr rekonstruiert/berücksichtigt werden.)
<div .container>
<em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
aufbewahrt werden müssen.
<div .container>
^{btnWdgt}
|]
defaultLayout $ do
let delWdgt = $(widgetFile "widgets/data-delete")
$(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer")
@ -280,14 +256,14 @@ mkOwnedCoursesTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` lecturer) -> do
dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
dbtColonnade = mconcat
[ dbRow
@ -299,10 +275,10 @@ mkOwnedCoursesTable =
schoolCell <$> view (_dbrOutput . _1 . re _Just)
<*> view (_dbrOutput . _2 )
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput)
courseCellCL <$> view _dbrOutput
]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -313,7 +289,7 @@ mkOwnedCoursesTable =
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..})
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
@ -340,7 +316,7 @@ mkEnrolledCoursesTable =
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view ( _courseTerm . re _Just)
<*> view ( _courseSchool )
<*> view _courseSchool
, sortable (Just "course") (i18nCell MsgCourse) $
courseCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "time") (i18nCell MsgRegistered) $ do
@ -374,17 +350,16 @@ mkSubmissionTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
let sht = ( sheet E.^. SheetName
)
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
let sht = sheet E.^. SheetName
return (crse, sht, submission, lastSubEdit uid submission)
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
@ -393,7 +368,7 @@ mkSubmissionTable =
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid
return . E.max_ $ subEdit E.^. SubmissionEditTime
dbtProj = \x -> return $ x
dbtProj x = return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _2 %~ E.unValue
& _dbrOutput . _4 %~ E.unValue
@ -404,7 +379,7 @@ mkSubmissionTable =
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just)
<*> view ( _2 )
<*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
@ -439,7 +414,7 @@ mkSubmissionTable =
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid
in dbTableWidget' validator $ DBTable {..}
in dbTableWidget' validator DBTable{..}
-- in do dbtSQLQuery <- dbtSQLQuery'
-- dbtSorting <- dbtSorting'
-- return $ dbTableWidget' validator $ DBTable {..}
@ -455,7 +430,7 @@ mkSubmissionGroupTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do
dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
@ -471,7 +446,7 @@ mkSubmissionGroupTable =
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
dbtProj = \x -> return $ x
dbtProj x = return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _3 %~ E.unValue
@ -481,7 +456,7 @@ mkSubmissionGroupTable =
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just)
<*> view ( _2 )
<*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
@ -507,7 +482,7 @@ mkSubmissionGroupTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..}
in dbTableWidget' validator DBTable{..}
@ -524,15 +499,15 @@ mkCorrectionsTable =
corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
return $ E.countRows
return E.countRows
corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime)
return $ E.countRows
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
return E.countRows
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
@ -542,7 +517,7 @@ mkCorrectionsTable =
)
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
dbtProj = \x -> return $ x
dbtProj x = return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _2 %~ E.unValue
@ -580,5 +555,5 @@ mkCorrectionsTable =
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..}
in dbTableWidget' validator DBTable{..}

32
src/Handler/School.hs
View File

@ -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"

63
src/Handler/Sheet.hs
View File

@ -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
@ -183,8 +178,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")
@ -192,10 +187,11 @@ getSheetListR tid ssh csh = do
$ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
case preview (_grading . _maxPoints) sType of
(Nothing) -> mempty
(Just maxPoints) ->
Just maxPoints
| maxPoints /= 0 ->
let percent = sPoints / maxPoints
in textCell $ textPercent $ realToFrac percent
_other -> mempty
_other -> mempty
]
psValidator = def
@ -213,7 +209,7 @@ getSheetListR tid ssh csh = do
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
return $ foldMap (\(E.Value st, E.Value mbPts) -> sheetTypeSum st (join mbPts)) rows
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
(_, table) <- dbTable psValidator $ DBTable
-- END ISSUE #223
-----------------------------------------------------
@ -235,7 +231,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"
@ -271,9 +267,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
@ -287,19 +281,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
@ -314,13 +309,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
)
]
}
@ -346,7 +341,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
@ -390,7 +385,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
@ -443,12 +437,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
@ -547,7 +539,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
@ -622,7 +613,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])
@ -644,7 +635,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
@ -684,7 +675,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
@ -739,7 +730,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
}
@ -764,9 +755,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 ()

98
src/Handler/Submission.hs
View File

@ -1,6 +1,6 @@
module Handler.Submission where
import Import hiding (joinPath)
import Import
import Jobs
@ -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
@ -89,7 +88,7 @@ getSubmissionOwnR tid ssh csh shn = do
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ submission E.^. SubmissionId
case submissions of
((E.Value sid):_) -> return sid
(E.Value sid : _) -> return sid
[] -> notFound
cID <- encrypt sid
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
@ -132,19 +131,21 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return (csheet, map E.unValue buddies, [])
(E.Value smid:_) -> do
cID <- encrypt smid
addMessageI Info $ MsgSubmissionAlreadyExists
addMessageI Info MsgSubmissionAlreadyExists
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
(Just smid) -> 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
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.orderBy [E.asc $ user E.^. UserEmail]
return $ (user E.^. UserId, user E.^. UserEmail)
return (user E.^. UserId, user E.^. UserEmail)
let breakUserFromBuddies (E.Value userID, E.Value email)
| uid == userID = (Any True , [])
| otherwise = (Any False, [email])
@ -159,17 +160,17 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
let userName = if isOwner || maySubmit
then E.just $ user E.^. UserDisplayName
else E.nothing
return $ (userName, submissionEdit E.^. SubmissionEditTime)
return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
mCID <- runDBJobs $ do
res' <- case res of
(FormMissing ) -> return $ FormMissing
FormMissing -> return FormMissing
(FormFailure failmsgs) -> return $ FormFailure failmsgs
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
(FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
| (Arbitrary {..}) <- sheetGrouping -> do
| Arbitrary{..} <- sheetGrouping -> do
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
@ -211,8 +212,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
case res' of
(FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
now <- liftIO $ getCurrentTime
(FormSuccess (mFiles, setFromList -> adhocIds)) -> do
smid <- do
smid <- case (mFiles, msmid) of
(Nothing, Just smid) -- no new files, existing submission partners updated
@ -261,13 +261,13 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
Just isFile = origIsFile <|> corrIsFile
in if
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
([whamlet|#{fileTitle'}|])
[whamlet|#{fileTitle'}|]
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty
Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
([whamlet|_{MsgFileCorrected}|])
[whamlet|_{MsgFileCorrected}|]
| otherwise -> i18nCell MsgCorrected
, sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
origTime = fileModified . entityVal . snd <$> mOrig
@ -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
@ -316,41 +316,39 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
runDB $ do
submissionID <- submissionMatchesSheet tid ssh csh shn cID
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
submissionID <- submissionMatchesSheet tid ssh csh shn cID
isRating <- maybe False (== submissionID) <$> isRatingFile path
isRating <- (== Just submissionID) <$> isRatingFile path
when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
case isRating of
True
| isUpdate -> do
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
| otherwise -> notFound
False -> do
results <- E.select . 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
E.&&. f E.^. FileTitle E.==. E.val path
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
return f
when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
let fileName = Text.pack $ takeFileName path
case results of
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
other -> do
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
case isRating of
True
| isUpdate -> do
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
| otherwise -> notFound
False -> do
results <- E.select . 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
E.&&. f E.^. FileTitle E.==. E.val path
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
return f
case results of
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
other -> do
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
@ -367,7 +365,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 +374,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

66
src/Handler/SystemMessage.hs
View File

@ -50,11 +50,12 @@ postMessageR cID = do
cID' <- encrypt tId
runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
$ (,)
<$> ( fmap (Entity tId) $ SystemMessageTranslation
<$> pure systemMessageTranslationMessage
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
<$> fmap (Entity tId)
( SystemMessageTranslation
<$> pure systemMessageTranslationMessage
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
)
<*> combinedButtonField (universeF :: [BtnSubmitDelete])
@ -68,25 +69,11 @@ 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
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
[BtnDelete'] -> do
runDB $ delete tId
addMessageI Success MsgSystemMessageDeleteTranslationSuccess
@ -125,9 +112,26 @@ postMessageR cID = do
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
forms <- traverse (const mkForm) $ () <$ guard maySubmit
defaultLayout $ do
defaultLayout
$(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)
@ -159,7 +163,7 @@ postMessageListR = do
dbtColonnade = mconcat
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext)
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
@ -172,12 +176,12 @@ postMessageListR = do
]
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
Just (_, smT) <- lift $ getSystemMessage appLanguages smId
return $ DBRow
return DBRow
{ dbrOutput = (smE, smT)
, ..
}
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
tableForm <- dbTable psValidator $ DBTable
tableForm <- dbTable psValidator DBTable
{ dbtSQLQuery
, dbtColonnade
, dbtProj
@ -191,8 +195,8 @@ postMessageListR = do
, dbtIdent = "messages" :: Text
}
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
now <- liftIO $ getCurrentTime
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
now <- liftIO getCurrentTime
let actions = Map.fromList
[ (SMDelete, pure SMDDelete)
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
@ -223,8 +227,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
@ -245,5 +249,5 @@ postMessageListR = do
addMessageI Success $ MsgSystemMessageAdded cID
redirect $ MessageR cID
defaultLayout $ do
defaultLayout
$(widgetFile "system-message-list")

20
src/Handler/Term.hs
View File

@ -13,7 +13,7 @@ import qualified Database.Esqueleto as E
validateTerm :: Term -> [Text]
validateTerm (Term{..}) =
validateTerm Term{..} =
[ msg | (False, msg) <-
[ --startOk
( termStart `withinTerm` termName
@ -60,15 +60,15 @@ 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{..},_) ->
cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
textCell $ (bool "" tickmark termActive :: Text)
textCell (bool "" tickmark termActive :: Text)
, sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
cell [whamlet|_{MsgNumCourses numCourses}|]
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
@ -96,7 +96,7 @@ getTermShowR = do
-- #{termToText termName}
-- |]
-- ]
((), table) <- dbTable def $ DBTable
((), table) <- dbTable def DBTable
{ dbtSQLQuery = termData
, dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput
@ -116,12 +116,12 @@ getTermShowR = do
]
, dbtFilter = Map.fromList
[ ( "active"
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
, FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
)
, ( "course"
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
[] -> E.val True :: E.SqlExpr (E.Value Bool)
cshs -> E.exists . E.from $ \course -> do
cshs -> E.exists . E.from $ \course ->
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
)
@ -134,7 +134,7 @@ getTermShowR = do
$(widgetFile "terms")
getTermEditR :: Handler Html
getTermEditR = do
getTermEditR =
-- TODO: Defaults für Semester hier ermitteln und übergeben
termEditHandler Nothing
@ -162,7 +162,7 @@ termEditHandler term = do
-- MIT INTERNATIONALISIERUNG:
addMessageI Success $ MsgTermEdited tid
redirect TermShowR
(FormMissing ) -> return ()
FormMissing -> return ()
(FormFailure _) -> addMessageI Warning MsgInvalidInput
let actionUrl = TermEditR
defaultLayout $ do

4
src/Handler/Users.hs
View File

@ -69,7 +69,7 @@ getUsersR = do
psValidator = def
& defaultSorting [("name", SortAsc),("display-name", SortAsc)]
((), userList) <- dbTable psValidator $ DBTable
((), userList) <- dbTable psValidator DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtColonnade
, dbtProj = return
@ -106,7 +106,7 @@ postAdminHijackUserR cID = do
otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
unless ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
permissionDenied "Cannot escalate admin status to additional schools"
get404 uid

2
src/Handler/Utils.hs
View File

@ -31,7 +31,7 @@ downloadFiles = do
return userDefaultDownloadFiles
tidFromText :: Text -> Maybe TermId
tidFromText = (fmap TermKey) . maybeRight . termFromText
tidFromText = fmap TermKey . maybeRight . termFromText
simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]

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

@ -10,7 +10,7 @@ module Handler.Utils.DateTime
import Import
import Data.Time.Zones hiding (localTimeToUTCFull)
import Data.Time.Zones
import qualified Data.Time.Zones as TZ
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
@ -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
@ -38,7 +36,7 @@ instance HasLocalTime Day where
toLocalTime d = LocalTime d midnight
instance HasLocalTime UTCTime where
toLocalTime t = utcToLocalTime t
toLocalTime = utcToLocalTime
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
@ -80,7 +78,7 @@ getDateTimeFormat sel = do
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
-- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
validDateTimeFormats _ SelFormatDateTime = Set.fromList $
validDateTimeFormats _ SelFormatDateTime = Set.fromList
[ DateTimeFormat "%a %d %b %Y %R"
, DateTimeFormat "%a %b %d %Y %R"
, DateTimeFormat "%A, %d %B %Y %R"
@ -97,7 +95,7 @@ validDateTimeFormats _ SelFormatDateTime = Set.fromList $
, DateTimeFormat "%Y-%m-%d %T"
, DateTimeFormat "%Y-%m-%dT%T"
]
validDateTimeFormats _ SelFormatDate = Set.fromList $
validDateTimeFormats _ SelFormatDate = Set.fromList
[ DateTimeFormat "%a %d %b %Y"
, DateTimeFormat "%a %b %d %Y"
, DateTimeFormat "%A, %d %B %Y"
@ -128,7 +126,7 @@ dateTimeFormatOptions sel = do
let
toOption fmt@DateTimeFormat{..} = do
dateTime <- formatTime' unDateTimeFormat now
return $ (dateTime, fmt)
return (dateTime, fmt)
optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel

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

@ -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
@ -137,7 +131,7 @@ buttonForm csrf = do
buttonIdent <- newFormIdent
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
let widget = do
let widget =
[whamlet|
#{csrf}
$forall bView <- btnViews
@ -169,16 +163,16 @@ natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMess
natFieldI msg = checkBool (>= 0) msg intField
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField
natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") intField
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
@ -261,7 +255,7 @@ zipFileField doUnpack = Field{..}
| [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
| null files = return $ Right Nothing
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
fieldView fieldId fieldName attrs _ req = do
fieldView fieldId fieldName attrs _ req =
[whamlet|
$newline never
<input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
@ -290,7 +284,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
@ -460,7 +454,7 @@ utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
-- Browser returns LocalTime
utcTimeField = Field
{ fieldParse = parseHelperGen $ readTime
{ fieldParse = parseHelperGen readTime
, fieldView = \theId name attrs val isReq -> do
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
[whamlet|
@ -478,10 +472,10 @@ utcTimeField = Field
readTime :: Text -> Either UniWorXMessage UTCTime
readTime t =
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
(Just (LTUUnique time _)) -> Right time
(Just (LTUNone _ _)) -> Left MsgIllDefinedUTCTime
(Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
Nothing -> Left MsgInvalidDateTimeFormat
Just LTUUnique{_ltuResult} -> Right _ltuResult
Just LTUNone{} -> Left MsgIllDefinedUTCTime
Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
Nothing -> Left MsgInvalidDateTimeFormat
langField :: Bool -- ^ Only allow values from `appLanguages`
-> Field (HandlerT UniWorX IO) Lang
@ -511,7 +505,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))
@ -557,13 +551,13 @@ apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-- ^ Pseudo required
apreq f fs mx = formToAForm $ do
mr <- getMessageRender
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx)
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ do
mr <- getMessageRender
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx)
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
@ -579,7 +573,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"))

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

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

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

@ -13,7 +13,7 @@ module Handler.Utils.Rating
, extractRatings
) where
import Import hiding ((</>))
import Import
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
@ -56,9 +56,9 @@ instance Pretty x => Pretty (CI x) where
instance Pretty SheetGrading where
pretty (Points {..}) = pretty ( (show maxPoints) <> " Punkte" :: String)
pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String )
pretty (PassBinary) = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
data Rating = Rating
@ -138,10 +138,10 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
let
fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt"
fileTitle = "bewertung_" <> Text.unpack (toPathPiece cID) <.> "txt"
fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
return File{..}
@ -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

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

@ -37,8 +37,8 @@ pKey :: Parser Int
pKey = decimal
pType :: Parser StudyFieldType
pType = FieldPrimary <$ (try $ string "HF")
<|> FieldSecondary <$ (try $ string "NF")
pType = FieldPrimary <$ try (string "HF")
<|> FieldSecondary <$ try (string "NF")
decimal :: Parser Int
decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'

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

@ -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

7
src/Handler/Utils/Table.hs
View File

@ -1,8 +1,7 @@
module Handler.Utils.Table where
-- General Utilities for Tables
import Import hiding ((<>))
-- import Data.Monoid ((<>))
import Import
import Data.Profunctor
import Control.Monad.Except
@ -59,11 +58,11 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
case () of
_ | extId `elem` extIds
-> Just <$> (lift $ fromExternal extId)
-> Just <$> lift (fromExternal extId)
| otherwise
-> return Nothing
view _ name attributes val _ = do
view _ name attributes val _ =
[whamlet|
<label style="display: block">
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>

6
src/Handler/Utils/Table/Cells.hs
View File

@ -63,7 +63,7 @@ courseCellCL (tid,ssh,csh) = anchorCell link name
name = citext2widget csh
courseCell :: IsDBTable m a => Course -> DBCell m a
courseCell (Course {..}) = anchorCell link name `mappend` desc
courseCell Course{..} = anchorCell link name `mappend` desc
where
link = CourseR courseTerm courseSchool courseShorthand CShowR
name = citext2widget courseName
@ -84,7 +84,7 @@ sheetCell crse shn =
in anchorCell link $ display2widget shn
sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a
sheetTypeCell st = i18nCell $ SheetTypeComplete st
sheetTypeCell sheetType = i18nCell $ SheetTypeComplete sheetType
submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
submissionCell crse shn sid =
@ -93,7 +93,7 @@ submissionCell crse shn sid =
csh = crse ^. _3
mkCid = encrypt sid
mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
mkText cid = display2widget cid
mkText = display2widget
in anchorCellM' mkCid mkRoute mkText
correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a

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

@ -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_)
import Control.Monad.Writer hiding ((<>), mapM_)
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) }
@ -99,13 +92,13 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
filterColumn' cont is t = filterColumn' (cont t) is t
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
filterColumn' cont is t = filterColumn' (cont input) is' t
filterColumn' cont is = filterColumn' (cont input) is'
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 }
@ -268,12 +261,12 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
dbCell = iso
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
(\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
(uncurry WidgetCell)
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ = return . snd
dbHandler _ f = return . over _2 f
runDBTable act = liftHandlerT act
runDBTable = liftHandlerT
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty $ return mempty
@ -289,7 +282,7 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
dbCell = iso
(\DBCell{..} -> (dbCellAttrs, dbCellContents))
(\(attrs, mkWidget) -> DBCell attrs mkWidget)
(uncurry DBCell)
dbWidget _ = return . snd
dbHandler _ f = return . over _2 f
@ -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 $ fmap (over _2 f) . form
-- 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))
@ -335,7 +328,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let
sortingOptions = mkOptionList
[ Option t' (t, d) t'
@ -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,13 +344,13 @@ 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
}
psResult <- runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page")
<*> ireq checkBoxField (wIdent "table-only")
@ -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")
@ -467,7 +459,7 @@ cell :: IsDBTable m a => Widget -> DBCell m a
cell wgt = dbCell # ([], return wgt)
textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
textCell = cell . toWidget . (pack :: [Char] -> Text) . otoList
textCell = cell . toWidget . (pack :: String -> Text) . otoList
stringCell = textCell
i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
@ -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>
@ -499,10 +491,10 @@ anchorCell' :: IsDBTable m a
-> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a
anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
anchorCellM' xM x2route x2widget = cell $ do
x <- xM
let route = x2route x
@ -531,7 +523,7 @@ getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall r i a. Ord i
=> (r -> MForm (HandlerT UniWorX IO) i)
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
-> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
-> (r -> DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
formCell genIndex genForm input = FormCell
{ formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
@ -549,7 +541,7 @@ dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ db
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
=> Setter' a Bool
-> (r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])

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

@ -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}|]

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

@ -57,7 +57,7 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
fileContent
| hasTrailingPathSeparator zipEntryName = Nothing
| otherwise = Just $ mconcat contentChunks
yield $ File{..}
yield File{..}
consumeZip'
accContents :: Monad m => Sink (Either a b) m [b]
accContents = do
@ -81,7 +81,7 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
}
toZipData :: Monad m => File -> (ZipEntry, ZipData m)
toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
toZipEntry :: File -> ZipEntry
toZipEntry File{..} = ZipEntry

2
src/Import/NoFoundation.hs
View File

@ -40,6 +40,8 @@ import Data.List.NonEmpty as Import (NonEmpty(..))
import Control.Monad.Morph as Import (MFunctor(..))
import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Control.Monad.Trans.RWS (RWST)

257
src/Jobs.hs
View File

@ -2,6 +2,7 @@ module Jobs
( module Types
, module Jobs.Queue
, handleJobs
, stopJobCtl
) where
import Import
@ -25,7 +26,7 @@ import Data.Semigroup (Max(..))
import Utils.Sql
import Control.Monad.Random (evalRand, mkStdGen)
import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
import Cron
import qualified Data.HashMap.Strict as HashMap
@ -33,18 +34,18 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.List.NonEmpty as NonEmpty
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)
import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate, release)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger
import Control.Monad.Random (MonadRandom(..), evalRand)
import Data.Time.Clock
import Data.Time.Zones
@ -66,131 +67,171 @@ data JobQueueException = JInvalid QueuedJobId QueuedJob
instance Exception JobQueueException
handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m ()
-- | Read control commands from `appJobCtl` and address them as they come in
handleJobs :: ( MonadResource m
, MonadIO m
)
=> UniWorX -> m ()
-- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
--
-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
handleJobs recvChans foundation@UniWorX{..} = do
jobCrontab <- liftIO $ newTVarIO HashMap.empty
handleJobs foundation@UniWorX{..} = do
let num = appJobWorkers appSettings
jobCrontab <- liftIO $ newTMVarIO HashMap.empty
jobConfirm <- liftIO $ newTVarIO HashMap.empty
forM_ (zip [1..] recvChans) $ \(n, chan) ->
forM_ [1..num] $ \n -> do
(bChan, chan) <- atomically $ newBroadcastTMChan >>= (\c -> (c, ) <$> dupTMChan c)
let
logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
doFork = flip forkFinally (\_ -> removeChan) . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
(_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
-- Start cron operation
void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
writeJobCtlBlock JobCtlDetermineCrontab
registeredCron <- liftIO newEmptyTMVarIO
let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
registeredCron' <- atomically $ do
registeredCron' <- tryPutTMVar appCronThread cData
registeredCron' <$ putTMVar registeredCron registeredCron'
when registeredCron' $
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
writeJobCtlBlock JobCtlDetermineCrontab
stopJobCtl :: MonadIO m => UniWorX -> m ()
-- ^ Stop all worker threads currently running
stopJobCtl UniWorX{appJobCtl, appCronThread} = do
mcData <- atomically $ tryReadTMVar appCronThread
whenIsJust mcData $ \(rKey, _) -> do
liftIO $ release rKey
atomically . guardM $ isEmptyTMVar appCronThread
wMap <- liftIO $ readTVarIO appJobCtl
atomically $ forM_ wMap closeTMChan
atomically $ do
wMap' <- readTVar appJobCtl
guard . none (`Map.member` wMap') $ Map.keysSet wMap
execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) ()
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = flip evalStateT HashMap.empty . forever $ do
mapStateT (liftHandlerT . runDB . setSerializable) $ do
let
merge (Entity leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = lift $ delete leId
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
now <- liftIO getCurrentTime
(currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab <- liftBase . readTVar =<< asks jobCrontab
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
case earliestJob prevExec crontab now of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
newCrontab <- lift . lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
lift . lift $ upsertBy
(UniqueCronLastExec $ toJSON job)
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
other -> writeJobCtl other
| otherwise
-> lift . mapReaderT (liftIO . atomically) $
lift . flip writeTVar newCrontab =<< asks jobCrontab
case nextMatch of
MatchAsap -> doJob
MatchNone -> return ()
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
nextTime' <- applyJitter jobCtl nextTime
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
doJob
execCrontab = evalStateT go HashMap.empty
where
acc :: NominalDiffTime
acc = 1e-3
go = do
mapStateT (liftHandlerT . runDB . setSerializable) $ do
let
merge (Entity leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = lift $ delete leId
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do
appInstance <- getsYesod appInstanceID
let
halfRange = truncate $ 0.5 / acc
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t
refT <- liftIO getCurrentTime
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of
Nothing -> return Nothing
Just crontab -> Just <$> do
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
case earliestJob prevExec crontab refT of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab
case currentState of
Nothing -> return ()
Just (currentCrontab, (jobCtl, nextMatch)) -> do
let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
newCrontab <- lift . lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
void . lift . lift $ upsertBy
(UniqueCronLastExec $ toJSON job)
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
other -> writeJobCtl other
| otherwise
-> lift . mapReaderT (liftIO . atomically) $
lift . void . flip swapTMVar newCrontab =<< asks jobCrontab
case nextMatch of
MatchAsap -> doJob
MatchNone -> return ()
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
nextTime' <- applyJitter jobCtl nextTime
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
doJob
go
where
go (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev
, t' < t
= mbPrev
| otherwise
= Just (jobCtl, t)
acc :: NominalDiffTime
acc = 1e-3
applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do
appInstance <- getsYesod appInstanceID
let
halfRange = truncate $ 0.5 / acc
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
go' (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev
, t' < t
= mbPrev
| otherwise
= Just (jobCtl, t)
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
waitTime'
| diffT < acc = "Done"
| otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
$logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
if
| diffT < acc -> return True
| otherwise -> do
retVar <- liftIO newEmptyTMVarIO
void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
let
awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do
crontab' <- readTVar crontabTV
True <$ guard (crontab /= crontab')
crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
waitTime'
| diffT < acc = "Done"
| otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
$logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
if
| diffT < acc -> return True
| otherwise -> do
retVar <- liftIO newEmptyTMVarIO
void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar
let
awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do
crontab' <- tryReadTMVar crontabTV
True <$ guard (Just crontab /= crontab')
crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' :: Natural -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' wNum = C.mapM_ $ \jctl -> do
$logDebugS logIdent $ tshow jctl
resVars <- mapReaderT (liftIO . atomically) $
@ -228,7 +269,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
-- $logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . flip writeTVar newCTab =<< asks jobCrontab
lift . void . flip swapTMVar newCTab =<< asks jobCrontab
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
jLocked jId act = do

2
src/Jobs/Crontab.hs
View File

@ -92,7 +92,7 @@ determineCrontab = execWriterT $ do
collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
where
procCorrector :: Entity Submission -> (UserId , (Max (Maybe UTCTime)))
procCorrector :: Entity Submission -> (UserId ,Max (Maybe UTCTime))
procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal
<*> Max . submissionRatingAssigned . entityVal

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

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

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

@ -1,10 +1,11 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.CorrectionsAssigned
( 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")

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

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

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

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

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

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.SubmissionRated
( dispatchNotificationSubmissionRated
) where
@ -40,7 +42,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
, "submission-rating-comment" Aeson..= submissionRatingComment
, "submission-rating-time" Aeson..= submissionRatingTime
, "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
, "submission-rating-passed" Aeson..= (join $ gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints)
, "submission-rating-passed" Aeson..= join (gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints)
, "sheet-name" Aeson..= sheetName
, "sheet-type" Aeson..= sheetType
, "course-name" Aeson..= courseName

19
src/Jobs/Queue.hs
View File

@ -18,14 +18,24 @@ import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashMap.Strict as HashMap
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform)
import Control.Monad.Random (evalRand, mkStdGen, uniform)
data JobQueueException = JobQueuePoolEmpty
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
instance Exception JobQueueException
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
writeJobCtl cmd = do
tid <- liftIO myThreadId
chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
liftIO . atomically $ writeTMChan chan cmd
wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
if
| null wMap -> throwM JobQueuePoolEmpty
| otherwise -> do
let chan = flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) $ uniform wMap
liftIO . atomically $ writeTMChan chan cmd
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
writeJobCtlBlock cmd = do
@ -72,6 +82,3 @@ runDBJobs act = do
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
forM_ jIds $ writeJobCtl . JobCtlPerform
return ret

2
src/Jobs/Types.hs
View File

@ -55,6 +55,6 @@ instance Hashable JobCtl
data JobContext = JobContext
{ jobCrontab :: TVar (Crontab JobCtl)
{ jobCrontab :: TMVar (Crontab JobCtl)
, jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
}

26
src/Mail.hs
View File

@ -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 }

2
src/Model.hs
View File

@ -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

46
src/Model/Migration.hs
View File

@ -75,15 +75,15 @@ migrateAll = do
Confusion about quotes, from the PostgreSQL Manual:
Single quotes for string constants, double quotes for table/column names.
QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
#{anything} (no escaping);
QuasiQuoter: ^{TableName} @{ColumnName} (escaped as column/table-name; value determined from current model);
#{anything} (escaped as value);
-}
customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>)
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
, whenM (tableExists "user") $ do -- New theme format
, whenM (columnExists "user" "theme") $ do -- New theme format
userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |]
forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
Just v
@ -98,7 +98,7 @@ customMigrations = Map.fromListWith (>>)
|]
)
, ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
, whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now
, whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now
-- Read old table into memory
schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
@ -143,9 +143,9 @@ customMigrations = Map.fromListWith (>>)
FOREIGN KEY (school) REFERENCES school(shorthand);
|]
[executeQQ|
ALTER TABLE "school" DROP COLUMN "id";
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|]
ALTER TABLE "school" DROP COLUMN "id";
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|]
)
, ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|]
, whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
@ -161,32 +161,31 @@ customMigrations = Map.fromListWith (>>)
, whenM (tableExists "user") $ do
userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
[executeQQ|
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT '';
|]
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
Just name -> update uid [UserSurname =. name]
_other -> error $ "Empty userDisplayName found"
_other -> error "Empty userDisplayName found"
)
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
, whenM (tableExists "sheet") $ do
, whenM (tableExists "sheet") $
[executeQQ|
ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|]
)
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
, whenM (tableExists "user") $ do
, whenM (columnExists "user" "plugin") $
-- <> is standard sql for /=
[executeQQ|
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
ALTER TABLE "user" DROP COLUMN "plugin";
ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" json DEFAULT '"ldap"';
|]
)
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
, whenM (tableExists "user") $ do
, whenM (tableExists "user") $
[executeQQ|
ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]';
|]
)
, ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|]
@ -200,7 +199,18 @@ customMigrations = Map.fromListWith (>>)
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do
haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
case haveSchoolTable :: [Maybe (Single PersistValue)] of
haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
case haveTable :: [Maybe (Single PersistValue)] of
[Just _] -> return True
_other -> return False
columnExists :: MonadIO m
=> Text -- ^ Table
-> Text -- ^ Column
-> ReaderT SqlBackend m Bool
columnExists table column = do
haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|]
case haveColumn :: [Single PersistValue] of
[_] -> return True
_other -> return False

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

@ -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 ClassyPrelude.Yesod
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Database.Persist.Sql
import qualified Model as Current
@ -19,9 +15,9 @@ data SheetType
deriving (Show, Read, Eq)
sheetType :: SheetType -> Current.SheetType
sheetType Bonus {..} = Current.Bonus $ Current.Points {..}
sheetType Normal {..} = Current.Normal $ Current.Points {..}
sheetType Pass {..} = Current.Normal $ Current.PassPoints {..}
sheetType Bonus {..} = Current.Bonus Current.Points {..}
sheetType Normal {..} = Current.Normal Current.Points {..}
sheetType Pass {..} = Current.Normal Current.PassPoints {..}
sheetType NotGraded = Current.NotGraded
{- TODO:
@ -30,4 +26,4 @@ sheetType NotGraded = Current.NotGraded
deriveJSON defaultOptions ''SheetType
Current.derivePersistFieldJSON ''SheetType
Current.derivePersistFieldJSON ''SheetType

21
src/Model/Migration/Version.hs
View File

@ -64,22 +64,25 @@ instance PersistFieldSql Version where
version, migrationVersion :: QuasiQuoter
version = QuasiQuoter{..}
version = undefinedQuote{quoteExp}
where
quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
[x] -> x
quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
[x] -> TH.lift x
[] -> error "No parse"
_ -> error "Ambiguous parse"
quotePat = error "version cannot be used as pattern"
quoteType = error "version cannot be used as type"
quoteDec = error "version cannot be used as declaration"
migrationVersion = QuasiQuoter{..}
migrationVersion = undefinedQuote{quoteExp}
where
quoteExp "initial" = TH.lift InitialVersion
quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
[x] -> MigrationVersion x
quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
[x] -> TH.lift $ MigrationVersion x
[] -> error "No parse"
_ -> error "Ambiguous parse"
undefinedQuote :: QuasiQuoter
undefinedQuote = QuasiQuoter{..}
where
quoteExp = error "version cannot be used as expression"
quotePat = error "version cannot be used as pattern"
quoteType = error "version cannot be used as type"
quoteDec = error "version cannot be used as declaration"

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

@ -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"|]) []
]
]

4
src/Settings.hs
View File

@ -81,7 +81,7 @@ data AppSettings = AppSettings
, appMailObjectDomain :: Text
, appMailVerp :: VerpMode
, appMailSupport :: Address
, appJobWorkers :: Int
, appJobWorkers :: Natural
, appJobFlushInterval :: Maybe NominalDiffTime
, appJobCronInterval :: NominalDiffTime
, appJobStaleThreshold :: NominalDiffTime
@ -136,7 +136,7 @@ instance Show PWHashConf where
instance FromJSON PWHashConf where
parseJSON = withObject "PWHashConf" $ \o -> do
pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text
pwHashAlgorithm <- if
| pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
| pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2

2
src/Settings/Cluster.hs
View File

@ -114,7 +114,7 @@ instance FromJSON ClientSession.Key where
instance ClusterSetting 'ClusterErrorMessageKey where
type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
initClusterSetting _ = liftIO $ SecretBox.newKey
initClusterSetting _ = liftIO SecretBox.newKey
knownClusterSetting _ = ClusterErrorMessageKey
instance ToJSON SecretBox.Key where

45
src/Utils.hs
View File

@ -21,6 +21,7 @@ import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Control.Lens as Utils (none)
import Text.Blaze (Markup, ToMarkup)
@ -56,7 +57,7 @@ import qualified Data.Aeson as Aeson
-- Yesod --
-----------
newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }
newtype MsgRendererS site = MsgRenderer { render :: forall msg. RenderMessage site msg => msg -> Text }
getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
getMsgRenderer = do
@ -103,29 +104,29 @@ tickmarkT = tickmark
text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types
toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
a -> WidgetT site m ()
toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
=> a -> WidgetT site m ()
toWgt = toWidget . toHtml
-- Convenience Functions to avoid type signatures:
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
Text -> WidgetT site m ()
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
=> Text -> WidgetT site m ()
text2widget t = [whamlet|#{t}|]
citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
(CI Text) -> WidgetT site m ()
citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
=> CI Text -> WidgetT site m ()
citext2widget t = [whamlet|#{CI.original t}|]
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
String -> WidgetT site m ()
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
=> String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|]
display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
a -> WidgetT site m ()
display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a)
=> a -> WidgetT site m ()
display2widget = text2widget . display
withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
withFragment form html = flip fmap form $ over _2 (toWidget html >>)
-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
@ -173,7 +174,7 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out
-}
textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> (pack $ show rx) <> "%"
textPercent x = lz <> pack (show rx) <> "%"
where
round' :: Double -> Int -- avoids annoying warning
round' = round
@ -259,10 +260,10 @@ infixl 5 !!!
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
(!!!) m k = (fromMaybe mempty) $ Map.lookup k m
(!!!) m k = fromMaybe mempty $ Map.lookup k m
groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend
@ -367,19 +368,19 @@ whenIsRight (Left _) _ = return ()
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return
maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err
whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
whenMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
whenMExceptT b err = when b $ lift err >>= throwE
guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
guardExceptT b err = unless b $ throwE err
guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
guardMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
guardMExceptT b err = unless b $ lift err >>= throwE
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
@ -397,9 +398,9 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
shortCircuitM sc mx my bop = do
x <- mx
case sc x of
True -> return x
False -> bop <$> pure x <*> my
if
| sc x -> return x
| otherwise -> bop <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m ()
@ -434,7 +435,7 @@ allM xs f = andM $ fmap f xs
-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M ma mb = ifM ma (return True) mb
or2M ma = ifM ma (return True)
orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
orM = Fold.foldr or2M (return False)

4
src/Utils/DB.hs
View File

@ -24,11 +24,11 @@ entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal ent
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m (Maybe (Key record))
getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m (Key record)
getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m Bool

96
src/Utils/Form.hs
View File

@ -31,7 +31,7 @@ data FormLayout = FormStandard
renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
(res, (($ []) -> views)) <- aFormToForm aform
(res, ($ []) -> views) <- aFormToForm aform
let widget = $(widgetFile "widgets/form")
return (res, widget)
@ -40,58 +40,58 @@ renderAForm formLayout aform fragment = do
--------------------
fsl :: Text -> FieldSettings site
fsl lbl =
FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
fsl lbl
= FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
fslI :: RenderMessage site msg => msg -> FieldSettings site
fslI lbl =
FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
fslI lbl
= FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
fslp :: Text -> Text -> FieldSettings site
fslp lbl placeholder =
FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = [("placeholder", placeholder)]
}
fslp lbl placeholder
= FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = [("placeholder", placeholder)]
}
fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
fslpI lbl placeholder =
FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = [("placeholder", placeholder)]
}
fslpI lbl placeholder
= FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = [("placeholder", placeholder)]
}
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
where
newAttrs :: [(Text,Text)] -> [(Text,Text)]
newAttrs [] = [(attr,valu)]
newAttrs (p@(a,v):t)
| attr==a = (a,T.append valu $ cons ' ' v):t
| otherwise = p:(newAttrs t)
newAttrs [] = [(attr, valu)]
newAttrs (p@(a,v) : t)
| attr==a = (a, T.append valu $ cons ' ' v) : t
| otherwise = p : newAttrs t
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
where
newAttrs :: [(Text,Text)] -> [(Text,Text)]
newAttrs [] = [(attr,T.intercalate " " valus)]
newAttrs (p@(a,v):t)
| attr==a = (a,T.intercalate " " (v:valus)):t
| otherwise = p:(newAttrs t)
newAttrs :: [(Text, Text)] -> [(Text, Text)]
newAttrs [] = [(attr, T.intercalate " " valus)]
newAttrs (p@(a,v) : t)
| attr==a = ( a, T.intercalate " " $ v : valus ) : t
| otherwise = p : newAttrs t
addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class"
@ -103,17 +103,19 @@ addName :: Text -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just nm }
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
addIdClass gId gClass fs = fs { fsId = Just gId, fsAttrs = ("class",gClass) : fsAttrs fs }
setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
setClass fs c = fs { fsAttrs = ("class",c) : fsAttrs fs }
setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
setNameClass fs gName gClass = fs { fsName = Just gName
, fsAttrs = ("class",gClass) : fsAttrs fs
}
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
@ -179,7 +181,7 @@ identForm = identifyForm . toPathPiece
data family ButtonCssClass site :: *
bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc))
class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
label :: a -> WidgetT site IO ()
@ -213,7 +215,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
fieldParse _ _ = return $ Left "Multiple button values"
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField btns = traverse b2f btns
combinedButtonField = traverse b2f
where
b2f b = aopt (buttonField b) "" Nothing
@ -247,7 +249,7 @@ reorderField optList = Field{..}
olNum = fromIntegral $ length olOptions
selOptions = Map.fromList $ do
i <- [1..olNum]
(readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
(readMay -> Just (n :: Word), '.' : extVal) <- break (== '.') . unpack <$> optlist
guard $ i == n
Just val <- return . olReadExternal $ pack extVal
return (i, val)

4
src/Utils/Lang.hs
View File

@ -24,9 +24,7 @@ selectLanguage' avL (l:ls)
| not $ null l
, Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l
, found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL
= case found of
Just l' -> l'
Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
= flip fromMaybe found $ selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
| otherwise = selectLanguage' avL ls
langMatches :: Lang -- ^ Needle

2
src/Utils/Lens.hs
View File

@ -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(..))

4
src/Utils/Sql.hs
View File

@ -6,7 +6,7 @@ import ClassyPrelude.Yesod
import Database.Persist.Sql
import Database.PostgreSQL.Simple (sqlErrorHint)
import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint)
import Control.Monad.Catch (handleIf)
import Data.Time.Clock
@ -18,7 +18,7 @@ setSerializable act = setSerializable' (0 :: Integer)
setSerializable' (min 10 -> logBackoff) =
handleIf
(\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
(\SqlError{sqlErrorHint} -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint)
(\e -> do
let
delay :: NominalDiffTime

2
stack.yaml
View File

@ -38,4 +38,6 @@ extra-deps:
- saltine-0.1.0.1
- hlint-test-0.1.0.0
resolver: lts-10.5

2
templates/correction-user.hamlet
View File

@ -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}

2
templates/default-layout.hamlet
View File

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

2
templates/login.hamlet
View File

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

2
templates/mail/submissionRated.hamlet
View File

@ -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>

2
templates/mail/support.hamlet
View File

@ -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

2
templates/messages/submissionFilesIgnored.hamlet
View File

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

14
templates/widgets/asidenav.hamlet
View File

@ -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 _

2
templates/widgets/campus-login-form.hamlet
View File

@ -1,2 +1,2 @@
<form method=POST action=@{toMaster $ PluginR "LDAP" []} enctype=#{loginEnctype}>
<form method=POST action=@{toMaster $ PluginR "LDAP" []} enctype=#{loginEnctype} #login--campus>
^{login}

27
templates/widgets/data-delete.hamlet Normal file
View File

@ -0,0 +1,27 @@
<form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
<h2>
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
<div .container>
Während der Testphase von Uni2work können Sie hiermit
Ihren Account bei Uni2work vollständig löschen.
Mit Ihrem Campus-Account können Sie sich aber danach
jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
<div .container>
Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
wenn die Dateien ausschließlich Ihnen zugeordnet sind.
Dateien aus Gruppenabgaben werden also erst dann gelöscht,
wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
<div .container>
<em>Achtung:
Auch abgegebene Hausübungen werden gelöscht!
Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
auch nicht mehr rekonstruiert/berücksichtigt werden.)
<div .container>
<em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
aufbewahrt werden müssen.
<div .container>
^{btnWdgt}

2
templates/widgets/dummy-login-form.hamlet
View File

@ -1,2 +1,2 @@
<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}>
<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype} #login--dummy>
^{login}

2
templates/widgets/hash-login-form.hamlet
View File

@ -1,2 +1,2 @@
<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}>
<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype} #login--hash>
^{login}

2
templates/widgets/rating.hamlet
View File

@ -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

73
templates/widgets/sheetTypeSummary.hamlet
View File

@ -1,38 +1,41 @@
$with realGrades <- normalSummary <> bonusSummary
$with allGrades <- realGrades <> informationalSummary
<div>
<ul>
$maybe realPoints <- positiveSum (sumGradePoints realGrades)
<li>
Gesamtpunktzahl #{display realPoints}
$maybe nPts <- getSum <$> achievedPoints realGrades
\ davon #{display nPts} erreicht
$maybe bPts <- getSum <$> achievedPoints bonusSummary
\ (inklusive #{display bPts} #
$maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary)
von #{display achievedBonus} erreichbaren #
Bonuspunkten)
$# $with allGrades <- realGrades <> informationalSummary
<div>
<ul>
$maybe realPoints <- positiveSum (sumGradePoints realGrades)
<li>
Gesamtpunktzahl #{display realPoints}
$maybe nPts <- getSum <$> achievedPoints realGrades
\ davon #{display nPts} erreicht
$maybe bPts <- getSum <$> achievedPoints bonusSummary
\ (inklusive #{display bPts} #
$maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary)
von #{display achievedBonus} erreichbaren #
Bonuspunkten)
$if realPoints /= 0
\ #{textPercent $ realToFrac $ nPts / realPoints}
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
<li>
<em>Hinweis:
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
$maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
, davon wurden #{display achievedFakes} erreicht
\.
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
<li>
<em>Hinweis:
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
$maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
, davon wurden #{display achievedFakes} erreicht
$if fakePoints /= 0
\ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
.
$maybe reqPasses <- positiveSum (numGradePasses normalSummary)
<li>
Aufgaben zum Bestehen: #{display reqPasses}
$maybe passed <- getSum <$> achievedPasses realGrades
\ davon #{display passed} bestanden
$maybe bonusPassed <- getSum <$> achievedPasses bonusSummary
\ (inklusive #{display bonusPassed} Bonusaufgaben)
.
$maybe noGradeSheets <- positiveSum numNotGraded
<li>
#{display noGradeSheets} unbewertete Aufgabenblätter.
\.
$maybe reqPasses <- positiveSum (numGradePasses normalSummary)
<li>
Aufgaben zum Bestehen: #{display reqPasses}
$maybe passed <- getSum <$> achievedPasses realGrades
\ davon #{display passed} bestanden
$maybe bonusPassed <- getSum <$> achievedPasses bonusSummary
\ (inklusive #{display bonusPassed} Bonusaufgaben)
\.
$maybe noGradeSheets <- positiveSum numNotGraded
<li>
#{display noGradeSheets} unbewertete Aufgabenblätter.

2
test.sh
View File

@ -11,4 +11,4 @@ if [[ -d .stack-work-test ]]; then
trap move-back EXIT
fi
stack test --flag uniworx:dev --flag uniworx:library-only ${@}
stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@}

11
test/CronSpec.hs
View File

@ -5,7 +5,6 @@ module CronSpec where
import TestImport
import Cron
import Numeric.Natural
import Data.Time
import Data.Time.Clock.System
@ -22,9 +21,9 @@ sampleCron :: Natural -> Cron -> [UTCTime]
sampleCron n = go n baseTime Nothing
where
go 0 _ _ _ = []
go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
MatchAsap -> t : go (pred n) t (Just t) cron
MatchAt t' -> t' : go (pred n) t' (Just t') cron
go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
MatchAsap -> t : go n' t (Just t) cron
MatchAt t' -> t' : go n' t' (Just t') cron
MatchNone -> []
@ -32,8 +31,8 @@ spec :: Spec
spec = do
describe "Cron" $ do
it "generates correct example series" . mapM_ seriesExample $
[ (Cron CronAsap Nothing CronScheduleBefore, [baseTime])
, (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime)
[ (Cron CronAsap CronRepeatNever 0 (Right CronNotScheduled), [baseTime])
, (Cron CronAsap (CronRepeatScheduled CronAsap) 10 (Right CronNotScheduled), iterate (addUTCTime 10) baseTime)
]
seriesExample :: (Cron, [UTCTime]) -> Expectation

27
test/Handler/HomeSpec.hs
View File

@ -6,30 +6,11 @@ import TestImport
spec :: Spec
spec = withApp $ do
describe "Homepage" $ do
it "loads the index and checks it looks right" $ do
get HomeR
statusIs 200
htmlAnyContain "h1" "a modern framework for blazing fast websites"
request $ do
setMethod "POST"
setUrl HomeR
addToken
fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
byLabel "What's on the file?" "Some Content"
setMethod "GET"
setUrl HomeR
addRequestHeader ("Accept-Language", "de")
statusIs 200
-- more debugging printBody
htmlAllContain ".upload-response" "text/plain"
htmlAllContain ".upload-response" "Some Content"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get HomeR
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEq "user table empty" 0 $ length users
htmlAnyContain "h1" "Aktuelle Termine"

45
test/Handler/ProfileSpec.hs
View File

@ -6,25 +6,40 @@ import TestImport
import qualified Data.CaseInsensitive as CI
import Yesod.Core.Handler (toTextUrl)
import Yesod.Core.Unsafe (fakeHandlerGetLogger)
spec :: Spec
spec = withApp $ do
describe "Profile page" $ do
it "asserts no access to my-account for anonymous users" $ do
get ProfileR
describe "Profile page" $ do
it "asserts no access to my-account for anonymous users" $ do
get ProfileR
statusIs 403
app <- getTestYesod
loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR)
it "asserts access to my-account for authenticated users" $ do
userEntity <- createUser "foo"
authenticateAs userEntity
assertHeader "Location" $ encodeUtf8 loginText
either (fail . unpack) (\_ -> return ()) =<< followRedirect
statusIs 200
get ProfileR
statusIs 200
it "asserts access to my-account for authenticated users" $ do
userEntity <- createUser "foo"
authenticateAs userEntity
it "asserts user's information is shown" $ do
userEntity <- createUser "bar"
authenticateAs userEntity
get ProfileR
statusIs 200
get ProfileR
let (Entity _ user) = userEntity
htmlAnyContain ".username" . unpack . CI.original $ userIdent user
it "displays basic user data" $ do
userEntity@(Entity _userId User{..}) <- createUser "foo"
authenticateAs userEntity
get ProfileDataR
statusIs 200
forM_ (words userDisplayName) $ \nameWord -> do
htmlAnyContain ".profile dd" $ unpack nameWord
htmlAnyContain ".profile dd" $ unpack userSurname
htmlAnyContain ".profile dd" . unpack $ CI.original userIdent
htmlAnyContain ".profile dd" . unpack $ CI.original userEmail

3
test/Handler/Utils/ZipSpec.hs
View File

@ -23,6 +23,7 @@ instance Arbitrary File where
fileModified <- addUTCTime <$> arbitrary <*> pure (UTCTime date 0)
fileContent <- arbitrary
return File{..}
shrink = genericShrink
spec :: Spec
spec = describe "Zip file handling" $ do
@ -31,7 +32,7 @@ spec = describe "Zip file handling" $ do
zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume
forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do
let acceptableFilenameChanges
= makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid
= makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid
acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2
(shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file)
when (inZipRange $ fileModified file) $

7
test/Model/TypesSpec.hs
View File

@ -14,7 +14,7 @@ instance Arbitrary Season where
instance Arbitrary TermIdentifier where
arbitrary = do
season <- arbitrary
year <- arbitrary
year <- arbitrary `suchThat` (\y -> abs y >= 100)
return $ TermIdentifier{..}
shrink = genericShrink
@ -24,8 +24,9 @@ spec = do
it "has compatible encoding/decoding to/from Text" . property $
\term -> termFromText (termToText term) == Right term
it "works for some examples" . mapM_ termExample $
[ (TermIdentifier 2017 Summer, "S2017")
, (TermIdentifier 1995 Winter, "W1995")
[ (TermIdentifier 2017 Summer, "S17")
, (TermIdentifier 1995 Winter, "W95")
, (TermIdentifier 3068 Winter, "W3068")
]
termExample :: (TermIdentifier, Text) -> Expectation

89
test/TestImport.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module TestImport
( module TestImport
, module X
@ -11,11 +6,10 @@ module TestImport
import Application (makeFoundation, makeLogWare)
import ClassyPrelude as X hiding (delete, deleteBy, Handler)
import Database.Persist as X hiding (get)
import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, unSingle, connEscapeName, sqlQQ)
import Foundation as X
import Model as X
import Test.Hspec as X
import Text.Shakespeare.Text (st)
import Yesod.Default.Config2 (useEnv, loadYamlSettings)
import Yesod.Auth as X
import Yesod.Test as X
@ -23,8 +17,12 @@ import Yesod.Core.Unsafe (fakeHandlerGetLogger)
import Test.QuickCheck as X
import Test.QuickCheck.Gen as X
import Data.Default as X
import Test.QuickCheck.Instances as X
import Test.QuickCheck.Instances as X ()
import System.IO as X (hPrint, hPutStrLn, stderr)
import Jobs (handleJobs, stopJobCtl)
import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase)
import Data.Pool (destroyAllResources)
import Settings
@ -34,60 +32,61 @@ import qualified Data.CaseInsensitive as CI
runDB :: SqlPersistM a -> YesodExample UniWorX a
runDB query = do
app <- getTestYesod
liftIO $ runDBWithApp app query
app <- getTestYesod
liftIO $ runDBWithApp app query
runDBWithApp :: UniWorX -> SqlPersistM a -> IO a
runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a
runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app)
runHandler :: Handler a -> YesodExample UniWorX a
runHandler handler = do
app <- getTestYesod
fakeHandlerGetLogger appLogger app handler
app <- getTestYesod
fakeHandlerGetLogger appLogger app handler
withApp :: SpecWith (TestApp UniWorX) -> Spec
withApp = before $ do
settings <- loadYamlSettings
["config/test-settings.yml", "config/settings.yml"]
[]
useEnv
foundation <- makeFoundation settings
wipeDB foundation
logWare <- liftIO $ makeLogWare foundation
return (foundation, logWare)
withApp :: YSpec UniWorX -> Spec
withApp = around $ \act -> runResourceT $ do
settings <- liftIO $ loadYamlSettings
["config/test-settings.yml", "config/settings.yml"]
[]
useEnv
foundation <- makeFoundation settings
let
stopDBAccess = do
stopJobCtl foundation
liftIO . destroyAllResources $ appConnPool foundation
bracket_ stopDBAccess (handleJobs foundation) $ wipeDB foundation
logWare <- makeLogWare foundation
lift $ act (foundation, logWare)
-- This function will truncate all of the tables in your database.
-- 'withApp' calls it before each test, creating a clean environment for each
-- spec to run in.
wipeDB :: UniWorX -> IO ()
wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m ()
wipeDB app = runDBWithApp app $ do
tables <- getTables
sqlBackend <- ask
tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|]
sqlBackend <- ask
let escapedTables = map (connEscapeName sqlBackend . DBName) tables
query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables
rawExecute query []
getTables :: MonadIO m => ReaderT SqlBackend m [Text]
getTables = do
tables <- rawSql [st|
SELECT table_name
FROM information_schema.tables
WHERE table_schema = 'public';
|] []
return $ map unSingle tables
let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables
query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY"
protected = ["applied_migration"]
rawExecute query []
-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
-- being set in test-settings.yaml, which enables dummy authentication in
-- Foundation.hs
authenticateAs :: Entity User -> YesodExample UniWorX ()
authenticateAs (Entity _ User{..}) = do
request $ do
setMethod "POST"
addPostParam "ident" $ CI.original userIdent
setUrl $ AuthR $ PluginR "dummy" []
request $ do
setMethod "GET"
addRequestHeader ("Accept-Language", "de")
setUrl $ AuthR LoginR
request $ do
setMethod "POST"
addToken_ "#login--dummy"
byLabelExact "Nutzer-Kennung" $ CI.original userIdent
setUrl $ AuthR $ PluginR "dummy" []
-- | Create a user. The dummy email entry helps to confirm that foreign-key
-- checking is switched off in wipeDB for those database backends which need it.
@ -106,4 +105,6 @@ createUser userIdent = do
userDateFormat = userDefaultDateFormat
userTimeFormat = userDefaultTimeFormat
userDownloadFiles = userDefaultDownloadFiles
userMailLanguages = def
userNotificationSettings = def
runDB $ insertEntity User{..}