caddy.hs

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}

import Data.Text hiding (filter, unwords)
import Pipes
import Data.IORef
import Data.Maybe

import Data.Time (UTCTime(..), getCurrentTime)
import qualified Data.Map.Strict as M


import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Network.Discord

data State = State {
  golfLobby :: [String], -- players
  registry :: M.Map Snowflake UTCTime
}

defaultState = State [] (M.fromList [])

reply :: Message -> Text -> Effect DiscordM ()
reply Message{messageChannel=chan} cont = fetch' $ CreateMessage chan cont Nothing

embedSnowflake :: Snowflake -> String
embedSnowflake u = "<@" ++ show u ++ ">"

embedUser :: User -> String
embedUser = embedSnowflake . userId

main :: IO ()
main = do
  ref <- newIORef defaultState
  let update = liftIO . (modifyIORef ref)
  runBot (Bot "TOKEN") $ do
    with ReadyEvent $ \(Init v u _ _ _) ->
      liftIO . putStrLn $ "Connected to gateway v" ++ show v ++ " as user " ++ show u

    with MessageCreateEvent $ \msg@Message{..} -> do
      liftIO $ putStrLn (show msg)
      let contains s = s `isInfixOf` messageContent

      when (contains "?golf") $ do
        st <- liftIO $ readIORef ref
        reply msg $ listPlayers st
      when (contains "!clear") $ update clearPlayers
      when (contains "+golf") $ do
        let player = embedUser messageAuthor
        update (addPlayer player)
        st <- liftIO $ readIORef ref
        reply msg $ listPlayers st
      when (contains "-golf") $ do
        let player = embedUser messageAuthor
        update (removePlayer player)
      when (contains "?seen") $ do
        (State _ r) <- liftIO $ readIORef ref
        case listToMaybe messageMentions >>= return . userId of
          Just sf -> let mdate = M.lookup sf r >>= return . show
                     in reply msg $ pack $ fromMaybe "\127761" mdate
          Nothing -> reply msg $ pack (showRegistry r)

    with UserUpdateEvent $ \obj -> liftIO . putStrLn $ show obj
    with PresenceUpdateEvent $ \obj -> do
      liftIO $ putStrLn $ (show obj)
      let sf = presenceUpdateToSnowflake obj
      t <- liftIO $ getCurrentTime
      update $ tryRegisterUser sf t


-- Registry

showRegistry = M.foldlWithKey format ""
  where format s sf t = s ++ embedSnowflake sf ++ " @ " ++ show t ++ ". "

presenceUpdateToSnowflake :: Object -> Maybe Snowflake
presenceUpdateToSnowflake o = flip parseMaybe o $ \obj -> do
                                 user <- obj .: "user"
                                 sf <- user .: "id"
                                 return sf

tryRegisterUser :: Maybe Snowflake -> UTCTime -> State -> State
tryRegisterUser ms t st@(State _ r) = maybe st (\s -> st { registry = M.insert s t r }) ms

lastSeen :: Snowflake -> State -> Maybe UTCTime
lastSeen sf (State _ r) = M.lookup sf r

-- Lobby

listPlayers :: State -> Text
listPlayers (State ps _) = pack $ "\129337 " ++ unwords ps

addPlayer p st@(State ps _) = if p `elem` ps then st else st { golfLobby = (p:ps) }

clearPlayers s = s { golfLobby = [] }

removePlayer p s@(State ps _) = s { golfLobby = filter (/= p) ps }