Warum wirft meine Yesod-App eine TlsNotSupported-Ausnahme, wenn ich mich anmelde?

Question

Ich versuche mit Yesod's cookbook for a blog zu folgen. Ich habe ein paar Dinge geändert, wie den Wechsel zu einer PostgreSQL-Datenbank, das Hinzufügen eines Links für die Google E-Mail-Authentifizierung und das Verschieben einiger Shakespeare-Vorlagen in separate Dateien.

Mein Problem ist, dass, wenn ich die App laufen und versuchen, zu authentifizieren, bekomme ich eine TlsNotSupported Ausnahme zurück und ich habe keine Ahnung, was es verursacht oder wie es herauszufinden. Ich habe beide Formen der Authentifizierung in einer separaten App verwendet und beide haben gut funktioniert.

Mein Code ist unten. Jede Hilfe würde sehr geschätzt werden.

{-# 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 == "xxxxx@gmail.com" 

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 

bearbeiten: Meine Plattform ist Arch Linux.

Answer 1

import Network.HTTP.Client (defaultManagerSettings)

Sie müssen stattdessen tlsManagerSettings von Network.HTTP.Client.TLS verwenden.