From 22f331b726ac142bde3765d98aa3c539f148ae39 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 24 Jan 2012 04:38:58 +0200 Subject: [PATCH] Removed Facebook --- Web/Authenticate/Facebook.hs | 119 ----------------------------------- authenticate.cabal | 4 +- 2 files changed, 1 insertion(+), 122 deletions(-) delete mode 100644 Web/Authenticate/Facebook.hs diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs deleted file mode 100644 index fcf2dd0e..00000000 --- a/Web/Authenticate/Facebook.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -module Web.Authenticate.Facebook - ( Facebook (..) - , AccessToken (..) - , getForwardUrlParams - , getForwardUrlWithState - , getForwardUrl - , getAccessToken - , getGraphData - , getGraphData_ - , getLogoutUrl - ) where - -import Network.HTTP.Conduit -import Data.Conduit (ResourceT) -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types (parseSimpleQuery) -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Data (Data) -import Data.Typeable (Typeable) -import Control.Exception (Exception, throwIO) -import Data.Attoparsec.Lazy (parse, eitherResult) -import qualified Data.ByteString.Char8 as S8 -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Blaze.ByteString.Builder (toByteString, copyByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromText) -import Network.HTTP.Types (renderQueryText) -import Data.Monoid (mappend) -import Data.ByteString (ByteString) -import Control.Arrow ((***)) - -data Facebook = Facebook - { facebookClientId :: Text - , facebookClientSecret :: Text - , facebookRedirectUri :: Text - } - deriving (Show, Eq, Read, Ord, Data, Typeable) - -newtype AccessToken = AccessToken { unAccessToken :: Text } - deriving (Show, Eq, Read, Ord, Data, Typeable) - -getForwardUrlParams :: Facebook -> [(Text, Text)] -> Text -getForwardUrlParams fb params = - TE.decodeUtf8 $ toByteString $ - copyByteString "https://graph.facebook.com/oauth/authorize" - `mappend` - renderQueryText True - ( ("client_id", Just $ facebookClientId fb) - : ("redirect_uri", Just $ facebookRedirectUri fb) - : map (id *** Just) params) - --- Internal function used to simplify getForwardUrl & getForwardUrlWithState -getForwardUrlWithExtra_ :: Facebook -> [Text] -> [(Text, Text)] -> Text -getForwardUrlWithExtra_ fb perms extra = getForwardUrlParams fb $ (if null perms - then id - else (("scope", T.intercalate "," perms):)) extra - -getForwardUrlWithState :: Facebook -> [Text] -> Text -> Text -getForwardUrlWithState fb perms state = getForwardUrlWithExtra_ fb perms [("state", state)] - -getForwardUrl :: Facebook -> [Text] -> Text -getForwardUrl fb perms = getForwardUrlWithExtra_ fb perms [] - -accessTokenUrl :: Facebook -> Text -> ByteString -accessTokenUrl fb code = - toByteString $ - copyByteString "https://graph.facebook.com/oauth/access_token" - `mappend` - renderQueryText True - [ ("client_id", Just $ facebookClientId fb) - , ("redirect_uri", Just $ facebookRedirectUri fb) - , ("code", Just code) - , ("client_secret", Just $ facebookClientSecret fb) - ] - -getAccessToken :: Facebook -> Text -> Manager -> ResourceT IO AccessToken -getAccessToken fb code manager = do - let url = accessTokenUrl fb code - req <- liftIO $ parseUrl $ S8.unpack url - Response _ _ b <- httpLbs req manager - let params = parseSimpleQuery $ S8.concat $ L8.toChunks b - case lookup "access_token" params of - Just x -> return $ AccessToken $ T.pack $ S8.unpack x - Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b - -graphUrl :: AccessToken -> Text -> ByteString -graphUrl (AccessToken s) func = - toByteString $ - copyByteString "https://graph.facebook.com/" - `mappend` fromText func - `mappend` renderQueryText True [("access_token", Just s)] - -getGraphData :: AccessToken -> Text -> Manager -> ResourceT IO (Either String Value) -getGraphData at func manager = do - let url = graphUrl at func - req <- liftIO $ parseUrl $ S8.unpack url - Response _ _ b <- httpLbs req manager - return $ eitherResult $ parse json b - -getGraphData_ :: AccessToken -> Text -> Manager -> ResourceT IO Value -getGraphData_ a b m = getGraphData a b m >>= either (liftIO . throwIO . InvalidJsonException) return - -data InvalidJsonException = InvalidJsonException String - deriving (Show, Typeable) -instance Exception InvalidJsonException - --- | Logs out the user from their Facebook session. -getLogoutUrl :: AccessToken - -> Text -- ^ URL the user should be directed to in your site domain. - -> Text -- ^ Logout URL in @https://www.facebook.com/@. -getLogoutUrl (AccessToken s) next = - TE.decodeUtf8 $ toByteString $ - copyByteString "https://www.facebook.com/logout.php" - `mappend` renderQueryText True [("next", Just next), ("access_token", Just s)] diff --git a/authenticate.cabal b/authenticate.cabal index 96c7d5e6..4e9b64cd 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -5,8 +5,7 @@ license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani maintainer: Michael Snoyman synopsis: Authentication methods for Haskell web applications. -description: Focus is on third-party authentication methods, such as OpenID, - rpxnow and Facebook. +description: Focus is on third-party authentication methods, such as OpenID and BrowserID. category: Web stability: Stable cabal-version: >= 1.6 @@ -43,7 +42,6 @@ library Web.Authenticate.BrowserId, Web.Authenticate.OpenId.Providers, Web.Authenticate.OAuth, - Web.Authenticate.Facebook Web.Authenticate.Kerberos other-modules: Web.Authenticate.Internal, OpenId2.Discovery,