suztomoの日記

because type variable `s' would escape its scope

00:15

Yesod.Auth.OAuthをいじくってGoogle PlusのOAuth2.0を使ってみようとしたら謎なエラーめっせーじ。

GooglePlusOAuth.hs:44:54:
    Couldn't match type `sub0' with `s'
      because type variable `s' would escape its scope
    This (rigid, skolem) type variable is bound by
      a type expected by the context:
        (Route Auth -> Route m) -> GWidget s m ()
    The following variables have types that mention sub0
      login :: (AuthRoute -> Route m)
               -> GGWidget
                    m
                    (Control.Monad.Trans.Reader.ReaderT
                       (HandlerData sub0 m)
                       (enumerator-0.4.16:Data.Enumerator.Internal.Iteratee
                          ByteString ghc-prim:GHC.Types.IO))
                    ()
        (bound at GooglePlusOAuth.hs:70:5)
    In the third argument of `AuthPlugin', namely `login'
    In the expression: AuthPlugin name dispatch login
    In an equation for `authOAuth':
        authOAuth name ident reqUrl accUrl authUrl key sec
          = AuthPlugin name dispatch login
          where
              url = PluginR name []
              oauth
                = OAuth
                    {oauthServerName = unpack name, oauthRequestUri = reqUrl,
                     oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl,
                     oauthSignatureMethod = HMACSHA1, oauthConsumerKey = fromString key,
                     oauthConsumerSecret = fromString sec, oauthCallback = Nothing}
              dispatch "GET" ["forward"]
                = do { render <- getUrlRender;
                       .... }
              dispatch "GET" []
                = do { (verifier, oaTok) <- runInputGet
                                          $     (,) <$> ireq textField "oauth_verifier"
                                            <*>
                                              ireq textField "oauth_token";
                       .... }
              dispatch _ _ = notFound
              login tm
                = do { render <- lift getUrlRender;
                       .... }

YesodのAuthenticationを学ぶ

23:24

BlogのExampleにあるようにAuthenticationをするには

    isAuthorized HomeR _ = return AuthenticationRequired
    isAuthorized _ _ = return Authorized

でAuthenticationが必要なHandlerをパターンマッチングで指定すればいい。このisAuthorizedはhttp://hackage.haskell.org/packages/archive/yesod-core/0.9.4/doc/html/src/Yesod-Internal-Core.html#defaultYesodRunner:title=defaultYesodRunner?で使われている。

AuthenticationはPluginとして提供することができる。

data AuthPlugin m = AuthPlugin
    { apName :: Text
    , apDispatch :: Method -> [Piece] -> GHandler Auth m ()
    , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()
    }

これに沿うデータ型を定義すれば認証ができる。裏で何をやっているかはYesod.Auth.OAuthが参考になりそう。

instance YesodAuth OsojiPhoto where
    type AuthId OsojiPhoto = UserId

    -- Where to send a user after successful login
    loginDest _ = RootR
    -- Where to send a user after logout
    logoutDest _ = RootR

    getAuthId creds = runDB $ do
        x <- getBy $ UniqueUser $ credsIdent creds
        case x of
            Just (uid, _) -> return $ Just uid
            Nothing -> do
                fmap Just $ insert $ User (credsIdent creds) Nothing

    -- You can add other plugins like BrowserID, email or OAuth here
    authPlugins = [authOpenId]
--    authPlugins = [authGoogleEmail]

一度ログインしてしまえばhttp://hackage.haskell.org/packages/archive/yesod-auth/0.7.7/doc/html/src/Yesod-Auth.html#maybeAuthId:title=Yesod-Auth maybeAuthId?でSessionからlookupが行われる。

Pluginはその名前であるapNameとapDispatch, ap

apNameは

/page/#Text/STRINGS PluginR

handlePluginRはこのTextの部分とapNameを比べて、piecesというのには例えば["forward"]がくる。apDispatchの第２引数はGETとかがくる。http://hackage.haskell.org/packages/archive/yesod-auth/0.6.1/doc/html/src/Yesod-Auth-OAuth.html:title=Yesod.Auth.OAuthのauthOAuthのdispatch?が対応する。

handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()
handlePluginR plugin pieces = do
    env <- waiRequest
    let method = decodeUtf8With lenientDecode $ W.requestMethod env
    case filter (\x -> apName x == plugin) authPlugins of
        [] -> notFound
        ap:_ -> apDispatch ap method pieces