{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Authenticate.Facebook
    ( Facebook (..)
    , AccessToken (..)
    , getForwardUrlParams
    , getForwardUrlWithState
    , getForwardUrl
    , getAccessToken
    , getGraphData
    , getGraphData_
    , getLogoutUrl
    ) where

import Network.HTTP.Conduit
import Data.Conduit (ResourceT)
import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Types (parseSimpleQuery)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as L8
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)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Blaze.ByteString.Builder (toByteString, copyByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Network.HTTP.Types (renderQueryText)
import Data.Monoid (mappend)
import Data.ByteString (ByteString)
import Control.Arrow ((***))

data Facebook = Facebook
    { facebookClientId :: Text
    , facebookClientSecret :: Text
    , facebookRedirectUri :: Text
    }
    deriving (Show, Eq, Read, Ord, Data, Typeable)

newtype AccessToken = AccessToken { unAccessToken :: Text }
    deriving (Show, Eq, Read, Ord, Data, Typeable)

getForwardUrlParams :: Facebook -> [(Text, Text)] -> Text
getForwardUrlParams fb params =
    TE.decodeUtf8 $ toByteString $
    copyByteString "https://graph.facebook.com/oauth/authorize"
    `mappend`
    renderQueryText True
        (  ("client_id", Just $ facebookClientId fb)
         : ("redirect_uri", Just $ facebookRedirectUri fb)
         : map (id *** Just) params)

-- Internal function used to simplify getForwardUrl & getForwardUrlWithState
getForwardUrlWithExtra_ :: Facebook -> [Text] -> [(Text, Text)] -> Text
getForwardUrlWithExtra_ fb perms extra = getForwardUrlParams fb $ (if null perms
                                                                   then id
                                                                   else (("scope", T.intercalate "," perms):)) extra

getForwardUrlWithState :: Facebook -> [Text] -> Text -> Text
getForwardUrlWithState fb perms state = getForwardUrlWithExtra_ fb perms [("state", state)]

getForwardUrl :: Facebook -> [Text] -> Text
getForwardUrl fb perms = getForwardUrlWithExtra_ fb perms []

accessTokenUrl :: Facebook -> Text -> ByteString
accessTokenUrl fb code =
    toByteString $
    copyByteString "https://graph.facebook.com/oauth/access_token"
    `mappend`
    renderQueryText True
        [ ("client_id", Just $ facebookClientId fb)
        , ("redirect_uri", Just $ facebookRedirectUri fb)
        , ("code", Just code)
        , ("client_secret", Just $ facebookClientSecret fb)
        ]

getAccessToken :: Facebook -> Text -> Manager -> ResourceT IO AccessToken
getAccessToken fb code manager = do
    let url = accessTokenUrl fb code
    req <- liftIO $ parseUrl $ S8.unpack url
    Response _ _ b <- httpLbs req manager
    let params = parseSimpleQuery $ S8.concat $ L8.toChunks b
    case lookup "access_token" params of
        Just x -> return $ AccessToken $ T.pack $ S8.unpack x
        Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b

graphUrl :: AccessToken -> Text -> ByteString
graphUrl (AccessToken s) func =
    toByteString $
    copyByteString "https://graph.facebook.com/"
    `mappend` fromText func
    `mappend` renderQueryText True [("access_token", Just s)]

getGraphData :: AccessToken -> Text -> Manager -> ResourceT IO (Either String Value)
getGraphData at func manager = do
    let url = graphUrl at func
    req <- liftIO $ parseUrl $ S8.unpack url
    Response _ _ b <- httpLbs req manager
    return $ eitherResult $ parse json b

getGraphData_ :: AccessToken -> Text -> Manager -> ResourceT IO Value
getGraphData_ a b m = getGraphData a b m >>= either (liftIO . throwIO . InvalidJsonException) return

data InvalidJsonException = InvalidJsonException String
    deriving (Show, Typeable)
instance Exception InvalidJsonException

-- | Logs out the user from their Facebook session.
getLogoutUrl :: AccessToken
             -> Text -- ^ URL the user should be directed to in your site domain.
             -> Text -- ^ Logout URL in @https://www.facebook.com/@.
getLogoutUrl (AccessToken s) next =
    TE.decodeUtf8 $ toByteString $
    copyByteString "https://www.facebook.com/logout.php"
    `mappend` renderQueryText True [("next", Just next), ("access_token", Just s)]