{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Main where import At 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 Data.Function (on) 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, callMethodWithConfig, 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: this does not sowhttp://apps.facebook.com/featsofstrength/invite/0/invited -- 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" -- TODO: move to library conjunction :: String -> [String] -> String conjunction conj [] = [] conjunction conj [w] = w conjunction conj [a,b] = a ++ " " ++ conj ++ " " ++ b conjunction conj ws = conjunction' conj ws where conjunction' conj [a,b] = a ++ ", " ++ conj ++ " " ++ b conjunction' conj (w:ws) = w ++ ", " ++ conjunction' conj ws authorize :: (XMLGenerator m, EmbedAsChild m c) => FacebookConfig -> c -> XMLGenT m (HSX.XML m) authorize config c = <% c %> 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=" -- 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
<% formXML %>
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 , endedChallenges :: 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 , endedChallenges = 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) usersEndedChallenges :: User -> Query State Challenges usersEndedChallenges user = do cs <- endedChallenges <$> ask return $ (cs @= user) endChallenge :: ChallengeId -> Update State (Failing Challenge) endChallenge challengeId = do state <- get let cs = challenges state oldCs = endedChallenges state mChallenge = getOne $ cs @= challengeId case mChallenge of Nothing -> return $ Failure [show challengeId ++ " does not exist."] (Just challenge) -> do let cs' = IxSet.delete challenge cs oldCs' = IxSet.insert challenge oldCs put $ state { challenges = cs', endedChallenges = oldCs' } return (Success challenge) $(mkMethods ''State ['addParticipants, 'addScore, 'addInvitees, 'addInviteRequest, 'askChallengeById, 'bongWannabes , 'createChallenge, 'friendsChallenges, 'allChallenges, 'usersChallenges , 'usersEndedChallenges, 'endChallenge ]) appTemplate :: ( XMLGenerator m , EmbedAsChild m body , HasFacebookConfig m ) => String -> body -> m (HSX.XML m) appTemplate title xml = unXMLGenT $ do config <- askFacebookConfig <% title %>
<% fbStyle %> Homepage Create a New Challenge Join a Challenge Ended Challenges <% xml %>

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" $

Challenge your friends to feats of strength.

else appTemplate "Feats of Strength" $

Update Your Score

How many pushups did you just do? Enter the number here to update all the challenges you are currently in.

<% renderForm "score" ((canvasURLS config) "score/submit") scoreForm %>

Current Standings

<% challengesFBML challenges %>
endedChallengesSP :: ( XMLGenerator m , MonadIO m , MonadPlus m , ServerMonad m , HasUser m , HasSessionKey m , HasFacebookConfig m ) => m (HSX.XML m) endedChallengesSP = dir "ended" $ do config <- askFacebookConfig user <- askUser challenges <- query (UsersEndedChallenges user) if IxSet.null challenges then appTemplate "Feats of Strength" $

You have not yet participated in any challenges which have ended.

else appTemplate "Feats of Strength" $

Ended Challenges

<% challengesFBML challenges %>
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) ->
Error retrieving the list of your friends: <% show err %>
(Right friends) -> do user <- askUser availChallenges <- query (FriendsChallenges (user : friends)) if IxSet.null availChallenges then do config <- askFacebookConfig
None of your friends are currently involved in any challenges. Why don't you start one?
else challengesFBML availChallenges {- do user <- askUser config <- askFacebookConfig eInfo <- callMethod (Users.GetStandardInfo [user] [Users.UID .. Users.ProxiedEmail]) case eInfo of (Left err) ->
Error calling Users.getStandardInfo: <% show err %>
-- (Right str) ->
<% str %>
(Right [info]) -> let tz = fromMaybe utc (Users.timeZone info) in (Right info) ->
Error calling Users.getStandardInfo: <% show info %>
-} 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) ->
Error calling Users.getStandardInfo: <% show err %>
(Right [info]) -> let tz = fromMaybe utc (Users.timeZone info) in (Right info) ->
Error calling Users.getStandardInfo: <% show info %>
challengeFBML :: (XMLGenerator m) => TimeZone -> User -> FacebookConfig -> Challenge -> XMLGenT m (HSX.XML m) challengeFBML timeZone user config challenge =
<% mapM (\(u,scores) -> ) (Map.toList (participants challenge)) %>
PlayerCurrent Score
<% show $ sum (map pushups scores) %>
Starts<% timeStr timeZone (startDate challenge) %>
Ends<% timeStr timeZone (endDate challenge) %>
<% if user == (owner challenge) then let cidStr = (show . unChallengeId . challengeId $ challenge) inviteFBML =

Invite additional challengers.

in if not (Set.null (wannabes challenge)) then [ inviteFBML ,

<% show $ Set.size (wannabes challenge) %> requests to join.

] else [ inviteFBML] else if Map.member user (participants challenge) then [

You are in this challenge.

] else if Set.member user (wannabes challenge) then [

You have requested an invitation to this challenge.

] else if Set.member user (invited challenge) then [

Accept invitation to join this challenge.

] else [

Request invitation to join this challenge.

] %>
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"

An error occurred while updating your score: <% show msg %>

(Success cs) -> do let competitors = List.delete user $ nub $ concatMap (Map.keys . participants) (IxSet.toList cs) name = renderAsFBML . evalIdentity $ 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!"

Scored updated successfully.

handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] -> XMLGenT m (HSX.XML m) handleFailure errs formXML =
<% show errs %>
<% formXML %>
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"

An error occured while attempting to request an invite. <% show msg %>

(Success ()) -> do config <- askFacebookConfig let name = renderAsFBML . evalIdentity $ invitation = renderAsFBML . evalIdentity $ invitation notification = name ++ " has requested an " ++ invitation ++ " to your pushup challenge." res <- callMethod (Notifications.Send [owner challenge] notification (Just Notifications.UserToUser)) appTemplate "Invitation Requested"

You request to join the challenge has been sent.

(Right [(_,_,_)]) -> appTemplate "Not Friends"

You must be friends with to request an invitation.

(Left err) -> appTemplate "Error"

Error calling Friends.AreFriends

, dir "approve" $ challengeSP $ \challenge -> do liftIO $ print ("approve: " ++ show challenge) user <- askUser config <- askFacebookConfig if (user /= owner challenge) then appTemplate "Authorization Error"

You are not the owner of this challenge, so you can not approve invitation requests.

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"

An error occurred while approving invitations: <% show msg %>

(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"

Approved invite requests for <% mapM (\(User u) -> ) users %>.

handleSuccess config challenge (users, False) = do res <- update (BongWannabes (challengeId challenge) users) case res of (Failure msg) -> XMLGenT $ appTemplate "Error"

An error occurred while bonging wannabes: <% show msg %>

(Success ()) -> XMLGenT $ appTemplate "Denied"

Denied invite requests for <% mapM (\(User u) -> ) users %>.

handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] -> XMLGenT m (HSX.XML m) handleFailure errs formXML =
<% show errs %>
<% formXML %>
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"

An error occurred while approving invitations: <% show msg %>

(Success ()) -> XMLGenT $ appTemplate "Aprroved"

Approved invite requests for <% mapM (\(User u) -> ) users %>.

handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] -> XMLGenT m (HSX.XML m) handleFailure errs formXML =
<% show errs %>
<% formXML %>
{- 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, )) (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 -> [
    <% listItems %>
]) (catMaybes <$> (sequenceA $ map mkCheckbox items)) where mkCheckbox (val, labelText) = generalInput (\n mv -> if mv == (Just val) then [
  • <% labelText %>
    • ] else [
  • <% labelText %>
    • ]) -- 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 $ [ at ]) *> 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 $ [
    ] label str = xml $ [
    ] 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 _ -> [])) `check` (\res -> case res of Nothing -> pure False (Just "") -> pure False _ -> pure True ) -- |move the challenge to the endedChallenges list and send out winner notification to the participants endChallengeTask :: (MonadIO m) => FacebookConfig -> String -> ChallengeId -> m () endChallengeTask config rootLoggerName challengeId = do fChallenge <- update (EndChallenge challengeId) case fChallenge of (Failure errs) -> liftIO $ mapM_ (logM rootLoggerName ERROR) errs (Success challenge) -> case Map.toList (participants challenge) of [] -> return () -- no one was playing, though maybe we should still notify the owner? participants' -> do let numPushups = \ (who, score) -> (who, sum (map pushups score)) winners = head $ groupBy ((==) `on` snd) (sortBy (flip compare `on` snd) (map numPushups participants')) case winners of [(user, score)] -> do let name = renderAsFBML . evalIdentity $ notification = "Pushup Challenge Ended. Winner is " ++ name ++ " with " ++ show score ++ " pushups." -- TODO: add link _ <- callMethodWithConfig config (Notifications.SendNS (map fst participants') notification) -- TODO: check for error, include owner in list of receivers return () _ -> do let names = map (\(user, _) -> renderAsFBML . evalIdentity $ ) winners notification = "Pushup Challenge Ended. Winners are " ++ (conjunction "and" names) ++ " who all did " ++ show (snd (head winners)) ++ " pushups." -- TODO: add link _ <- callMethodWithConfig config (Notifications.SendNS (map fst participants') notification) -- TODO: check for error, include owner in list of receivers return () -- 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) ) => String -> AtQ -> m (HSX.XML m) createChallengeSP rootLoggerName atQ = dir "create" $ appTemplate "Create a Challenge"

    Create a Challenge

    <% 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 %>
    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]) liftIO $ at atQ (zonedTimeToUTC endDate) (endChallengeTask config rootLoggerName (challengeId challenge)) let inviteURL = (uriToString id (canvasURL config) ("invite/" ++ show (unChallengeId (challengeId challenge)))) handleFailure :: [ErrorMsg] -> [XMLGenT m (HSX.XML m)] -> XMLGenT m (HSX.XML m) handleFailure errs formXML =
    <% show errs %>
    <% formXML %>
    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"

    Challenges have to been sent the following users.

    <% mapM (\u -> ) users %>
    , nullDir >> appTemplate "Invite Other Players." ")> ] 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"

    An error occurred while accepting the invitation: <% show errs %>

    (Success ()) -> appTemplate "Invitation Accepted"

    Invitation accepted

    else do config <- askFacebookConfig appTemplate "Invitation Required"

    You have not received an invitation to this challenge. Click here to request an invitation.

    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)) -- FIXME: this rounds to nearest second even though more precision is available clockTimeToUTC :: ClockTime -> UTCTime clockTimeToUTC (TOD epochSeconds _) = (posixSecondsToUTCTime (fromIntegral epochSeconds)) impl :: String -> AtQ -> ServerPartT IO Response impl rootLoggerName atQ = 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 rootLoggerName atQ , addScoreSP , acceptSP , inviteSP , inviteRequestSP , joinSP , endedChallengesSP , nullDir >> homepage ]) , toResponse <$> loginSP , toResponse . FbXML <$> do config <- askFacebookConfig appTemplate "Hello"

    This app is about pushups. Click here to add it.

    ] ] 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 at queue atq <- newAtQ 60 challenges <- query AllChallenges mapM (\challenge -> at atq (clockTimeToUTC (endDate challenge)) (endChallengeTask facebookConfig progName (challengeId challenge))) (IxSet.toList challenges) -- start the http server httpTid <- forkIO $ simpleHTTP (httpConf appConf) (impl rootLoggerName atq) -- checkpoint the state once a day cronTid <- forkIO $ cron (60*60*24) (createCheckpoint control) -- wait for termination signal waitForTermination -- cleanup deleteAtQ atq 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 =