{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-}
module Happstack.Facebook.Connect where

import Control.Applicative ((<$>))
import Control.Monad(MonadPlus(mzero))
import Control.Monad.Reader (ask, asks, runReaderT)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as L
import Data.Char (toLower)
import Data.Function
import Data.List
import Data.Time.Clock.POSIX (POSIXTime)
import Happstack.Crypto.MD5 ( md5, stringMD5)
import Happstack.Facebook.Common
import Happstack.Facebook.FacebookT
import Happstack.Server

data FacebookConnectData =
    FacebookConnectData 
    { _fbc_cookies           :: [(String,Cookie)]
    , _fbc_sig_expires       :: Maybe POSIXTime
    , _fbc_sig_session_key   :: Maybe SessionKey
    , _fbc_sig_ss            :: Maybe String
    , _fbc_user              :: Maybe User
    , _fbc_sig               :: Maybe String
    }
    deriving (Eq, Show)


-- ** convenience functions for getting information from the FacebookConnectData
-- |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 FacebookConnectData m) => m (Maybe POSIXTime)
fb_sig_expires = fbd _fbc_sig_expires

-- |session key
-- NOTE: only available if the user is logged in
fb_sig_session_key :: (HasFacebookData FacebookConnectData m) => m (Maybe SessionKey)
fb_sig_session_key = fbd _fbc_sig_session_key

fb_sig_ss :: (HasFacebookData FacebookConnectData m) => m (Maybe String)
fb_sig_ss = fbd _fbc_sig_ss

fb_user :: (HasFacebookData FacebookConnectData m) => m (Maybe User)
fb_user = fbd _fbc_user

-- |the signature for the request
fb_sig :: (HasFacebookData FacebookConnectData m) => m (Maybe String)
fb_sig = fbd _fbc_sig

validateSignature :: AppSecret -> FacebookConnectData -> Bool
validateSignature secret d = (Just sig) == (_fbc_sig d)
  where sorted = sortBy (compare `on` fst) (_fbc_cookies d)
        dataStr = concatMap (\(k,v) -> k ++ '=' : (cookieValue v)) sorted
        sig = stringMD5 (md5 (L.pack (dataStr++(unAppSecret secret))))                                                             

-- todo: add code to validate the sent fb_sig
{-
withFacebookConnectData :: (Monad m) => FacebookConfig -> (FacebookConnectData -> ServerPartT m r) -> ServerPartT m r
withFacebookConnectData config f =
  withDataFn buildFBCData f
  where 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)
        lookupString :: String -> RqData (Maybe String)
        lookupString k = do
          cookies <- asks snd
          return $ fmap cookieValue $ lookup (map toLower (unApiKey (apiKey config) ++k)) cookies
        buildFBCData :: RqData FacebookConnectData
        buildFBCData = do
          expires <- lookupString "_expires"
          sesKey <- lookupString "_session_key"                                                                                               
          ss <- lookupString "_ss"                                                                                                             
          sig <- lookupString ""
          user <- lookupString "_user"
          cookies <- asks snd
          return $ FacebookConnectData
            (filter (isPrefixOf (unApiKey (apiKey config)++"_") . fst) cookies)
            (fmap readTime expires) sesKey ss (fmap (User . read) user) sig
-}

-- TODO: add code to validate the sent fb_sig
withFacebookConnectData :: 
    ( Monad m
    , MonadPlus m
    , ServerMonad m
    ) => FacebookConfig -> (FacebookConnectData -> m r) -> m r
withFacebookConnectData config f =
  withDataFn buildFBCData f
  where 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)
        lookupString :: String -> RqData (Maybe String)
        lookupString k = do
          cookies <- asks snd
          return $ fmap cookieValue $ lookup (map toLower (unApiKey (apiKey config) ++k)) cookies
        buildFBCData :: RqData FacebookConnectData
        buildFBCData = do
          expires <- lookupString "_expires"
          sesKey <- lookupString "_session_key"                                                                                               
          ss <- lookupString "_ss"                                                                                                             
          sig <- lookupString ""
          user <- lookupString "_user"
          cookies <- asks snd
          return $ FacebookConnectData
            (filter (isPrefixOf (unApiKey (apiKey config)++"_") . fst) cookies)
            (fmap readTime expires) sesKey ss (fmap (User . read) user) sig

{-
withFacebookConnect :: (Monad m) => FacebookConfig -> FacebookT (FacebookState FacebookConnectData) (ServerPartT m) a -> ServerPartT m a
withFacebookConnect config sp = withFacebookConnectData config $ \fbd -> withFacebook' config fbd sp
-}

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

withUserSP :: ( HasFacebookConfig (FacebookT (s d) m)
              , HasFacebookData d (FacebookT (s d) m)
              , HasFacebookData FacebookConnectData (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


withSessionSP :: ( HasFacebookConfig (FacebookT (s d) m)
                 , HasFacebookData d (FacebookT (s d) m)
                 , HasFacebookData FacebookConnectData (FacebookT (s d) m)
                 , HasFacebookData FacebookConnectData (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