diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 73cc67c1..2c162f32 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -1,6 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} -module Web.Authenticate.Facebook where +{-# LANGUAGE OverloadedStrings #-} +module Web.Authenticate.Facebook + ( Facebook (..) + , getForwardUrl + , getAccessToken + , getGraphData + ) where import Network.HTTP.Enumerator import Data.List (intercalate) @@ -12,64 +18,72 @@ 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 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) data Facebook = Facebook - { facebookClientId :: String - , facebookClientSecret :: String - , facebookRedirectUri :: String + { facebookClientId :: Text + , facebookClientSecret :: Text + , facebookRedirectUri :: Text } deriving (Show, Eq, Read, Ord, Data, Typeable) -newtype AccessToken = AccessToken { unAccessToken :: String } +newtype AccessToken = AccessToken { unAccessToken :: Text } deriving (Show, Eq, Read, Ord, Data, Typeable) -getForwardUrl :: Facebook -> [String] -> String -getForwardUrl fb perms = concat - [ "https://graph.facebook.com/oauth/authorize?client_id=" - , qsEncode $ facebookClientId fb - , "&redirect_uri=" - , qsEncode $ facebookRedirectUri fb - , if null perms - then "" - else "&scope=" ++ qsEncode (intercalate "," perms) - ] +getForwardUrl :: Facebook -> [Text] -> Text +getForwardUrl fb perms = + TE.decodeUtf8 $ toByteString $ + copyByteString "https://graph.facebook.com/oauth/authorize" + `mappend` + renderQueryText True + ( ("client_id", Just $ facebookClientId fb) + : ("redirect_uri", Just $ facebookRedirectUri fb) + : if null perms + then [] + else [("scope", Just $ T.intercalate "," perms)]) -accessTokenUrl :: Facebook -> String -> String -accessTokenUrl fb code = concat - [ "https://graph.facebook.com/oauth/access_token?client_id=" - , qsEncode $ facebookClientId fb - , "&redirect_uri=" - , qsEncode $ facebookRedirectUri fb - , "&client_secret=" - , qsEncode $ facebookClientSecret fb - , "&code=" - , qsEncode code - ] -getAccessToken :: Facebook -> String -> IO AccessToken +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) + ] + +getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- simpleHttp $ S8.pack url + b <- simpleHttp url let (front, back) = splitAt 13 $ L8.unpack b case front of - "access_token=" -> return $ AccessToken back + "access_token=" -> return $ AccessToken $ T.pack back _ -> error $ "Invalid facebook response: " ++ back -graphUrl :: AccessToken -> String -> String -graphUrl (AccessToken s) func = concat - [ "https://graph.facebook.com/" - , func - , "?access_token=" - , s - ] +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 -> String -> IO (Either String Value) +getGraphData :: AccessToken -> Text -> IO (Either String Value) getGraphData at func = do let url = graphUrl at func - b <- simpleHttp $ S8.pack url + b <- simpleHttp url return $ eitherResult $ parse json b -getGraphData' :: AccessToken -> String -> IO Value +getGraphData' :: AccessToken -> Text -> IO Value getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return data InvalidJsonException = InvalidJsonException String diff --git a/facebook.hs b/facebook.hs index b88459ca..e86e5936 100644 --- a/facebook.hs +++ b/facebook.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} import Yesod import Web.Authenticate.Facebook -import Data.Object 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 fb :: FB fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb" - "http://localhost:3000/facebook/" + "http://localhost:3000/facebook" mkYesod "FB" [$parseRoutes| / RootR GET /facebook FacebookR GET @@ -18,40 +22,41 @@ instance Yesod FB where approot _ = "http://localhost:3000" getRootR = do FB f <- getYesod - redirectString RedirectTemporary $ getForwardUrl f ["email"] + let s = encodeUtf8 $ getForwardUrl f ["email"] + redirectString RedirectTemporary s return () getFacebookR = do FB f <- getYesod code <- runFormGet' $ stringInput "code" - at <- liftIO $ getAccessToken f code + at <- liftIO $ getAccessToken f $ pack code mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq - so <- liftIO $ getGraphData at req + Right so <- liftIO $ getGraphData at $ pack req let so' = objToHamlet so - hamletToRepHtml [$hamlet| -%form - %input!type=hidden!name=code!value=$string.code$ - Request: $ - %input!type=text!name=req!value=$string.req$ - \ $ - %input!type=submit -%hr -^so'^ + hamletToRepHtml [$hamlet|\ +