diff --git a/.gitignore b/.gitignore index bce03bdeb..b85a1c848 100644 --- a/.gitignore +++ b/.gitignore @@ -30,4 +30,5 @@ src/Handler/Course.SnapCustom.hs /instance .stack-work-* .directory -tags \ No newline at end of file +tags +test.log \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index 60c1f2c33..f3243a773 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -29,9 +29,11 @@ notification-expiration: 259201 session-timeout: 7200 log-settings: - log-detailed: "_env:DETAILED_LOGGING:false" - log-all: "_env:LOG_ALL:false" - log-minimum-level: "_env:LOGLEVEL:warn" + detailed: "_env:DETAILED_LOGGING:false" + all: "_env:LOG_ALL:false" + minimum-level: "_env:LOGLEVEL:warn" + destination: "_env:LOGDEST:stderr" + # Debugging auth-dummy-login: "_env:DUMMY_LOGIN:false" diff --git a/config/test-settings.yml b/config/test-settings.yml index c6e5bf360..23f59aed5 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -1,11 +1,10 @@ database: - # NOTE: By design, this setting prevents the PGDATABASE environment variable - # from affecting test runs, so that we don't accidentally affect the - # production database during testing. If you're not concerned about that and - # would like to have environment variable overrides, you could instead use - # something like: - # - # database: "_env:PGDATABASE:uniworx_test" - database: uniworx_test + database: "_env:PGDATABASE_TEST:uniworx_test" + +log-settings: + detailed: true + all: true + minimum-level: "debug" + destination: "test.log" auth-dummy-login: true diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 86c1d0cd5..44209ffb9 100644 --- a/messages/uniworx/de.msg +++ b/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 -ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err} -ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren -ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch) -ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err} +EncodedSecretBoxCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein +EncodedSecretBoxInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err} +EncodedSecretBoxInvalidPadding: Verschlüsselte Daten sind nicht korrekt padded +EncodedSecretBoxCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren +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 diff --git a/package.yaml b/package.yaml index 0853fdd38..4e09e10e4 100644 --- a/package.yaml +++ b/package.yaml @@ -110,6 +110,7 @@ dependencies: - monad-memo - xss-sanitize - text-metrics + - pkcs7 other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index e1fbfa575..90792b4f5 100644 --- a/src/Application.hs +++ b/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, - toLogStr) +import System.Log.FastLogger ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet + , 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 - tgetter <- newTimeCache "%Y-%m-%d %T %z" - loggerSet <- newStderrLoggerSet defaultBufSize - return $ Yesod.Logger loggerSet tgetter + appLogSettings <- liftIO $ newTVarIO appInitialLogSettings + + let + 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") - logFunc = messageLoggerSource tempFoundation appLogger + (error "secretBoxKey forced in tempFoundation") + 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 --------------------------------------------- diff --git a/src/Cron.hs b/src/Cron.hs index 600eb873c..53a7a01b3 100644 --- a/src/Cron.hs +++ b/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 diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index d7db622ff..7dc9123e8 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 4960f292b..ea504444d 100644 --- a/src/Foundation.hs +++ b/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 - , appStatic :: Static -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. - , appSmtpPool :: Maybe SMTPPool - , appHttpManager :: Manager - , appLogger :: Logger - , appLogSettings :: TVar LogSettings - , appCryptoIDKey :: CryptoIDKey - , appInstanceID :: InstanceId - , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) - , appCronThread :: TMVar (ReleaseKey, ThreadId) - , appErrorMsgKey :: SecretBox.Key - , appSessionKey :: ClientSession.Key + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appSmtpPool :: Maybe SMTPPool + , appHttpManager :: Manager + , appLogger :: (ReleaseKey, TVar Logger) + , appLogSettings :: TVar LogSettings + , appCryptoIDKey :: CryptoIDKey + , appInstanceID :: InstanceId + , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) + , appCronThread :: TMVar (ReleaseKey, ThreadId) + , 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 - 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 + ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson + [whamlet|

_{MsgErrorResponseEncrypted}

-                    #{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:
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index da8a8aed8..feea45783 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -4,16 +4,7 @@ import Import
 import Handler.Utils
 import Jobs
 
-import qualified Data.ByteString as BS
-
-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 Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 
 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) ->
-    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
+  plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
 
   defaultLayout
     [whamlet|
       $maybe t <- plaintext
         
-          #{t}
+          #{encodePrettyToTextBuilder t}
 
       
^{ctView} diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2589ca409..aa16a97b5 100644 --- a/src/Handler/Corrections.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 161ebcd1d..e843ade32 100644 --- a/src/Handler/Course.hs +++ b/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 ) - => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) +makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) + => _ -> 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") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index f6f329951..2a87a09e8 100644 --- a/src/Handler/Home.hs +++ b/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, _, _) } diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4e1f7abe1..dab2a6b83 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -204,25 +204,25 @@ getProfileDataR = do , studyfeat E.^. StudyFeaturesType , studyfeat E.^. StudyFeaturesSemester) ) - -- Tabelle mit eigenen Kursen - (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid - -- Tabelle mit allen Teilnehmer: Kurs (link), Datum - enrolledCoursesTable <- mkEnrolledCoursesTable uid - -- Tabelle mit allen Klausuren und Noten + ( (hasRows, ownedCoursesTable) + , enrolledCoursesTable + , submissionTable + , submissionGroupTable + , 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 919dc3f53..18a4c473a 100644 --- a/src/Handler/Sheet.hs +++ b/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) } diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 280fc3a48..cc645a929 100644 --- a/src/Handler/Submission.hs +++ b/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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 9ab849b41..0bde9b1c8 100644 --- a/src/Handler/SystemMessage.hs +++ b/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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index e5bb7641e..41262bd44 100644 --- a/src/Handler/Term.hs +++ b/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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 178957385..ec3924508 100644 --- a/src/Handler/Users.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 67beeabd1..7ccf0a731 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -69,4 +69,3 @@ warnTermDays tid times = do forM_ warnholidays $ warnI MsgDayIsAHoliday forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoftermdays $ warnI MsgDayIsOutOfTerm - diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index c1e2648c5..3d405fff8 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 82f177cde..f41a26689 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 - dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) + -- | Format @DBTable@ when sort-circuiting + 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 - dbHandler _ f = return . over _2 f + dbWidget _ _ = return . snd + 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 - dbHandler _ f = return . over _2 f + dbWidget _ _ = return . snd + 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 - dbHandler _ f form = return $ fmap (over _2 f) . form + dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi + 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| + + |] + 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) - <*> (piFilter <$> psResult) - <*> (piLimit <$> psResult) - <*> (piPage <$> psResult) - <*> (piShortcircuit <$> psResult) + piPrevious <- fmap (fmap (set _piShortcircuit False) . maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + + $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> piResult) + <*> (piFilter <$> piResult) + <*> (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 - FormFailure errs' -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing - _ -> runPSValidator dbtable Nothing + | not (piIsUnset pi) + -> runPSValidator dbtable $ Just pi + 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 $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' + rows' <- E.select . E.from $ \t -> do + 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) - - rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' + let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f) - let - rowCount - | (E.Value n, _):_ <- rows' = n - | otherwise = 0 + rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' - table' :: WriterT x m Widget - table' = do - getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + let + rowCount + | (E.Value n, _):_ <- rows' = n + | otherwise = 0 - let - tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams + table' :: WriterT x m Widget + table' = do + getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest - genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do - 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") + let + tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams - columnCount :: Int64 - columnCount = olength64 $ getColonnade dbtColonnade + genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do + 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 - 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] + wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable - 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) diff --git a/src/Jobs.hs b/src/Jobs.hs index 50bb56e5d..45a5f74f6 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 001471544..851b2bf77 100644 --- a/src/Jobs/Queue.hs +++ b/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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index e38e55bb5..1aa9fe36a 100644 --- a/src/Model/Migration.hs +++ b/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'; + |] + ) ] diff --git a/src/Settings.hs b/src/Settings.hs index b05ae3c5d..9b4e48541 100644 --- a/src/Settings.hs +++ b/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 diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index 65219f347..a6fb11799 100644 --- a/src/Settings/Cluster.hs +++ b/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 - type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key +instance ClusterSetting 'ClusterSecretBoxKey where + 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 diff --git a/src/Utils.hs b/src/Utils.hs index a451eb70b..e7776ec5b 100644 --- a/src/Utils.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index 1e74d2310..083c073db 100644 --- a/stack.yaml +++ b/stack.yaml @@ -40,4 +40,6 @@ extra-deps: - hlint-test-0.1.0.0 + - pkcs7-1.0.0.1 + resolver: lts-10.5 diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 1cdd12452..8deb58679 100644 --- a/templates/default-layout.lucius +++ b/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 { diff --git a/templates/standalone/inputs.julius b/templates/standalone/inputs.julius index 88b658851..f45a224c7 100644 --- a/templates/standalone/inputs.julius +++ b/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"); }); }); diff --git a/templates/table/layout.julius b/templates/table/layout.julius index 25ded585f..d202b780f 100644 --- a/templates/table/layout.julius +++ b/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); - table.querySelector('tbody').innerHTML = data; + wrapper.classList.remove("js-initialized"); + 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 })); +}); diff --git a/templates/widgets/pageactionprime.hamlet b/templates/widgets/pageactionprime.hamlet index 13aff9d10..624ec8e51 100644 --- a/templates/widgets/pageactionprime.hamlet +++ b/templates/widgets/pageactionprime.hamlet @@ -1,17 +1,16 @@ $newline never $if hasPageActions
-