It's been a while since this was posted. Hopefully the information in here is still useful to you (if it isn't please let me know!). If you want to get the new stuff as soon as it's out though, sign up to the mailing list below.Join the Mailing list
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 ...
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
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
>>=) 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
completePasswordReset, in their respective components.
First 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
??? 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
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
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
*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 email@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
I 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
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:
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
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 –
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:
Mailercomponent to do email template things (loading templates from disk, rendering a template) ✔
DBBackendcomponent 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
-- ... 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
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
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.