Fixed facebook tokens

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
+    let params = parseSimpleQuery $ S8.concat $ L8.toChunks b
-    case front of
+    case lookup "access_token" params of
-        "access_token=" -> return $ AccessToken $ T.pack back
+        Just x -> return $ AccessToken $ T.pack $ S8.unpack x
-        _ -> error $ "Invalid facebook response: " ++ back
+        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_ :: AccessToken -> Text -> IO Value
-getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return
+getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return
 
 data InvalidJsonException = InvalidJsonException String
     deriving (Show, Typeable)

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 <michael@snoyman.com>

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"
+fb = FB Facebook
-                   "http://localhost:3000/facebook"
+    { facebookClientId = "154414801293567"
-mkYesod "FB" [$parseRoutes|
+    , 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)
+    liftIO $ print ("Redirecting" :: String, s)
-    redirectString RedirectTemporary s
+    redirectText RedirectTemporary s
-    return ()
 
+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|\
 <form>
     <input type="hidden" name="code" value="#{code}">
     \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.String s) = [hamlet|#{s}|]
-objToHamlet (A.Array list) = [$hamlet|
+objToHamlet (A.Array list) = [hamlet|
 <ul>
     $forall o <- V.toList list
         <li>^{objToHamlet o}
 |]
-objToHamlet (A.Object pairs) = [$hamlet|\
+objToHamlet (A.Object pairs) = [hamlet|\
 <dl>
     $forall pair <- M.toList pairs
         <dt>#{fst pair}
         <dd>^{objToHamlet $ snd pair}
 |]
+objToHamlet (A.Number i) = [hamlet|<i>#{show i}|]
+objToHamlet (A.Bool True) = [hamlet|<i>true|]
+objToHamlet (A.Bool False) = [hamlet|<i>false|]
+objToHamlet A.Null = [hamlet|<i>null|]