Why is my Yesod app throwing a TlsNotSupported exception when I try to log in?

Question

I'm trying to follow along with Yesod's cookbook for a blog. I've changed a few things such as switching to a PostgreSQL database, adding a link for GoogleEmail authentication, and moving some of the Shakespearean templates to separate files.

My problem is that when I run the app and try to authenticate, I get returned a TlsNotSupported exception and I have no idea what's causing it or how to find out. I've used both forms of authentication in a separate app and both have worked fine.

My code is below. Any help would be greatly appreciated.

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
             TemplateHaskell, GADTs, FlexibleContexts,
             MultiParamTypeClasses, DeriveDataTypeable #-}

import Yesod
import Yesod.Auth
import Yesod.Form.Nic (YesodNic, nicHtmlField)
import Yesod.Auth.BrowserId (authBrowserId, def)
import Yesod.Auth.GoogleEmail (authGoogleEmail)
import Data.Text (Text)
import Network.HTTP.Client (defaultManagerSettings)
import Network.HTTP.Conduit (Manager, newManager)
import Database.Persist.Postgresql
    ( ConnectionString, ConnectionPool, SqlPersistT, runSqlPool, runMigration
    , withPostgresqlPool, runSqlPersistMPool
    )
import Data.Time (UTCTime, getCurrentTime)
import Control.Applicative ((<$>), (<*>), pure)
import Data.Typeable (Typeable)
import Text.Hamlet (hamletFile)
import Text.Lucius (luciusFile)

share [mkPersist sqlOnlySettings, mkMigrate "migrateAll"]
  [persistLowerCase|
User
  email Text
  UniqueUser email
  deriving Typeable

Entry
  title Text
  posted UTCTime
  content Html

Comment
  entry EntryId
  posted UTCTime
  user UserId
  name Text
  text Textarea
|]

data Blog = Blog
            { connPool :: ConnectionPool
            , httpManager :: Manager
            }

mkMessage "Blog" "blog-messages" "en"

mkYesod "Blog" [parseRoutes|
/              HomeR  GET
/blog          BlogR  GET POST
/blog/#EntryId EntryR GET POST
/auth          AuthR  Auth getAuth
|]

instance Yesod Blog where
  approot = ApprootStatic "http://localhost:3000"

  isAuthorized BlogR True = do
    mauth <- maybeAuth
    case mauth of
      Nothing -> return AuthenticationRequired
      Just (Entity _ user)
        | isAdmin user -> return Authorized
        | otherwise    -> unauthorizedI MsgNotAnAdmin

  isAuthorized (EntryR _) True = do
    mauth <- maybeAuth
    case mauth of
      Nothing -> return AuthenticationRequired
      Just _  -> return Authorized

  isAuthorized _ _ = return Authorized

  authRoute _ = Just (AuthR LoginR)

  defaultLayout inside = do
    mmsg <- getMessage
    pc <- widgetToPageContent $ do
      toWidget $(luciusFile "template.lucius")
      inside

    giveUrlRenderer $(hamletFile "template.hamlet")

isAdmin :: User -> Bool
isAdmin user = userEmail user == "[email protected]"

instance YesodPersist Blog where
  type YesodPersistBackend Blog = SqlPersistT
  runDB f = do
    master <- getYesod
    let pool = connPool master
    runSqlPool f pool

type Form x = Html -> MForm Handler (FormResult x, Widget)

instance RenderMessage Blog FormMessage where
  renderMessage _ _ = defaultFormMessage

instance YesodNic Blog

instance YesodAuth Blog where
  type AuthId Blog = UserId
  loginDest _ = HomeR
  logoutDest _ = HomeR
  authHttpManager = httpManager
  authPlugins _ = [ authBrowserId def
                  , authGoogleEmail
                  ]
  getAuthId creds = do
    let email = credsIdent creds
        user = User email
    res <- runDB $ insertBy user
    return $ Just $ either entityKey id res

getHomeR :: Handler Html
getHomeR = defaultLayout $ do
  setTitleI MsgHomepageTitle
  [whamlet|
<p>_{MsgWelcomeHomepage}
<p>
   <a href=@{BlogR}>_{MsgSeeArchive}
|]

entryForm :: Form Entry
entryForm = renderDivs $ Entry
            <$> areq textField (fieldSettingsLabel MsgNewEntryTitle) Nothing
            <*> lift (liftIO getCurrentTime)
            <*> areq nicHtmlField (fieldSettingsLabel MsgNewEntryContent) Nothing

getBlogR :: Handler Html
getBlogR = do
  muser <- maybeAuth
  entries <- runDB $ selectList [] [Desc EntryPosted]
  (entryWidget, enctype) <- generateFormPost entryForm
  defaultLayout $ do
    setTitleI MsgBlogArchiveTitle
    $(whamletFile "blog.hamlet")

postBlogR :: Handler Html
postBlogR = do
  ((res, entryWidget), enctype) <- runFormPost entryForm
  case res of
    FormSuccess entry -> do
      entryId <- runDB $ insert entry
      setMessageI $ MsgEntryCreated $ entryTitle entry
      redirect $ EntryR entryId
    _ -> defaultLayout $ do
      setTitleI MsgPleaseCorrectEntry
      [whamlet|
<form method=post enctype=#{enctype}>
  ^{entryWidget}
  <div>
    <input type=submit value=_{MsgNewEntry}>
|]

commentForm :: EntryId -> Form Comment
commentForm entryId = renderDivs $ Comment
                      <$> pure entryId
                      <*> lift (liftIO getCurrentTime)
                      <*> lift requireAuthId
                      <*> areq textField (fieldSettingsLabel MsgCommentName) Nothing
                      <*> areq textareaField (fieldSettingsLabel MsgCommentText) Nothing

getEntryR :: EntryId -> Handler Html
getEntryR entryId = do
  (entry, comments) <- runDB $ do
    entry <- get404 entryId
    comments <- selectList [CommentEntry ==. entryId] [Asc CommentPosted]
    return (entry, map entityVal comments)
  muser <- maybeAuth
  (commentWidget, enctype) <- generateFormPost (commentForm entryId)
  defaultLayout $ do
    setTitleI $ MsgEntryTitle $ entryTitle entry
    $(whamletFile "entry.hamlet")

postEntryR :: EntryId -> Handler Html
postEntryR entryId = do
  ((res, commentWidget), enctype) <- runFormPost (commentForm entryId)
  case res of
    FormSuccess comment -> do
      _ <- runDB $ insert comment
      setMessageI MsgCommentAdded
      redirect $ EntryR entryId
    _ -> defaultLayout $ do
      setTitleI MsgPleaseCorrectComment
      [whamlet|
<form method=post enctype=#{enctype}>
    ^{commentWidget}
    <div>
        <input type=submit value=_{MsgAddCommentButton}>
|]

openConnectionCount :: Int
openConnectionCount = 10

connStr :: ConnectionString
connStr = "host=localhost dbname=postgres user=postgres password=postgres port=5432"

main :: IO ()
main = withPostgresqlPool connStr openConnectionCount $ \pool -> do
  runSqlPersistMPool (runMigration migrateAll) pool
  manager <- newManager defaultManagerSettings
  warp 3000 $ Blog pool manager

edit: My platform is Arch Linux.

Answer 1

import Network.HTTP.Client (defaultManagerSettings)

You need to use tlsManagerSettings from Network.HTTP.Client.TLS instead.