Dlaczego moja aplikacja Yesod wyrzuca wyjątek TlsNotSupported podczas próby zalogowania?

Question

Próbuję wykonać wraz z Yesod's cookbook for a blog. Zmieniłem kilka rzeczy, takich jak przełączanie się do bazy danych PostgreSQL, dodawanie linku do uwierzytelniania GoogleEmail i przenoszenie niektórych szablonów Shakespeare'a w celu oddzielenia plików.

Mój problem polega na tym, że po uruchomieniu aplikacji i próbie uwierzytelnienia otrzymuję wyjątek od TlsNotSupported i nie mam pojęcia, co jest przyczyną tego problemu i jak się o tym dowiedzieć. Użyłem obu metod uwierzytelniania w oddzielnej aplikacji i obie zadziałały prawidłowo.

Mój kod znajduje się poniżej. Każda pomoc będzie bardzo ceniona.

{-# 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 

edycja: Moja platforma to Arch Linux.

Answer 1

import Network.HTTP.Client (defaultManagerSettings)

Trzeba użyć tlsManagerSettings od Network.HTTP.Client.TLS zamiast.