diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 0769049f..97ace9ec 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -7,19 +7,19 @@ module Web.Authenticate.Facebook , getForwardUrl , getAccessToken , getGraphData + , getGraphData_ ) where import Network.HTTP.Enumerator -import Data.List (intercalate) +import Network.HTTP.Types (parseSimpleQuery) import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L8 -import Web.Authenticate.Internal (qsEncode) 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, pack) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Blaze.ByteString.Builder (toByteString, copyByteString) @@ -67,10 +67,10 @@ getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code b <- simpleHttp $ S8.unpack url - let (front, back) = splitAt 13 $ L8.unpack b - case front of - "access_token=" -> return $ AccessToken $ T.pack back - _ -> error $ "Invalid facebook response: " ++ back + 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 = @@ -85,8 +85,8 @@ getGraphData at func = do b <- simpleHttp $ S8.unpack url return $ eitherResult $ parse json b -getGraphData' :: AccessToken -> Text -> IO Value -getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return +getGraphData_ :: AccessToken -> Text -> IO Value +getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return data InvalidJsonException = InvalidJsonException String deriving (Show, Typeable) diff --git a/authenticate.cabal b/authenticate.cabal index fde92373..12d43cc7 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.1 +version: 0.9.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman diff --git a/facebook.hs b/facebook.hs index 1495a86a..686f37b3 100644 --- a/facebook.hs +++ b/facebook.hs @@ -2,40 +2,45 @@ import Yesod import Web.Authenticate.Facebook import Data.Maybe (fromMaybe) -import Network.HTTP.Enumerator -import Data.Text (pack) import qualified Data.Aeson as A import qualified Data.Vector as V import qualified Data.Map as M -import Data.Text.Encoding (encodeUtf8) data FB = FB Facebook +type Handler = GHandler FB FB + fb :: FB -fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb" - "http://localhost:3000/facebook" -mkYesod "FB" [$parseRoutes| +fb = FB Facebook + { facebookClientId = "154414801293567" + , facebookClientSecret = "f901e124bee0d162c9188f92b939b370" + , facebookRedirectUri = "http://localhost:3000/facebook" + } + +mkYesod "FB" [parseRoutes| / RootR GET /facebook FacebookR GET |] instance Yesod FB where approot _ = "http://localhost:3000" +getRootR :: Handler () getRootR = do FB f <- getYesod let s = getForwardUrl f ["email"] - liftIO $ print ("Redirecting", s) - redirectString RedirectTemporary s - return () + liftIO $ print ("Redirecting" :: String, s) + redirectText RedirectTemporary s +getFacebookR :: Handler RepHtml getFacebookR = do FB f <- getYesod code <- runFormGet' $ stringInput "code" at <- liftIO $ getAccessToken f code + liftIO $ print at mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq Right so <- liftIO $ getGraphData at req let so' = objToHamlet so - hamletToRepHtml [$hamlet|\ + hamletToRepHtml [hamlet|\
\Request: @@ -46,18 +51,23 @@ getFacebookR = do \^{so'} |] +main :: IO () main = warpDebug 3000 fb objToHamlet :: A.Value -> Hamlet url -objToHamlet (A.String s) = [$hamlet|#{s}|] -objToHamlet (A.Array list) = [$hamlet| +objToHamlet (A.String s) = [hamlet|#{s}|] +objToHamlet (A.Array list) = [hamlet|