Merge branch 'master' into stundenplan
This commit is contained in:
Sarah Vaupel
commit
2c62a988df
32
CHANGELOG.md
32
CHANGELOG.md
@ -2,6 +2,38 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
### [21.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.1...v21.0.2) (2020-11-04)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* build ([fa61b46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa61b46d308753354623df17241b5312f324321e))
|
||||
|
||||
### [21.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.0...v21.0.1) (2020-11-04)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **mail:** better separation of sender/from/envelope-from ([0dbf4f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0dbf4f8bde99431cafeec954dc164a73227154ad))
|
||||
|
||||
## [21.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.14.0...v21.0.0) (2020-11-04)
|
||||
|
||||
|
||||
### ⚠ BREAKING CHANGES
|
||||
|
||||
* **course:** AccessPredicates now take continuation
|
||||
|
||||
### Features
|
||||
|
||||
* **course:** warning if re-registration is not possible ([4451cee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4451ceedf7bde0da7f3bb4c0818b79d7c5df1cbd)), closes [#646](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/646)
|
||||
* **mail:** archive all sent mail & better verp ([1666081](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1666081fea0eec0bf5440a100db0e8cc69be8295))
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **course:** don't delete applications when deregistering ([b666408](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b6664089f75dcb3b2c89dbd2941c064e8aa86404)), closes [#648](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/648)
|
||||
* **courses:** better defaults for application/registration ([1c2c8fe](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1c2c8fe3d99176e079d0473dd45039b44128c491))
|
||||
|
||||
## [20.14.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.13.0...v20.14.0) (2020-11-02)
|
||||
|
||||
|
||||
|
||||
@ -18,10 +18,11 @@ mail-from:
|
||||
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
|
||||
mail-verp:
|
||||
separator: "_env:VERP_SEPARATOR:+"
|
||||
at-replacement: "_env:VERP_AT_REPLACEMENT:="
|
||||
prefix: "_env:VERP_PREFIX:bounce"
|
||||
mail-support:
|
||||
name: "_env:MAILSUPPORT_NAME:"
|
||||
email: "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
|
||||
mail-retain-sent: 31470547
|
||||
|
||||
job-workers: "_env:JOB_WORKERS:10"
|
||||
job-flush-interval: "_env:JOB_FLUSH:30"
|
||||
|
||||
@ -17,14 +17,6 @@ CronLastExec
|
||||
instance InstanceId -- Which uni2work-instance did the work
|
||||
UniqueCronLastExec job
|
||||
|
||||
|
||||
SentNotification
|
||||
content Value
|
||||
user UserId
|
||||
time UTCTime
|
||||
instance InstanceId
|
||||
|
||||
|
||||
TokenBucket
|
||||
ident TokenBucketIdent
|
||||
lastValue Int64
|
||||
|
||||
13
models/mail.model
Normal file
13
models/mail.model
Normal file
@ -0,0 +1,13 @@
|
||||
SentMail
|
||||
sentAt UTCTime
|
||||
sentBy InstanceId
|
||||
objectId MailObjectId Maybe
|
||||
bounceSecret BounceSecret Maybe
|
||||
recipient UserId Maybe
|
||||
headers MailHeaders
|
||||
contentRef SentMailContentId
|
||||
|
||||
SentMailContent
|
||||
hash MailContentReference
|
||||
content MailContent
|
||||
Primary hash
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "20.14.0",
|
||||
"version": "21.0.2",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "20.14.0",
|
||||
"version": "21.0.2",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 20.14.0
|
||||
version: 21.0.2
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
|
||||
@ -183,7 +183,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
-- 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 appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache = UniWorX {..}
|
||||
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret = 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
|
||||
@ -199,6 +199,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
(error "ClusterID forced in tempFoundation")
|
||||
(error "memcached forced in tempFoundation")
|
||||
(error "MinioConn forced in tempFoundation")
|
||||
(error "VerpSecret forced in tempFoundation")
|
||||
|
||||
runAppLoggingT tempFoundation $ do
|
||||
$logInfoS "InstanceID" $ UUID.toText appInstanceID
|
||||
@ -242,6 +243,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
|
||||
appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
|
||||
appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
|
||||
appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool
|
||||
|
||||
appMemcached <- for appMemcachedConf $ \memcachedConf -> do
|
||||
$logDebugS "setup" "Memcached"
|
||||
@ -259,7 +261,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing
|
||||
return conn
|
||||
|
||||
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache
|
||||
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret
|
||||
|
||||
-- Return the foundation
|
||||
$logDebugS "setup" "Done"
|
||||
|
||||
@ -39,6 +39,16 @@ import Network.Wai.Parse (lbsBackEnd)
|
||||
|
||||
import UnliftIO.Pool (withResource)
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import qualified Crypto.Hash as Crypto
|
||||
import qualified Crypto.MAC.KMAC as Crypto
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
data instance ButtonClass UniWorX
|
||||
= BCIsButton
|
||||
@ -178,23 +188,99 @@ instance YesodAuthPersist UniWorX where
|
||||
|
||||
instance YesodMail UniWorX where
|
||||
defaultFromAddress = getsYesod $ view _appMailFrom
|
||||
envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom
|
||||
mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
|
||||
mailVerp = getsYesod $ view _appMailVerp
|
||||
mailDateTZ = return appTZ
|
||||
mailSmtp act = do
|
||||
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
|
||||
withResource pool act
|
||||
mailT ctx mail = defMailT ctx $ do
|
||||
void setMailObjectIdRandom
|
||||
setDateCurrent
|
||||
replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
|
||||
mailT ctx mail = do
|
||||
mailRecord <- newEmptyTMVarIO
|
||||
mailProcess <- allocateLinkedAsync $ do
|
||||
defMailT ctx $ do
|
||||
void setMailObjectIdRandom
|
||||
sentMailSentAt <- liftIO getCurrentTime
|
||||
setDate sentMailSentAt
|
||||
replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailSender . to renderAddress)
|
||||
|
||||
(mRes, smtpData) <- listen mail
|
||||
unless (view _MailSmtpDataSet smtpData)
|
||||
setMailSmtpData
|
||||
(mRes, smtpData) <- listen mail
|
||||
|
||||
return mRes
|
||||
sentMailObjectId <- getMailObjectId
|
||||
|
||||
mContent <- State.get
|
||||
|
||||
smtpData' <- if | smtpData ^. _MailSmtpDataSet -> return smtpData
|
||||
| otherwise -> getMailSmtpData
|
||||
verpMode <- getsYesod $ view _appMailVerp
|
||||
(smtpData'', sentMailBounceSecret) <- if
|
||||
| Verp{..} <- verpMode
|
||||
, [_] <- smtpData' ^.. _smtpRecipients . folded
|
||||
, Just [l, d] <- previews (_smtpEnvelopeFrom . _Wrapped . _Just) (Text.splitOn "@") smtpData'
|
||||
-> do
|
||||
verpSecret <- getsYesod appVerpSecret
|
||||
let bounceSecret = BounceSecret . Crypto.kmacGetDigest $ kmaclazy ("bounce" :: ByteString) verpSecret $ Binary.encode mContent
|
||||
verpAddr = l <> Text.singleton verpSeparator <> verpPrefix <> "." <> toPathPiece bounceSecret <> "@" <> d
|
||||
return ( smtpData' <> mempty { smtpEnvelopeFrom = Last $ Just verpAddr }
|
||||
, Just bounceSecret
|
||||
)
|
||||
| otherwise -> return (smtpData', Nothing)
|
||||
tell smtpData''
|
||||
|
||||
sentMailSentBy <- getsYesod appInstanceID
|
||||
let sentMailRecipient = Nothing -- Fill in later
|
||||
sentMailHeaders = MailHeaders $ mconcat
|
||||
[ renderAddressHeader "From" [mailFrom mContent]
|
||||
, fromMaybe [] $ do
|
||||
toAddrs <- assertM' (not . null) $ mailTo mContent
|
||||
return $ renderAddressHeader "To" toAddrs
|
||||
, fromMaybe [] $ do
|
||||
ccAddrs <- assertM' (not . null) $ mailCc mContent
|
||||
return $ renderAddressHeader "Cc" ccAddrs
|
||||
, fromMaybe [] $ do
|
||||
bccAddrs <- assertM' (not . null) $ mailBcc mContent
|
||||
return $ renderAddressHeader "Bcc" bccAddrs
|
||||
, mailHeaders mContent
|
||||
]
|
||||
where
|
||||
renderAddressHeader :: ByteString -> [Address] -> [(ByteString, Text)]
|
||||
renderAddressHeader lbl = pure . (lbl, ) . Text.intercalate ", " . map renderAddress
|
||||
sentMailContent = MailContent $ mailParts mContent
|
||||
sentMailContentRef = SentMailContentKey . MailContentReference . Crypto.hashlazy $ Binary.encode sentMailContent
|
||||
|
||||
atomically $ putTMVar mailRecord
|
||||
( smtpData'' ^.. _smtpRecipients . folded
|
||||
, sentMailContent
|
||||
, SentMail{..}
|
||||
)
|
||||
atomically . guardM $ isEmptyTMVar mailRecord
|
||||
return mRes
|
||||
|
||||
(smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
|
||||
liftHandler . runDB . setSerializable $ do
|
||||
sentMailRecipient <- if
|
||||
| [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
|
||||
recipUsers <- E.select . E.from $ \user -> do
|
||||
E.where_ $ user E.^. UserDisplayEmail E.==. E.val recipAddr
|
||||
E.||. user E.^. UserEmail E.==. E.val recipAddr
|
||||
E.||. user E.^. UserIdent E.==. E.val recipAddr
|
||||
return user
|
||||
let recipUserCompare = mconcat
|
||||
[ comparing $ Down . (== recipAddr) . userIdent . entityVal
|
||||
, comparing $ Down . (== recipAddr) . userEmail . entityVal
|
||||
, comparing $ Down . (== recipAddr) . userDisplayEmail . entityVal
|
||||
]
|
||||
return $ if
|
||||
| ( bU : us ) <- sortBy recipUserCompare recipUsers
|
||||
, maybe True (\u -> recipUserCompare bU u == LT) $ listToMaybe us
|
||||
-> Just $ entityKey bU
|
||||
| otherwise -> Nothing
|
||||
| otherwise -> return Nothing
|
||||
|
||||
void $ insertUnique SentMailContent{ sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
|
||||
, sentMailContentContent
|
||||
}
|
||||
insert_ sentMail{ sentMailRecipient }
|
||||
wait mailProcess
|
||||
|
||||
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
||||
type MonadCryptoKey m = CryptoIDKey
|
||||
|
||||
@ -57,6 +57,7 @@ data UniWorX = UniWorX
|
||||
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
|
||||
, appMemcached :: Maybe (AEAD.Key, Memcached.Connection)
|
||||
, appUploadCache :: Maybe MinioConn
|
||||
, appVerpSecret :: VerpSecret
|
||||
}
|
||||
|
||||
makeLenses_ ''UniWorX
|
||||
|
||||
@ -651,7 +651,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
lift $ update jId [ QueuedJobContent =. toJSON uContent' ]
|
||||
in runConduit $ getQueuedJobs .| C.mapM_ updateQueuedJob
|
||||
|
||||
updateWhere [ SentNotificationUser ==. oldUserId ] [ SentNotificationUser =. newUserId ]
|
||||
updateWhere [ SentMailRecipient ==. Just oldUserId ] [ SentMailRecipient =. Just newUserId ]
|
||||
|
||||
updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ]
|
||||
|
||||
|
||||
@ -146,7 +146,7 @@ import Data.Time.Clock.Instances as Import ()
|
||||
import Data.Time.LocalTime.Instances as Import ()
|
||||
import Data.Time.Calendar.Instances as Import ()
|
||||
import Data.Time.Format.Instances as Import ()
|
||||
import Network.Mail.Mime.Instances as Import ()
|
||||
import Network.Mail.Mime.Instances as Import
|
||||
import Yesod.Core.Instances as Import ()
|
||||
import Data.Aeson.Types.Instances as Import ()
|
||||
import Database.Esqueleto.Instances as Import ()
|
||||
|
||||
@ -60,6 +60,7 @@ import Jobs.Handler.PruneInvitations
|
||||
import Jobs.Handler.ChangeUserDisplayEmail
|
||||
import Jobs.Handler.Files
|
||||
import Jobs.Handler.PersonalisedSheetFiles
|
||||
import Jobs.Handler.PruneOldSentMails
|
||||
|
||||
import Jobs.HealthReport
|
||||
|
||||
|
||||
@ -78,6 +78,16 @@ determineCrontab = execWriterT $ do
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
|
||||
oldestSentMail <- lift $ preview (_head . _entityVal . _sentMailSentAt) <$> selectList [] [Asc SentMailSentAt, LimitTo 1]
|
||||
whenIsJust ((,) <$> appMailRetainSent <*> oldestSentMail) $ \(retain, oldest) -> tell $ HashMap.singleton
|
||||
(JobCtlQueue JobPruneOldSentMails)
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime retain oldest
|
||||
, cronRepeat = CronRepeatOnChange
|
||||
, cronRateLimit = retain / 2
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
|
||||
|
||||
whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
|
||||
tell $ HashMap.singleton
|
||||
|
||||
21
src/Jobs/Handler/PruneOldSentMails.hs
Normal file
21
src/Jobs/Handler/PruneOldSentMails.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Jobs.Handler.PruneOldSentMails
|
||||
( dispatchJobPruneOldSentMails
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
|
||||
dispatchJobPruneOldSentMails :: JobHandler UniWorX
|
||||
dispatchJobPruneOldSentMails = JobHandlerAtomic $ do
|
||||
retain' <- getsYesod $ view _appMailRetainSent
|
||||
whenIsJust retain' $ \retain -> do
|
||||
now <- liftIO getCurrentTime
|
||||
del <- deleteWhereCount [SentMailSentAt <. addUTCTime (-retain) now]
|
||||
$logInfoS "JobPruneOldSentMails" [st|Deleted #{del} old sent mails|]
|
||||
del <- E.deleteCount . E.from $ \sentMailContent ->
|
||||
E.where_ . E.not_ . E.exists . E.from $ \sentMail ->
|
||||
E.where_ $ sentMail E.^. SentMailContentRef E.==. sentMailContent E.^. SentMailContentId
|
||||
$logInfoS "JobPruneOldSentMails" [st|Deleted #{del} old sent mail bodies|]
|
||||
@ -23,10 +23,5 @@ import Jobs.Handler.SendNotification.SubmissionEdited
|
||||
|
||||
|
||||
dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
|
||||
dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do
|
||||
dispatchJobSendNotification jRecipient jNotification = JobHandlerException $
|
||||
$(dispatchTH ''Notification) jNotification jRecipient
|
||||
|
||||
instanceID' <- getsYesod $ view instanceID
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
runDB . insert_ $ SentNotification (toJSON jNotification) jRecipient now instanceID'
|
||||
|
||||
@ -63,6 +63,10 @@ dispatchHealthCheckMatchingClusterConfig
|
||||
ourSetting <- getsYesod $ fmap fst . appMemcached
|
||||
dbSetting <- clusterSetting @'ClusterMemcachedKey
|
||||
return $ maybe True ((== dbSetting) . Just) ourSetting
|
||||
clusterSettingMatches ClusterVerpSecret = do
|
||||
ourSetting <- getsYesod appVerpSecret
|
||||
dbSetting <- clusterSetting @'ClusterVerpSecret
|
||||
return $ Just ourSetting == dbSetting
|
||||
|
||||
|
||||
clusterSetting :: forall key.
|
||||
|
||||
@ -96,6 +96,7 @@ data Job
|
||||
| JobPruneFallbackPersonalisedSheetFilesKeys
|
||||
| JobRechunkFiles
|
||||
| JobDetectMissingFiles
|
||||
| JobPruneOldSentMails
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification
|
||||
= NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
|
||||
90
src/Mail.hs
90
src/Mail.hs
@ -8,13 +8,12 @@ module Mail
|
||||
module Network.Mail.Mime
|
||||
-- * MailT
|
||||
, MailT, defMailT
|
||||
, MailSmtpData(..)
|
||||
, MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
|
||||
, _MailSmtpDataSet
|
||||
, MailContext(..)
|
||||
, MonadMail(..)
|
||||
, getMailMessageRender, getMailMsgRenderer
|
||||
-- * YesodMail
|
||||
, VerpMode(..)
|
||||
, YesodMail(..)
|
||||
, MailException(..)
|
||||
-- * Monadically constructing Mail
|
||||
@ -25,12 +24,13 @@ module Mail
|
||||
, MonadHeader(..)
|
||||
, MailHeader
|
||||
, MailObjectId
|
||||
, replaceMailHeader, addMailHeader, removeMailHeader
|
||||
, replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader
|
||||
, replaceMailHeaderI, addMailHeaderI
|
||||
, setSubjectI
|
||||
, setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
|
||||
, getMailObjectId
|
||||
, setDate, setDateCurrent
|
||||
, setMailSmtpData
|
||||
, getMailSmtpData
|
||||
, _addressName, _addressEmail
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
|
||||
, _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
|
||||
@ -50,7 +50,7 @@ import Settings.Mime
|
||||
import Data.Monoid (Last(..))
|
||||
import Control.Monad.Trans.RWS (RWST(..))
|
||||
import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
|
||||
import Control.Monad.Trans.Writer (execWriter, Writer)
|
||||
import Control.Monad.Trans.Writer (execWriter, execWriterT, Writer)
|
||||
import Control.Monad.RWS.Class (MonadWriter(..), MonadState(..), modify)
|
||||
import Control.Monad.Fail
|
||||
import Control.Monad.Base
|
||||
@ -62,16 +62,15 @@ import qualified Data.Sequence as Seq
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import qualified Data.Foldable as Foldable
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.Text.Lazy.Builder as LTB
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT, YamlValue)
|
||||
import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue)
|
||||
import Utils.Lens.TH
|
||||
|
||||
import Control.Lens hiding (from)
|
||||
@ -109,8 +108,6 @@ import Data.Universe.Instances.Reverse ()
|
||||
import Data.Universe.Instances.Reverse.JSON ()
|
||||
import Data.Universe.Instances.Reverse.Hashable ()
|
||||
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -123,6 +120,8 @@ import Crypto.Hash.Algorithms (SHAKE128)
|
||||
|
||||
import Language.Haskell.TH (nameBase)
|
||||
|
||||
import Network.Mail.Mime.Instances()
|
||||
|
||||
|
||||
makeLenses_ ''Address
|
||||
makeLenses_ ''Mail
|
||||
@ -152,7 +151,7 @@ instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) =>
|
||||
|
||||
data MailSmtpData = MailSmtpData
|
||||
{ smtpEnvelopeFrom :: Last Text
|
||||
, smtpRecipients :: Set Text
|
||||
, smtpRecipients :: Set Address
|
||||
} deriving (Eq, Ord, Show, Read, Generic)
|
||||
|
||||
instance Semigroup MailSmtpData where
|
||||
@ -188,6 +187,8 @@ instance Default MailContext where
|
||||
|
||||
makeLenses_ ''MailContext
|
||||
|
||||
makeLenses_ ''MailSmtpData
|
||||
|
||||
class (MonadHandler m, MonadState Mail m) => MonadMail m where
|
||||
askMailLanguages :: m Languages
|
||||
askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
|
||||
@ -198,16 +199,6 @@ instance MonadHandler m => MonadMail (MailT m) where
|
||||
askMailDateTimeFormat = (view _mcDateTimeFormat ??)
|
||||
tellMailSmtpData = tell
|
||||
|
||||
data VerpMode = VerpNone
|
||||
| Verp { verpSeparator, verpAtReplacement :: Char }
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''VerpMode
|
||||
|
||||
getMailMessageRender :: ( MonadMail m
|
||||
, HandlerSite m ~ site
|
||||
, RenderMessage site msg
|
||||
@ -234,6 +225,8 @@ instance Exception MailException
|
||||
class Yesod site => YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
||||
envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
envelopeFromAddress = addressEmail <$> defaultFromAddress
|
||||
|
||||
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
mailObjectIdDomain = pack <$> liftIO getHostName
|
||||
@ -248,11 +241,6 @@ class Yesod site => YesodMail site where
|
||||
) => (SMTPConnection -> m a) -> m a
|
||||
mailSmtp _ = throwM MailNotAvailable
|
||||
|
||||
mailVerp :: ( MonadHandler m
|
||||
, HandlerSite m ~ site
|
||||
) => m VerpMode
|
||||
mailVerp = return VerpNone
|
||||
|
||||
mailT :: ( MonadHandler m
|
||||
, HandlerSite m ~ site
|
||||
, MonadUnliftIO m
|
||||
@ -304,7 +292,7 @@ defMailT ls (MailT mailC) = do
|
||||
MailSmtpData{ smtpRecipients }
|
||||
| Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
|
||||
MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
|
||||
, smtpRecipients = (map unpack . toList -> recipients)
|
||||
, smtpRecipients = (map (unpack . addressEmail) . toList -> recipients)
|
||||
} -> mailSmtp $ \conn -> do
|
||||
$logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
|
||||
liftIO $ SMTP.sendMail
|
||||
@ -434,15 +422,17 @@ partIsAttachment (repack -> fName) = modifyPart $ _partDisposition .= Attachment
|
||||
|
||||
|
||||
class MonadHandler m => MonadHeader m where
|
||||
stateHeaders :: forall a. (Headers -> (a, Headers)) -> m a
|
||||
modifyHeaders :: (Headers -> Headers) -> m ()
|
||||
modifyHeaders f = stateHeaders $ ((), ) . f
|
||||
objectIdHeader :: m MailHeader
|
||||
|
||||
instance MonadHandler m => MonadHeader (MailT m) where
|
||||
modifyHeaders f = MailT . modify $ over _mailHeaders f
|
||||
stateHeaders = MailT . zoom _mailHeaders . state
|
||||
objectIdHeader = return "Message-ID"
|
||||
|
||||
instance MonadHandler m => MonadHeader (StateT Part m) where
|
||||
modifyHeaders f = _partHeaders %= f
|
||||
stateHeaders = zoom _partHeaders . state
|
||||
objectIdHeader = return "Content-ID"
|
||||
|
||||
|
||||
@ -459,6 +449,12 @@ addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (hea
|
||||
removeMailHeader :: MonadHeader m => MailHeader -> m ()
|
||||
removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
|
||||
|
||||
getMailHeaders :: MonadHeader m => MailHeader -> m [Text]
|
||||
getMailHeaders header = stateHeaders $ \hdrs -> (, hdrs) . map (view _2) $ filter (views _1 (== header)) hdrs
|
||||
|
||||
lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
|
||||
lookupMailHeader = fmap listToMaybe . getMailHeaders
|
||||
|
||||
|
||||
replaceMailHeaderI :: ( RenderMessage site msg
|
||||
, MonadMail m
|
||||
@ -512,6 +508,11 @@ setMailObjectIdPseudorandom obj = do
|
||||
seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
|
||||
setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)
|
||||
|
||||
getMailObjectId :: ( MonadHeader m, YesodMail (HandlerSite m) ) => m (Maybe MailObjectId)
|
||||
getMailObjectId = fmap (fmap stripBrackets) . lookupMailHeader =<< objectIdHeader
|
||||
where stripBrackets val = fromMaybe val $
|
||||
Text.stripSuffix ">" =<< Text.stripPrefix "<" val
|
||||
|
||||
|
||||
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
|
||||
setDateCurrent = setDate =<< liftIO getCurrentTime
|
||||
@ -539,27 +540,12 @@ setDate time = do
|
||||
]
|
||||
|
||||
|
||||
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m ()
|
||||
setMailSmtpData = do
|
||||
Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum
|
||||
[ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
|
||||
, use _mailFrom
|
||||
]
|
||||
recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
|
||||
getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData
|
||||
getMailSmtpData = execWriterT $ do
|
||||
from <- envelopeFromAddress
|
||||
recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
|
||||
|
||||
tell $ mempty { smtpRecipients = recps }
|
||||
|
||||
verpMode <- mailVerp
|
||||
if
|
||||
| Verp{..} <- verpMode
|
||||
, [recp] <- Set.toList recps
|
||||
-> let (user, domain) = Text.breakOn "@" from
|
||||
verp = mconcat
|
||||
[ user
|
||||
, Text.singleton verpSeparator
|
||||
, Text.replace "@" (Text.singleton verpAtReplacement) recp
|
||||
, domain
|
||||
]
|
||||
in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
|
||||
| otherwise
|
||||
-> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
|
||||
tell $ mempty
|
||||
{ smtpRecipients = recps
|
||||
, smtpEnvelopeFrom = Last $ Just from
|
||||
}
|
||||
|
||||
@ -176,6 +176,8 @@ migrateManual = do
|
||||
, ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" )
|
||||
, ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" )
|
||||
, ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" )
|
||||
, ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
|
||||
, ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")
|
||||
]
|
||||
where
|
||||
addIndex :: Text -> Sql -> Migration
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
{-|
|
||||
Module: Model.Types.Mail
|
||||
@ -17,6 +18,18 @@ import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Crypto.Hash (digestFromByteString, SHAKE128)
|
||||
import Database.Persist.Sql (PersistFieldSql)
|
||||
|
||||
import Data.ByteArray (ByteArrayAccess)
|
||||
import qualified Data.ByteArray as BA
|
||||
|
||||
import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
|
||||
|
||||
import Data.ByteString.Base32
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
|
||||
--
|
||||
@ -85,3 +98,32 @@ instance FromJSON NotificationSettings where
|
||||
return . NotificationSettings $ \n -> fromMaybe (notificationAllowed def n) $ HashMap.lookup n o'
|
||||
|
||||
derivePersistFieldJSON ''NotificationSettings
|
||||
|
||||
|
||||
newtype BounceSecret = BounceSecret (Digest (SHAKE128 64))
|
||||
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
|
||||
deriving newtype ( PersistField, PersistFieldSql
|
||||
, Hashable, NFData
|
||||
, ByteArrayAccess
|
||||
)
|
||||
|
||||
instance PathPiece BounceSecret where
|
||||
toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
|
||||
fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
|
||||
|
||||
newtype MailContent = MailContent [Alternatives]
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving anyclass (Binary)
|
||||
|
||||
derivePersistFieldJSON ''MailContent
|
||||
|
||||
newtype MailContentReference = MailContentReference (Digest SHA3_512)
|
||||
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
|
||||
deriving newtype ( PersistField, PersistFieldSql
|
||||
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
|
||||
, Hashable, NFData
|
||||
, ByteArrayAccess
|
||||
)
|
||||
|
||||
derivePersistFieldJSON ''MailHeaders
|
||||
|
||||
@ -1,20 +1,31 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Network.Mail.Mime.Instances
|
||||
(
|
||||
( MailHeaders(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Network.Mail.Mime
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson.TH
|
||||
|
||||
import Control.Monad.Fail (MonadFail(..))
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
import Utils (assertM)
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import qualified Data.ByteString.Base64 as Base64
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
import Data.Text.Encoding (decodeUtf8')
|
||||
|
||||
import Control.Lens
|
||||
|
||||
|
||||
deriving instance Read Address
|
||||
@ -29,9 +40,9 @@ deriveToJSON defaultOptions
|
||||
} ''Address
|
||||
|
||||
instance FromJSON Address where
|
||||
parseJSON = withObject "Address" $ \obj -> do
|
||||
addressName <- assertM (not . null) <$> (obj .:? "name")
|
||||
addressEmail <- obj .: "email"
|
||||
parseJSON = Aeson.withObject "Address" $ \obj -> do
|
||||
addressName <- assertM (not . null) <$> (obj Aeson..:? "name")
|
||||
addressEmail <- obj Aeson..: "email"
|
||||
return Address{..}
|
||||
|
||||
|
||||
@ -43,3 +54,68 @@ instance Csv.ToNamedRecord Address where
|
||||
|
||||
instance Csv.DefaultOrdered Address where
|
||||
headerOrder _ = Csv.header [ "name", "email" ]
|
||||
|
||||
|
||||
newtype MailHeaders = MailHeaders Headers
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToJSON MailHeaders where
|
||||
toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs
|
||||
instance FromJSON MailHeaders where
|
||||
parseJSON = fmap (MailHeaders . over (traverse . _1) encodeUtf8) . parseJSON
|
||||
|
||||
deriving instance Generic Encoding
|
||||
deriving instance Generic Disposition
|
||||
deriving instance Generic PartContent
|
||||
deriving instance Generic Part
|
||||
deriving instance Generic Mail
|
||||
|
||||
instance Binary Encoding
|
||||
instance Binary Disposition
|
||||
instance Binary PartContent
|
||||
instance Binary Part
|
||||
instance Binary Address
|
||||
instance Binary Mail
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''Encoding
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece . dropSuffix "Disposition"
|
||||
} ''Disposition
|
||||
|
||||
instance ToJSON PartContent where
|
||||
toJSON (PartContent (toStrict -> content))
|
||||
| BS.all (< 0x80) content
|
||||
, Right content' <- decodeUtf8' content = Aeson.String content'
|
||||
toJSON (PartContent content) = Aeson.object
|
||||
[ "encoding" Aeson..= ("base64" :: String)
|
||||
, "content" Aeson..= decodeUtf8 (Base64.encode $ toStrict content)
|
||||
]
|
||||
toJSON (NestedParts ps) = toJSON ps
|
||||
instance FromJSON PartContent where
|
||||
parseJSON (Aeson.String t) = return . PartContent . fromStrict $ encodeUtf8 t
|
||||
parseJSON (Aeson.Object o) = do
|
||||
encoding <- o Aeson..: "encoding"
|
||||
content <- o Aeson..: "content"
|
||||
if | encoding == "base64" -> either fail (return . PartContent . fromStrict) . Base64.decode $ encodeUtf8 content
|
||||
| otherwise -> fail $ "Unknown encoding: “" <> encoding <> "”"
|
||||
parseJSON v = NestedParts <$> parseJSON v
|
||||
|
||||
instance ToJSON Part where
|
||||
toJSON Part{..} = Aeson.object
|
||||
[ "type" Aeson..= partType
|
||||
, "encoding" Aeson..= partEncoding
|
||||
, "disposition" Aeson..= partDisposition
|
||||
, "headers" Aeson..= MailHeaders partHeaders
|
||||
, "content" Aeson..= partContent
|
||||
]
|
||||
instance FromJSON Part where
|
||||
parseJSON = Aeson.withObject "Part" $ \o -> do
|
||||
partType <- o Aeson..: "type"
|
||||
partEncoding <- o Aeson..: "encoding"
|
||||
partDisposition <- o Aeson..: "disposition"
|
||||
MailHeaders partHeaders <- o Aeson..: "headers"
|
||||
partContent <- o Aeson..: "content"
|
||||
return Part{..}
|
||||
|
||||
@ -112,9 +112,12 @@ data AppSettings = AppSettings
|
||||
, appSessionTokenExpiration :: Maybe NominalDiffTime
|
||||
, appSessionTokenEncoding :: JwtEncoding
|
||||
|
||||
, appMailFrom :: Address
|
||||
, appMailObjectDomain :: Text
|
||||
, appMailVerp :: VerpMode
|
||||
, appMailRetainSent :: Maybe NominalDiffTime
|
||||
, appMailEnvelopeFrom :: Text
|
||||
, appMailFrom
|
||||
, appMailSender
|
||||
, appMailSupport :: Address
|
||||
, appJobWorkers :: Natural
|
||||
, appJobFlushInterval :: Maybe NominalDiffTime
|
||||
@ -308,6 +311,16 @@ data TokenBucketConf = TokenBucketConf
|
||||
, tokenBucketInitialValue :: Int64
|
||||
} deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
|
||||
data VerpMode = VerpNone
|
||||
| Verp { verpPrefix :: Text, verpSeparator :: Char }
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''VerpMode
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 2
|
||||
} ''TokenBucketConf
|
||||
@ -456,9 +469,12 @@ instance FromJSON AppSettings where
|
||||
appIpFromHeader <- o .: "ip-from-header"
|
||||
|
||||
appMailFrom <- o .: "mail-from"
|
||||
appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom
|
||||
appMailSender <- o .:? "mail-sender" .!= appMailFrom
|
||||
appMailSupport <- o .: "mail-support"
|
||||
appMailObjectDomain <- o .: "mail-object-domain"
|
||||
appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
|
||||
appMailSupport <- o .: "mail-support"
|
||||
appMailRetainSent <- o .: "mail-retain-sent"
|
||||
|
||||
appJobWorkers <- o .: "job-workers"
|
||||
appJobFlushInterval <- o .:? "job-flush-interval"
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
module Settings.Cluster
|
||||
( ClusterSettingsKey(..)
|
||||
, ClusterSetting(..)
|
||||
, VerpSecret(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -36,6 +37,9 @@ import Control.Monad.Fail
|
||||
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
import Data.ByteArray (ByteArray, ByteArrayAccess)
|
||||
import qualified Crypto.Random as Crypto
|
||||
|
||||
|
||||
data ClusterSettingsKey
|
||||
= ClusterCryptoIDKey
|
||||
@ -44,6 +48,7 @@ data ClusterSettingsKey
|
||||
| ClusterJSONWebKeySet
|
||||
| ClusterId
|
||||
| ClusterMemcachedKey
|
||||
| ClusterVerpSecret
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
instance Universe ClusterSettingsKey
|
||||
@ -131,3 +136,19 @@ instance ClusterSetting 'ClusterMemcachedKey where
|
||||
type ClusterSettingValue 'ClusterMemcachedKey = AEAD.Key
|
||||
initClusterSetting _ = liftIO AEAD.newKey
|
||||
knownClusterSetting _ = ClusterMemcachedKey
|
||||
|
||||
|
||||
newtype VerpSecret = VerpSecret ByteString
|
||||
deriving newtype (Eq, Ord, Monoid, Semigroup, ByteArray, ByteArrayAccess)
|
||||
|
||||
instance ToJSON VerpSecret where
|
||||
toJSON (VerpSecret vSecret) = Aeson.String . decodeUtf8 $ Base64.encode vSecret
|
||||
instance FromJSON VerpSecret where
|
||||
parseJSON = Aeson.withText "VerpSecret" $ \t -> do
|
||||
bytes <- either fail return . Base64.decode $ encodeUtf8 t
|
||||
return $ VerpSecret bytes
|
||||
|
||||
instance ClusterSetting 'ClusterVerpSecret where
|
||||
type ClusterSettingValue 'ClusterVerpSecret = VerpSecret
|
||||
initClusterSetting _ = liftIO $ Crypto.getRandomBytes 16
|
||||
knownClusterSetting _ = ClusterVerpSecret
|
||||
|
||||
@ -233,6 +233,8 @@ makeLenses_ ''Rating'
|
||||
|
||||
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
makeLenses_ ''SentMail
|
||||
|
||||
makePrisms ''AllocationPriority
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
@ -14,7 +14,7 @@ instance Arbitrary MailContext where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary VerpMode where
|
||||
instance Arbitrary Address where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -25,5 +25,3 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, monoidLaws ]
|
||||
lawsCheckHspec (Proxy @MailContext)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
|
||||
lawsCheckHspec (Proxy @VerpMode)
|
||||
[ eqLaws, showReadLaws, jsonLaws ]
|
||||
|
||||
@ -5,9 +5,10 @@ module ModelSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Settings (getTimeLocale')
|
||||
import Settings (getTimeLocale', VerpMode(..))
|
||||
|
||||
import Model.TypesSpec ()
|
||||
import MailSpec ()
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.ByteString.Char8 as CBS
|
||||
@ -203,6 +204,11 @@ instance {-# OVERLAPS #-} (HasCryptoID ns ct pt (ReaderT CryptoIDKey Catch), Arb
|
||||
where
|
||||
tmpKey = unsafePerformIO genKey
|
||||
|
||||
instance Arbitrary VerpMode where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
parallel $ do
|
||||
@ -214,3 +220,5 @@ spec = do
|
||||
[ eqLaws ]
|
||||
lawsCheckHspec (Proxy @Term)
|
||||
[ eqLaws, jsonLaws ]
|
||||
lawsCheckHspec (Proxy @VerpMode)
|
||||
[ eqLaws, showReadLaws, jsonLaws ]
|
||||
|
||||
Reference in New Issue
Block a user