Merge branch 'master' into 'live'

Master

See merge request !112

.gitignore

@@ -31,3 +31,4 @@ src/Handler/Course.SnapCustom.hs
 .stack-work-*
 .directory
 tags
+test.log

config/settings.yml

@@ -29,9 +29,11 @@ notification-expiration: 259201
 session-timeout: 7200
 
 log-settings:
-  log-detailed:      "_env:DETAILED_LOGGING:false"
+  detailed:      "_env:DETAILED_LOGGING:false"
-  log-all:           "_env:LOG_ALL:false"
+  all:           "_env:LOG_ALL:false"
-  log-minimum-level: "_env:LOGLEVEL:warn"
+  minimum-level: "_env:LOGLEVEL:warn"
+  destination:   "_env:LOGDEST:stderr"
+
 
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"

config/test-settings.yml

@@ -1,11 +1,10 @@
 database:
-  # NOTE: By design, this setting prevents the PGDATABASE environment variable
+  database: "_env:PGDATABASE_TEST:uniworx_test"
-  # from affecting test runs, so that we don't accidentally affect the
+
-  # production database during testing. If you're not concerned about that and
+log-settings:
-  # would like to have environment variable overrides, you could instead use
+  detailed:      true
-  # something like:
+  all:           true
-  #
+  minimum-level: "debug"
-  #   database: "_env:PGDATABASE:uniworx_test"
+  destination:   "test.log"
-  database: uniworx_test
 
 auth-dummy-login: true

messages/uniworx/de.msg

@@ -491,11 +491,12 @@ ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere vers
 
 ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
 ErrMsgCiphertext: Verschlüsselte Fehlermeldung
-ErrMsgCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
+EncodedSecretBoxCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
-ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
+EncodedSecretBoxInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
-ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
+EncodedSecretBoxInvalidPadding: Verschlüsselte Daten sind nicht korrekt padded
-ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
+EncodedSecretBoxCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
-ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
+EncodedSecretBoxCouldNotOpenSecretBox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
+EncodedSecretBoxCouldNotDecodePlaintext aesonErr@String: Konnte Klartext nicht JSON-dekodieren: #{aesonErr}
 ErrMsgHeading: Fehlermeldung entschlüsseln
 ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
 

package.yaml

@@ -110,6 +110,7 @@ dependencies:
   - monad-memo
   - xss-sanitize
   - text-metrics
+  - pkcs7
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Application.hs

@@ -30,8 +30,9 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                              IPAddrSource (..),
                                              OutputFormat (..), destination,
                                              mkRequestLogger, outputFormat)
-import System.Log.FastLogger                (defaultBufSize, newStderrLoggerSet,
+import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
-                                             toLogStr)
+                                            , toLogStr, rmLoggerSet
+                                            )
 
 import qualified Data.Map.Strict as Map
 
@@ -61,7 +62,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
 
 import qualified Data.HashMap.Strict as HashMap
 
-import Control.Lens ((&))
+import Control.Lens
 
 import Data.Proxy
 
@@ -100,10 +101,30 @@ makeFoundation appSettings@AppSettings{..} = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
-    appLogger <- liftIO $ do
+    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
-      tgetter <- newTimeCache "%Y-%m-%d %T %z"
+
-      loggerSet <- newStderrLoggerSet defaultBufSize
+    let
-      return $ Yesod.Logger loggerSet tgetter
+      mkLogger LogSettings{..} = do
+        tgetter <- newTimeCache "%Y-%m-%d %T %z"
+        loggerSet <- case logDestination of
+          LogDestStderr -> newStderrLoggerSet defaultBufSize
+          LogDestStdout -> newStdoutLoggerSet defaultBufSize
+          LogDestFile{..} -> newFileLoggerSet defaultBufSize logDestFile
+        return $ Yesod.Logger loggerSet tgetter
+      mkLogger' = liftIO $ do
+        initialSettings <- readTVarIO appLogSettings
+        tVar <- newTVarIO =<< mkLogger initialSettings
+        let updateLogger prevSettings = do
+              newSettings <- atomically $ do
+                newSettings <- readTVar appLogSettings
+                guard $ newSettings /= prevSettings
+                return newSettings
+              oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
+              rmLoggerSet $ loggerSet oldLogger
+              updateLogger newSettings
+        (tVar, ) <$> fork (updateLogger initialSettings)
+    appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
+
     appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
 
     appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
@@ -111,14 +132,12 @@ makeFoundation appSettings@AppSettings{..} = do
     appJobCtl <- liftIO $ newTVarIO Map.empty
     appCronThread <- liftIO newEmptyTMVarIO
 
-    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
-
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appErrorMsgKey = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -127,8 +146,10 @@ makeFoundation appSettings@AppSettings{..} = do
           (error "smtpPool forced in tempFoundation")
           (error "cryptoIDKey forced in tempFoundation")
           (error "sessionKey forced in tempFoundation")
-          (error "errorMsgKey forced in tempFoundation")
+          (error "secretBoxKey forced in tempFoundation")
-        logFunc = messageLoggerSource tempFoundation appLogger
+        logFunc loc src lvl str = do
+          f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
+          f loc src lvl str
 
     flip runLoggingT logFunc $ do
       $logDebugS "InstanceID" $ UUID.toText appInstanceID
@@ -145,9 +166,9 @@ makeFoundation appSettings@AppSettings{..} = do
       migrateAll `runSqlPool` sqlPool
       appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
       appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
-      appErrorMsgKey <- clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
+      appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
 
-      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
+      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey
 
       handleJobs foundation
 
@@ -228,12 +249,13 @@ makeLogWare app = do
 
   let
     mkLogWare ls@LogSettings{..} = do
+      logger <- readTVarIO . snd $ appLogger app
       logWare <- mkRequestLogger def
         { outputFormat = bool
             (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
             (Detailed True)
             logDetailed
-        , destination = Logger . loggerSet $ appLogger app
+        , destination = Logger $ loggerSet logger
         }
       atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
       return logWare
@@ -255,9 +277,11 @@ warpSettings foundation = defaultSettings
     & setPort (appPort $ appSettings foundation)
     & setHost (appHost $ appSettings foundation)
     & setOnException (\_req e ->
-        when (defaultShouldDisplayException e) $ messageLoggerSource
+        when (defaultShouldDisplayException e) $ do
+          logger <- readTVarIO . snd $ appLogger foundation
+          messageLoggerSource
             foundation
-            (appLogger foundation)
+            logger
             $(qLocation >>= liftLoc)
             "yesod"
             LevelError
@@ -322,7 +346,9 @@ getApplicationRepl = do
     return (getPort wsettings, foundation, app1)
 
 shutdownApp :: MonadIO m => UniWorX -> m ()
-shutdownApp = stopJobCtl
+shutdownApp app = do
+  stopJobCtl app
+  release . fst $ appLogger app
 
 
 ---------------------------------------------

src/Cron.hs

@@ -150,10 +150,11 @@ genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMa
 
 nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
               -> Maybe UTCTime -- ^ Time of last execution of the job
+              -> NominalDiffTime -- ^ Scheduling precision
               -> UTCTime -- ^ Current time, used only for `CronCalendar`
               -> Cron
               -> CronNextMatch UTCTime
-nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
+nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
   MatchAsap -> MatchNone
   MatchAt ts
     | MatchAt ts' <- nextMatch
@@ -183,7 +184,7 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
       Just prevT
         -> case cronRepeat of
             CronRepeatOnChange
-              | not $ matchesCron tz Nothing prevT c
+              | not $ matchesCron tz Nothing prec prevT c
                 -> let
                      cutoffTime = addUTCTime cronRateLimit prevT
                    in case execRef now False cronInitial of
@@ -240,13 +241,14 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
 
 matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
             -> Maybe UTCTime -- ^ Previous execution of the job
+            -> NominalDiffTime -- ^ Scheduling precision
             -> UTCTime -- ^ "Current" time
             -> Cron
             -> Bool
 -- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron`
 --   specification @c@ should match @now@, under the assumption that the next
 --   check will occur no earlier than @now + prec@.
-matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of
+matchesCron tz mPrev prec now cron = case nextCronMatch tz mPrev prec now cron of
   MatchAsap -> True
   MatchNone -> False
-  MatchAt ts -> ts <= now
+  MatchAt ts -> ts <= addUTCTime prec now

src/Data/CaseInsensitive/Instances.hs

@@ -18,6 +18,8 @@ import qualified Data.Text.Encoding as Text
 
 import Language.Haskell.TH.Syntax (Lift(..))
 
+import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
+
 
 instance PersistField (CI Text) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@@ -41,6 +43,14 @@ instance ToJSON a => ToJSON (CI a) where
 instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
   parseJSON = fmap CI.mk . parseJSON
 
+instance (ToJSONKey a, ToJSON a) => ToJSONKey (CI a) where
+  toJSONKey = case toJSONKey of
+    ToJSONKeyText  toVal toEnc -> ToJSONKeyText (toVal . CI.original) (toEnc . CI.original)
+    ToJSONKeyValue toVal toEnc -> ToJSONKeyValue (toVal . CI.original) (toEnc . CI.original)
+
+instance (FromJSON a, FromJSONKey a, CI.FoldCase a) => FromJSONKey (CI a) where
+  fromJSONKey = CI.mk <$> fromJSONKey
+
 instance ToMessage a => ToMessage (CI a) where
   toMessage = toMessage . CI.original
 

src/Foundation.hs

@@ -66,8 +66,6 @@ import Utils.Lens
 import Utils.Form
 import Utils.SystemMessage
 
-import Data.Aeson hiding (Error, Success)
-
 import Text.Shakespeare.Text (st)
 
 import Yesod.Form.I18n.German
@@ -76,7 +74,6 @@ import qualified Yesod.Auth.Message as Auth
 import qualified Data.Conduit.List as C
 
 import qualified Crypto.Saltine.Core.SecretBox as SecretBox
-import qualified Crypto.Saltine.Class as Saltine
 
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
@@ -99,19 +96,19 @@ instance DisplayAble SchoolId where
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data UniWorX = UniWorX
-    { appSettings    :: AppSettings
+    { appSettings     :: AppSettings
-    , appStatic      :: Static -- ^ Settings for static file serving.
+    , appStatic       :: Static -- ^ Settings for static file serving.
-    , appConnPool    :: ConnectionPool -- ^ Database connection pool.
+    , appConnPool     :: ConnectionPool -- ^ Database connection pool.
-    , appSmtpPool    :: Maybe SMTPPool
+    , appSmtpPool     :: Maybe SMTPPool
-    , appHttpManager :: Manager
+    , appHttpManager  :: Manager
-    , appLogger      :: Logger
+    , appLogger       :: (ReleaseKey, TVar Logger)
-    , appLogSettings :: TVar LogSettings
+    , appLogSettings  :: TVar LogSettings
-    , appCryptoIDKey :: CryptoIDKey
+    , appCryptoIDKey  :: CryptoIDKey
-    , appInstanceID  :: InstanceId
+    , appInstanceID   :: InstanceId
-    , appJobCtl      :: TVar (Map ThreadId (TMChan JobCtl))
+    , appJobCtl       :: TVar (Map ThreadId (TMChan JobCtl))
-    , appCronThread  :: TMVar (ReleaseKey, ThreadId)
+    , appCronThread   :: TMVar (ReleaseKey, ThreadId)
-    , appErrorMsgKey :: SecretBox.Key
+    , appSessionKey   :: ClientSession.Key
-    , appSessionKey  :: ClientSession.Key
+    , appSecretBoxKey :: SecretBox.Key
     }
 
 type SMTPPool = Pool SMTPConnection
@@ -201,6 +198,7 @@ embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
 embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
+embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@@ -678,18 +676,15 @@ instance Yesod UniWorX where
         encrypted plaintextJson plaintext = do
           canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
           shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
-          errKey <- getsYesod appErrorMsgKey
           if
             | shouldEncrypt
             , not canDecrypt -> do
-                nonce <- liftIO SecretBox.newNonce
+                ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
-                let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
+
-                    encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
-                    formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
                 [whamlet|
                   <p>_{MsgErrorResponseEncrypted}
                   <pre .errMsg>
-                    #{formatted}
+                    #{ciphertext}
                 |]
             | otherwise -> plaintext
 
@@ -757,7 +752,7 @@ instance Yesod UniWorX where
       LogSettings{..} <- readTVarIO $ appLogSettings app
       return $ logAll || level >= logMinimumLevel
 
-    makeLogger = return . appLogger
+    makeLogger = readTVarIO . snd . appLogger
 
 
 siteLayout :: Maybe Html -- ^ Optionally override `pageHeading`
@@ -1694,7 +1689,9 @@ instance HasHttpManager UniWorX where
     getHttpManager = appHttpManager
 
 unsafeHandler :: UniWorX -> Handler a -> IO a
-unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
+unsafeHandler f h = do
+  logger <- makeLogger f
+  Unsafe.fakeHandlerGetLogger (const logger) f h
 
 
 instance YesodMail UniWorX where
@@ -1720,6 +1717,9 @@ instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto
   type MonadCryptoKey m = CryptoIDKey
   cryptoIDKey f = getsYesod appCryptoIDKey >>= f
 
+instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
+  secretBoxKey = getsYesod appSecretBoxKey
+
 -- Note: Some functionality previously present in the scaffolding has been
 -- moved to documentation in the Wiki. Following are some hopefully helpful
 -- links:

src/Handler/Admin.hs

@@ -4,16 +4,7 @@ import Import
 import Handler.Utils
 import Jobs
 
-import qualified Data.ByteString as BS
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
-
-import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
-import qualified Data.ByteString.Base64.URL as Base64
-import Crypto.Saltine.Core.SecretBox (secretboxOpen)
-import qualified Crypto.Saltine.Class as Saltine
-
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-import Data.Char (isSpace)
 
 import Control.Monad.Trans.Except
 
@@ -110,31 +101,17 @@ getAdminUserR uuid = do
 getAdminErrMsgR, postAdminErrMsgR :: Handler Html
 getAdminErrMsgR = postAdminErrMsgR
 postAdminErrMsgR = do
-  errKey <- getsYesod appErrorMsgKey
-  
   ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
         (unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
     <*  submitButton
 
-  plaintext <- formResultMaybe ctResult $ \(encodeUtf8 . Text.filter (not . isSpace) -> inputBS) ->
+  plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
-    exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) $ do
-      ciphertext <- either (throwE . MsgErrMsgInvalidBase64) return $ Base64.decode inputBS
-
-      unless (BS.length ciphertext >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
-        throwE MsgErrMsgCiphertextTooShort
-      let (nonceBS, secretbox) = BS.splitAt Saltine.secretBoxNonce ciphertext
-
-      nonce <- maybe (throwE MsgErrMsgCouldNotDecodeNonce) return $ Saltine.decode nonceBS
-
-      plainBS <- maybe (throwE MsgErrMsgCouldNotOpenSecretbox) return $ secretboxOpen errKey nonce secretbox
-
-      either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
 
   defaultLayout
     [whamlet|
       $maybe t <- plaintext
         <pre style="white-space:pre-wrap; font-family:monospace">
-          #{t}
+          #{encodePrettyToTextBuilder t}
 
       <form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
         ^{ctView}

src/Handler/Corrections.hs

@@ -179,7 +179,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
 
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
+                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
       dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
@@ -278,7 +278,7 @@ data ActionCorrectionsData = CorrDownloadData
 
 correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
-  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
+  tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return
   ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
     (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
     (actionRes, action) <- multiAction actions Nothing
@@ -551,8 +551,11 @@ postCorrectionR tid ssh csh shn cid = do
           uid <- requireAuthId
 
           void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+          {-case res of
+            (Left _) -> addMessageI Success MsgRatingFilesUpdated
+            (Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected
+            (Right other) -> throw other-}
 
-          addMessageI Success MsgRatingFilesUpdated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       mr <- getMessageRender
@@ -760,7 +763,7 @@ postCorrectionsGradeR = do
         & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
       unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
 
-  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
+  tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
     cID <- encrypt subId
     void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
     return i

src/Handler/Course.hs

@@ -109,10 +109,10 @@ course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \cou
     E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
       E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
 
-makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
+makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
-                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
 makeCourseTable whereClause colChoices psValidator = do
-  muid <- maybeAuthId
+  muid <- lift maybeAuthId
   let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
       dbtSQLQuery qin@(course `E.InnerJoin` school) = do
         E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
@@ -122,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
+  snd <$> dbTable psValidator DBTable
     { dbtSQLQuery
     , dbtColonnade = colChoices
     , dbtProj
@@ -179,7 +179,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
       whereClause = const $ E.val True
       validator = def
         & defaultSorting [("course", SortAsc), ("term", SortDesc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI MsgCourseListTitle
     [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
@@ -211,7 +211,7 @@ getTermSchoolCourseListR tid ssh = do
         E.&&. course E.^. CourseSchool E.==. E.val ssh
       validator = def
         & defaultSorting [("cshort", SortAsc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI $ MsgTermSchoolCourseListTitle tid school
     $(widgetFile "courses")
@@ -233,7 +233,7 @@ getTermCourseListR tid = do
       whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
       validator = def
         & defaultSorting [("cshort", SortAsc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI . MsgTermCourseListTitle $ tid
     $(widgetFile "courses")

src/Handler/Home.hs

@@ -72,7 +72,7 @@ homeAnonymous = do
         , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
             cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
         ]
-  ((), courseTable) <- dbTable def DBTable
+  courseTable <- runDB $ dbTableWidget' def DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
     , dbtProj      = return
@@ -166,7 +166,7 @@ homeUser uid = do
                                         tickmark
         ]
   let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
-  ((), sheetTable) <- dbTable validator DBTable
+  sheetTable <- runDB $ dbTableWidget' validator DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
     , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }

src/Handler/Profile.hs

@@ -204,25 +204,25 @@ getProfileDataR = do
                   , studyfeat   E.^. StudyFeaturesType
                   , studyfeat   E.^. StudyFeaturesSemester)
       )
-  -- Tabelle mit eigenen Kursen
+  (   (hasRows, ownedCoursesTable)
-  (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
+    , enrolledCoursesTable
-  -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
+    , submissionTable
-  enrolledCoursesTable <- mkEnrolledCoursesTable uid
+    , submissionGroupTable
-  -- Tabelle mit allen Klausuren und Noten
+    , correctionsTable
+    ) <- runDB $ (,,,,)
+           <$> mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+           <*> mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
+           <*> mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
+           <*> mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
+           <*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
+  
+  
   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
-  submissionGroupTable <- mkSubmissionGroupTable uid
-  -- Tabelle mit allen Korrektor-Aufgaben
-  correctionsTable <- mkCorrectionsTable uid
-  -- Tabelle mit allen eigenen Tutorials
   let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-  -- Tabelle mit allen Tutorials
   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
   defaultLayout $ do
     let delWdgt = $(widgetFile "widgets/data-delete")
     $(widgetFile "profileData")
@@ -230,7 +230,7 @@ getProfileDataR = do
 
 
 
-mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget)
+mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
 -- Table listing all courses that the given user is a lecturer for
 mkOwnedCoursesTable =
   let dbtIdent = "courseOwnership" :: Text
@@ -277,7 +277,7 @@ mkOwnedCoursesTable =
 
 
 
-mkEnrolledCoursesTable :: UserId -> Handler Widget
+mkEnrolledCoursesTable :: UserId -> DB Widget
 -- Table listing all courses that the given user is enrolled in
 mkEnrolledCoursesTable =
   let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
@@ -324,7 +324,7 @@ mkEnrolledCoursesTable =
 
 
 
-mkSubmissionTable :: UserId -> Handler Widget
+mkSubmissionTable :: UserId -> DB Widget
 -- Table listing all submissions for the given user
 mkSubmissionTable =
   let dbtIdent = "submissions" :: Text
@@ -405,7 +405,7 @@ mkSubmissionTable =
 
 
 
-mkSubmissionGroupTable :: UserId -> Handler Widget
+mkSubmissionGroupTable :: UserId -> DB Widget
 -- Table listing all submissions for the given user
 mkSubmissionGroupTable =
   let dbtIdent = "subGroups" :: Text
@@ -470,7 +470,7 @@ mkSubmissionGroupTable =
 
 
 
-mkCorrectionsTable :: UserId -> Handler Widget
+mkCorrectionsTable :: UserId -> DB Widget
 -- Table listing sum of corrections made by the given user per sheet
 mkCorrectionsTable =
   let dbtIdent = "corrections" :: Text

src/Handler/Sheet.hs

@@ -194,7 +194,7 @@ getSheetListR tid ssh csh = do
       ]
     psValidator = def
       & defaultSorting [("submission-since", SortAsc)]
-  ((), table) <- dbTable psValidator $ DBTable
+  table <- runDB $ dbTableWidget' psValidator DBTable
     { dbtSQLQuery  = sheetData
     , dbtColonnade = sheetCol
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
@@ -286,7 +286,7 @@ getSShowR tid ssh csh shn = do
         ]
   let psValidator = def
         & defaultSorting [("type", SortAsc), ("path", SortAsc)]
-  (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable
+  (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }

src/Handler/Submission.hs

@@ -312,7 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           ]
         , dbtFilter = Map.empty
         }
-  mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
+  mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn

src/Handler/SystemMessage.hs

@@ -174,7 +174,7 @@ postMessageListR = do
         , ..
         }
     psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
-  tableForm <- dbTable psValidator DBTable
+  tableForm <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery
     , dbtColonnade
     , dbtProj

src/Handler/Term.hs

@@ -96,7 +96,7 @@ getTermShowR = do
 --                       #{termToText termName}
 --                 |]
 --           ]
-      ((), table) <- dbTable def DBTable
+      table <- runDB $ dbTableWidget' def DBTable
         { dbtSQLQuery = termData
         , dbtColonnade = colonnadeTerms
         , dbtProj = return . dbrOutput

src/Handler/Users.hs

@@ -69,7 +69,7 @@ getUsersR = do
     psValidator = def
       & defaultSorting [("name", SortAsc),("display-name", SortAsc)]
   
-  ((), userList) <- dbTable psValidator DBTable
+  ((), userList) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
     , dbtColonnade
     , dbtProj      = return

src/Handler/Utils.hs

@@ -69,4 +69,3 @@ warnTermDays tid times = do
   forM_ warnholidays  $ warnI MsgDayIsAHoliday
   forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
   forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
-

src/Handler/Utils/Submission.hs

@@ -421,6 +421,7 @@ sinkSubmission userId mExists isUpdate = do
         when anyChanges $ do
 
           Sheet{..} <- lift $ getJust submissionSheet
+          --TODO: should display errorMessages
           mapM_ throwM $ validateRating sheetType r'
 
           touchSubmission

src/Handler/Utils/Table/Pagination.hs

@@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination
   ) where
 
 import Handler.Utils.Table.Pagination.Types
+import Utils
 import Utils.Lens.TH
 
 import Import hiding (pi)
@@ -59,6 +60,10 @@ import Data.Ratio ((%))
 
 import Control.Lens
 
+import Data.Aeson (Options(..), defaultOptions, decodeStrict')
+import Data.Aeson.Text
+import Data.Aeson.TH (deriveJSON)
+
 
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
@@ -72,6 +77,10 @@ instance PathPiece SortDirection where
     | t == "desc" = Just SortDesc
     | otherwise   = Nothing
 
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''SortDirection
+
 sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
 sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
 sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
@@ -119,15 +128,32 @@ instance Default PaginationSettings where
     , psShortcircuit = False
     }
 
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''PaginationSettings
+
 data PaginationInput = PaginationInput
   { piSorting      :: Maybe [(CI Text, SortDirection)]
   , piFilter       :: Maybe (Map (CI Text) [Text])
   , piLimit        :: Maybe Int64
   , piPage         :: Maybe Int64
   , piShortcircuit :: Bool
-  }
+  } deriving (Eq, Ord, Show, Read, Generic)
+
+instance Default PaginationInput where
+  def = PaginationInput
+    { piSorting      = Nothing
+    , piFilter       = Nothing
+    , piLimit        = Nothing
+    , piPage         = Nothing
+    , piShortcircuit = False
+    }
 
 makeLenses_ ''PaginationInput
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields = True
+  } ''PaginationInput
 
 piIsUnset :: PaginationInput -> Bool
 piIsUnset PaginationInput{..} = and
@@ -240,8 +266,10 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
   dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
     
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
-  dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
+  -- | Format @DBTable@ when sort-circuiting
-  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
+  dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
+  -- | Format @DBTable@ when not short-circuiting
+  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
   runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
 
 cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
@@ -264,8 +292,8 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
     (uncurry WidgetCell)
   
   -- dbWidget Proxy Proxy = iso (, ()) $ view _1
-  dbWidget _ = return . snd
+  dbWidget _ _ = return . snd
-  dbHandler _ f = return . over _2 f
+  dbHandler _ _ f = return . over _2 f
   runDBTable = liftHandlerT
 
 instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
@@ -284,8 +312,8 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
     (\DBCell{..} -> (dbCellAttrs, dbCellContents))
     (uncurry DBCell)
 
-  dbWidget _ = return . snd
+  dbWidget _ _ = return . snd
-  dbHandler _ f = return . over _2 f
+  dbHandler _ _ f = return . over _2 f
   -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
   runDBTable = mapReaderT liftHandlerT
 
@@ -312,13 +340,22 @@ 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 _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
+  dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
-  dbHandler _ f form = return $ fmap (over _2 f) . form
+  dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi 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))
   runDBTable = return . withFragment
 
+addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
+addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
+    <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
+  |]
+  where
+    wIdent n
+      | not $ null dbtIdent = dbtIdent <> "-" <> n
+      | otherwise           = n
+
 instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
   mempty = FormCell mempty (return mempty)
   (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
@@ -327,7 +364,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
       
 
-dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
+dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
 dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
   let
     sortingOptions = mkOptionList
@@ -348,79 +385,89 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
       , fieldEnctype = UrlEncoded
       }
     
-  psResult <- runInputGetResult $ PaginationInput
+  piResult <- lift . 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)
     <*> iopt intField (wIdent "pagesize")
     <*> iopt intField (wIdent "page")
     <*> ireq checkBoxField (wIdent "table-only")
 
-  $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult)
+  piPrevious <- fmap (fmap (set _piShortcircuit False) . maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
-                               <*> (piFilter <$> psResult)
+
-                               <*> (piLimit <$> psResult)
+  $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> piResult)
-                               <*> (piPage <$> psResult)
+                               <*> (piFilter <$> piResult)
-                               <*> (piShortcircuit <$> psResult)
+                               <*> (piLimit <$> piResult)
+                               <*> (piPage <$> piResult)
+                               <*> (piShortcircuit <$> piResult)
 
   let
-    (errs, PaginationSettings{..}) = case psResult of
+    (errs, PaginationSettings{..}) = case piPrevious <|> piResult of
       FormSuccess pi
-        | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi
+        | not (piIsUnset pi)
-      FormFailure errs'      -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
+          -> runPSValidator dbtable $ Just pi
-      _                      -> runPSValidator dbtable Nothing
+      FormFailure errs'
+          -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
+      _   -> runPSValidator dbtable Nothing
+    paginationInput
+      | FormSuccess pi <- piPrevious <|> piResult
+      , not $ piIsUnset pi
+      = pi
+      | otherwise
+      = def
     psSorting' = map (first (dbtSorting !)) psSorting
-    sqlQuery' = E.from $ \t -> dbtSQLQuery t
-      <* E.orderBy (map (sqlSortDirection t) psSorting')
-      <* E.limit psLimit
-      <* E.offset (psPage * psLimit)
-      <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
 
   mapM_ (addMessageI Warning) errs
 
-  runDB $ do
+  rows' <- E.select . E.from $ \t -> do
-    rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
+    res <- dbtSQLQuery t
+    E.orderBy (map (sqlSortDirection t) psSorting')
+    E.limit psLimit
+    E.offset (psPage * psLimit)
+    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
+    return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
 
-    let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
+  let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
 
-    rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
+  rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
 
-    let
+  let
-      rowCount
+    rowCount
-        | (E.Value n, _):_ <- rows' = n
+      | (E.Value n, _):_ <- rows' = n
-        | otherwise = 0
+      | otherwise = 0
 
-      table' :: WriterT x m Widget
+    table' :: WriterT x m Widget
-      table' = do
+    table' = do
-        getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
 
-        let
+      let
-          tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
 
-          genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
+        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-            widget <- sortableContent ^. cellContents
+          widget <- sortableContent ^. cellContents
-            let
+          let
-              directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
+            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-              isSortable = isJust sortableKey
+            isSortable = isJust sortableKey
-              isSorted = (`elem` directions)
+            isSorted = (`elem` directions)
-              attrs = sortableContent ^. cellAttrs
+            attrs = sortableContent ^. cellAttrs
-            return $(widgetFile "table/cell/header")
+          return $(widgetFile "table/cell/header")
 
-          columnCount :: Int64
+        columnCount :: Int64
-          columnCount = olength64 $ getColonnade dbtColonnade
+        columnCount = olength64 $ getColonnade dbtColonnade
 
-        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
 
-        wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
+      wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
-          widget <- cell' ^. cellContents
+        widget <- cell' ^. cellContents
-          let attrs = cell' ^. cellAttrs
+        let attrs = cell' ^. cellAttrs
-          return $(widgetFile "table/cell/body")
+        return $(widgetFile "table/cell/body")
 
-        let table = $(widgetFile "table/colonnade")
+      let table = $(widgetFile "table/colonnade")
-            pageCount = max 1 . ceiling $ rowCount % psLimit
+          pageCount = max 1 . ceiling $ rowCount % psLimit
-            pageNumbers = [0..pred pageCount]
+          pageNumbers = [0..pred pageCount]
 
-        return $(widgetFile "table/layout")
+      return $(widgetFile "table/layout")
 
-    bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
+  bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
     tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
@@ -431,10 +478,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
     setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
 
 dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-    -> Handler (DBResult (HandlerT UniWorX IO) x)
+    -> DB (DBResult (HandlerT UniWorX IO) x)
 dbTableWidget = dbTable
 
-dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget
+dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
 dbTableWidget' = fmap (fmap snd) . dbTable
 
 widgetColonnade :: (Headedness h, Monoid x)

src/Jobs.hs

@@ -207,7 +207,7 @@ execCrontab = evalStateT go HashMap.empty
               | otherwise
               = Just (jobCtl, t)
               where
-                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
+                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) acc now cron
 
         waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
         waitUntil crontabTV crontab nextTime = runResourceT $ do

src/Jobs/Queue.hs

@@ -77,7 +77,8 @@ type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJo
 queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
 queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
 
-runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
+runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX)
+ => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
 runDBJobs act = do
   (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
   forM_ jIds $ writeJobCtl . JobCtlPerform

src/Model/Migration.hs

@@ -50,9 +50,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
       deriving Show Eq Ord
   |]
 
-migrateAll :: MonadIO m => ReaderT SqlBackend m ()
+migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
 migrateAll = do
-  runMigration $ do
+  mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do
     -- Manual migrations to go to InitialVersion below:
     migrateEnableExtension "citext"
 
@@ -69,7 +69,7 @@ migrateAll = do
   -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
   Map.foldlWithKey doCustomMigration (return ()) missingMigrations 
   
-  runMigration migrateAll'
+  mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'
 
 {-
   Confusion about quotes, from the PostgreSQL Manual:
@@ -193,6 +193,12 @@ customMigrations = Map.fromListWith (>>)
         sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |]
         forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]                
     )
+  , ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
+    , whenM (tableExists "cluster_config") $
+        [executeQQ|
+           UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
+        |]
+    )
   ]
 
 

src/Settings.hs

@@ -114,11 +114,16 @@ data AppSettings = AppSettings
 data LogSettings = LogSettings
   { logAll, logDetailed :: Bool
   , logMinimumLevel :: LogLevel
+  , logDestination :: LogDestination
   } deriving (Show, Read, Generic, Eq, Ord)
 
+data LogDestination = LogDestStderr | LogDestStdout | LogDestFile { logDestFile :: !FilePath }
+  deriving (Show, Read, Generic, Eq, Ord)
+
 deriving instance Generic LogLevel
 instance Hashable LogLevel
 instance Hashable LogSettings
+instance Hashable LogDestination
 
 data UserDefaultConf = UserDefaultConf
   { userDefaultTheme :: Theme
@@ -178,12 +183,19 @@ data SmtpAuthConf = SmtpAuthConf
   } deriving (Show)
 
 deriveJSON defaultOptions
-  { fieldLabelModifier = intercalate "-" . map toLower . splitCamel
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = UntaggedValue
+  , unwrapUnaryRecords = True
+  } ''LogDestination
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
   } ''LogSettings
   
 deriveFromJSON defaultOptions ''Ldap.Scope
 deriveFromJSON defaultOptions
-  { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  { fieldLabelModifier = camelToPathPiece' 2
   } ''UserDefaultConf
 
 instance FromJSON LdapConf where

src/Settings/Cluster.hs

@@ -36,7 +36,7 @@ import qualified Data.ByteString.Base64.URL as Base64
 data ClusterSettingsKey
   = ClusterCryptoIDKey
   | ClusterClientSessionKey
-  | ClusterErrorMessageKey
+  | ClusterSecretBoxKey
   deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 instance Universe ClusterSettingsKey
@@ -108,10 +108,10 @@ instance FromJSON ClientSession.Key where
     either fail return $ Serialize.decode bytes
 
 
-instance ClusterSetting 'ClusterErrorMessageKey where
+instance ClusterSetting 'ClusterSecretBoxKey where
-  type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
+  type ClusterSettingValue 'ClusterSecretBoxKey = SecretBox.Key
   initClusterSetting _ = liftIO SecretBox.newKey
-  knownClusterSetting _ = ClusterErrorMessageKey
+  knownClusterSetting _ = ClusterSecretBoxKey
 
 instance ToJSON SecretBox.Key where
   toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode

src/Utils.hs

@@ -14,7 +14,9 @@ import Data.Monoid (Sum(..))
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text as Text
 
 import Utils.DB as Utils
 import Utils.TH as Utils
@@ -27,7 +29,7 @@ import Control.Lens as Utils (none)
 
 import Text.Blaze (Markup, ToMarkup)
 
-import Data.Char (isDigit)
+import Data.Char (isDigit, isSpace)
 import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
 import Numeric (showFFloat)
 
@@ -39,8 +41,9 @@ import qualified Data.Map as Map
 -- import qualified Data.List as List
 
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
+import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans.Maybe (MaybeT(..))
-import Control.Monad.Catch
+import Control.Monad.Catch hiding (throwM)
 
 
 import qualified Database.Esqueleto as E (Value, unValue)
@@ -54,6 +57,12 @@ import qualified Data.Aeson as Aeson
 
 import Data.Universe
 
+import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
+import qualified Data.ByteString.Base64.URL as Base64
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Crypto.Data.PKCS7 as PKCS7
+
 
 
 -----------
@@ -391,6 +400,10 @@ exceptT f g = either f g <=< runExceptT
 catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
 catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
 
+throwExceptT :: ( Exception e, MonadThrow m )
+             => ExceptT e m a -> m a
+throwExceptT = exceptT throwM return
+
 
 
 ------------
@@ -512,3 +525,89 @@ lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI
 
 hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool
 hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)
+
+------------------
+-- Cryptography --
+------------------
+
+data SecretBoxEncoding = SecretBoxShort | SecretBoxPretty
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe SecretBoxEncoding
+instance Finite SecretBoxEncoding
+instance Default SecretBoxEncoding where
+  def = SecretBoxShort
+
+encodedSecretBoxBlocksize :: Word8
+-- | `encodedSecretBox'` tries to hide plaintext length by ensuring the message
+--   length (before addition of HMAC and nonce) is always a multiple of
+--   `encodedSecretBlocksize`.
+--   Bigger blocksizes hide exact message length better but lead to longer messages
+encodedSecretBoxBlocksize = maxBound
+
+
+encodedSecretBox' :: ( ToJSON a, MonadIO m )
+                  => SecretBox.Key
+                  -> SecretBoxEncoding
+                  -> a -> m Text
+encodedSecretBox' sKey pretty val = liftIO $ do
+  nonce <- SecretBox.newNonce
+  let
+    encrypt = SecretBox.secretbox sKey nonce
+    base64 = decodeUtf8 . Base64.encode
+    pad = PKCS7.padBytesN (fromIntegral encodedSecretBoxBlocksize)
+    attachNonce = mappend $ Saltine.encode nonce
+    chunk
+      | SecretBoxPretty <- pretty = Text.intercalate "\n" . Text.chunksOf 76
+      | otherwise                 = id
+
+  return . chunk . base64 . attachNonce . encrypt . pad . toStrict $ Aeson.encode val
+
+data EncodedSecretBoxException
+  = EncodedSecretBoxInvalidBase64 !String
+  | EncodedSecretBoxInvalidPadding
+  | EncodedSecretBoxCiphertextTooShort
+  | EncodedSecretBoxCouldNotDecodeNonce
+  | EncodedSecretBoxCouldNotOpenSecretBox
+  | EncodedSecretBoxCouldNotDecodePlaintext !String
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception EncodedSecretBoxException
+
+encodedSecretBoxOpen' :: (FromJSON a, MonadError EncodedSecretBoxException m)
+                      => SecretBox.Key
+                      -> Text -> m a
+encodedSecretBoxOpen' sKey chunked = do
+  let unchunked = Text.filter (not . isSpace) chunked
+  decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked
+
+  unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
+    throwError EncodedSecretBoxCiphertextTooShort
+  let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce decoded
+  nonce <- maybe (throwError EncodedSecretBoxCouldNotDecodeNonce) return $ Saltine.decode nonceBS
+  padded <- maybe (throwError EncodedSecretBoxCouldNotOpenSecretBox) return $ SecretBox.secretboxOpen sKey nonce encrypted
+
+  unpadded <- maybe (throwError EncodedSecretBoxInvalidPadding) return $ PKCS7.unpadBytesN (fromIntegral encodedSecretBoxBlocksize) padded
+
+  either (throwError . EncodedSecretBoxCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' unpadded
+
+class Monad m => MonadSecretBox m where
+  secretBoxKey :: m SecretBox.Key
+
+instance MonadSecretBox ((->) SecretBox.Key) where
+  secretBoxKey = id
+
+instance Monad m => MonadSecretBox (ReaderT SecretBox.Key m) where
+  secretBoxKey = ask
+
+encodedSecretBox :: ( ToJSON a, MonadSecretBox m, MonadIO m )
+                 => SecretBoxEncoding
+                 -> a -> m Text
+encodedSecretBox pretty val = do
+  sKey <- secretBoxKey
+  encodedSecretBox' sKey pretty val
+
+encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
+                     => Text -> m a
+encodedSecretBoxOpen ciphertext = do
+  sKey <- secretBoxKey
+  encodedSecretBoxOpen' sKey ciphertext

stack.yaml

@@ -40,4 +40,6 @@ extra-deps:
 
   - hlint-test-0.1.0.0
 
+  - pkcs7-1.0.0.1
+
 resolver: lts-10.5

templates/default-layout.lucius

@@ -5,8 +5,9 @@
   --color-success: #23d160;
   --color-info: #c4c4c4;
   --color-lightblack: #1A2A36;
-  --color-lightwhite: #FCFFFA;
+  --color-lightwhite: #fcfffa;
   --color-grey: #B1B5C0;
+  --color-grey-light: #f4f5f6;
   --color-font: #34303a;
   --color-fontsec: #5b5861;
 

templates/standalone/inputs.julius

@@ -118,23 +118,27 @@ document.addEventListener('setup', function(e) {
     return;
 
   // initialize checkboxes
-  Array.from(e.detail.scope.querySelectorAll('input[type="checkbox"]')).forEach(function(inp) {
+  Array.from(e.detail.scope.querySelectorAll('input[type="checkbox"]:not(.js-initialized)')).forEach(function(inp) {
     window.utils.initializeCheckboxRadio(inp, 'checkbox');
+    inp.classList.add("js-initialized");
   });
 
   // initialize radios
-  Array.from(e.detail.scope.querySelectorAll('input[type="radio"]')).forEach(function(inp) {
+  Array.from(e.detail.scope.querySelectorAll('input[type="radio"]:not(.js-initialized)')).forEach(function(inp) {
     window.utils.initializeCheckboxRadio(inp, 'radio');
+    inp.classList.add("js-initialized");
   });
 
   // initialize file-upload-fields
-  Array.from(e.detail.scope.querySelectorAll('input[type="file"]')).forEach(function(inp) {
+  Array.from(e.detail.scope.querySelectorAll('input[type="file"]:not(.js-initialized)')).forEach(function(inp) {
     window.utils.initializeFileUpload(inp);
+    inp.classList.add("js-initialized");
   });
 
   // initialize file-checkbox-fields
-  Array.from(e.detail.scope.querySelectorAll('.js-file-checkbox')).forEach(function(inp) {
+  Array.from(e.detail.scope.querySelectorAll('.js-file-checkbox:not(.js-initialized)')).forEach(function(inp) {
     window.utils.reactiveFileCheckbox(inp);
+    inp.classList.add("js-initialized");
   });
 });
 

templates/table/layout.julius

@@ -3,6 +3,11 @@
 
   document.addEventListener('setup', function DOMContentLoaded(e) {
 
+    console.log('dbtable', e);
+
+    if (e.detail.module && e.detail.module !== 'dbtable')
+      return;
+
     function setupAsync(wrapper) {
 
       var table = wrapper.querySelector('#' + #{String $ dbtIdent});
@@ -66,16 +71,30 @@
           wrapper.innerHTML = data;
 
           // set up async functionality again
-          setupAsync(wrapper);
+          wrapper.classList.remove("js-initialized");
-          table.querySelector('tbody').innerHTML = data;
+          document.dispatchEvent(new CustomEvent('setup', {
+            detail: { scope: wrapper },
+            bubbles: true,
+            cancelable: true
+          }));
+          // table.querySelector('tbody').innerHTML = data;
         }).catch(function(err) {
           console.error(err);
         });
       }
+
+      wrapper.classList.add("js-initialized");
     }
 
-    var wrapperEl = e.detail.scope.querySelector('#' + #{String $ dbtIdent} + '-table-wrapper');
+    var selector = '#' + #{String $ dbtIdent} + '-table-wrapper:not(.js-initialized)';
+    var wrapperEl = e.detail.scope.querySelector(selector);
     if (wrapperEl)
       setupAsync(wrapperEl);
+    else if (e.detail.scope.matches(selector))
+      setupAsync(e.detail.scope);
   });
 })();
+
+document.addEventListener('DOMContentLoaded', function() {
+  document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'dbtable' }, bubbles: true, cancelable: true }));
+});

templates/widgets/pageactionprime.hamlet

@@ -1,17 +1,16 @@
 $newline never
 $if hasPageActions
   <div .page-nav-prime>
-    <ul .pagenav__list>
+    $forall (MenuItem{menuItemLabel, menuItemType, menuItemModal}, menuIdent, route) <- menuTypes
-      $forall (MenuItem{menuItemLabel, menuItemType, menuItemModal}, menuIdent, route) <- menuTypes
+      $case menuItemType
-        $case menuItemType
+        $of PageActionPrime
-          $of PageActionPrime
+          <div .pagenav__list-item>
-            <li .pagenav__list-item>
+            $if menuItemModal
-              $if menuItemModal
+              <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+            <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
-              <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
+        $of PageActionSecondary
-          $of PageActionSecondary
+          <div .pagenav__list-item>
-            <li .pagenav__list-item>
+            $if menuItemModal
-              $if menuItemModal
+              <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+            <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
-              <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
+        $of _
-          $of _

templates/widgets/pageactionprime.lucius

@@ -1,19 +1,10 @@
 .page-nav-prime {
-  margin: 4px 0 13px;
+  margin: 10px 0 20px;
-  border-left: 2px solid #c3c3c3;
+  background-color: var(--color-grey-light);
-  padding-left: 10px;
-}
-
-.pagenav__list {
-  display: block;
-  margin-left: 0;
 }
 
 .pagenav__list-item {
   display: inline-block;
-
+  padding: 15px;
-  &:not(:last-child) {
+  box-shadow: 0 0 2px 0 rgba(0, 0, 0, 0.1);
-    margin-right: 7px;
-    padding-right: 7px;
-  }
 }

test/CronSpec.hs

@@ -21,7 +21,7 @@ sampleCron :: Natural -> Cron -> [UTCTime]
 sampleCron n = go n baseTime Nothing
   where
     go 0 _ _ _ = []
-    go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
+    go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev 0 t cron of
       MatchAsap -> t : go n' t (Just t) cron
       MatchAt t' -> t' : go n' t' (Just t') cron
       MatchNone -> []

test/Database.hs

@@ -12,6 +12,7 @@ import Data.Pool (destroyAllResources)
 
 import Database.Persist.Postgresql
 import Control.Monad.Logger
+import Control.Monad.Trans.Resource
 
 import System.Console.GetOpt
 import System.Exit (exitWith, ExitCode(..))
@@ -50,6 +51,7 @@ main = do
       DBTruncate -> db $ do
         foundation <- getYesod
         stopJobCtl foundation
+        release . fst $ appLogger foundation
         liftIO . destroyAllResources $ appConnPool foundation
         truncateDb
       DBMigrate -> db $ return ()

test/Handler/ProfileSpec.hs

@@ -7,7 +7,6 @@ import TestImport
 import qualified Data.CaseInsensitive as CI
 
 import Yesod.Core.Handler (toTextUrl)
-import Yesod.Core.Unsafe (fakeHandlerGetLogger)
 
 spec :: Spec
 spec = withApp $ do
@@ -15,8 +14,7 @@ spec = withApp $ do
     it "asserts no access to my-account for anonymous users" $ do
       get ProfileR
 
-      app <- getTestYesod
+      loginText <- runHandler . toTextUrl $ AuthR LoginR
-      loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR)
 
       assertHeader "Location" $ encodeUtf8 loginText
   

test/TestImport.hs

@@ -44,7 +44,8 @@ runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app)
 runHandler :: Handler a -> YesodExample UniWorX a
 runHandler handler = do
   app <- getTestYesod
-  fakeHandlerGetLogger appLogger app handler
+  logger <- liftIO . readTVarIO . snd $ appLogger app
+  fakeHandlerGetLogger (const logger) app handler
 
 
 withApp :: YSpec UniWorX -> Spec

test/UtilsSpec.hs

@@ -0,0 +1,39 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module UtilsSpec where
+
+import TestImport
+import Utils
+
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import Data.Aeson
+
+instance Arbitrary Value where
+  arbitrary = sized $ \size -> if
+    | size <= 0 -> oneof [pure Null, bool', number, string]
+    | otherwise -> resize (size `div` 2) $ oneof [pure Null, bool', number, string, array, object']
+    where
+      bool' = Bool <$> arbitrary
+      number = Number <$> arbitrary
+      string = String <$> arbitrary
+      array = Array <$> arbitrary
+      object' = Object <$> arbitrary
+  shrink = genericShrink
+
+instance Arbitrary SecretBoxEncoding where
+  arbitrary = arbitraryBoundedEnum
+
+spec :: Spec
+spec = do
+  describe "encodedSecretBox" $ do
+    it "has comptabile encryption/decryption" . property $
+      \val pretty -> ioProperty $ do
+        sKey <- SecretBox.newKey
+        ciphertext <- encodedSecretBox' sKey pretty (val :: Value)
+        plaintext <- throwExceptT $ encodedSecretBoxOpen' sKey ciphertext
+        return $ plaintext == val
+    it "produces pretty ciphertext" . property $
+      \val -> ioProperty $ do
+        sKey <- SecretBox.newKey
+        ciphertext <- encodedSecretBox' sKey SecretBoxPretty (val :: Value)
+        return . all ((<= 76) . length) $ lines ciphertext