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

import Control.Arrow (first)
import Control.Applicative(Applicative((<*>), pure), (<$>), (<*),(*>))
import Control.Applicative.Error(Failing(Failure, Success), ErrorMsg, maybeRead')
import Control.Concurrent (MVar, forkIO, killThread)
import Control.Monad(MonadPlus(mplus, 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.Fixed
import qualified Data.Foldable as F
import Data.Traversable (sequenceA)
import Data.Generics (Data, Typeable, Typeable1)
import Data.Maybe (fromJust, fromMaybe, catMaybes)
import Data.List as List
import Data.Ix
import           Data.Set (Set)
import qualified Data.Set
import Data.Time
import Data.Time.Clock.POSIX
import qualified Data.Traversable  as T
import Happstack.Facebook.Application as Application (FacebookData, withFacebook, withUserSP, withSessionSP)
import Happstack.Facebook.Common (ApiKey(unApiKey), HasUser(askUser), HasSessionKey, HasFacebookConfig(askFacebookConfig), FbXML(FbXML), FacebookConfig(apiKey, canvasURL), HasFacebookData, User(User, uid), callMethod, FacebookStateS)
import Happstack.Facebook.FacebookT (FacebookT(..), renderAsFBML)
import qualified Happstack.Facebook.Friends as Friends
import qualified Happstack.Facebook.Users as Users
import qualified Happstack.Facebook.Notifications as Notifications
import Happstack.Facebook.Formlets (formletPart)
import Happstack.Facebook.XdReceiver 
import Happstack.Server (Conf(port, validator), FilterMonad, ServerMonad, ServerPartT, Response, WebMonad, RqData, ToMessage, dir, look, lookPairs, lookRead, nullConf, nullDir, path, simpleHTTP, toResponse, seeOther, withDataFn, ok)
import Happstack.Data (Default, Version(..), deriveAll, deriveNewData)
import qualified Happstack.Data.IxSet as IxSet
import           Happstack.Data.IxSet ((@=), (@+), inferIxSet, getOne, noCalcs)
import Happstack.State
import Happstack.State.ClockTime (ClockTime(TOD))
import Happstack.Util.Cron (cron)
import FeatsOfStrengthConfig (facebookConfig)
import HSP 
import HSP.Formlets (fset, input, select, submit, label)
import HSP.Identity(evalIdentity)
import qualified HSX.XMLGenerator as HSX
import Network.URI (parseURI, uriToString)
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (stdout)
import System.Log.Logger (Priority(DEBUG, INFO, ERROR), logM, rootLoggerName, setHandlers, setLevel, updateGlobalLogger)
import System.Log.Handler.Simple (fileHandler, streamHandler)
import System.Locale (TimeLocale(..),defaultTimeLocale)
import System.Time (TimeDiff(..), getClockTime)
import Text.Formlets (Form, check, checkM, generalInput, plug, runFormState, xml)

-- TODO: handle improper redirect when you click 'add it'

-- TODO: handle expired session key for facebook connect

-- TODO: expire contests

-- TODO: move to happstack-extra Happstack.State.ClockTime
deriving instance Typeable TimeDiff
deriving instance Data TimeDiff
instance Version TimeDiff
$(deriveSerialize ''TimeDiff)

-- TODO: move to library
canvasURLS :: FacebookConfig -> ShowS
canvasURLS config = uriToString id $ canvasURL config

-- TODO: move to library
addLink :: FacebookConfig -> String
addLink config =
    "http://www.facebook.com/add.php?api_key="++(unApiKey . apiKey $ config) ++ "&v=1.0"

authorize :: (XMLGenerator m, EmbedAsChild m c) => FacebookConfig -> c -> XMLGenT m (HSX.XML m)
authorize config c =
    <a href=(uriToString id (canvasURL config) "") requirelogin=(1 :: Int)><% c %></a>

loginSP ::
    ( XMLGenerator m
    , MonadPlus m
    , ServerMonad m
    , HasFacebookConfig m
    )
    => m (HSX.XML m)
loginSP =
   unXMLGenT $
    dir "login" $ 
        do config <- askFacebookConfig
           let key = unApiKey (apiKey config)
               next = uriToString id (canvasURL config) ""
               uri = "http://www.facebook.com/login.php?v=1.0&api_key=" ++ key  ++"&next=" ++ next ++  "&canvas="
           <fb:redirect url=uri />

-- TODO: move somewhere
deriving instance (Data a) => Data (Failing a)
deriving instance Typeable1 Failing
instance Version (Failing a)
$(deriveSerialize ''Failing)

-- TODO: move to happstack / happstack-extra
instance Version Text
instance Serialize Text where
    putCopy = putCopy . Text.encodeUtf8
    getCopy = contain $ fmap Text.decodeUtf8 safeGet

-- TODO: move to library
renderForm :: (XMLGenerator x, Monad v) => String -> String -> Form [XMLGenT x (HSX.XML x)] v a -> XMLGenT x (HSX.XML x)
renderForm prefix action form =
    let (_,formXML,_) = runFormState [] prefix form
    in <form action=action method="POST" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8" >
        <% formXML %>
       </form>


data Score = Score { pushups :: Int
                   , situps  :: Int
                   , date    :: ClockTime
                   }
      deriving (Eq, Ord, Show, Typeable, Data)

instance Version Score
$(deriveSerialize ''Score)

newtype ChallengeId = ChallengeId { unChallengeId :: Integer }
      deriving (Eq, Ord, Show, Ix, Typeable, Data)

instance Enum ChallengeId where
    succ   = ChallengeId . succ . unChallengeId
    pred   = ChallengeId . pred . unChallengeId
    toEnum = ChallengeId . toEnum
    fromEnum = fromEnum . unChallengeId
    enumFrom = map ChallengeId . enumFrom . unChallengeId

instance Version ChallengeId
$(deriveSerialize ''ChallengeId)

data Challenge = Challenge { challengeId  :: ChallengeId
                           , owner        :: User 
                           , startDate    :: ClockTime
                           , endDate      :: ClockTime
                           , participants :: Map User [Score]
                           , invited      :: Set User
                           , wannabes     :: Set User
                           }
      deriving (Eq, Ord, Show, Typeable, Data)

instance Version Challenge
$(deriveSerialize ''Challenge)

$(inferIxSet "Challenges" ''Challenge 'noCalcs [''ChallengeId, ''User])

data State 
    = State { challenges      :: Challenges
            , nextChallengeId :: ChallengeId
            , users           :: Set User
            }
      deriving (Show, Typeable, Data)

instance Version State
$(deriveSerialize ''State)

instance Component State where
    type Dependencies State = End
    initialValue = State { challenges      = IxSet.empty
                         , nextChallengeId = ChallengeId 0
                         , users           = Set.empty
                         }

-- | challengeId will be ignored and replaced with the new challengeId
createChallenge :: User -- ^ ower of the challenge (does not have to be a participant)
                -> ClockTime -- ^ start date
                -> ClockTime -- ^ day of reckoning
                -> [User]
                -> Update State Challenge
createChallenge owner startDate endDate initialParticipants =
    do state <- get
       let challengeId = nextChallengeId state
           challenge = Challenge { challengeId  = challengeId
                                 , owner        = owner 
                                 , startDate    = startDate
                                 , endDate      = endDate
                                 , participants = Map.fromList $ map  (\u -> (u,[])) initialParticipants
                                 , invited      = Set.empty
                                 , wannabes     = Set.empty
                                 }
       put $ state { nextChallengeId = succ challengeId
                   , challenges = IxSet.insert challenge (challenges state)
                   }
       return challenge

modifyChallenge :: ChallengeId -> (Challenge -> Failing Challenge) -> Update State (Failing ())
modifyChallenge cid f =
    do state <- get
       let challenges' = challenges state
           mChallenge = getOne $ (challenges' @= cid)
       case mChallenge of
         Nothing -> return (Failure ["Invalid " ++ show cid])
         (Just challenge) ->
             case f challenge of
               (Success challenge') ->
                   do put $ state { challenges = IxSet.updateIx cid challenge' challenges' }
                      return (Success ())
               (Failure errs) ->
                   do return (Failure errs)

addInvitees :: ChallengeId
            -> [User]
            -> Update State (Failing ())
addInvitees challengeId users =
    modifyChallenge challengeId $ \challenge ->
        Success $ challenge { invited = Set.union (Set.fromList users) (invited challenge) }
-- preconditions:
-- user must be friends with owner
addInviteRequest :: ChallengeId -> User -> Update State (Failing ())
addInviteRequest challengeId user =
    modifyChallenge challengeId $ \challenge ->
        Success $ challenge { wannabes = Set.insert user (wannabes challenge) }

-- |users that are already added will be ignored
-- this alsa removes the users from the invited and wannabes Sets
addParticipants :: ChallengeId
                -> [User]
                -> Update State (Failing ())
addParticipants challengeId newParticipants =
    modifyChallenge challengeId $ \challenge ->
        let participants' = foldr (\u p -> Map.insertWith' (\ _ oldValue -> oldValue) u [] p) (participants challenge) newParticipants
        in Success (challenge { participants = participants' 
                              , invited      = Set.difference (invited challenge) (Set.fromList newParticipants)
                              , wannabes     = Set.difference (wannabes challenge) (Set.fromList newParticipants)
                              })

bongWannabes :: ChallengeId
             -> [User]
             -> Update State (Failing ())
bongWannabes challengeId users =
    modifyChallenge challengeId $ \challenge ->
        Success $ challenge { wannabes = Set.difference (wannabes challenge) (Set.fromList users) }
{-
addScore :: User -> Score -> ChallengeId -> Update State (Failing ())
addScore user score challengeId =
    modifyChallenge challengeId $ \challenge ->
        case Map.lookup user (participants challenge) of
          Nothing -> Failure [show user ++ " is not a participant in " ++ show challengeId]
          (Just _) -> 
              let participants' = Map.update (\scores -> Just (score : scores)) user (participants challenge)
              in Success (challenge { participants = participants' })
-}

addScore :: User -> Score -> Update State (Failing Challenges)
addScore user score =
    do state <- get
       let cs = IxSet.toList $ (challenges state) @= user
       case cs of
         [] -> return (Success IxSet.empty)
         _ -> case sequenceA $ map addScore' cs of
                (Success cs') -> 
                    let updatedChallenges = foldr (\c cs -> IxSet.updateIx (challengeId c) c cs) (challenges state) cs'
                        cids = map challengeId cs'
                    in do put $ state { challenges = updatedChallenges }
                          return (Success updatedChallenges)
                (Failure err) -> return (Failure err)
    where
      addScore' challenge =
        case Map.lookup user (participants challenge) of
          Nothing -> Failure [show user ++ " is not a participant in " ++ show challengeId]
          (Just _) -> 
              let participants' = Map.update (\scores -> Just (score : scores)) user (participants challenge)
              in Success (challenge { participants = participants' })

-- FIXME: this will returns challenges that are already completed
friendsChallenges :: [User] -> Query State Challenges
friendsChallenges friends =
    do cs <- challenges <$> ask
       return $ (cs @+ friends)

askChallengeById :: ChallengeId -> Query State (Maybe Challenge)
askChallengeById cid = 
    do cs <- challenges <$> ask
       return $ getOne (cs @= cid)

allChallenges :: Query State Challenges
allChallenges = challenges <$> ask

usersChallenges :: User -> Query State Challenges
usersChallenges user =
    do cs <- challenges <$> ask
       return $ (cs @= user)

$(mkMethods ''State ['addParticipants, 'addScore, 'addInvitees, 'addInviteRequest, 'askChallengeById, 'bongWannabes, 'createChallenge, 'friendsChallenges, 'allChallenges, 'usersChallenges])

appTemplate :: ( XMLGenerator m
               , EmbedAsChild m body
               , HasFacebookConfig m
               ) 
            => String -> body -> m (HSX.XML m)
appTemplate title xml =
    unXMLGenT $ 
    do config <- askFacebookConfig
       <fb:fbml  version="1.0">
             <fb:title><% title %></fb:title>
              <div class="fbbody">
                <% fbStyle %>
                <fb:dashboard>
                 <fb:action href=(uriToString id (canvasURL config) "")>Homepage</fb:action>
                 <fb:action href=(uriToString id (canvasURL config) "create")>Create a New Contest</fb:action>
                 <fb:action href=(uriToString id (canvasURL config) "join")>Join a Contest</fb:action>
                </fb:dashboard>
                <% xml %>

                <p/>
                <fb:share-button class="meta">
                 <meta name="title"content="Feats of Strength" />
                 <meta name="description" content="Challenge your friends in feats of strength" />
                 <link rel="target_url" href=(uriToString id (canvasURL config) "") />
                </fb:share-button>
                <p/>

             </div>
           </fb:fbml>

homepage ::
    ( XMLGenerator m
    , MonadIO m
    , HasUser m
    , HasSessionKey m
    , HasFacebookConfig m
    ) 
    => m (HSX.XML m)
homepage =
 do config <- askFacebookConfig
    user <- askUser
    challenges <- query (UsersChallenges user)
    if IxSet.null challenges
       then appTemplate "Feats of Strength" $ 
                <div>
                  <p>Challenge your friends to feats of strength.</p>
                </div>
       else appTemplate "Feats of Strength" $
                <div>
                  <h3>Update Your Score</h3>
                  <% renderForm "score" ((canvasURLS config) "score/submit") scoreForm %>
                  <h3>Current Standings</h3>
                  <% challengesFBML challenges %>
                </div>

friendsChallengesFBML :: 
    ( XMLGenerator m
    , MonadIO m
    , HasUser m
    , HasSessionKey m
    , HasFacebookConfig m
    ) 
    => XMLGenT m (HSX.XML m)
friendsChallengesFBML =
    do eFriends <- callMethod (Friends.Get Nothing)
       case eFriends of
         (Left err) -> <div>Error retrieving the list of your friends: <% show err %> </div>
         (Right friends) -> 
             do user <- askUser
                availChallenges <- query (FriendsChallenges (user : friends))
                if IxSet.null availChallenges
                  then do config <- askFacebookConfig
                          <div>None of your friends are currently involved in any challenges. Why don't you <a href=(uriToString id (canvasURL config) "create")>start one</a>?</div>
                  else challengesFBML availChallenges
{-
                       do user <- askUser
                          config <- askFacebookConfig
                          eInfo <- callMethod (Users.GetStandardInfo [user] [Users.UID .. Users.ProxiedEmail])
                          case eInfo of
                            (Left err) -> <div>Error calling Users.getStandardInfo: <% show err %></div>
--                            (Right str) -> <div><% str %></div>

                            (Right [info]) ->
                                let tz = fromMaybe utc (Users.timeZone info) in
                                <ul><% mapM (\c -> <li><% challengeFBML tz user config c %></li>) (IxSet.toList availChallenges) %></ul>
                            (Right info) ->
                                <div>Error calling Users.getStandardInfo: <% show info %></div>
-}
challengesFBML :: 
    ( MonadIO m
    , XMLGenerator m
    , HasFacebookConfig m
    , HasUser m
    , HasSessionKey m
    )
    => Challenges -> XMLGenT m (HSX.XML m)
challengesFBML challenges =
    do user <- askUser
       config <- askFacebookConfig
       eInfo <- callMethod (Users.GetStandardInfo [user] [Users.UID .. Users.ProxiedEmail])
       case eInfo of
         (Left err) -> <div>Error calling Users.getStandardInfo: <% show err %></div>
         (Right [info]) ->
             let tz = fromMaybe utc (Users.timeZone info) in
             <ul><% mapM (\c -> <li><% challengeFBML tz user config c %></li>) (IxSet.toList challenges) %></ul>
         (Right info) ->
             <div>Error calling Users.getStandardInfo: <% show info %></div>

challengeFBML :: (XMLGenerator m) => TimeZone -> User -> FacebookConfig -> Challenge -> XMLGenT m (HSX.XML m)
challengeFBML timeZone user config challenge =
    <div>
     <table>
      <tr><td>Starts</td><td><% timeStr timeZone (startDate challenge) %></td></tr>
      <tr><td>Ends</td><td><% timeStr timeZone (endDate challenge) %></td></tr>
     </table>
     <table>
      <thead>
        <tr><th>Player</th><th>Current Score</th></tr>
      </thead>
      <tbody>
        <% mapM (\(u,scores) -> <tr><td><fb:name uid=(show $ uid u) capitalise="true" /></td><td><% show $ sum (map pushups scores) %></td></tr>) (Map.toList (participants challenge)) %>
      </tbody>
     </table>
     <% if user == (owner challenge)
         then let cidStr = (show . unChallengeId . challengeId $ challenge)
                  inviteFBML =
                      <p><a href=((canvasURLS config) "invite/" ++ cidStr )>Invite</a> additional challengers.</p>
              in if not (Set.null (wannabes challenge))
                 then [ inviteFBML 
                      , <p><% show $ Set.size (wannabes challenge) %> <a href=((canvasURLS config) "approve/" ++ cidStr)>requests</a> to join.</p>
                      ]
                 else [ inviteFBML]
               
         else if Map.member user (participants challenge) then
                [<p>You are in this challenge.</p>]
              else if Set.member user (wannabes challenge) then
                [<p>You have requested an invitation to this challenge.</p>]
              else if Set.member user (invited challenge) then
                [<p><a href=((uriToString id $ canvasURL config) ("accept/" ++ (show . unChallengeId . challengeId $ challenge)))>Accept invitation</a> to join this challenge.</p>]
              else 
                [<p><a href=((uriToString id $ canvasURL config) ("request/" ++ (show . unChallengeId . challengeId $ challenge)))>Request invitation</a> to join this challenge.</p>]
        %>
    </div>
    where
      timeStr :: TimeZone -> ClockTime -> String
      timeStr timeZone = formatTime defaultTimeLocale "%a, %b %e, %Y at %R (%z)" . clockTimeToZonedTime timeZone

joinSP :: 
    ( XMLGenerator m
    , MonadIO m
    , MonadPlus m
    , ServerMonad m
    , HasUser m
    , HasSessionKey m
    , HasFacebookConfig m
    ) 
    => m (HSX.XML m)
joinSP =
    dir "join" $ 
        do config <- askFacebookConfig
           appTemplate "Feats of Strength" friendsChallengesFBML


-- TODO: check that use actually belongs to a competition
addScoreSP :: 
    forall m.
    ( XMLGenerator m
    , MonadIO m
    , MonadPlus m
    , Functor m
    , ServerMonad m
    , FilterMonad Response m
    , WebMonad Response m
    , ToMessage (HSX.XML m)
    , HasUser m
    , HasSessionKey m
    , HasFacebookConfig m
    ) => m (HSX.XML m)
addScoreSP =
    dir "score" $
        do user <- askUser
           config <- askFacebookConfig
           appTemplate "Update Score" $ formletPart "score" ((canvasURLS config) "score/submit") (handleSuccess config user) handleFailure scoreForm
    where
      handleSuccess :: FacebookConfig -> User -> Score -> XMLGenT m (HSX.XML m)
      handleSuccess config user score =
          do res <- update (AddScore user score)
             case res of
               (Failure msg) ->
                   XMLGenT $ appTemplate "Error" <p>An error occurred while updating your score: <% show msg %></p>
               (Success cs) ->
                   do let competitors = List.delete user $ nub $ concatMap (Map.keys . participants) (IxSet.toList cs)
                          name = renderAsFBML . evalIdentity $ 
                                 <fb:name uid=(show $ uid user) />
                          notification = name ++ " just completed " ++ (show . pushups $ score) ++ " pushups." -- TODO: add link
                      callMethod (Notifications.Send competitors notification (Just Notifications.AppToUser)) -- TODO: check for error
                      XMLGenT $ appTemplate "Score!" <p>Scored updated successfully.</p>
      
      handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] ->  XMLGenT m (HSX.XML m)
      handleFailure errs formXML =
          <div>
            <div><% show errs %></div>
            <% formXML %>
          </div>

scoreForm :: (XMLGenerator m) => Form [XMLGenT m (HSX.XML m)] IO Score
scoreForm = 
    label "# of Pushups" *> (input Nothing `checkM` (\str -> 
                                                              case maybeRead' str "Please enter the number of pushups you did." of
                                                                (Success n) -> 
                                                                    do now <- getClockTime
                                                                       return $ pure $ Score { pushups = n
                                                                                             , situps = 0
                                                                                             , date = now
                                                                                             }
                                                                (Failure err) -> return $ Failure err
                                                          )) <* fbSubmit "Submit"

                   

                                                                    

inviteRequestSP :: 
    forall m.
    ( XMLGenerator m
    , MonadIO m
    , MonadPlus m
    , Functor m
    , ServerMonad m
    , FilterMonad Response m
    , WebMonad Response m
    , ToMessage (HSX.XML m)
    , HasUser m
    , HasSessionKey m
    , HasFacebookConfig m
    ) => m (HSX.XML m)
inviteRequestSP =
  msum 
    [ dir "request" $ challengeSP $ \challenge ->
        do user <- askUser
           res <- callMethod (Friends.AreFriends [(owner challenge, user)])
           case res of 
             (Right [(_,_,Just True)]) ->
                 do res <- update (AddInviteRequest (challengeId challenge) user)
                    case res of
                      (Failure msg) ->
                          appTemplate "Error" <p>An error occured while attempting to request an invite. <% show msg %></p>
                      (Success ()) ->
                          do config <- askFacebookConfig
                             let name = renderAsFBML . evalIdentity $ 
                                   <fb:name uid=(show $ uid user) />
                                 invitation = renderAsFBML . evalIdentity $
                                   <a href=((canvasURLS config) "approve/" ++ (show . unChallengeId . challengeId $ challenge))>invitation</a>
                                 notification = name ++ " has requested an " ++ invitation ++ " to your pushup contest."
                             res <- callMethod (Notifications.Send [owner challenge] notification (Just Notifications.UserToUser))
                             appTemplate "Invitation Requested" <p>You request to join the challenge has been sent.</p>
             (Right [(_,_,_)]) ->
                 appTemplate "Not Friends" <p>You must be friends with <fb:name uid=(show . uid $ owner challenge) /> to request an invitation.</p>
             (Left err) -> 
                 appTemplate "Error" <p>Error calling Friends.AreFriends</p>
    , dir "approve" $ challengeSP $ \challenge ->
          do liftIO $ print ("approve: " ++ show challenge)
             user <- askUser
             config <- askFacebookConfig
             if (user /= owner challenge)
                then appTemplate "Authorization Error"
                      <p>You are not the owner of this challenge, so you can not approve invitation requests.</p>
                else appTemplate "Approve Invitations" (formletPart "approval" ((uriToString id (canvasURL config)) ("approve/" ++ (show . unChallengeId . challengeId $ challenge) ++ "/submit")) (handleSuccess config challenge) handleFailure (approvalForm challenge))
    ]
      where
        handleSuccess :: FacebookConfig -> Challenge -> ([User], Bool) -> XMLGenT m (HSX.XML m)
        handleSuccess config challenge (users, True) =
          do res <- update (AddParticipants (challengeId challenge) users)
             case res of
               (Failure msg) ->
                   XMLGenT $ appTemplate "Error" <p>An error occurred while approving invitations: <% show msg %></p>
               (Success ()) ->
                   do let notification = "Congrats, you have been accepted into the push competition." -- TODO: link to the competition page
                      callMethod (Notifications.Send users notification (Just Notifications.UserToUser))
                      XMLGenT $ appTemplate "Aprroved" <p>Approved invite requests for <% mapM (\(User u) -> <fb:name uid=(show u) />) users %>.</p>
        handleSuccess config challenge (users, False) =
            do res <- update (BongWannabes (challengeId challenge) users)
               case res of
                 (Failure msg) ->
                     XMLGenT $ appTemplate "Error" <p>An error occurred while bonging wannabes: <% show msg %></p>
                 (Success ()) ->
                     XMLGenT $ appTemplate "Denied" <p>Denied invite requests for <% mapM (\(User u) -> <fb:name uid=(show u) />) users %>.</p>

        handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] ->  XMLGenT m (HSX.XML m)
        handleFailure errs formXML =
          <div>
            <div><% show errs %></div>
            <% formXML %>
          </div>

approvalPart :: 
    forall m.
          ( XMLGenerator m
          , MonadIO m
          , MonadPlus m
          , Functor m
          , ServerMonad m
          , FilterMonad Response m
          , WebMonad Response m
          , ToMessage (HSX.XML m)
          , HasFacebookConfig m
          ) 
          => Challenge -> XMLGenT m (HSX.XML m)
approvalPart challenge =
          do config <- askFacebookConfig
             formletPart "approval" ((uriToString id (canvasURL config)) "/approve/submit") (handleSuccess config) handleFailure (approvalForm challenge)
       where
        handleSuccess :: FacebookConfig -> ([User], Bool) -> XMLGenT m (HSX.XML m)
        handleSuccess config (users, True) =
          do res <- update (AddParticipants (challengeId challenge) users)
             case res of
               (Failure msg) ->
                   XMLGenT $ appTemplate "Error" <p>An error occurred while approving invitations: <% show msg %></p>
               (Success ()) ->
                   XMLGenT $ appTemplate "Aprroved" <p>Approved invite requests for <% mapM (\(User u) -> <fb:name uid=(show u) />) users %>.</p>

        handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] ->  XMLGenT m (HSX.XML m)
        handleFailure errs formXML =
          <div>
            <div><% show errs %></div>
            <% formXML %>
          </div>


{-
approvalPart :: 
    forall m.
    ( XMLGenerator m
    , MonadIO m
    , MonadPlus m
    , Functor m
    , ServerMonad m
    , FilterMonad Response m
    , WebMonad Response m
    , ToMessage (HSX.XML m)
    , HasFacebookConfig m
    ) =>
    Challenge -> XMLGenT m (HSX.XML m)
-}
    


approvalForm :: (XMLGenerator x, Applicative v, Monad v) => Challenge -> Form [XMLGenT x (HSX.XML x)] v ([User], Bool)
approvalForm challenge =
    (,) <$> ((checkboxes $ map (\u -> (uid u, <fb:name uid=(show $ uid u) />)) (Set.toList $ wannabes challenge)) `check` (\uids -> Success $ map User uids))
        <*> approveDeny
    where
      approveDeny = 
          ((,) <$> fbSubmit "Approve" <*> fbSubmit "Deny") 
          `check`
          (\res ->
               case res of
                 (True, False) -> Success True
                 (False, True) -> Success False
                 (False, False) -> Failure ["You must select Approve or Deny. You selected neither."]                                                           
                 (True, True) -> Failure ["You must select Approve or Deny. You somehow selected both."]
          )

checkboxes :: (XMLGenerator x, EmbedAsChild x c, Monad v, Applicative v, Read a, Show a) => [(a, c)] -> Form [XMLGenT x (HSX.XML x)] v [a]
checkboxes items = checkboxes' (map (first show) items) `check` (\strs -> sequenceA $ map (flip maybeRead' "Could not parse checkbox data") strs)

{-
Normally checkboxes all have the same 'name' element, and you get an
array of results back. But we don't want to parse the array, so we use
a trick and just give each checkbox a unique name.
-}
checkboxes' :: (XMLGenerator x, Monad v, Applicative v, EmbedAsChild x c) => [(String, c)] -> Form [XMLGenT x (HSX.XML x)] v [String]
checkboxes' items =
    plug (\listItems -> [<ul class="checkboxes"><% listItems %></ul>]) (catMaybes <$> (sequenceA $ map mkCheckbox items))
    where 
      mkCheckbox (val, labelText) =
          generalInput (\n mv ->
                      if mv == (Just val)
                      then [<li><input type="checkbox" name=n value=val checked="checked"><% labelText %></input></li>]
                      else [<li><input type="checkbox" name=n value=val ><% labelText %></input></li>])

-- return hour/minute in 24 hour time
-- FIXME: move to library
timePicker :: (XMLGenerator x, Applicative v, Monad v) 
           => Maybe TimeOfDay -> TimeZone -> Form [XMLGenT x (HSX.XML x)] v (TimeOfDay, TimeZone)
timePicker mTime defaultTZ =
    ((,,) <$> hour <*> minute <*> ampm) `check` asTOD
    where
      (hr, mn, _, mr) = traverse4 (\ (TimeOfDay h m s) -> militaryToCivilian (h, m, s)) mTime
      hour   = (select ((\tod -> (((todHour tod) - 1) `mod` 12) + 1) <$> mTime) $ map (\n -> (n, show n)) [1..12]) `check` (required "hour")
      minute = (select (todMin <$> mTime)                $ map (\n -> (n, show n)) [0..59]) `check` (required "minute")
      ampm   = (select ((\tod -> if (todHour tod) >= 12 then PM else AM) <$> mTime)     $ [(AM, "AM"), (PM, "PM")])   `check` (required "AM/PM")
      required descr Nothing = Failure [descr ++ " is required"]
      required _     (Just a) = Success a
      asTOD (hour, min, meridiem) = 
          let (h, m, _) = civilianToMilitary (hour, min, 0, meridiem)
              tod = TimeOfDay h m 0
          in Success $ (tod, defaultTZ)


traverse4 :: (Functor f) => (a -> (b, c, d, e)) -> f a -> (f b, f c, f d, f e)
traverse4 f a = sequence4 (fmap f a)

sequence4 :: (Functor f) => f (a, b, c, d) -> (f a, f b, f c, f d)      
sequence4 m = (fstM m, sndM m, thdM m, fthM m)
    where
      fstM :: (Functor f) => f (a, b, c, d) -> f a
      fstM = fmap (\(a, b, c, d) -> a)
      sndM :: (Functor f) => f (a, b, c, d) -> f b
      sndM = fmap (\(a, b, c, d) -> b)
      thdM :: (Functor f) => f (a, b, c, d) -> f c
      thdM = fmap (\(a, b, c, d) -> c)
      fthM :: (Functor f) => f (a, b, c, d) -> f d
      fthM = fmap (\(a, b, c, d) -> d)

data Meridiem = AM | PM deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Ix)

civilianToMilitary :: (Int, Int, Pico, Meridiem) -> (Int, Int, Pico)
civilianToMilitary (hour, minute, second, AM) = (hour `mod` 12, minute, second)
civilianToMilitary (hour, minute, second, PM) = ((hour `mod` 12) + 12, minute, second)

militaryToCivilian :: (Int, Int, Pico) -> (Int, Int, Pico, Meridiem)
militaryToCivilian (h, m, s)
    | h == 0    = (12, m, s, AM)
    | h < 12    = ( h, m, s, AM)
    | h == 12   = (12, m, s, PM) 
    | otherwise = ( h - 12, m, s, PM)

dayPicker :: (XMLGenerator x, Applicative v, Monad v) 
          => Maybe Day -> Day -> Day -> Form [XMLGenT x (HSX.XML x)] v Day
dayPicker defaultDay earliest latest =
    let (eYear, _eMonth, _eDay) = toGregorian earliest
        (lYear, _lMonth, _lDay) = toGregorian latest
        (dYear, dMonth, dDay) = 
            case defaultDay of
              Nothing -> (Nothing, Nothing, Nothing)
              (Just ld) ->
                  let (y,m,d)= toGregorian ld
                  in (Just y, Just m, Just d)
        year  = (select dYear  $ map (\n -> (n, show n)) [eYear..lYear])                               `check` (required "year")
        month = (select dMonth $ map (\n -> (n, fst $ (months defaultTimeLocale)!!(n - 1))) [1 .. 12]) `check` (required "month")
        day   = (select dDay   $ map (\n -> (n, show n)) [1..31])                                      `check` (required "day")
    in ((,,) <$> year <*> month <*> day) `check` validDay
    where
      required descr Nothing = Failure [descr ++ " is required"]
      required _     (Just a) = Success a
      validDay (year, month, day) =
          let gDay  = fromGregorian year month day
              (year', month', day') = toGregorian gDay
          in if not (year == year &&  month == month' && day == day') then
               Failure ["The date " ++ "year = " ++ show year ++ " month = " ++ show month ++ " day = " ++ show day ++ " does not exist."]
             else if gDay < earliest then
               Failure ["You must pick a date that is on or after " ++ showGregorian earliest ++ ". You picked: " ++ showGregorian gDay]
             else if gDay > latest then
               Failure ["You must pick a date that is on or before " ++ showGregorian latest  ++ ". You picked: " ++ showGregorian gDay]
             else
               Success gDay

zonedTimePicker :: (XMLGenerator x, Applicative v, Monad v)
                => Maybe ZonedTime -> ZonedTime -> ZonedTime -> TimeZone -> Form [XMLGenT x (HSX.XML x)] v ZonedTime
zonedTimePicker defaultZonedTime earliest latest defaultTZ =
    ((,) <$> dayPicker (localDay . zonedTimeToLocalTime <$> defaultZonedTime) (localDay (zonedTimeToLocalTime earliest)) (localDay (zonedTimeToLocalTime latest))
         <*> ((xml $ [<span> at </span>]) *> timePicker (localTimeOfDay . zonedTimeToLocalTime <$> defaultZonedTime) defaultTZ))
    `check` validate
    where
      validate (day, (tod, zone)) =
          let zt = ZonedTime (LocalTime day tod) zone
          in if (zonedTimeToUTC zt) < (zonedTimeToUTC earliest) then
                 Failure ["The date and time must be on or after " ++ show earliest ++ ". You picked: " ++ show zt]
             else if (zonedTimeToUTC zt) > (zonedTimeToUTC latest) then
                 Failure ["The date and time must be on or before " ++ show latest ++ ". You picked: " ++ show zt]
             else
                 Success zt


data ChallengeForm = ChallengeForm ZonedTime ZonedTime

challengeForm :: (XMLGenerator x, Applicative v, MonadIO v) 
              => ZonedTime -> ZonedTime -> TimeZone -> Form [XMLGenT x (HSX.XML x)] v ChallengeForm
challengeForm earliest latest tz =
    do (ChallengeForm <$> ((label "Start Date:") `fset` ["class" := "date-label"] *> zonedTimePicker (Just earliest)  earliest latest tz <* br) 
                      <*> ((label "End Date:")   `fset` ["class" := "date-label"] *> zonedTimePicker (Just nextMonth) earliest latest tz <* br)
        <* (fbSubmit "Create"))
      `checkM` validate
    where
      nextMonth  =
          let (ZonedTime (LocalTime day tod) tz) = earliest
          in (ZonedTime (LocalTime (addGregorianMonthsRollOver 1 day) tod) tz)
      br          = xml $ [<br />]
      label str   = xml $ [<div><label><% str %></label></div>]      
      validate  c@(ChallengeForm startDate endDate) = return $ Success c -- TODO: check that end date is after start date

-- TODO: move
fbSubmit lbl = (submit' lbl  `fset` ["class" := "inputsubmit", "label" := lbl])

-- TODO: patch in formlets-hsp
submit' :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v Bool
submit' val = (generalInput (\n _ -> [<input type="submit" name=n value=val />])) `check` 
             (\res -> 
                  case res of
                    Nothing -> pure False
                    (Just "") -> pure False
                    _ -> pure True
             )



-- FIXME: the current time is recalculated every call, which is a bit annoying.
createChallengeSP :: 
    forall m.
    ( XMLGenerator m
    , HasFacebookConfig m
    , HasUser m
    , ServerMonad m
    , MonadPlus m
    , Functor m
    , MonadIO m
    , FilterMonad Response m
    , WebMonad Response m
    , ToMessage (HSX.XML m)
    ) 
    => m (HSX.XML m)
createChallengeSP =
  dir "create" $
    appTemplate "Create a Challenge" 
        <div>
          <h1>Create a Challenge</h1>
          <% do (ZonedTime (LocalTime day tod') timeZone) <- liftIO getZonedTime
                config <- askFacebookConfig
                let tod = TimeOfDay (todHour tod') (todMin tod') 0
                    now = (ZonedTime (LocalTime day tod) timeZone)
                    (y,m,d) = toGregorian day
                    nextYear = ZonedTime (LocalTime (fromGregorian (y+1) m d) tod) timeZone 
                formletPart "create" ((uriToString id (canvasURL config)) "create/submit") handleSuccess handleFailure (challengeForm now nextYear timeZone)  -- NOTE: the 'facebook' prefix is not shown
          %>
        </div>
    where
      handleSuccess :: ChallengeForm -> XMLGenT m (HSX.XML m)
      handleSuccess (ChallengeForm startDate endDate) =
          do user <- askUser
             config <- askFacebookConfig
             challenge <- update (CreateChallenge user (ztToClockTime startDate) (ztToClockTime endDate) [user])
             let inviteURL = (uriToString id (canvasURL config) ("invite/" ++ show (unChallengeId (challengeId challenge))))
             <fb:redirect url=inviteURL />

      handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] ->  XMLGenT m (HSX.XML m)
      handleFailure errs formXML =
          <div>
            <div><% show errs %></div>
            <% formXML %>
          </div>

inviteSP ::
    ( MonadIO m
    , MonadPlus m
    , HasUser m
    , HasFacebookConfig m
    , XMLGenerator m
    , ServerMonad m
    ) 
    => m (HSX.XML m)    
inviteSP =
    dir "invite" $ challengeSP $ \challenge -> 
        do user <- askUser
           config <- askFacebookConfig
           if (owner challenge) /= user
            then mzero -- FIXME: better error message
            else msum [ dir "invited" $ withDataFn lookIds $ \users ->
                            do update (AddInvitees (challengeId challenge) users)
                               appTemplate "Invited" 
                                          <div>
                                            <p>Challenges have to been sent the following users.</p>
                                            <% mapM (\u -> <fb:name uid=(show $ uid u) />) users %>
                                          </div>
                      , nullDir >> appTemplate "Invite Other Players." 
                                      <fb:request-form
                                          action=(uriToString id (canvasURL config) ("invite/"++(show . unChallengeId . challengeId $ challenge)++"/invited"))
                                          method="POST"
                                          invite="true"
                                          type="Feats of Strength"
                                          content=
                                            ("You have been challenged to a Pushup Contest. <fb:req-choice url='"++ uriToString id (canvasURL config) "' label='Accept Challenge' />")>
                                        <fb:multi-friend-selector show-border="false" actiontext="Challenge your puney friends." />
                                      </fb:request-form>
                      ]
    where
      lookIds :: RqData [User]
      lookIds =
          do pairs <- lookPairs
             case lookups "ids[]" pairs of
               [] -> mzero
               users -> return $ map (User . read) users
      -- TODO: move
      lookups :: (Eq a) => a -> [(a,b)] -> [b]
      lookups a = map snd . filter ((a ==) . fst)

acceptSP ::
    ( MonadIO m
    , MonadPlus m
    , HasUser m
    , HasFacebookConfig m
    , XMLGenerator m
    , ServerMonad m
    ) 
    => m (HSX.XML m)    
acceptSP =
    dir "accept" $ challengeSP $ \challenge ->
        do user <- askUser
           if Set.member user (invited challenge) 
            then do res <- update (AddParticipants (challengeId challenge) [user])
                    case res of
                      (Failure errs) -> 
                          appTemplate "Error" <p>An error occurred while accepting the invitation: <% show errs %></p>
                      (Success ()) ->
                          appTemplate "Invitation Accepted"
                             <p>Invitation accepted</p>
            else do config <- askFacebookConfig
                    appTemplate "Invitation Required"
                       <p>You have not received an invitation to this challenge. Click <a href=((uriToString id $ canvasURL config) "request/" ++ (show . unChallengeId . challengeId $ challenge))>here</a> to request an invitation.</p>
           
challengeSP ::
    ( MonadIO m
    , MonadPlus m
    , ServerMonad m
    )
    => (Challenge -> m a) -> m a
challengeSP f =
    path $ \i ->
    do let cid = ChallengeId i
       mChallenge <- query (AskChallengeById cid)
       liftIO $ print (cid, mChallenge)
       all <- query AllChallenges
       let mChallenge = getOne (all @= cid)
       liftIO $ print (cid, all @= cid)
       case mChallenge of
         Nothing -> mzero -- FIXME: maybe a real error message?
         (Just challenge) -> f challenge

-- FIXME: this rounds to nearest second even though more precision is available
ztToClockTime :: ZonedTime -> ClockTime
ztToClockTime zt = 
    TOD (round (utcTimeToPOSIXSeconds (zonedTimeToUTC zt))) 0

-- FIXME: this rounds to nearest second even though more precision is available
clockTimeToZonedTime :: TimeZone -> ClockTime -> ZonedTime
clockTimeToZonedTime tz (TOD epochSeconds _) =
    utcToZonedTime tz (posixSecondsToUTCTime (fromIntegral epochSeconds))

impl :: ServerPartT IO Response
impl = 
    msum [ {- dir "fbconnect" $ -- FIXME: should come from config
           msum [ xdReceiverPart
                , toResponse . FbXML <$> withFacebookConnect facebookConfig (msum [ dir "members" $ withSessionSP members
                                                                                  , homepage
                                                                                  ])
                ]
         , -} 
           dir "facebook" $
               withFacebook facebookConfig $ 
                  msum [ withSessionSP 
                         (toResponse . FbXML <$> msum [ createChallengeSP
                                                      , addScoreSP
                                                      , acceptSP
                                                      , inviteSP
                                                      , inviteRequestSP
                                                      , joinSP
                                                      , nullDir >> homepage
                                                      ])
                       , toResponse <$> loginSP
                       , toResponse . FbXML <$> 
                                    do config <- askFacebookConfig
                                       appTemplate "Hello" <p>This app is about pushups. Click <a href=(uriToString id (canvasURL config) "login")>here</a> to add it.</p>
                       ]
         ]

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])


stateProxy :: Proxy State
stateProxy = Proxy

main :: IO ()
main = do
  -- progname effects where state is stored and what the logfile is named
  progName <- getProgName
  args <- getArgs

  appConf <- case parseConfig args of
               (Left e) -> do logM progName ERROR (unlines e)
                              exitFailure
               (Right f) -> return (f $ defaultConf progName)

  setupLogger progName (logs appConf) (logMode appConf)

  -- start the state system
  control <- startSystemState' (store appConf) stateProxy
  
  -- start the http server

  httpTid <- forkIO $ simpleHTTP (httpConf appConf) impl

  -- checkpoint the state once a day
  cronTid <- forkIO $ cron (60*60*24) (createCheckpoint control)
  
  -- wait for termination signal
  waitForTermination
  
  -- cleanup
  killThread httpTid
  killThread cronTid
  createCheckpoint control
  shutdownSystem control 


data AppConf
    = AppConf { httpConf :: Conf
              , store    :: FilePath
              , static   :: FilePath 
              , imageStore :: FilePath
              , imageCache :: FilePath
              , logs     :: FilePath
              , logMode  :: LogMode
              , domain  :: String
              }

defaultConf :: String -> AppConf
defaultConf progName
    = AppConf { httpConf = nullConf
              , store    = "_local/" ++ progName ++ "_state"
              , static   = "static"
              , imageStore = "_local/imageStore"
              , imageCache = "_local/imageCache"
              , logs     = ""
              , logMode  = Development
              , domain  = ""
              }

opts :: [OptDescr (AppConf -> AppConf)]
opts = [ Option [] ["http-port"]   (ReqArg (\h c -> c { httpConf = (httpConf c) {port = read h} }) "port") "port to bind http server"
       , Option [] ["no-validate"] (NoArg (\ c -> c { httpConf = (httpConf c) { validator = Nothing } })) "Turn off HTML validation"
       , Option [] ["store"]       (ReqArg (\h c -> c {store = h}) "PATH") "The directory used for database storage."
       , Option [] ["static"]      (ReqArg (\h c -> c {static = h}) "PATH") "The directory searched for static files" 
       , Option [] ["logs"]        (ReqArg (\h c -> c {logs = h}) "PATH") "The directory to store log files in"
       , Option [] ["log-mode"]    (ReqArg (\h c -> c {logMode = read h}) (show ([minBound .. maxBound] :: [LogMode]))) "The logging mode to use"
       , Option [] ["domain"]    (ReqArg (\h c -> c {domain = h}) "URI") ("The domain name associated with this server.")
       ]

parseConfig :: [String] -> Either [String] (AppConf -> AppConf)
parseConfig args
    = case getOpt Permute opts args of
        (flags,_,[]) -> Right $ \appConf -> foldr ($) appConf flags
        (_,_,errs)   -> Left errs

startSystemState' :: (Component st, Methods st) => String -> Proxy st -> IO (MVar TxControl)
startSystemState' = runTxSystem . Queue . FileSaver

-- TODO: move to library       
fbStyle :: (XMLGenerator m) => XMLGenT m (HSX.XML m)
fbStyle = 
    <style>
            /* Default Facebook CSS */
            .fbbody
            {
                font-family: "lucida grande",tahoma,verdana,arial,sans-serif;
                font-size: 11px;
                color: #333333;
            }
            /* Default Anchor Style */
            .fbbody a
            {
                color: #3b5998;
                outline-style: none;
                text-decoration: none;
                font-size: 11px;
                font-weight: bold;
            }
            .fbbody a:hover
            {
                text-decoration: underline;
            }
            /* Facebook Box Styles */
            .fbgreybox
            {
                background-color: #f7f7f7;
                border: 1px solid #cccccc;
                color: #333333;
                padding: 10px;
                font-size: 13px;
                font-weight: bold;
            }
            .fbbluebox
            {
                background-color: #eceff6;
                border: 1px solid #d4dae8;
                color: #333333;
                padding: 10px;
                font-size: 13px;
                font-weight: bold;
            }
            .fbinfobox
            {
                background-color: #fff9d7;
                border: 1px solid #e2c822;
                color: #333333;
                padding: 10px;
                font-size: 13px;
                font-weight: bold;
            }
            .fberrorbox
            {
                background-color: #ffebe8;
                border: 1px solid #dd3c10;
                color: #333333;
                padding: 10px;
                font-size: 13px;
                font-weight: bold;
            }
            /* Content Divider on White Background */
            .fbcontentdivider
            {
                margin-top: 15px;
                margin-bottom: 15px;
                width: 520px;
                height: 1px;
                background-color: #d8dfea;
            }
            /* Facebook Tab Style */
            .fbtab
            {
                padding: 8px;
                background-color: #d8dfea;
                color: #3b5998;
                font-weight: bold;
                float: left;
                margin-right: 4px;
                text-decoration: none;
            }
            .fbtab:hover
            {
                background-color: #3b5998;
                color: #ffffff;
                cursor: hand;
            }
            .date-label
            {
              width: 10em;
            }
    </style>