Move Facebook to Text
This commit is contained in:
Michael Snoyman
parent
572df52d03
commit
bd9ea53ea8
@ -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
|
||||
|
||||
59
facebook.hs
59
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|\
|
||||
<form>
|
||||
<input type="hidden" name="code" value="#{string code}">
|
||||
\Request:
|
||||
<input type="text" name="req" value="#{string req}">
|
||||
\
|
||||
<input type="submit">
|
||||
<hr>
|
||||
\^{so'}
|
||||
|]
|
||||
|
||||
main = withHttpEnumerator $ basicHandler 3000 fb
|
||||
main = warpDebug 3000 fb
|
||||
|
||||
objToHamlet :: StringObject -> Hamlet url
|
||||
objToHamlet (Scalar s) = [$hamlet|$string.s$|]
|
||||
objToHamlet (Sequence list) = [$hamlet|
|
||||
%ul
|
||||
$forall list o
|
||||
%li ^objToHamlet.o^
|
||||
objToHamlet :: A.Value -> Hamlet url
|
||||
objToHamlet (A.String s) = [$hamlet|#{s}|]
|
||||
objToHamlet (A.Array list) = [$hamlet|
|
||||
<ul>
|
||||
$forall o <- V.toList list
|
||||
<li>^{objToHamlet o}
|
||||
|]
|
||||
objToHamlet (Mapping pairs) = [$hamlet|
|
||||
%dl
|
||||
$forall pairs pair
|
||||
%dt $string.fst.pair$
|
||||
%dd ^objToHamlet.snd.pair^
|
||||
objToHamlet (A.Object pairs) = [$hamlet|\
|
||||
<dl>
|
||||
$forall pair <- M.toList pairs
|
||||
<dt>#{fst pair}
|
||||
<dd>^{objToHamlet $ snd pair}
|
||||
|]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user