{-# 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 Control.Monad.Trans (MonadIO(..))
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
    , _fbc_valid_sig         :: Bool
    }
    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

fb_sig_cookies :: (HasFacebookData FacebookConnectData m) => m [(String, Cookie)]
fb_sig_cookies = fbd _fbc_cookies

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

validateSignature :: AppSecret -> Maybe String -> [(String, Cookie)] -> Bool
validateSignature secret sig cookies = sig == sig'
  where sorted = sortBy (compare `on` fst) cookies
        dataStr = concatMap (\(k,v) -> k ++ '=' : (cookieValue v)) sorted
        sig' = Just $ stringMD5 (md5 (L.pack (dataStr++(unAppSecret secret))))                                                             

withFacebookConnectData :: 
    ( Functor m
    , Monad m
    , MonadPlus m
    , ServerMonad m
    , HasRqData m
    , MonadIO 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) <- ask
          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) <- ask
          let fbcCookies = map (\(k,v) -> (drop ((length (unApiKey (apiKey config)))+1) k, v)) $ filter (isPrefixOf ((unApiKey (apiKey config))++"_") . fst) cookies
          return $ FacebookConnectData
                     { _fbc_cookies = fbcCookies
                     , _fbc_sig_expires = (fmap readTime expires) 
                     , _fbc_sig_session_key = sesKey 
                     , _fbc_sig_ss = ss
                     , _fbc_user = (fmap (User . read) user) 
                     , _fbc_sig = sig
                     , _fbc_valid_sig = (validateSignature (appSecret config) sig fbcCookies)
                     }

withFacebookConnect :: 
    ( Functor m
    , Monad m
    , MonadPlus m
    , ServerMonad m
    , HasRqData m
    , MonadIO 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
                 , Functor 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

-- |clear the facebook connect cookies effectively logging the user out
fbcLogout :: (HasFacebookData FacebookConnectData m, HasFacebookConfig m, FilterMonad Response m, MonadIO m) => m ()
fbcLogout =
    do cookies <- fb_sig_cookies
       config <- askFacebookConfig
       let clear c =
               do let key = unApiKey (apiKey config) ++"_"++ c
                      cookie = (mkCookie key "0")
                  addCookie Expired cookie
       mapM (clear . fst) cookies
       return ()