gistfile1.hs

authorizedCallback :: MonadIO m => Maybe TL.Text -> Maybe TL.Text -> AppT m (Authorized)
authorizedCallback mc ms = do
  case (mc, ms) of
    (Just code, Just state) -> do
      cache <- asks configCache
      let eitherIdpApp = parseIDP (TL.takeWhile (/= '.') state)
      case eitherIdpApp of
        Right (IDPApp idp) -> fetchTokenAndUser cache code idp
        Left _ -> throwError err400

    _ -> throwError err400
  where
    lookIdp :: (MonadIO m, HasLabel a) =>
           CacheStore -> a -> m (Maybe IDPData)
    lookIdp c1 idp1 = liftIO $ lookupKey c1 (idpLabel idp1)

    fetchTokenAndUser :: (HasTokenReq a, HasUserReq a, HasLabel a)
                  => CacheStore
                  -> TL.Text           -- ^ code
                  -> a
                  -> AppT m (Authorized)
    fetchTokenAndUser cache code idp = do
        maybeIdpData <- lookIdp cache idp
        when (isNothing maybeIdpData) (throwError err400 { errBody = "Cannot find data in cache"})
        let idpData = fromJust maybeIdpData
        result <- fetchTokenAndUser' cache (TL.toStrict code) idp idpData
        case result of
                Right _  -> return $ AuthorizedSuccess "some" "body"
                Left err -> throwError err400 { errBody = Data.Text.Lazy.Encoding.encodeUtf8 $ err}
               
    fetchTokenAndUser' :: (HasTokenReq a, HasUserReq a) =>
                CacheStore -> Text -> a -> IDPData -> AppT m (Either TL.Text ())
    fetchTokenAndUser' c code idp idpData = do
        githubKey <- asks configOauth
        mgr <- liftIO $ newManager tlsManagerSettings
        token <- liftIO $ tokenReq idp githubKey mgr (ExchangeToken $ code)

        result <- case token of
                Right at -> tryFetchUser mgr at idp
                Left e   -> return (Left $ TL.pack $ "tryFetchUser: cannot fetch asses token. error detail: " ++ show e)

        case result of
                Right (luser, at) -> liftIO $ updateIdp c idpData luser at >> return (Right ())
                Left err    -> return $ Left ("fetchTokenAndUser: " `TL.append` err)

        where
          updateIdp c1 oldIdpData luser token =
                insertIDPData c1 (oldIdpData {loginUser = Just luser, oauth2Token = Just token })

          tryFetchUser :: HasUserReq a =>
                              Manager
                              -> OAuth2Token -> a -> AppT m (Either TL.Text (LoginUser, OAuth2Token))
          tryFetchUser mgr at idp = do
                re <- fetchUser idp mgr (accessToken at)
                return $ case re of
                        Right user' -> Right (user', at)
                        Left e      -> Left e

                        -- * Fetch UserInfo
                        --
          fetchUser :: (HasUserReq a) => a -> Manager -> AccessToken -> AppT m (Either TL.Text LoginUser)
          fetchUser idp mgr token = do
                        re <- userReq idp mgr token
                        return (first bslToText re)