DDG search drop in powered by ddg.patdryburgh.com
UPDATE (02/10/2018) Don’t use HSTringTemplate… Use Ginger. You probably know Jinja2 templates already, the template structure if familiar, more robust, and the documentation is way better.
It’s pretty common for applications to have to send out emails, and applications in Haskell are no different. In most large applications I’ve worked on, this often means taking a template (with copy approved by management/UX designers/whatever), injecting it with data, and sending it to the user. In this post I’ll go into how I navigated extended bare SMTP functionality in an application I’ve been writing with template rendering/sending.
Note that since I’m going to be adding this functionality, I’m at a point in the application development where I already have a functioning Mailer component. At present all it’s doing is sending log messages (jury-rigged pagerduty), along with a message when the server starts up. While I won’t go into how the Mailer was made (maybe in a future blog post?), the API to the component is pretty straight forward and expressive so it should be obvious what’s happening.
Without much further ado, let’s get on to how I extended my Mailercomponent to handle reading, rendering, and and sending templates for emails from disk. The feature I’ll be adding that will be using this functionality will be password resetting.
As usual, the first step is to read whatever manuals/information I can find to get myself more familiar with the task I"m about to try and undertake. This time, that means spending a little time looking for templating packages for Haskell. I came across a few things:
I chose to go with HStringTemplate mostly for it’s simplicity and generality – it’s just going to template some text for me and spit it out. I spent some time reading the HStringTemplate documentation, in particular the text section.
For building this functionality, I’m going to do a front-to-back approach, meaning that I’m going to:
I start by adding the routes that will do the email things:
--- ... other code ...
:<|> "password-reset" :> "initiate" :> QueryParam "email" Email :> Post '[JSON] (EnvelopedResponse ())
:<|> "password-reset" :> "complete" :> QueryParam "token" PasswordResetToken :> QueryParam "password" Password :> Post '[JSON] (EnvelopedResponse ())
--- ... other code ...
If you’re not familiar with Haskell’s Servant library, check it out, it’s pretty amazing and lets you build expressive routing trees like this – since it supports expressing your API as a type.
Then some initial handlers that are somewhat mocked out at this stage:
--- ... other code ...
passwordResetInitiate :: Maybe Email -> WithApplicationGlobals Handler (EnvelopedResponse ())
passwordResetInitiate Nothing = throwError Err.genericBadRequest
passwordResetInitiate (Just address) = getDBBackendAndMailer -- gets the components
>>= \(backend, mailer) -> liftIO (createPasswordResetTokenForUser backend address) -- uses the DBBackend component component
>>= ifNothingThrowError Err.failedToFindEntity
>>= \((user,token)) -> liftIO (sendPasswordResetEmail mailer user token) -- uses the mailer component
>> return $ EnvelopedResponse "success" "Password reset email sent" ()
passwordResetComplete :: Maybe PasswordResetToken -> Maybe Password -> WithApplicationGlobals Handler (EnvelopedResponse ())
passwordResetComplete Nothing _ = throwError Err.genericBadRequest
passwordResetComplete _ Nothing = throwError Err.genericBadRequest
passwordResetComplete (Just token) (Just newPass) = getDBBackendOrFail
>>= \backend -> liftIO (completePasswordReset backend token newPass)
>>= ifNothingThrowError (Err.enveloped (Err.makeGenericError "Failed to complete password request"))
>> return $ EnvelopedResponse "success" "Password reset completed" ()
--- ... other code ...
Note that functionslike createPasswordResetTokenForUser, completePasswordReset and sendPasswordResetEmail don’t exist yet on the components they’re being called on – I’m going to be adding them shortly. I’ve also noted this before but I prefer to bind (>>=) functionality together in a chain rather than with Haskell’s normal do notation. I find that it helps me to modularize the code, and think more modularly about what is happening to inputs/outputs.
With the routes and handlers written it’s time to extend the various components that the app uses with some of the imaginary methods I was calling. This is the part where I write the code for methods like createPasswordResetTokenForUser and completePasswordReset, in their respective components.
Mailer componentFirst thing I did was add a few of types as I was thinking about the problem very early on:
type TemplateName = String -- newtype might be better here, but at the very least it's a little self-describing
data TemplateData = PasswordReset User Token deriving (Eq, Show) -- various TemplateData data types will contain the different data needed, here's an example of the data password reset template might need
type TemplateRegistry = HMS.HashMap String (TemplateData, ???) -- note: HMS ==> Data.HashMap.Strict
The ??? type I use there has more to do with what HStringTemplate produces/works with so I just left it unknown for a little bit. Looking at the HStringTemplate Text documentation, I thought that the ??? type should be StringTemplate String, but it ended up being StringTemplate ByteString (which makes sense, given the various ways text can be represented).
Next, the endpoints that would be needed in the Mailer:
class Mailer m where
-- ... other stuff ...
--^ Email template related functionality
getTemplateRegistry :: m -> TemplateRegistry
hasTemplate :: TemplateName -> m -> Bool
loadTemplates :: FilePath -> m -> IO ()
renderTemplate :: TemplateName -> TemplateData -> m -> Maybe Mail
sendRenderedTemplateEmail :: TemplateName -> TemplateData -> m -> IO ()
It turns out I don’t have to work too hard to load my templates from disk – there’s actually already a way to load templates from disk with HStringTemplate. Doing it the HStringTemplate way changes my expectation of being able to use a HMS.HashMap String (StringTemplate ByteString) – but I do get to some methods they’ve already provided that do what I wanted to do, for example, the implementation of hasTemplate changes from:
hasTemplate name = member name . getTemplateRegistry
to:
hasTemplate name = isJust . getStringTemplate name . getTemplateRegistry
Not a huge deal but thought it was worth mentioning.
Here’s what the code that was added to the mailer component looks like:
instance Mailer MailerBackend where
-- ... other code ...
getTemplateRegistry (LocalMailer _ _ r) = r
getTemplateRegistry (SMTPMailer _ _ r) = r
hasTemplate name = isJust . getStringTemplate name . getTemplateRegistry
getTemplate name = getStringTemplate name . getTemplateRegistry
getTemplates names m = (`getTemplate` m) <$> names
loadTemplates templateDir m = logMsg m INFO ("Loading templates from " <> show templateDir)
>> try (directoryGroup templateDir)
>>= either (logFailureAndReturn m) (pure . setTemplates m)
where
logFailureAndReturn :: MailerBackend -> SomeException -> IO MailerBackend
logFailureAndReturn s = (>> return s) . logMsg s INFO . ("Failed to load templates. Error: "<>) . show
renderTemplate name templateData m = if templateMissing then Left (MissingTemplate (show templateNames)) else Right (map fromJust templates)
>>= pure . listToTuple . map (render . setAttribs templateData)
where
templateNames = [name <> ".html", name <> ".text"]
templates = getTemplates templateNames m
templateMissing = any isNothing templates
listToTuple [x,y] = (x,y)
sendRenderedTemplateEmail m sender recipient name templateData = pure (renderTemplate name templateData m)
>>= errorIfLeft
>>= makeMail
>>= sendMail m
where
senderAddr = Address Nothing sender
recipientAddr = Address Nothing recipient
makeMail (html, text) = let bodyText = DTL.fromStrict (decodeUtf8 text)
bodyHTML = DTL.fromStrict (decodeUtf8 html)
title = emailName templateData
in simpleMail recipientAddr senderAddr title bodyText bodyHTML []
Most of it is pretty straight forward and pretty easy to read as well. Another utility I added was the ability to trigger an email template generation from the command line:
data SubCommand = PrintSwaggerJSON
| MigrateBackend
| PrintEmailTemplate String -- <----- new!
| RunServer deriving (Eq, Show, Read)
instance Runnable SubCommand where
-- ... other code ...
run (PrintEmailTemplate name) = getDefaultOrEnvValue "Development" "ENVIRONMENT"
>>= fmap appMailerConfig . getCurrentEnvConfig
>>= startMailerBackend
>>= ifNothingThrowError (MissingTemplate name) . getTemplate name
>>= print . render
>> return ()
A little long winded, but this addition allows me to write something like run PrintEmailTemplate <template name> in GHCi (or on the actual executable) and generate a single email – in the process testing whether email generation works at all. Here’s what one of the runs looked like (in GHCi):
*Main> run (PrintEmailTemplate "password-reset-completed.html")
[2017-11-23 23:49:23 JST : App.Mailer : INFO] Starting Mailer...
[2017-11-23 23:49:23 JST : App.Mailer : INFO] Connected to LocalMailer (No-op)
[2017-11-23 23:49:23 JST : App.Mailer : INFO] Loading templates from "infra/email/templates"
"<h1>Your password reset has been completed</h1>\n<p>If you've received this email in error (and you haven't completed a password reset), please contact support@example.com immediately</p>\n\nHappy Hunting!\n<br/>\nexample.com"
The output is kinda boring, but you get the idea – the email template was generated. More importantly, when I try one that doesn’t exist, the error is pretty obvvious:
*Main> run (PrintEmailTemplate "nope.html")
[2017-11-23 23:53:29 JST : App.Mailer : INFO] Starting Mailer...
[2017-11-23 23:53:29 JST : App.Mailer : INFO] Connected to LocalMailer (No-op)
[2017-11-23 23:53:29 JST : App.Mailer : INFO] Loading templates from "infra/email/templates"
*** Exception: The html and/or text templates are missing for the following templates: nope.html
DBBackend (DAO) componentI have a component in my application that basically acts as a DAO and gives me a nicer interface to looking for things in the database – it’s a DatabaseBackend which I often shorten to DBBackend, and the only current implmenetation is SqliteBackend, for now.
I’ve added two new imaginary methods to that component, namely createPasswordResetTokenForUser and completePasswordReset. The underlying SQLite database also needs to be migrated to support the functionality that I’m adding to the DBBackend – this means creating a migration that will be run when the app starts up to move the database into the state it expects.
Before I got started writing the migration, I did need to spend a little time thinking about how I wanted to store the “tokens”. There are at least two options:
303832c5ff5c4e92b3843f1d24537889)Web.JWT package)JWTs seem like overkill, and I’m pretty lazy so I went with just creating a tokens table that holds a bunch of randomly generated alphanumeric strings (actually, UUIDs, because I’m lazy).
The table looks like:
CREATE TABLE IF NOT EXISTS tokens ( -- Holds tokens for any use
id INTEGER PRIMARY KEY,
type TEXT, -- Token type (haskell types: AuthToken, PasswordResetToken, etc)
token TEXT, -- The token itself
creatorId INTEGER REFERENCES users(id), -- creator of the token's user ID
createdAt TEXT, -- creation time of the token
expiresAt TEXT -- expiry time of the token
);
After creating the migration needed to get the actual database into the state I wanted, it was time to extend the SqliteBackend (DBBackend) component with some functions to make accessing and manipulating that data much easier:
instance DatabaseBackend SqliteBackend where
-- ... other code ...
createTokenForUser b uid tType = makeToken uid tType
>>= \token -> maybe (return Nothing) (insertEntityAndGet_ token) (backendConn b)
getTokenByContent b token = maybe (return Nothing) handle (backendConn b)
where
handle = getRowBySimpleField_ DBQ.tokensTableName DBQ.tokensTokenFieldName token
removeTokenByID b tokenId = maybe (return False) handle (backendConn b)
where
handle = deleteRowBySimpleField_ DBQ.tokensTableName DBQ.genericIDField tokenId
removeTokensByTypeForCreatorWithID b tokenType creatorId = maybe (return False) handle (backendConn b)
where
deleteTokens c = S.withTransaction c (S.executeNamed c DBQ.deleteTokensOfTypeForCreator ["creatorId" S.:= creatorId, "tokenType" S.:= tokenType] >> S.changes c)
handle = fmap (>0) . deleteTokens
completePasswordReset b token newPass = maybe (return Nothing) handle (backendConn b)
where
handle c = rightToMaybe <$> (try (updatePassword c) :: IO (Either DBBackendError (ModelWithID User)))
updatePassword c = getTokenByContent b token
>>= ifNothingThrowError MissingEntity
-- Get the user associated to the token
>>= \token -> (getUserByID b . tCreatorId . model) token
>>= ifNothingThrowError MissingEntity
-- Update the password for the user
>>= \user -> updatePasswordForUser_ newPass c (Just user)
>> logMsg b INFO ("Successfully reset password for user with email "<> (show . mId) user)
-- Remove the token
>> removeTokensByTypeForCreatorWithID b PasswordResetToken (mId user)
>> pure user
The function names have changed a little bit, but the most important methods are still there – createTokenForUser and completePasswordReset – they’ll be the driving force behind most of the work that the handlers are trying to do.
You’ll note that in a bunch of these functions, I’m actually throwing Exceptions, and returning Maybe as. This is a pretty bad approach (maybe even an anti-pattern?) – rather than throwing exceptions, I should be returning an Either SomeException a, but for some twisted sense of consistency with the rest of the previous code, I haven’t completely switched to that better approach.
After adding the functionality to the DBBackend component, since some of the naming and functionality shifted from my initial vision, I needed to go back to the handlers and makes ome changes:
passwordResetInitiate :: Maybe Email -> WithApplicationGlobals Handler (EnvelopedResponse ())
passwordResetInitiate Nothing = throwError Err.genericBadRequest
passwordResetInitiate (Just address) = getDBBackendAndMailer
>>= \(backend, mailer) -> liftIO (getUserByEmail backend address)
>>= ifNothingThrowIOError (Err.makeGenericError "failed to find user with given email address")
>>= \(ModelWithID uid user) -> liftIO (createTokenForUser backend uid PasswordResetToken)
>>= ifNothingThrowIOError (Err.makeGenericError "failed to create token")
>>= liftIO . sendPasswordResetInitiatedEmail mailer user . tToken . model
>>= ifLeftConvertAndThrow
>> return (EnvelopedResponse "success" "Password reset email sent" ())
passwordResetComplete :: Maybe PasswordResetToken -> Maybe Password -> WithApplicationGlobals Handler (EnvelopedResponse ())
passwordResetComplete Nothing _ = throwError Err.genericBadRequest
passwordResetComplete _ Nothing = throwError Err.genericBadRequest
passwordResetComplete (Just token) (Just newPass) = getDBBackendAndMailer
>>= \(backend, mailer) -> liftIO (completePasswordReset backend token newPass)
>>= ifNothingThrowIOError (Err.enveloped (Err.make404 "Failed to find reset password request"))
>>= liftIO . sendPasswordResetCompletedEmail mailer . model
>>= ifLeftConvertAndThrow
>> return (EnvelopedResponse "success" "Password reset completed" ())
The logic is a more involved (and likely could be much cleaner), but you still only need to hold about one line in your head at a time due to the modular nature of using >>= in this manner.
OK at this point, I’ve:
Mailer component to do email template things (loading templates from disk, rendering a template) ✔DBBackend component with some methods for dealing with tokens ✔Now it’s time to add some basic tests to keep my paranoia in check. In particular, I’m going adding some integration tests on the DBBackend that make sure the added functionality works as I expect, in the “happy” path.
Here’s an excerpt from integration tests for the DBBackend component:
-- ... other tests/code ...
describe "users" $ do
-- ... other tests ...
it "can create password reset tokens" $ \b -> addUser b testUser testUserPassword
>>= shouldBeSomething
>>= \(ModelWithID uid u) -> createTokenForUser b uid PasswordResetToken
>>= \token -> token `shouldNotBe` Nothing
it "can retrieve tokens by the token value" $ \b -> addUser b testUser testUserPassword
>>= shouldBeSomething
>>= \(ModelWithID uid u) -> createTokenForUser b uid PasswordResetToken
>>= shouldBeSomething
>>= \(ModelWithID tid t) -> getTokenByContent b (tToken t)
>>= containsSomething
it "can remove tokens by id" $ \b -> addUser b testUser testUserPassword
>>= shouldBeSomething
>>= \(ModelWithID uid u) -> createTokenForUser b uid PasswordResetToken
>>= shouldBeSomething
>>= \(ModelWithID tid t) -> getTokenByContent b (tToken t)
>>= containsSomething
>> removeTokenByID b tid
>>= \result -> result `shouldBe` True
The E2E tests for the Mailer component are actually kind of out of scope/lengthy to add here – I do my E2E testing from javascript (using tools like WebDriverIO) , so these tests basically involve running an API executable, doing email things, and watching the output, and waiting for the LocalMailer (implementation of the Mailer) to spit things out.
Though the functionality added is pretty bare, it was fun to work through this problem in Haskell and see how it’s handled. I had the usual warm fuzzies working within the constraints of Haskell’s typesystem while writing the functionality, and am pretty happy with how the code turned out. Most importantly, it didn’t take me much time to write this implementation (since I was able to use HStringTemplate off the shelf, hats off to Sterling Clover, the maintainer of HStringTemplate).
In this day and age, it’s pretty common that apps be able to handle communicating with their users – I’ve seen functionality like this re-written many times (and at larger companies, tickets to improve the codebase that existed with things like batch sendingr). In the future, I’m absolutely going to make a easily deployable, self-hostable, standalone service that handles this for engineers so that they don’t have to rebuild this functionality every time they want more configurability/API access/control. While I don’t know if that service will be written in Haskell (why not?), exploring the problem as I have today will help if I do decide to write it in haskell.