Fix Facebook code
This commit is contained in:
parent
f3997728f6
commit
6232f52aa0
@ -60,6 +60,7 @@ accessTokenUrl fb code =
|
|||||||
[ ("client_id", Just $ facebookClientId fb)
|
[ ("client_id", Just $ facebookClientId fb)
|
||||||
, ("redirect_uri", Just $ facebookRedirectUri fb)
|
, ("redirect_uri", Just $ facebookRedirectUri fb)
|
||||||
, ("code", Just code)
|
, ("code", Just code)
|
||||||
|
, ("client_secret", Just $ facebookClientSecret fb)
|
||||||
]
|
]
|
||||||
|
|
||||||
getAccessToken :: Facebook -> Text -> IO AccessToken
|
getAccessToken :: Facebook -> Text -> IO AccessToken
|
||||||
|
|||||||
@ -16,7 +16,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master
|
|||||||
library
|
library
|
||||||
build-depends: base >= 4 && < 5,
|
build-depends: base >= 4 && < 5,
|
||||||
aeson >= 0.3.1.1 && < 0.4,
|
aeson >= 0.3.1.1 && < 0.4,
|
||||||
http-enumerator >= 0.6 && < 0.7,
|
http-enumerator >= 0.6.5.2 && < 0.7,
|
||||||
tagsoup >= 0.6 && < 0.13,
|
tagsoup >= 0.6 && < 0.13,
|
||||||
failure >= 0.0.0 && < 0.2,
|
failure >= 0.0.0 && < 0.2,
|
||||||
transformers >= 0.1 && < 0.3,
|
transformers >= 0.1 && < 0.3,
|
||||||
|
|||||||
11
facebook.hs
11
facebook.hs
@ -22,23 +22,24 @@ instance Yesod FB where approot _ = "http://localhost:3000"
|
|||||||
|
|
||||||
getRootR = do
|
getRootR = do
|
||||||
FB f <- getYesod
|
FB f <- getYesod
|
||||||
let s = encodeUtf8 $ getForwardUrl f ["email"]
|
let s = getForwardUrl f ["email"]
|
||||||
|
liftIO $ print ("Redirecting", s)
|
||||||
redirectString RedirectTemporary s
|
redirectString RedirectTemporary s
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
getFacebookR = do
|
getFacebookR = do
|
||||||
FB f <- getYesod
|
FB f <- getYesod
|
||||||
code <- runFormGet' $ stringInput "code"
|
code <- runFormGet' $ stringInput "code"
|
||||||
at <- liftIO $ getAccessToken f $ pack code
|
at <- liftIO $ getAccessToken f code
|
||||||
mreq <- runFormGet' $ maybeStringInput "req"
|
mreq <- runFormGet' $ maybeStringInput "req"
|
||||||
let req = fromMaybe "me" mreq
|
let req = fromMaybe "me" mreq
|
||||||
Right so <- liftIO $ getGraphData at $ pack req
|
Right so <- liftIO $ getGraphData at req
|
||||||
let so' = objToHamlet so
|
let so' = objToHamlet so
|
||||||
hamletToRepHtml [$hamlet|\
|
hamletToRepHtml [$hamlet|\
|
||||||
<form>
|
<form>
|
||||||
<input type="hidden" name="code" value="#{string code}">
|
<input type="hidden" name="code" value="#{code}">
|
||||||
\Request:
|
\Request:
|
||||||
<input type="text" name="req" value="#{string req}">
|
<input type="text" name="req" value="#{req}">
|
||||||
\
|
\
|
||||||
<input type="submit">
|
<input type="submit">
|
||||||
<hr>
|
<hr>
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user