A working Facebook API and simple sample application

Web/Authenticate/Facebook.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Web.Authenticate.Facebook where
+
+import Network.HTTP.Wget
+import Control.Failure hiding (Error)
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import Data.Object
+import Data.Object.Json
+import Data.ByteString.Char8 (pack)
+
+data Facebook = Facebook
+    { facebookClientId :: String
+    , facebookClientSecret :: String
+    , facebookRedirectUri :: String
+    }
+
+newtype AccessToken = AccessToken { unAccessToken :: String }
+    deriving Show
+
+getForwardUrl :: Facebook -> [String] -> String
+getForwardUrl fb perms = concat
+    [ "https://graph.facebook.com/oauth/authorize?client_id="
+    , facebookClientId fb -- FIXME escape
+    , "&redirect_uri="
+    , facebookRedirectUri fb -- FIXME escape
+    , if null perms
+        then ""
+        else "&scope=" ++ intercalate "," perms
+    ]
+
+accessTokenUrl :: Facebook -> String -> String
+accessTokenUrl fb code = concat
+    [ "https://graph.facebook.com/oauth/access_token?client_id="
+    , facebookClientId fb
+    , "&redirect_uri="
+    , facebookRedirectUri fb
+    , "&client_secret="
+    , facebookClientSecret fb
+    , "&code="
+    , code
+    ]
+
+getAccessToken :: Facebook -> String -> IO AccessToken
+getAccessToken fb code = do
+    let url = accessTokenUrl fb code
+    b <- wget url [] []
+    let (front, back) = splitAt 13 b
+    case front of
+        "access_token=" -> return $ AccessToken back
+        _ -> error $ "Invalid facebook response: " ++ back
+
+graphUrl :: AccessToken -> String -> String
+graphUrl (AccessToken s) func = concat
+    [ "https://graph.facebook.com/"
+    , func
+    , "?access_token="
+    , s
+    ]
+
+getGraphData :: AccessToken -> String -> IO StringObject
+getGraphData at func = do
+    let url = graphUrl at func
+    b <- wget url [] []
+    decode $ pack b

Web/Authenticate/OpenId.hs

@@ -26,11 +26,7 @@ module Web.Authenticate.OpenId
 import Network.HTTP.Wget
 import Text.HTML.TagSoup
 import Numeric (showHex)
-#if MIN_VERSION_transformers(0,2,0)
 import "transformers" Control.Monad.IO.Class
-#else
-import "transformers" Control.Monad.Trans
-#endif
 import Data.Data
 import Control.Failure hiding (Error)
 import Control.Exception

Web/Authenticate/Rpxnow.hs

@@ -22,11 +22,7 @@ module Web.Authenticate.Rpxnow
 import Data.Object
 import Data.Object.Json
 import Network.HTTP.Wget
-#if MIN_VERSION_transformers(0,2,0)
 import "transformers" Control.Monad.IO.Class
-#else
-import "transformers" Control.Monad.Trans
-#endif
 import Control.Failure
 import Data.Maybe
 import Web.Authenticate.OpenId (AuthenticateException (..))

authenticate.cabal

@@ -1,5 +1,5 @@
 name:            authenticate
-version:         0.6.2
+version:         0.6.3
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -23,5 +23,6 @@ library
                      transformers >= 0.1 && < 0.3,
                      bytestring >= 0.9 && < 0.10
     exposed-modules: Web.Authenticate.Rpxnow,
-                     Web.Authenticate.OpenId
+                     Web.Authenticate.OpenId,
+                     Web.Authenticate.Facebook
     ghc-options:     -Wall -fno-warn-orphans

facebook.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
+import Yesod
+import Web.Authenticate.Facebook
+import Data.Object
+import Data.Maybe (fromMaybe)
+
+data FB = FB Facebook
+fb :: FB
+fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb"
+                   "http://localhost:3000/facebook/"
+mkYesod "FB" [$parseRoutes|
+/ RootR GET
+/facebook FacebookR GET
+|]
+
+instance Yesod FB where approot _ = "http://localhost:3000"
+
+getRootR = do
+    FB f <- getYesod
+    redirectString RedirectTemporary $ getForwardUrl f ["email"]
+    return ()
+
+getFacebookR = do
+    FB f <- getYesod
+    code <- runFormGet $ required $ input "code"
+    at <- liftIO $ getAccessToken f code
+    mreq <-runFormGet $ optional $ input "req"
+    let req = fromMaybe "me" mreq
+    so <- liftIO $ getGraphData at 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'^
+|]
+
+main = toWaiApp fb >>= basicHandler 3000
+
+objToHamlet :: StringObject -> Hamlet url
+objToHamlet (Scalar s) = [$hamlet|$string.s$|]
+objToHamlet (Sequence list) = [$hamlet|
+%ul
+    $forall list o
+        %li ^objToHamlet.o^
+|]
+objToHamlet (Mapping pairs) = [$hamlet|
+%dl
+    $forall pairs pair
+        %dt $string.fst.pair$
+        %dd ^objToHamlet.snd.pair^
+|]