{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses,
TemplateHaskell, OverloadedStrings, StandaloneDeriving #-}
import System.Environment (getEnv)
import System.Exit (exitFailure)
import System.IO.Error (isDoesNotExistError)
import Yesod
import Yesod.Auth
import Yesod.Auth.Facebook.ClientSide
import Yesod.Form.I18n.English
import qualified Control.Exception.Lifted as E
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Facebook as FB
import qualified Network.HTTP.Conduit as H
data Test = Test { httpManager :: H.Manager
, fbCreds :: FB.Credentials }
mkYesod "Test" [parseRoutes|
/ HomeR GET
/auth AuthR Auth getAuth
/fbchannelfile FbChannelFileR GET
|]
instance Yesod Test where
approot = ApprootStatic "http://dev.whonodes.org:3000"
instance RenderMessage Test FormMessage where
renderMessage _ _ = englishFormMessage
instance YesodAuth Test where
type AuthId Test = T.Text
loginDest _ = HomeR
logoutDest _ = HomeR
getAuthId creds@(Creds _ id_ _) = do
setSession "creds" (T.pack $ show creds)
return (Just id_)
authPlugins _ = [authFacebookClientSide]
redirectToReferer _ = True
authHttpManager = httpManager
deriving instance Show (Creds m)
instance YesodAuthFbClientSide Test where
fbCredentials = fbCreds
getFbChannelFile = return FbChannelFileR
getHomeR :: Handler RepHtml
getHomeR = do
muid <- maybeAuthId
mcreds <- lookupSession "creds"
mtoken <- getUserAccessToken
let perms = []
pc <- widgetToPageContent $ [whamlet|
^{facebookJSSDK AuthR}
<p>
Current uid: #{show muid}
<br>
Current credentials: #{show mcreds}
<br>
Current access token: #{show mtoken}
<p>
<button onclick="#{facebookLogin perms}">
Login
<p>
<a href="@{AuthR $ facebookForceLoginR perms}">
Force login route (avoid this in your code when possible).
<p>
<button onclick="#{facebookLogout}">
Logout
|]
hamletToRepHtml [hamlet|
$doctype 5
<html>
<head>
<title>Yesod.Auth.Facebook.ClientSide test
^{pageHead pc}
<body>
^{pageBody pc}
|]
getFbChannelFileR :: GHandler sub master ChooseRep
getFbChannelFileR = serveChannelFile
main :: IO ()
main = do
manager <- H.newManager H.def
creds <- getCredentials
warpDebug 3000 (Test manager creds)
-- Copy & pasted from the "fb" package:
-- | Grab the Facebook credentials from the environment.
getCredentials :: IO FB.Credentials
getCredentials = tryToGet `E.catch` showHelp
where
tryToGet = do
[appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"]
return $ FB.Credentials (B.pack appName) (B.pack appId) (B.pack appSecret)
showHelp exc | not (isDoesNotExistError exc) = E.throw exc
showHelp _ = do
putStrLn $ unlines
[ "In order to run the tests from the 'fb' package, you need"
, "developer access to a Facebook app. The tests are designed"
, "so that your app isn't going to be hurt, but we may not"
, "create a Facebook app for this purpose and then distribute"
, "its secret keys in the open."
, ""
, "Please give your app's name, id and secret on the enviroment"
, "variables APP_NAME, APP_ID and APP_SECRET, respectively. "
, "For example, before running the test you could run in the shell:"
, ""
, " $ export APP_NAME=\"example\""
, " $ export APP_ID=\"458798571203498\""
, " $ export APP_SECRET=\"28a9d0fa4272a14a9287f423f90a48f2304\""
, ""
, "Of course, these values above aren't valid and you need to"
, "replace them with your own."
, ""
, "(Exiting now with a failure code.)"]
exitFailure