7

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.

2
  • What platform are you testing on?
    – shang
    Commented Sep 14, 2014 at 4:17
  • Thanks, I should have had stated that. My platform is Arch. Commented Sep 14, 2014 at 4:32

1 Answer 1

12

import Network.HTTP.Client (defaultManagerSettings)

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.