{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Main where

import Control.Applicative((<$>))
import Control.Monad(MonadPlus, mzero, msum)
import Control.Monad.Reader (ask)
import Control.Monad.State (get,put)
import Control.Monad.Trans(MonadIO(..))
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Generics (Typeable)
import Data.Maybe (catMaybes)
import Happstack.Facebook.Connect as Connect (FacebookConnectData, withFacebookConnect, withSessionSP)
import Happstack.Facebook.Common (HasUser(askUser), HasSessionKey, HasFacebookConfig(askFacebookConfig), FbXML(FbXML),FacebookStateU, FacebookStateS, FacebookConfig(apiKey, connectURL), HasFacebookData, User(uid), callMethod)
import Happstack.Facebook.FacebookT (FacebookT(..))
import qualified Happstack.Facebook.Friends as Friends
import Happstack.Facebook.XdReceiver 
import Happstack.Server (ServerMonad, WebMonad, FilterMonad, ServerPartT, Response, Conf(port), dir, nullConf, simpleHTTP, toResponse)
import qualified Happstack.Server as Happstack
import Happstack.Data (Default, Version(..), deriveAll, deriveNewData)
import Happstack.State
import Happstack.State.ClockTime (ClockTime)
import FacebookConfig (facebookConfig)
import HSP 
import Network.URI
import qualified HSX.XMLGenerator as HSX
import System.Environment (getProgName)
import System.FilePath ((</>))
import System.IO (stdout)
import System.Log.Logger (Priority(DEBUG, INFO), rootLoggerName, setHandlers, setLevel, updateGlobalLogger)
import System.Log.Handler.Simple (fileHandler, streamHandler)
import System.Time

-- TODO: handle expired session key

main :: IO ()
main = 
    do progName <- getProgName
       setupLogger progName "." Development
       simpleHTTP nullConf { port = maybe 80 (read . drop 1 . uriPort) $ uriAuthority (connectURL facebookConfig) } (impl facebookConfig) 

impl :: FacebookConfig -> ServerPartT IO Response
impl fbConfig = 
    msum [ withFacebookConnect fbConfig
                          (msum [ xdReceiverPart
                                , dir "members" $ requireSession (toResponse . FbXML <$> members)
                                , toResponse . FbXML <$> homepage
                                ])
         ]


homepage :: 
    ( MonadIO m
    , MonadPlus m
    , HasFacebookData d (FacebookT (s d) m)
    , HasFacebookData FacebookConnectData (FacebookT (FacebookStateU d) m)
    , HasFacebookData FacebookConnectData (FacebookT (s d) m)
    , HasFacebookConfig (FacebookT (s d) m)
    )
    => FacebookT (s d) m (HSX.XML (FacebookT (s d) m))

homepage =
    msum [ withSessionSP $ 
                      do u <- askUser
                         pageTemplate "Facebook Connect Demo" ()
                          <div>
                           <p>You are Connected!</p>
                           <fb:profile-pic uid=(show $ uid u) facebook="true"/>
                           <br />
                           <fb:name uid=(show $ uid u) useyou="false" />
                           <p>Visit the <a href="/members">members area</a>.</p>
                          </div>
         , pageTemplate "Facebook Connect Demo" ()
                        <div>
                         <p>You are not yet connected.</p>
                         <fb:login-button onlogin="window.location.reload();"></fb:login-button> 
                        </div>
         ]

requireSession ::
    ( 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
    , WebMonad Response m
    , FilterMonad Response m
    ) 
    => FacebookT (FacebookStateS d) m a 
    -> FacebookT (s d) m a
requireSession m =
    msum [ withSessionSP m
         , Happstack.escape $ toResponse . FbXML <$> (pageTemplate "Login Required." () 
                               <div>
                                <p>To enjoy this awesome site you must first Connect with Facebook Connect.</p>
                                <fb:login-button></fb:login-button>
                               </div>)
         ]

members :: 
    ( MonadIO m
    , HasFacebookConfig (FacebookT s m)
    , HasUser           (FacebookT s m)
    , HasSessionKey     (FacebookT s m)
    )
    => FacebookT s m (HSX.XML (FacebookT s m))
members =
  do config <- askFacebookConfig
     user <- askUser
     res <- callMethod (Friends.Get Nothing)
     case res of
      (Right friends) ->
       do friendly <- callMethod (Friends.AreFriends [(user, head friends)])
          appUsers <- callMethod Friends.GetAppUsers
          lists    <- callMethod Friends.GetLists
          pageTemplate "Facebook Connect Demo: Members Area" ()
             <div> 
                <p>This demo page is pretty wacky. Sorry about that.</p>
                <p>Here are ten of your friends.</p>
                <% mapM (\friend ->
                         <fb:profile-pic uid=(show $ uid friend) />) (take 10 friends)
                 %>
                 <br />
                 <p>Are you friendly with your friend?</p>
                 <% show friendly %>
                 <p>Here are some of your friends who also use this app</p>
                 <p><% show appUsers  %></p>
                 <p>Here are your friend lists</p>
                 <% show lists %>
             </div>
      (Left e) -> pageTemplate "Facebook Connect Demo: " () (show e)


pageTemplate :: (EmbedAsAttr m (Attr (String, String) String),
                 XMLGenerator m,
                 EmbedAsChild m header,
                 EmbedAsChild m body,
                 HasFacebookConfig m
                 ) =>
                String -> header -> body -> m (HSX.XML m)
pageTemplate title header body =
    unXMLGenT $
     <html xmlns="http://www.w3.org/1999/xhtml" xmlns:fb="http://www.facebook.com/2008/fbml">
            <head>
             <meta http-equiv="content-type" content="text/html; charset=UTF-8" />
             <title><% title %></title>
             <% fbFeatureLoader %>
             <% header %>
            </head>
            <body>
             <% body %>
             <% fbInit . apiKey =<< askFacebookConfig %>
            </body>
           </html>

data LogMode
    = Production
    | Development
      deriving (Read, Show, Eq, Ord, Enum, Bounded)

setupLogger :: String -> FilePath -> LogMode -> IO ()
setupLogger progName logDir logMode = do
    appLog    <- fileHandler (logDir </> (progName ++ "_root.log"))   DEBUG
    accessLog <- fileHandler (logDir </> (progName ++ "_access.log")) INFO
    stdoutLog <- streamHandler stdout DEBUG

    case logMode of
      Development -> do
          -- Root Log
          updateGlobalLogger rootLoggerName 
            (setLevel DEBUG . setHandlers [appLog, stdoutLog])
          -- Access Log
          updateGlobalLogger "Happstack.Server.AccessLog.Combined" 
            (setLevel INFO . setHandlers [accessLog])

      Production -> do
          -- Root Log
          updateGlobalLogger rootLoggerName 
            (setLevel INFO . setHandlers [appLog])
          -- Access Log
          updateGlobalLogger "Happstack.Server.AccessLog.Combined" 
            (setLevel INFO . setHandlers [accessLog])