Merge branch 'master' into 'live'

#225

Closes #225

See merge request !90

.hlint.yaml

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

hlint/Hlint.hs

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

models

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

package.yaml

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

routes

@@ -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                    SchoolListR       GET             !development
-/school/#SchoolId          SchoolShowR       GET
+/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

shell.nix

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

src/Application.hs

@@ -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
+    appJobCtl <- liftIO $ newTVarIO Map.empty
-        chan <- newBroadcastTMChan
+    appCronThread <- liftIO newEmptyTMVarIO
-        recvChan <- dupTMChan chan
-        return (chan, recvChan)
 
     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
+shutdownApp = stopJobCtl
-  liftIO . atomically $ mapM_ closeTMChan appJobCtl
 
 
 ---------------------------------------------

src/Cron.hs

@@ -1,5 +1,6 @@
 module Cron
-  ( CronNextMatch(..)
+  ( evalCronMatch
+  , CronNextMatch(..)
   , nextCronMatch
   , module Cron.Types
   ) where
@@ -18,11 +19,7 @@ import Data.Ratio ((%))
 
 import qualified Data.Set as Set
 
-import Data.List.NonEmpty (NonEmpty(..))
+import Utils.Lens hiding (from, to)
-import qualified Data.List.NonEmpty as NonEmpty
-
-import Utils.Lens.TH
-import Control.Lens
 
   
 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    = mergeAnd as (b:bs)
-      | a == b = a : mergeAnd as bs
+      | a == b    = a : mergeAnd as bs
-      | a >  b = mergeAnd (a:as) bs
+      | otherwise = mergeAnd (a:as) bs
 genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
 genMatch p m st (CronMatchUnion 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 (b:bs)
-      | a == b = a : merge as bs
+      | a == b    = a : merge as bs
-      | a >  b = b : merge (a:as) bs
+      | otherwise = b : merge (a:as) bs
 
 nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
               -> 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
-    
+    nextMatch = case mPrev of
-    nextCronMatch' tz mPrev now c@Cron{..}
+      Nothing
-      | isNothing mPrev
+        -> execRef now False cronInitial
-      = execRef now False cronInitial
+      Just prevT
-      | Just prevT <- mPrev
+        -> case cronRepeat of
-      = case cronRepeat of
+            CronRepeatOnChange
-          CronRepeatOnChange
+              | not $ matchesCron tz Nothing prevT c
-            | not $ matchesCron tz Nothing prevT c
+                -> let
-              -> let
+                     cutoffTime = addUTCTime cronRateLimit prevT
-                   cutoffTime = addUTCTime cronRateLimit prevT
+                   in case execRef now False cronInitial of
-                 in case execRef now False cronInitial of
+                        MatchAsap
-                      MatchAsap
+                          | now < cutoffTime -> MatchAt cutoffTime
-                        | now < cutoffTime -> MatchAt cutoffTime
+                        MatchAt ts 
-                      MatchAt ts 
+                          | ts < cutoffTime -> MatchAt cutoffTime
-                        | ts < cutoffTime -> MatchAt cutoffTime
+                        other -> other
-                      other -> other
+            CronRepeatScheduled cronNext
-          CronRepeatScheduled cronNext
+              -> case cronNext of
-            -> case cronNext of
+                   CronAsap
-                 CronAsap
+                     | addUTCTime cronRateLimit prevT <= now
-                   | addUTCTime cronRateLimit prevT <= now
+                       -> MatchAsap
-                     -> MatchAsap
+                     | otherwise
-                   | otherwise
+                       -> MatchAt $ addUTCTime cronRateLimit prevT
-                     -> MatchAt $ addUTCTime cronRateLimit prevT
+                   _other
-                 cronNext
+                     -> execRef (addUTCTime cronRateLimit prevT) True cronNext
-                   -> execRef (addUTCTime cronRateLimit prevT) True cronNext
+            _other -> MatchNone
-          _other -> MatchNone
 
     execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
       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
+        mCronYear <- genMatch 400 False cdYear cronYear
-        cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
+        mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
-        cronMonth <- genMatch 12 True cdMonth cronMonth
+        mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
-        cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
+        mCronMonth <- genMatch 12 True cdMonth cronMonth
-        cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
+        mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
-        cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
+        mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
-        cronHour <- genMatch 24 True cdHour cronHour
+        mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
-        cronMinute <- genMatch 60 True cdMinute cronMinute
+        mCronHour <- genMatch 24 True cdHour cronHour
-        cronSecond <- genMatch 60 True cdSecond cronSecond
+        mCronMinute <- genMatch 60 True cdMinute cronMinute
-        guard $ consistentCronDate CronDate{..}
+        mCronSecond <- genMatch 60 True cdSecond cronSecond
-        localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
+        guard $ consistentCronDate CronDate
-        let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)
+          { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth
+          , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond
+          , cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
+          , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek
+          }
+
+        localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
+        let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
         return $ localTimeToUTCTZ tz LocalTime{..}
       CronNotScheduled -> MatchNone
 

src/CryptoID.hs

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

src/Data/Universe/Instances/Reverse/JSON.hs

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

src/Foundation.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
 
 module Foundation where
 
@@ -10,20 +11,18 @@ import Text.Jasmine         (minifym)
 import qualified Web.ClientSession as ClientSession
 
 import Yesod.Auth.Message
-import Yesod.Auth.Dummy
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
 import Jobs.Types
 
-import qualified Network.Wai as W (requestMethod, pathInfo)
+import qualified Network.Wai as W (pathInfo)
 
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-import qualified Data.Text.Encoding as TE
 
 import qualified Data.CryptoID as E
 
@@ -40,12 +39,10 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Data.List (foldr1)
-import qualified Data.List as List
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
-import Data.List (findIndex)
 
 import Data.Monoid (Any(..))
 
@@ -61,22 +58,14 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
-import Control.Monad.Catch (handleAll)
 import qualified Control.Monad.Catch as C
 
-import System.FilePath
-
-import Handler.Utils.Templates
 import Handler.Utils.StudyFeatures
 import Control.Lens
-import Utils
 import Utils.Form
-import Utils.Lens
 import Utils.SystemMessage
 
 import Data.Aeson hiding (Error, Success)
-import Data.Aeson.TH
-import qualified Data.Yaml as Yaml
 
 import Text.Shakespeare.Text (st)
 
@@ -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)
+  renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang'))
-    | lang == "de-DE" = mr MsgGermanGermany
+    | ["de", "DE"] <- lang' = mr MsgGermanGermany
-    | "de" `isPrefixOf` lang = mr MsgGerman
+    | ("de" : _)   <- lang' = mr MsgGerman
+    | otherwise = lang
     where
       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 _) _ = reason
-andAR _  _ reason@(Unauthorized x) = 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
+                $forall err' <- errs
-                  <li .errMsg>#{err}
+                  <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
+      breadcrumbsWgt :: Widget
-      breadcrumbs = $(widgetFile "widgets/breadcrumbs")
+      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"
   

src/Handler/Admin.hs

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

src/Handler/Corrections.hs

@@ -24,7 +24,7 @@ import Data.Semigroup (Sum(..))
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
 --
-import Colonnade hiding (fromMaybe, singleton, bool)
+-- import Colonnade hiding (fromMaybe, singleton, bool)
 -- import Yesod.Colonnade
 --
 -- import qualified Data.UUID.Cryptographic as UUID
@@ -40,25 +40,19 @@ import qualified Database.Esqueleto as E
 import Web.PathPieces
 
 import Text.Hamlet (ihamletFile)
-import Text.Blaze.Html (preEscapedToHtml)
 
 import Database.Persist.Sql (updateWhereCount)
 
 import Data.List (genericLength)
 
-import Data.CaseInsensitive (CI)
+import Control.Monad.Trans.Writer (WriterT(..), runWriter)
-import qualified Data.CaseInsensitive as CI
-
-import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
-import Control.Monad.Writer.Class (MonadWriter(..))
 
 import Control.Monad.Trans.RWS (RWST)
 
-import Control.Monad.Trans.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)
+  protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
-  in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+  in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
   
 colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colRating = 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
@@ -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
+        unless (null unassigned) $ do
-          (assigned, unassigned) <- assignSubmissions shid (Just unassigned)
+          (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
-          when (not $ null assigned) $
+          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
+                       , SubmissionRatingPoints  =. ratingPoints'
-                       , SubmissionRatingComment =. ratingComment
+                       , 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
+            if
-              [x] -> do
+              | length (groups :: [E.Value SubmissionGroupId]) < 2
-                subId <- insert submission
+                -> do
-                void . insert $ SubmissionEdit uid now subId
+                  subId <- insert submission
-                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                  void . insert $ SubmissionEdit uid now subId
+                  insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                     { submissionUserUser = sheetPseudonymUser
                     , submissionUserSubmission = subId
                     }
-              [] -> do
+                  when (null groups) $
-                subId <- insert submission
+                    addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
-                void . insert $ SubmissionEdit uid now subId
+              | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
-                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-                    { submissionUserUser = sheetPseudonymUser
-                    , submissionUserSubmission = subId
-                    }               
-                addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
-              _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
           NoGroups
             | [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])
+    partitionEithers' :: [[Either a b]] -> ([[b]], [a])
-    partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) 
+    partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) 
     
     textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
     textToList (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")

src/Handler/Course.hs

@@ -2,9 +2,7 @@ module Handler.Course where
 
 import Import hiding (catMaybes)
 
-import Control.Lens
 import Utils.Lens
-import Utils.TH
 -- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
@@ -20,20 +18,15 @@ import qualified Data.Map as Map
 
 import qualified Data.CaseInsensitive as CI
 
-
-import Colonnade hiding (fromMaybe,bool)
--- import Yesod.Colonnade
-
 import qualified Database.Esqueleto as E
 
-import qualified Data.UUID.Cryptographic as UUID
 
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
 
 colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
               [whamlet|#{display courseName}|]
 
@@ -44,19 +37,19 @@ colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
 
 colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colDescription = sortable Nothing (i18nCell MsgCourseDescription)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             case courseDescription of
               Nothing      -> mempty
               (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr)
 
 colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
 
 colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
             ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
             ( case courseDescription of
                 Nothing      -> mempty
@@ -70,7 +63,7 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
 
 colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
 
 colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
@@ -85,24 +78,24 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
 
 colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
             maybe mempty timeCell courseRegisterFrom
             -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
 
 colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
-            cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
+            maybe mempty timeCell courseRegisterTo
 
 colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colParticipants = 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, _, _) ->
+      whereClause (course, _, _) =
-                course E.^. CourseTerm   E.==. E.val tid
+              course E.^. CourseTerm   E.==. E.val tid
-          E.&&. course E.^. CourseSchool E.==. E.val ssh
+        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 $
-      oldCourses <- runDB $ do
         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 :: Bool -> Maybe CourseForm -> Handler Html -- FIXME: _isGet is not used
-courseEditHandler isGet mbCourseForm = do
+courseEditHandler _isGet mbCourseForm = do
     aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
     ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
     case result of
-      (FormSuccess res@(
+      (FormSuccess res@CourseForm
-        CourseForm  { cfCourseId = Nothing
+        { cfCourseId = Nothing
-                    , cfShort    = csh
+        , cfShort    = csh
-                    , cfSchool   = ssh
+        , cfSchool   = ssh
-                    , cfTerm     = tid
+        , cfTerm     = tid
-                    })) ->  do -- create new course
+        }) -> 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@(
+      (FormSuccess res@CourseForm
-        CourseForm  { cfCourseId = Just cid
+        { cfCourseId = Just cid
-                    , cfShort    = csh
+        , cfShort    = csh
-                    , cfSchool   = ssh
+        , cfSchool   = ssh
-                    , cfTerm     = tid
+        , cfTerm     = tid
-                    })) -> do -- edit existing course
+        }) -> 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
+              (Just _) -> do
-                updOkay <- myReplaceUnique cid (  -- replaceUnique requires Eq Course, which we cannot have
+                updOkay <- myReplaceUnique cid Course
-                    Course  {  courseName            = cfName       res
+                  { courseName            = cfName       res
-                            ,  courseDescription     = cfDesc       res
+                  , courseDescription     = cfDesc       res
-                            ,  courseLinkExternal    = cfLink       res
+                  , courseLinkExternal    = cfLink       res
-                            ,  courseShorthand       = cfShort      res
+                  , courseShorthand       = cfShort      res
-                            ,  courseTerm            = cfTerm       res -- dangerous
+                  , courseTerm            = cfTerm       res -- dangerous
-                            ,  courseSchool          = cfSchool     res
+                  , courseSchool          = cfSchool     res
-                            ,  courseCapacity        = cfCapacity   res
+                  , courseCapacity        = cfCapacity   res
-                            ,  courseRegisterSecret  = cfSecret     res
+                  , courseRegisterSecret  = cfSecret     res
-                            ,  courseMaterialFree    = cfMatFree    res
+                  , courseMaterialFree    = cfMatFree    res
-                            ,  courseRegisterFrom    = cfRegFrom    res
+                  , courseRegisterFrom    = cfRegFrom    res
-                            ,  courseRegisterTo      = cfRegTo      res
+                  , courseRegisterTo      = cfRegTo      res
-                            ,  courseDeregisterUntil = cfDeRegUntil 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
+getCUserR _tid _ssh _csh uCId = do
-  uid <- decrypt uuid
+  -- Needs authorization check:
+  --
+  --   - User is current member of course
+  --   - User has submitted in course
+  --   - User is member of registered group for course
+  --   - User is corrector for course (?)
+  --   - User is lecturer for course (?)
+  uid <- decrypt uCId
   User{..} <- runDB $ get404 uid
-  defaultLayout $
+  defaultLayout -- TODO
     [whamlet|
-      <h1>TODO
+      <p>^{nameWidget userDisplayName userSurname}
-      <h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
     |]
 
 getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCHiWisR tid ssh csh = undefined -- TODO
+getCHiWisR = error "CHiWisR: Not implemented"

src/Handler/Home.hs

@@ -8,7 +8,6 @@ import qualified Data.Map as Map
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8')
 import Data.Time hiding (formatTime)
-import Data.Universe
 import Data.Universe.Helpers
 
 import Network.Wai (requestHeaderReferer)
@@ -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.&&. (       E.isNothing (course E.^. CourseRegisterTo)
-                        E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
+                        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
+      queueJob' JobHelpRequest
-                                  , jHelpRequest = hfRequest
+        { jSender      = hfUserId
-                                  , jRequestTime = now
+        , jHelpRequest = hfRequest
-                                  , jReferer     = hfReferer }
+        , jRequestTime = now
+        , jReferer     = hfReferer
+        }
       -- redirect $ HelpR
       addMessageI Success MsgHelpSent
       return ()

src/Handler/Profile.hs

@@ -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.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
-      E.where_ $ E.notExists $ E.from $ \subGroupUser -> do
+      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.select
-        E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
+      ( E.from $ \(adright `E.InnerJoin` school) -> do
-        E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
+          E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
-        return (school E.^. SchoolShorthand)
+          E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
-    )
+          return (school E.^. SchoolShorthand)
+      )
     <*>
-    (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
+    E.select
-        E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
+      ( E.from $ \(lecright `E.InnerJoin` school) -> do
-        E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
+          E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
-        return (school E.^. SchoolShorthand)
+          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.select
-        E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+      ( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> 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
+          E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
-        return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
+          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.select
-        E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+      ( E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-        E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
+          E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
-        E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+          E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
-        return  ( ( studydegree E.^. StudyDegreeName
+          E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-                    , studydegree E.^. StudyDegreeKey
+          return  ( ( studydegree E.^. StudyDegreeName
-                    )
+                      , studydegree E.^. StudyDegreeKey
-                , ( studyterms  E.^. StudyTermsName
+                      )
-                    , studyterms  E.^. StudyTermsKey
+                  , ( studyterms  E.^. StudyTermsName
-                    )
+                      , studyterms  E.^. StudyTermsKey
-                , studyfeat   E.^. StudyFeaturesType
+                      )
-                , studyfeat   E.^. StudyFeaturesSemester)
+                  , 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
+        let crse = ( course E.^. CourseTerm
-                    , course E.^. CourseSchool
+                   , course E.^. CourseSchool
-                    , course E.^. CourseShorthand
+                   , course E.^. CourseShorthand
-                    )
+                   )
-        let sht  =  ( sheet E.^. SheetName
+        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.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
-              E.&&.  (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime)
+               E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
-          return $ E.countRows
+          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{..}
 

src/Handler/School.hs

@@ -2,37 +2,9 @@ module Handler.School where
 
 import Import
 
--- import Control.Lens
--- import Utils.Lens
--- import Utils.TH
--- import Handler.Utils
--- import Handler.Utils.Table.Cells
---
--- -- import Data.Time
--- import qualified Data.Text as T
--- import Data.Function ((&))
--- -- import Yesod.Form.Bootstrap3
---
--- import qualified Data.Set as Set
--- import qualified Data.Map as Map
---
--- import Colonnade hiding (fromMaybe,bool)
---
--- import qualified Database.Esqueleto as E
---
--- import qualified Data.UUID.Cryptographic as UUID
-
-
 getSchoolListR :: Handler Html
-getSchoolListR = do
+getSchoolListR = error "getSchoolListR: Not implemented"
-  -- muid <- maybeAuthId
-  defaultLayout $ do
-    [whamlet|TODO: Liste aller Institute |] -- TODO
-
 
 getSchoolShowR :: SchoolId -> Handler Html
-getSchoolShowR ssh = do -- TODO
+getSchoolShowR = error "getSchoolShowR: Not implemented"
-  -- muid <- maybeAuthId
-  defaultLayout $ do
-    [whamlet|TODO: Informationen zu einem Institut |] -- TODO
 

src/Handler/Sheet.hs

@@ -31,7 +31,7 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
 
 -- import qualified Data.List as List
 
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT, mapExceptT, throwE)
+import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
 
 import Network.Mime
 
@@ -39,8 +39,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import Data.Map (Map, (!), (!?))
+import Data.Map (Map, (!?))
-import qualified Data.Map as 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
+                      cid' <- mkCid
-                      return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
+                      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
+  Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
-  let sheet = entityVal entSheet
-      sid   = entityKey entSheet
   -- 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))
+        , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
-                                                           (\(E.Value fName,_,_) -> str2widget fName)
+            (CSheetR tid ssh csh shn (SFileR fType fName))
+            (str2widget fName)
         , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
         ]
   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 ()
 

src/Handler/Submission.hs

@@ -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
+      (FormSuccess (mFiles, setFromList -> adhocIds)) -> do
-        now <- liftIO $ getCurrentTime
         smid <- do
           smid <- case (mFiles, msmid) of
             (Nothing, Just smid)   -- no new files, existing submission partners updated
@@ -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
+getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
-  runDB $ do
+  submissionID <- submissionMatchesSheet tid ssh csh shn cID
-    submissionID <- submissionMatchesSheet tid ssh csh shn cID
 
-    isRating <- maybe False (== submissionID) <$> isRatingFile path
+  isRating <- (== Just submissionID) <$> isRatingFile path
 
-    when (isUpdate || isRating) $
+  when (isUpdate || isRating) $
-      guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
+    guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
 
-    case isRating of
+  case isRating of
-      True
+    True
-        | isUpdate -> do
+      | isUpdate -> do
-            file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
+          file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
-            maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+          maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
-        | otherwise -> notFound
+      | otherwise -> notFound
-      False -> do
+    False -> do
-        results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
+      results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
-          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+        E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
-          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+        E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-               E.&&. f E.^. FileTitle E.==. E.val path
+             E.&&. f E.^. FileTitle E.==. E.val path
-               E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
+             E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
-               E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+             E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-               -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
+             -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
-          return f
+        return f
 
-        let fileName = Text.pack $ takeFileName path
+      case results of
-        case results of
+        [Entity _ File{ fileContent = Just c, fileTitle }] -> do
-          [Entity _ File{ fileContent = Just c, fileTitle }] -> do
+          whenM downloadFiles $ 
-            whenM downloadFiles $ 
+            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
-              addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
-            return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
+        [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
-          [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
+        other -> do
-          other -> do
+          $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
-            $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
+          error "Multiple matching files found."
-            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
 

src/Handler/SystemMessage.hs

@@ -50,11 +50,12 @@ postMessageR cID = do
         cID' <- encrypt tId
         runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
           $ (,)
-          <$> ( fmap (Entity tId) $ SystemMessageTranslation
+          <$> fmap (Entity tId)
-                <$> pure systemMessageTranslationMessage
+              ( SystemMessageTranslation
-                <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
+                  <$> pure systemMessageTranslationMessage
-                <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
+                  <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
-                <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
+                  <*> 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
+      formResult modifyRes $ modifySystemMessage smId
-        runDB $ update smId
-          [ SystemMessageFrom =. systemMessageFrom
-          , SystemMessageTo =. systemMessageTo
-          , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
-          , SystemMessageSeverity =. systemMessageSeverity
-          , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
-          , SystemMessageContent =. systemMessageContent
-          , SystemMessageSummary =. systemMessageSummary
-          ]
-        addMessageI Success MsgSystemMessageEditSuccess
-        redirect $ MessageR cID
 
-      formResult addTransRes $ \smt -> do
+      formResult addTransRes addTranslation
-        runDB . void . insert $ smt
-        addMessageI Success MsgSystemMessageAddTranslationSuccess
-        redirect $ MessageR cID
 
-      forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of
+      forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
         [BtnDelete'] -> do
           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
+    (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
-    now <- liftIO $ getCurrentTime
+    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)
+    FormSuccess (_, _selection) -- prop> null _selection
-      | null selection -> addMessageI Error MsgSystemMessageEmptySelection
+      -> 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")

src/Handler/Term.hs

@@ -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" $
+            [ sortable Nothing "Kürzel" $ \(Entity tid _, _) -> anchorCell
-                anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
+                (TermCourseListR tid)
-                            (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
+                [whamlet|#{toPathPiece tid}|]
             , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
                 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

src/Handler/Users.hs

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

src/Handler/Utils.hs

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

src/Handler/Utils/DateTime.hs

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

src/Handler/Utils/Form.hs

@@ -6,16 +6,12 @@ module Handler.Utils.Form
 import Utils.Form
 
 import Handler.Utils.Form.Types
-import Handler.Utils.Templates
 
 import Handler.Utils.DateTime
-import qualified Data.Time as Time
 
 import Import hiding (cons)
 import qualified Data.Char as Char
-import Data.String (IsString(..))
 
-import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Foldable as Foldable
@@ -32,10 +28,8 @@ import Handler.Utils.Zip
 import qualified Data.Conduit.List as C
 
 import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Internal.Sql as E
 
 import Data.Set (Set)
-import qualified Data.Set as Set
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -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 LTUUnique{_ltuResult} -> Right _ltuResult
-        (Just (LTUNone _ _))          -> Left MsgIllDefinedUTCTime
+        Just LTUNone{}             -> Left MsgIllDefinedUTCTime
-        (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
+        Just LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
-        Nothing -> Left MsgInvalidDateTimeFormat
+        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"))

src/Handler/Utils/Mail.hs

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

src/Handler/Utils/Rating.hs

@@ -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 Points{..}     = pretty ( show maxPoints <> " Punkte" :: String)
-  pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String )
+  pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
-  pretty (PassBinary)      = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: 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
+    (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
-    (reverse -> ratingLines, reverse -> headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
+    (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
     ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
-    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

src/Handler/Utils/StudyFeatures.hs

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

src/Handler/Utils/Submission.hs

@@ -9,13 +9,11 @@ module Handler.Utils.Submission
   , submissionMatchesSheet
   ) where
 
-import Import hiding ((.=), joinPath)
+import Import hiding (joinPath)
 import Jobs
 import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
-import Control.Lens
-import Control.Lens.Extras (is)
 import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
@@ -29,15 +27,12 @@ import Data.Maybe ()
 import qualified Data.List as List
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map, (!?))
+import Data.Map (Map)
 import qualified Data.Map as Map
 
 import qualified Data.Text as Text
 import Data.Ratio
 
-import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
-
 import Data.Monoid (Monoid, Any(..), Sum(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
@@ -49,7 +44,6 @@ import Handler.Utils.Submission.TH
 
 import qualified Database.Esqueleto as E
 
-import Data.Conduit
 import qualified Data.Conduit.List as Conduit
 import Data.Conduit.ResumableSink
 
@@ -76,7 +70,7 @@ assignSubmissions sid restriction = do
     Sheet{..} <- getJust sid
     correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
     let
-      byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
+      -- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
       corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
       corrsProp  = filter hasPositiveLoad correctors
       countsToLoad' :: UserId -> Bool
@@ -118,7 +112,7 @@ assignSubmissions sid restriction = do
     let
       prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
       prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
-        (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
+        (Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
         guard $ maybe True (not isByTutorial ||) byTutorial
         let proportion
               | CorrectorExcused <- sheetCorrectorState = 0
@@ -311,9 +305,9 @@ extractRatingsMsg :: ( MonadHandler m
                      ) => Conduit File m SubmissionContent
 extractRatingsMsg = do
   ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
-  let ignored :: Set (Either CryptoFileNameSubmission FilePath)
+  let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
-      ignored = Right `Set.map` ignored'
+      ignoredFiles = Right `Set.map` ignored'
-  unless (null ignored) $ do
+  unless (null ignoredFiles) $ do
     mr <- (toHtml . ) <$> getMessageRender
     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
+    { _submissionSinkId :: CryptoFileNameSubmission
-    , submissionSinkFedFile :: Maybe FilePath
+    , _submissionSinkFedFile :: Maybe FilePath
-    , submissionSinkException :: SubmissionSinkException
+    , _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

src/Handler/Utils/Table.hs

@@ -1,8 +1,7 @@
 module Handler.Utils.Table where
 -- General Utilities for Tables
 
-import Import hiding  ((<>))
+import Import
--- import Data.Monoid ((<>))
 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>

src/Handler/Utils/Table/Cells.hs

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

src/Handler/Utils/Table/Pagination.hs

@@ -27,13 +27,10 @@ module Handler.Utils.Table.Pagination
 import Handler.Utils.Table.Pagination.Types
 import Utils.Lens.TH
 
-import Import
+import Import hiding (pi)
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
 import qualified Database.Esqueleto.Internal.Language as E (From)
-import Text.Blaze (Attribute)
-import qualified Text.Blaze.Html5.Attributes as Html5
-import qualified Text.Blaze.Html5 as Html5
 
 import qualified Data.Binary.Builder as Builder
 
@@ -42,8 +39,8 @@ import qualified Network.Wai as Wai
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
-import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
+import Control.Monad.RWS hiding ((<>), mapM_)
-import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
+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)
+      go (acc, is3) (i:is2)
-        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
+        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
-        | otherwise = go (acc, is' . (i:)) is
+        | otherwise = go (acc, is3 . (i:)) is2
 
 data PaginationSettings = PaginationSettings
   { 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
+  dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
-  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf
+  dbHandler _ f form = return $ 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
+        wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
-          widget <- cell ^. cellContents
+          widget <- cell' ^. cellContents
-          let attrs = cell ^. cellAttrs
+          let attrs = cell' ^. cellAttrs
           return $(widgetFile "table/cell/body")
       
         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}|])

src/Handler/Utils/Templates.hs

@@ -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}|]
+    Left  route -> [whamlet|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|]
-    Right content -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]
+    Right _     -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]

src/Handler/Utils/Zip.hs

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

src/Import/NoFoundation.hs

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

src/Jobs.hs

@@ -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 ()
+handleJobs :: ( MonadResource m
--- | Read control commands from `appJobCtl` and address them as they come in
+              , 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
+handleJobs foundation@UniWorX{..} = do
-  jobCrontab <- liftIO $ newTVarIO HashMap.empty
+  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
+      removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
-    in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
+      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)
+  registeredCron <- liftIO newEmptyTMVarIO
-  liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+  let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
-    writeJobCtlBlock JobCtlDetermineCrontab
+        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
+execCrontab = evalStateT go HashMap.empty
-  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
   where
-    acc :: NominalDiffTime
+    go = do
-    acc = 1e-3
+      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
+      refT <- liftIO getCurrentTime
-    applyJitter seed t = do
+      currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
-      appInstance <- getsYesod appInstanceID
+        crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
-      let
+        case crontab' of
-        halfRange = truncate $ 0.5 / acc
+          Nothing -> return Nothing
-        diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
+          Just crontab -> Just <$> do
-      return $ addUTCTime diff t
+            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)
+      case currentState of
-    earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab
+        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
+        acc :: NominalDiffTime
-          | Just (_, t') <- mbPrev
+        acc = 1e-3
-          , t' < t
+
-          = mbPrev
+        applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
-          | otherwise
+        applyJitter seed t = do
-          = Just (jobCtl, t)
+          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 :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
-    waitUntil crontabTV crontab nextTime = runResourceT $ do
+        waitUntil crontabTV crontab nextTime = runResourceT $ do
-      diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
+          diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
-      let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
+          let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
-          waitTime'
+              waitTime'
-            | diffT < acc = "Done"
+                | diffT < acc = "Done"
-            | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
+                | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
-      $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
+          $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
-      if
+          if
-        | diffT < acc -> return True
+            | diffT < acc -> return True
-        | otherwise   -> do
+            | otherwise   -> do
-            retVar <- liftIO newEmptyTMVarIO
+                retVar <- liftIO newEmptyTMVarIO
-            void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
+                void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar
-            let
+                let
-              awaitDelayThread = False <$ takeTMVar retVar
+                  awaitDelayThread = False <$ takeTMVar retVar
-              awaitCrontabChange = do
+                  awaitCrontabChange = do
-                crontab' <- readTVar crontabTV
+                    crontab' <- tryReadTMVar crontabTV
-                True <$ guard (crontab /= crontab')
+                    True <$ guard (Just crontab /= crontab')
-            crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+                crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
-            bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+                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

src/Jobs/Crontab.hs

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

src/Jobs/Handler/HelpRequest.hs

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

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

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

src/Jobs/Handler/SendNotification/SheetActive.hs

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

src/Jobs/Handler/SendNotification/SheetInactive.hs

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

src/Jobs/Handler/SendNotification/SubmissionRated.hs

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

src/Jobs/Queue.hs

@@ -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
+  wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
-  liftIO . atomically $ writeTMChan chan cmd
+  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
-
-
-

src/Jobs/Types.hs

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

src/Mail.hs

@@ -32,14 +32,13 @@ module Mail
   ) where
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
-import qualified ClassyPrelude.Yesod as Yesod (getMessageRender)
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
 import qualified Network.Mail.Mime as Mime (addPart)
 
 import Data.Monoid (Last(..))
-import Control.Monad.Trans.RWS (RWST(..), execRWST)
+import Control.Monad.Trans.RWS (RWST(..))
-import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT)
+import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
 import Control.Monad.Trans.Writer (execWriter, Writer)
 import Control.Monad.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 }

src/Model.hs

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

src/Model/Migration.hs

@@ -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);
+    QuasiQuoter: ^{TableName} @{ColumnName} (escaped as column/table-name; value determined from current model);
-                  #{anything} (no escaping);
+                  #{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" DROP COLUMN "id";
-            ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
+          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;
+          ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]';
-          UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
         |]
     )
   , ( 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}); |]
+  haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
-  case haveSchoolTable :: [Maybe (Single PersistValue)] of
+  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
+  

src/Model/Migration/Types.hs

@@ -1,11 +1,7 @@
 module Model.Migration.Types where 
 
-import ClassyPrelude.Yesod hiding  (derivePersistFieldJSON)
+import ClassyPrelude.Yesod
-import qualified Data.Aeson as Aeson
+import Data.Aeson.TH (deriveJSON, defaultOptions)
-import qualified Data.Aeson.Types as Aeson
-import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
-import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 import Database.Persist.Sql
 
 import 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 Bonus {..}  = Current.Bonus  Current.Points {..}
-sheetType Normal {..} = Current.Normal $ Current.Points {..}
+sheetType Normal {..} = Current.Normal Current.Points {..}
-sheetType Pass {..}   = Current.Normal $ Current.PassPoints {..}
+sheetType Pass {..}   = Current.Normal Current.PassPoints {..}
 sheetType NotGraded   = Current.NotGraded
 
 {- TODO:

src/Model/Migration/Version.hs

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

src/Model/Types/JSON.hs

@@ -16,10 +16,10 @@ import Language.Haskell.TH.Datatype
 
 
 derivePersistFieldJSON :: Name -> DecsQ
-derivePersistFieldJSON n = do
+derivePersistFieldJSON tName = do
-  DatatypeInfo{..} <- reifyDatatype n
+  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"
+            text <- newName "text"
-            clause [[p|PersistText $(varP t)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE t)|]) []
+            clause [[p|PersistText $(varP text)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE text)|]) []
         , clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) []
         ]
       ]

src/Settings.hs

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

src/Settings/Cluster.hs

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

src/Utils.hs

@@ -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) =>
+toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
-  a -> WidgetT site m ()
+      => a -> WidgetT site m ()
 toWgt = toWidget . toHtml
 
 -- Convenience Functions to avoid type signatures:
-text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
-                Text -> WidgetT site m ()
+            => Text -> WidgetT site m ()
 text2widget t = [whamlet|#{t}|]
 
-citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
-                (CI Text) -> WidgetT site m ()
+              => CI Text -> WidgetT site m ()
 citext2widget t = [whamlet|#{CI.original t}|]
 
-str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
-                String -> WidgetT site m ()
+           => String -> WidgetT site m ()
 str2widget s = [whamlet|#{s}|]
 
-display2widget ::  (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
+display2widget ::  (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a)
-                a -> WidgetT site m ()
+               => 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
+  if
-    True  -> return x
+    | sc x      -> return x
-    False -> bop <$> pure x <*> my
+    | 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)

src/Utils/DB.hs

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

src/Utils/Form.hs

@@ -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 =
+fsl lbl
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = []
+                  , fsAttrs    = []
-  }
+                  }
 
 fslI :: RenderMessage site msg => msg -> FieldSettings site
-fslI lbl =
+fslI lbl
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = []
+                  , fsAttrs    = []
-  }
+                  }
 
 fslp ::  Text -> Text -> FieldSettings site
-fslp lbl placeholder =
+fslp lbl placeholder
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
+                  , fsAttrs    = [("placeholder", placeholder)]
-  }
+                  }
 
 fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
-fslpI lbl placeholder =
+fslpI lbl placeholder
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
+                  , 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 [] = [(attr, valu)]
-    newAttrs (p@(a,v):t)
+    newAttrs (p@(a,v) : t)
-      | attr==a   = (a,T.append valu $ cons ' ' v):t
+      | attr==a   = (a, T.append valu $ cons ' ' v) : t
-      | otherwise = p:(newAttrs 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 :: [(Text, Text)] -> [(Text, Text)]
-    newAttrs [] = [(attr,T.intercalate " " valus)]
+    newAttrs [] = [(attr, T.intercalate " " valus)]
-    newAttrs (p@(a,v):t)
+    newAttrs (p@(a,v) : t)
-      | attr==a   = (a,T.intercalate " " (v:valus)):t
+      | attr==a   = ( a, T.intercalate " " $ v : valus ) : t
-      | otherwise = p:(newAttrs 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)

src/Utils/Lang.hs

@@ -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
+  = flip fromMaybe found $ selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
-      Just l' -> l'
-      Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
   | otherwise = selectLanguage' avL ls
 
 langMatches :: Lang -- ^ Needle

src/Utils/Lens.hs

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

src/Utils/Sql.hs

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

stack.yaml

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

templates/correction-user.hamlet

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

templates/default-layout.hamlet

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

templates/login.hamlet

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

templates/mail/submissionRated.hamlet

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

templates/mail/support.hamlet

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

templates/messages/submissionFilesIgnored.hamlet

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

templates/widgets/asidenav.hamlet

@@ -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}">
+        <h3 .asidenav__box-title.js-show-hide__toggle data-sh-index="#{termToText tid}">
-          $case season
+          _{ShortTermIdentifier tid}
-            $of Winter
-              _{MsgWinterTermShort year}
-            $of Summer
-              _{MsgSummerTermShort year}
         <ul .asidenav__list.js-show-hide__target.list--iconless>
-          $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 _

templates/widgets/campus-login-form.hamlet

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

templates/widgets/data-delete.hamlet

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

templates/widgets/dummy-login-form.hamlet

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

templates/widgets/hash-login-form.hamlet

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

templates/widgets/rating.hamlet

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

templates/widgets/sheetTypeSummary.hamlet

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

test.sh

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

test/CronSpec.hs

@@ -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
+    go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
-      MatchAsap -> t : go (pred n) t (Just t) cron
+      MatchAsap -> t : go n' t (Just t) cron
-      MatchAt t' -> t' : go (pred 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 CronRepeatNever 0 (Right CronNotScheduled), [baseTime])
-      , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime)
+      , (Cron CronAsap (CronRepeatScheduled CronAsap) 10 (Right CronNotScheduled), iterate (addUTCTime 10) baseTime)
       ]
 
 seriesExample :: (Cron, [UTCTime]) -> Expectation

test/Handler/HomeSpec.hs

@@ -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"
+            setMethod "GET"
-              setUrl HomeR
+            setUrl HomeR
-              addToken
+            addRequestHeader ("Accept-Language", "de")
-              fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
-              byLabel "What's on the file?" "Some Content"
-
           statusIs 200
-          -- more debugging printBody
+          htmlAnyContain "h1" "Aktuelle Termine"
-          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

test/Handler/ProfileSpec.hs

@@ -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
+      app <- getTestYesod
-        it "asserts no access to my-account for anonymous users" $ do
+      loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR)
-            get ProfileR
-            statusIs 403
 
-        it "asserts access to my-account for authenticated users" $ do
+      assertHeader "Location" $ encodeUtf8 loginText
-            userEntity <- createUser "foo"
-            authenticateAs userEntity
   
-            get ProfileR
+      either (fail . unpack) (\_ -> return ()) =<< followRedirect
-            statusIs 200
+      statusIs 200
 
-        it "asserts user's information is shown" $ do
+    it "asserts access to my-account for authenticated users" $ do
-            userEntity <- createUser "bar"
+      userEntity <- createUser "foo"
-            authenticateAs userEntity
+      authenticateAs userEntity
+
+      get ProfileR
+      statusIs 200
+
+    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
           
-            get ProfileR
-            let (Entity _ user) = userEntity
-            htmlAnyContain ".username" . unpack . CI.original $ userIdent user

test/Handler/Utils/ZipSpec.hs

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

test/Model/TypesSpec.hs

@@ -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 2017 Summer, "S17")
-      , (TermIdentifier 1995 Winter, "W1995")
+      , (TermIdentifier 1995 Winter, "W95")
+      , (TermIdentifier 3068 Winter, "W3068")
       ]
 
 termExample :: (TermIdentifier, Text) -> Expectation

test/TestImport.hs

@@ -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
+  app <- getTestYesod
-    liftIO $ runDBWithApp app query
+  liftIO $ runDBWithApp app query
 
-runDBWithApp :: UniWorX -> SqlPersistM a -> IO a
+runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a
-runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
+runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app)
 
 runHandler :: Handler a -> YesodExample UniWorX a
 runHandler handler = do
-    app <- getTestYesod
+  app <- getTestYesod
-    fakeHandlerGetLogger appLogger app handler
+  fakeHandlerGetLogger appLogger app handler
 
 
-withApp :: SpecWith (TestApp UniWorX) -> Spec
+withApp :: YSpec UniWorX -> Spec
-withApp = before $ do
+withApp = around $ \act -> runResourceT $ do
-    settings <- loadYamlSettings
+  settings <- liftIO $ loadYamlSettings
-        ["config/test-settings.yml", "config/settings.yml"]
+    ["config/test-settings.yml", "config/settings.yml"]
-        []
+    []
-        useEnv
+    useEnv
-    foundation <- makeFoundation settings
+  foundation <- makeFoundation settings
-    wipeDB foundation
+  let
-    logWare <- liftIO $ makeLogWare foundation
+    stopDBAccess = do
-    return (foundation, logWare)
+      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
+  tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|]
-    sqlBackend <- ask
+  sqlBackend <- ask
 
-    let escapedTables = map (connEscapeName sqlBackend . DBName) tables
+  let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables
-        query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables
+      query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY"
-    rawExecute query []
+      protected = ["applied_migration"]
-
+  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
 
 -- | 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
+  request $ do
-        setMethod "POST"
+    setMethod "GET"
-        addPostParam "ident" $ CI.original userIdent
+    addRequestHeader ("Accept-Language", "de")
-        setUrl $ AuthR $ PluginR "dummy" []
+    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{..}