Merge branch 'master' into 'live'

Master

See merge request !112

.gitignore

@@ -30,4 +30,5 @@ src/Handler/Course.SnapCustom.hs
 /instance
 .stack-work-*
 .directory
-tags
+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

@@ -3,7 +3,7 @@ module Handler.Utils.Submission
   , assignSubmissions
   , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
   , submissionFileSource, submissionFileQuery
-  , submissionMultiArchive 
+  , submissionMultiArchive
   , SubmissionSinkException(..)
   , sinkSubmission, sinkMultiSubmission
   , submissionMatchesSheet
@@ -142,9 +142,9 @@ assignSubmissions sid restriction = do
       wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ]
       detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit
       detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps
-    
+
     $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
-    
+
     queue <- liftIO . Rand.evalRandIO . execWriterT $ do
       tell $ map Just detQueue
       forever $
@@ -162,11 +162,11 @@ assignSubmissions sid restriction = do
 
       maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
       maximumDeficit = do
-        transposed <- uses _3 invertMap 
+        transposed <- uses _3 invertMap
         traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)
 
     subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
-          
+
     subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do
       let
         restrictTuts
@@ -177,7 +177,7 @@ assignSubmissions sid restriction = do
         Just q' -> do
           $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)"
           assignSubmission False smid q'
-        Nothing 
+        Nothing
           | Set.null tuts -> do
               q <- preuse $ _2 . _head . _Just
               case q of
@@ -194,7 +194,7 @@ assignSubmissions sid restriction = do
     forM_ (Map.toList subTutor) $
         \(smid, tutid) -> update smid [ SubmissionRatingBy       =. Just tutid
                                       , SubmissionRatingAssigned =. Just now  ]
-        
+
     let assignedSubmissions   = Map.keysSet subTutor
         unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
     return (assignedSubmissions, unassigendSubmissions)
@@ -222,7 +222,7 @@ submissionMultiArchive (Set.toList -> ids) = do
   ratedSubmissions <- runDBRunner dbrunner $ do
     submissions <- selectList [ SubmissionId <-. ids ] []
     forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
-  
+
   (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
     let
       fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
@@ -231,7 +231,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 
         let
           directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
-              
+
           fileEntitySource = do
             submissionFileSource submissionID =$= Conduit.map entityVal
             yieldM (ratingFile cID rating)
@@ -249,7 +249,7 @@ submissionMultiArchive (Set.toList -> ids) = do
           }
 
         fileEntitySource =$= mapC withinDirectory
-          
+
     mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
 
 
@@ -374,7 +374,7 @@ sinkSubmission userId mExists isUpdate = do
               | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ]
               | otherwise                  = False
             undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
-  
+
         when anyChanges $ do
           touchSubmission
           when (not $ null collidingFiles) $
@@ -394,14 +394,14 @@ sinkSubmission userId mExists isUpdate = do
         when undoneDeletion $ do
           touchSubmission
           lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
-  
+
       Right (submissionId', r'@Rating'{..}) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
 
         unless (submissionId' == submissionId) $ do
           cID <- encrypt submissionId'
           throwM $ ForeignRating cID
-        
+
         alreadySeen <- gets $ getAny . sinkSeenRating
         when alreadySeen $ throwM DuplicateRating
         tellSt $ mempty{ sinkSeenRating = Any True }
@@ -410,19 +410,20 @@ sinkSubmission userId mExists isUpdate = do
 
         Submission{..} <- lift $ getJust submissionId
 
-        let anyChanges = or $ 
+        let anyChanges = or $
               [ submissionRatingPoints /= ratingPoints
               , submissionRatingComment /= ratingComment
               ]
         -- 'ratingTime' is ignored for consistency with 'File's:
-        -- 
+        --
         -- 'fileModified' is simply stored and never inspected while
-        -- 'submissionChanged' is always set to @now@.          
+        -- 'submissionChanged' is always set to @now@.
         when anyChanges $ do
 
           Sheet{..} <- lift $ getJust submissionSheet
-          mapM_ throwM $ validateRating sheetType r' 
+          --TODO: should display errorMessages
-                  
+          mapM_ throwM $ validateRating sheetType r'
+
           touchSubmission
           lift $ update submissionId
             [ SubmissionRatingPoints =. ratingPoints
@@ -514,7 +515,7 @@ data SubmissionMultiSinkException
     { _submissionSinkId :: CryptoFileNameSubmission
     , _submissionSinkFedFile :: Maybe FilePath
     , _submissionSinkException :: SubmissionSinkException
-    }                                   
+    }
   deriving (Typeable, Show)
 
 instance Exception SubmissionMultiSinkException
@@ -522,7 +523,7 @@ instance Exception SubmissionMultiSinkException
 sinkMultiSubmission :: UserId
                     -> Bool {-^ Are these corrections -}
                     -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId)
-               
+
 -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
 --
 -- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
@@ -545,7 +546,7 @@ sinkMultiSubmission userId isUpdate = do
         Nothing -> do
           lift $ do
             cID <- encrypt sId
-            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID 
+            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID
             Submission{..} <- get404 sId
             Sheet{..} <- get404 submissionSheet
             Course{..} <- get404 sheetCourse
@@ -595,7 +596,7 @@ sinkMultiSubmission userId isUpdate = do
     handleHCError _ e = throwM e
     handleCryptoID :: CryptoIDError -> _ (Maybe a)
     handleCryptoID _ = return Nothing
-    
+
 
 submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
 submissionMatchesSheet tid ssh csh shn cid = do

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'
 
-    let
+  rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
-      rowCount
-        | (E.Value n, _):_ <- rows' = n
-        | otherwise = 0
 
-      table' :: WriterT x m Widget
+  let
-      table' = do
+    rowCount
-        getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+      | (E.Value n, _):_ <- rows' = n
+      | otherwise = 0
 
-        let
+    table' :: WriterT x m Widget
-          tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+    table' = do
+      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
 
-          genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
+      let
-            widget <- sortableContent ^. cellContents
+        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
-            let
-              directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-              isSortable = isJust sortableKey
-              isSorted = (`elem` directions)
-              attrs = sortableContent ^. cellAttrs
-            return $(widgetFile "table/cell/header")
 
-          columnCount :: Int64
+        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-          columnCount = olength64 $ getColonnade dbtColonnade
+          widget <- sortableContent ^. cellContents
+          let
+            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
+            isSortable = isJust sortableKey
+            isSorted = (`elem` directions)
+            attrs = sortableContent ^. cellAttrs
+          return $(widgetFile "table/cell/header")
 
-        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+        columnCount :: Int64
+        columnCount = olength64 $ getColonnade dbtColonnade
 
-        wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
+      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
-          widget <- cell' ^. cellContents
-          let attrs = cell' ^. cellAttrs
-          return $(widgetFile "table/cell/body")
-      
-        let table = $(widgetFile "table/colonnade")
-            pageCount = max 1 . ceiling $ rowCount % psLimit
-            pageNumbers = [0..pred pageCount]
 
-        return $(widgetFile "table/layout")
+      wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
+        widget <- cell' ^. cellContents
+        let attrs = cell' ^. cellAttrs
+        return $(widgetFile "table/cell/body")
 
-    bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
+      let table = $(widgetFile "table/colonnade")
+          pageCount = max 1 . ceiling $ rowCount % psLimit
+          pageNumbers = [0..pred pageCount]
+
+      return $(widgetFile "table/layout")
+
+  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

@@ -46,7 +46,7 @@ writeJobCtlBlock cmd = do
     return var
   lift $ writeJobCtl cmd
   let
-    removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd 
+    removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd
   mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
   maybe (return ()) throwM mExc
 
@@ -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;
 
@@ -515,7 +516,7 @@ section {
     padding: 0 0 12px;
     margin: 0 0 12px;
     border-bottom: 1px solid #d3d3d3;
-    
+
 }
 
 section:last-of-type {

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