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}