{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.Facebook
    ( authFacebook
    , facebookUrl
    ) where

#include "qq.h"

import Yesod.Auth
import qualified Web.Authenticate.Facebook as Facebook
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Maybe (fromMaybe)

import Yesod.Form
import Yesod.Handler
import Yesod.Widget
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Text (Text)
import Control.Monad (mzero)
import Data.Monoid (mappend)
import qualified Data.Aeson.Types
import qualified Yesod.Auth.Message as Msg

facebookUrl :: AuthRoute
facebookUrl = PluginR "facebook" ["forward"]

authFacebook :: YesodAuth m
             => Text -- ^ Application ID
             -> Text -- ^ Application secret
             -> [Text] -- ^ Requested permissions
             -> AuthPlugin m
authFacebook cid secret perms =
    AuthPlugin "facebook" dispatch login
  where
    url = PluginR "facebook" []
    dispatch "GET" ["forward"] = do
        tm <- getRouteToMaster
        render <- getUrlRender
        let fb = Facebook.Facebook cid secret $ render $ tm url
        redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms
    dispatch "GET" [] = do
        render <- getUrlRender
        tm <- getRouteToMaster
        let fb = Facebook.Facebook cid secret $ render $ tm url
        code <- runInputGet $ ireq textField "code"
        at <- liftIO $ Facebook.getAccessToken fb code
        let Facebook.AccessToken at' = at
        so <- liftIO $ Facebook.getGraphData at "me"
        let c = fromMaybe (error "Invalid response from Facebook")
                $ parseMaybe (parseCreds at') $ either error id so
        setCreds True c
    dispatch _ _ = notFound
    login tm = do
        render <- lift getUrlRender
        let fb = Facebook.Facebook cid secret $ render $ tm url
        let furl = Facebook.getForwardUrl fb $ perms
        [QQ(whamlet)|
<p>
    <a href="#{furl}">_{Msg.Facebook}
|]

parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)
parseCreds at' (Object m) = do
    id' <- m .: "id"
    let id'' = "http://graph.facebook.com/" `mappend` id'
    name <- m .: "name"
    email <- m .: "email"
    return
        $ Creds "facebook" id''
        $ maybe id (\x -> (:) ("verifiedEmail", x)) email
        $ maybe id (\x -> (:) ("displayName ", x)) name
        [ ("accessToken", at')
        ]
parseCreds _ _ = mzero