{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances, TypeFamilies #-}
module Happstack.Facebook.Application where

import Control.Applicative
import Control.Arrow(first, second)
import Control.Monad (liftM)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as L
import Data.Function (on)
import Data.List (isPrefixOf, sortBy)
import Data.Maybe (fromJust)
import Data.Time.Clock.POSIX (POSIXTime)
import Happstack.Crypto.MD5 (md5, stringMD5)
import Happstack.Facebook.Common
import Happstack.Facebook.FacebookT
import qualified Network.HTTP as HTTP
import Network.Browser (Form(..),formToRequest, request, browse)
import Network.URI
import Happstack.Server (Method(POST, GET), ServerMonad, withDataFn, lookPairs)

-- |This data type holds all the informaton that facebook pass along with the request
-- http://wiki.developers.facebook.com/index.php/Your_callback_page_and_you
-- NOTE: the order of these fields is subject to change, so use the field labels for minimum breakage.
data FacebookData =
    FacebookData 
    { fbPairs         :: [(String, String)]
    , _fb_sig_added   :: Bool
    , _fb_sig_is_admin       :: Maybe Bool
    , _fb_sig_in_canvas      :: Bool
    , _fb_sig_request_method :: Method
    , _fb_sig_position_fix :: Bool
    , _fb_user        :: Maybe User
    , _fb_sig_time    :: POSIXTime
    , _fb_sig_api_key :: ApiKey
--    , _fb_sig_app_id  :: AppId
    , _fb_sig_locale  :: String
    , _fb_sig         :: String
    , _fb_sig_friends             :: Maybe [User]
    , _fb_sig_session_key         :: Maybe SessionKey
    , _fb_sig_expires             :: Maybe POSIXTime
    , _fb_sig_profile_update_time :: Maybe POSIXTime
    , _fb_sig_profile_user        :: Maybe User
    , _fb_sig_profile_session_key :: Maybe SessionKey
    , _fb_sig_page_id             :: Maybe Page
    , _fb_valid_sig :: Bool
    }
    deriving (Eq, Show)

-- ** convenience functions for getting information from the FacebookData

-- |has the user added our application
fb_sig_added :: (HasFacebookData FacebookData m) => m Bool
fb_sig_added = fbd _fb_sig_added

fb_sig_is_admin :: (HasFacebookData FacebookData m) => m (Maybe Bool)
fb_sig_is_admin = fbd _fb_sig_is_admin

fb_sig_in_canvas :: (HasFacebookData FacebookData m) => m Bool
fb_sig_in_canvas = fbd _fb_sig_in_canvas

fb_sig_request_method :: (HasFacebookData FacebookData m) => m Method
fb_sig_request_method = fbd _fb_sig_request_method

fb_sig_position_fix :: (HasFacebookData FacebookData m) => m Bool
fb_sig_position_fix = fbd _fb_sig_position_fix

-- |get the userid 
fb_user :: (HasFacebookData FacebookData m) => m (Maybe User)
fb_user = fbd _fb_user

-- |get current time
fb_sig_time :: (HasFacebookData FacebookData m) => m POSIXTime
fb_sig_time = fbd _fb_sig_time

-- |your api key
fb_sig_api_key :: (HasFacebookData FacebookData m) => m ApiKey
fb_sig_api_key = fbd _fb_sig_api_key

-- |the user's locale
fb_sig_locale :: (HasFacebookData FacebookData m) => m String
fb_sig_locale = fbd _fb_sig_locale

-- |the signature for the request
fb_sig :: (HasFacebookData FacebookData m) => m String
fb_sig = fbd _fb_sig

-- |is the signature valid
fb_valid_sig :: (HasFacebookData FacebookData m) => m Bool
fb_valid_sig = fbd _fb_valid_sig

-- |list of the users friends
-- NOTE: only available if the user is logged in
fb_sig_friends :: (HasFacebookData FacebookData m) => m (Maybe [User])
fb_sig_friends = fbd _fb_sig_friends

-- |session key
-- NOTE: only available if the user is logged in
fb_sig_session_key :: (HasFacebookData FacebookData m) => m (Maybe String)
fb_sig_session_key = fbd _fb_sig_session_key

-- |when this session key expires
--  0 == never
--  otherwise, time in seconds since epoch`
-- NOTE: only available if the user is logged in
fb_sig_expires :: (HasFacebookData FacebookData m) => m (Maybe POSIXTime)
fb_sig_expires = fbd _fb_sig_expires

-- |time profile was last updated
-- NOTE: only available if the user is logged in
fb_sig_profile_update_time :: (HasFacebookData FacebookData m) => m (Maybe POSIXTime)
fb_sig_profile_update_time = fbd _fb_sig_profile_update_time


-- |The user ID of the profile owner for the tab being requested.
fb_sig_profile_user  :: (HasFacebookData FacebookData m) => m (Maybe User)
fb_sig_profile_user = fbd _fb_sig_profile_user

-- |The session key for the profile owner, which you use to render this user's profile tab content.
fb_sig_profile_session_key  :: (HasFacebookData FacebookData m) => m (Maybe SessionKey)
fb_sig_profile_session_key = fbd _fb_sig_profile_session_key

fb_sig_page_id :: (HasFacebookData FacebookData m) => m (Maybe Page)
fb_sig_page_id = fbd _fb_sig_page_id

validateSignature :: AppSecret -> String -> [(String, String)] -> Bool
validateSignature secret sig pairs =
    let fb_sigs = map (first (drop 7)) $ filter (\(k,v) -> isPrefixOf "fb_sig_" k) pairs
        (sig',_) = signature secret fb_sigs
    in sig == sig'

parseFacebookData :: FacebookConfig -> [(String, String)] -> FacebookData
parseFacebookData config pairs =
           let lookupString k = case lookup k pairs of
                                  Nothing -> error ("Could not find required field " ++ k)
                                  (Just v) -> v
               read' str = case reads str of
                                [(a,[])] -> a
                                r -> error ("Failed to read " ++ str ++ " got " ++ show r)
               readTime :: String -> POSIXTime
               readTime str = realToFrac (read' str :: Double)
               fb_sig_added' = lookupBool "fb_sig_added" pairs
               fb_sig_is_admin = lookupMBool "fb_sig_is_admin" pairs
               fb_user' =
                   case lookup "fb_sig_user" pairs of
                     (Just uid) -> Just $ User (read' uid)
                     Nothing -> 
                         case lookup "fb_sig_canvas_user" pairs of
                           (Just uid) ->
                               Just $ User (read' uid)
                           Nothing -> Nothing
               fb_sig_time' = readTime $ lookupString "fb_sig_time"
               fb_sig_api_key' = ApiKey $ lookupString "fb_sig_api_key"
               fb_sig_locale' = lookupString "fb_sig_locale"
               fb_sig' = lookupString "fb_sig"
               fb_sig_friends' = fmap (\str -> let (Right fids) = parseUserIds str in fids) $ lookup "fb_sig_friends" pairs
               fb_sig_session_key' = lookup "fb_sig_session_key" pairs
               fb_sig_expires' = fmap readTime $ lookup "fb_sig_expires" pairs
               fb_sig_profile_update_time' = fmap readTime $ lookup "fb_sig_profile_update_time" pairs
               fb_sig_profile_user' =
                   case lookup "fb_sig_profile_user" pairs of
                     (Just uid) -> Just $ User (read' uid)
                     Nothing -> Nothing
               fb_sig_profile_session_key' = lookup "fb_sig_profile_session_key" pairs
               fb_sig_page_id = case lookup "fb_sig_page_id" pairs of
                                  (Just pid) -> Just $ Page (read' pid)
                                  Nothing -> Nothing
               valid_sig = validateSignature (appSecret config) fb_sig' pairs
           in (FacebookData { fbPairs = pairs 
                            , _fb_sig_added = fb_sig_added'
                            , _fb_sig_is_admin = fb_sig_is_admin
                            , _fb_sig_in_canvas = lookupBool "fb_sig_in_canvas" pairs
                            , _fb_sig_request_method = 
                                case lookupString "fb_sig_request_method" of
                                  "GET" -> GET
                                  "POST" -> POST
                            , _fb_sig_position_fix = lookupBool "fb_sig_position_fix" pairs
                            , _fb_user = fb_user'
                            , _fb_sig_time = fb_sig_time'
                            , _fb_sig_api_key = fb_sig_api_key'
                            , _fb_sig_locale = fb_sig_locale' 
                            , _fb_sig = fb_sig' 
                            , _fb_sig_friends = fb_sig_friends' 
                            , _fb_sig_session_key = fb_sig_session_key' 
                            , _fb_sig_expires = fb_sig_expires' 
                            , _fb_sig_profile_update_time = fb_sig_profile_update_time' 
                            , _fb_sig_profile_user = fb_sig_profile_user'
                            , _fb_sig_profile_session_key = fb_sig_profile_session_key'
                            , _fb_sig_page_id = fb_sig_page_id
                            , _fb_valid_sig = valid_sig
                            })

-- todo: add code to validate the sent fb_sig
withFacebookData :: (Monad m, MonadPlus m, ServerMonad m) => FacebookConfig -> (FacebookData -> m r) -> m r
withFacebookData config f =
    withDataFn 
       (do pairs <- lookPairs
           return $ parseFacebookData config pairs)
       f

withFacebook :: (Monad m, MonadPlus m, ServerMonad m) => FacebookConfig -> FacebookT (FacebookState FacebookData) m a -> m a
withFacebook config sp = withFacebookData config $ \fbd -> withFacebook' config fbd sp

withUserSP :: ( HasFacebookConfig (FacebookT (s d) m)
              , HasFacebookData d (FacebookT (s d) m)
              , HasFacebookData FacebookData (FacebookT (s d) m)
              , MonadPlus m
              ) 
              => FacebookT (FacebookStateU d) m a -> FacebookT (s d) m a
withUserSP handler =
    do mUser <- fb_user
       case mUser of
         Nothing     -> mzero
         (Just user) -> withUser user handler


withProfileUserSP :: ( HasFacebookConfig (FacebookT (s d) m)
              , HasFacebookData d (FacebookT (s d) m)
              , HasFacebookData FacebookData (FacebookT (s d) m)
              , MonadPlus m
              ) 
              => FacebookT (FacebookStateU d) m a -> FacebookT (s d) m a
withProfileUserSP handler =
    do mUser <- fb_sig_profile_user
       case mUser of
         Nothing     -> mzero
         (Just user) -> withUser user handler


withSessionSP :: ( HasFacebookConfig (FacebookT (s d) m)
                 , HasFacebookData d (FacebookT (s d) m)
                 , HasFacebookData FacebookData (FacebookT (s d) m)
                 , HasFacebookData FacebookData (FacebookT (FacebookStateU d) m)
                 , MonadPlus m
                 ) 
              => FacebookT (FacebookStateS d) m a -> FacebookT (s d) m a
withSessionSP handler =
    do mUser <- fb_user
       case mUser of
         Nothing -> mzero
         (Just user) ->
             withUser user $
                      do mSession <- fb_sig_session_key
                         case mSession of
                           Nothing -> mzero
                           (Just sessionKey) ->
                               withSession sessionKey handler



{-
withFacebook' :: (Monad m) => FacebookConfig -> FacebookData -> ServerPartT (FacebookT FacebookState m) a -> ServerPartT m a
withFacebook' config facebookData sp =
    mapServerPartT doFacebook sp
    where
      doFacebook sp =
          runReaderT (unFacebookT sp) (FacebookState config facebookData)

{-
withFacebook' :: FacebookConfig -> FacebookData -> ServerPartT (HSPT (FacebookT IO)) a -> ServerPartT IO a
withFacebook' config facebookData sp =
    mapServerPartT doHSPT sp
    where
      doHSPT hspt =
          evalStateT (unFacebookT (evalHSPT Nothing hspt >>= return .snd)) (FacebookState config facebookData)
-}

-- callMethodE :: (HasFacebookConfig m, MonadIO m, FacebookMethod m method) =>
--                 method -> m (Either FacebookError (FacebookResponse method))
{-
callMethodE :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either FacebookError (FacebookResponse method))
callMethodE method =
    do configData <- askFacebookConfig
       params     <- toParams method
       req <- return $ buildRequest configData params
       -- liftIO (putStrLn $ "FB Request: " ++ (show $  req (CallId 0)))
       res <- execRequest req
       -- liftIO (putStrLn $ "FB Response: " ++ (show res))
       return $ parseResponse' (Proxy :: Proxy (m method)) res 

callMethod :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either String (FacebookResponse method))
callMethod method =
    do configData <- askFacebookConfig
       params     <- toParams method
       req <- return $ buildRequest configData params
       -- liftIO (putStrLn $ "FB Request: " ++ (show $  req (CallId 0)))
       res <- execRequest req
       -- liftIO (putStrLn $ "FB Response: " ++ (show res))
       return $ parseResponse (Proxy :: Proxy (m method)) res 
-}
{-
class (Monad m) => HasFacebookData FacebookData m where
    askFacebookData :: m FacebookData

class (Monad m) => HasUser m where
    askUser    :: m User

class (Monad m) => HasSessionKey m where
    askSessionKey :: m  SessionKey
-}

{-


class (Monad m) => HasFacebookConfig m where
    askFacebookConfig :: m FacebookConfig

-}-}
{-
-- |our facebook code will live in the Facebook monad. Currently this
-- monad just provides some environment data. The Facebook monad lets
-- us embed Facebook Markup Language using literal XML via HSP.

type Facebook = HSPT (FacebookT IO)

instance Applicative Facebook where
    pure = return
    (<*>) = ap

-}


{-
buildRequest :: (HasFacebookConfig m) => Parameters -> m (CallId -> HTTP.Request String)
buildRequest parameters = 
    do fbConfig <- askFacebookConfig
       -- uid <- liftM (maybe "" (show . uid)) fb_user -- FIXME : not all calls require this
       return $ \cid ->
           let (sig, args) = signature (appSecret fbConfig) $
                      [ ("api_key", unApiKey $ apiKey fbConfig)
                      , ("call_id", show (toInteger cid))
                      , ("format","json")
                      , ("uid", uid)
                      , ("v","1.0")
                      ] ++ parameters
           in formToRequest (Form HTTP.POST fbRESTURI (args ++ [("sig",sig)]))
    where
      fbRESTURI :: URI
      fbRESTURI = fromJust $ parseURI "http://api.facebook.com/restserver.php"
-}

{-

class (Monad m) => HasFacebookData m where
    askFacebookData :: m FacebookData

-- |the State that lives in the facebook monad
data FacebookState 
    = FacebookState { fbConfig :: FacebookConfig -- our api id, etc,
                    , fbData   :: FacebookData   -- user specific information that facebook provides
                    }

instance (Monad m) => HasFacebookConfig (FacebookT FacebookState m) where
    askFacebookConfig = fbConfig <$> ask

instance (Monad m) => HasFacebookData (FacebookT FacebookState m) where
    askFacebookData = fbData <$> ask

data FacebookStateU 
    = FacebookStateU { fbuConfig :: FacebookConfig -- our api id, etc,
                     , fbuData   :: FacebookData   -- user specific information that facebook provides
                     , fbuUser   :: User
                     }

instance (Monad m) => HasFacebookConfig (FacebookT FacebookStateU m) where
    askFacebookConfig = fbuConfig <$> ask

instance (Monad m) => HasFacebookData (FacebookT FacebookStateU m) where
    askFacebookData = fbuData <$> ask

instance (Monad m) => HasUser (FacebookT FacebookStateU m) where
    askUser = fbuUser <$> ask

withUser :: (HasFacebookConfig n, HasFacebookData n) => FacebookT FacebookStateU m a -> n (Maybe (m a))
withUser (FacebookT action) =
    do c <- askFacebookConfig
       d <- askFacebookData
       u <- fb_user
       case u of
         Nothing -> return Nothing
         (Just u) ->
             return $ Just (runReaderT action (FacebookStateU c d u))

-- ** Facebook with Session Key

data FacebookStateS
    = FacebookStateS { fbsConfig     :: FacebookConfig -- our api id, etc,
                     , fbsData       :: FacebookData   -- user specific information that facebook provides
                     , fbsUser       :: User
                     , fbsSessionKey :: SessionKey
                     }

instance (Monad m) => HasFacebookConfig (FacebookT FacebookStateS m) where
    askFacebookConfig = fbsConfig <$> ask

instance (Monad m) => HasFacebookData (FacebookT FacebookStateS m) where
    askFacebookData = fbsData <$> ask

instance (Monad m) => HasUser (FacebookT FacebookStateS m) where
    askUser = fbsUser <$> ask

instance (Monad m) => HasSessionKey (FacebookT FacebookStateS m) where
    askSessionKey = fbsSessionKey <$> ask

withSession  :: (HasUser n, HasFacebookConfig n, HasFacebookData n) => FacebookT FacebookStateS m a -> n (Maybe (m a))
withSession (FacebookT action) =
    do c <- askFacebookConfig
       d <- askFacebookData
       u <- askUser
       s <- fb_sig_session_key
       case s of
         Nothing -> return Nothing
         (Just s) ->
             return $ Just (runReaderT action (FacebookStateS c d u s))


-- |function to read some FacebookData from the Facebook environment
fbd :: (HasFacebookData m) => (FacebookData -> a) -> m a
fbd select = 
    do d <- askFacebookData
       return (select d)
-}