<commit_before>{-# LANGUAGE TemplateHaskell, OverloadedStrings, QuasiQuotes #-}
module Handler.Handlers where

import DnP
import Control.Monad
import Control.Applicative
import Control.Arrow

import qualified Data.Map as M
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan

import Data.Maybe (fromMaybe)


import Data.List (sortBy)
import Data.Ord (comparing)

import Handler.Commands
import Handler.Util



getRootR :: Handler RepHtml
getRootR = do
    mu <- maybeAuth
    h2id <- newIdent
    defaultLayout $ do
        setTitle "Dice and Paper Online"
        addWidget $(widgetFile "homepage")


getCheckInR :: Handler RepJson
getCheckInR = do
  (uid,u) <- requireAuth
  --liftIO $ putStrLn $ "checkIn from " ++ show uid
  table <- getTable uid
  chan <- maybe (invalidArgs ["Invalid User ID"]) (return.channel) $ M.lookup uid (clients table)
  -- blocks until we have something to send
  msg <- liftIO . atomically $ readTChan chan
  case msg of
    MessageChat s c -> do
      --liftIO $ putStrLn $ "Responding to " ++ show uid ++ " with " ++ show (s,c)
      jsonToRepJson $ zipJson ["type", "sender", "content"] ["chat",s,c]
    MessageWhisper s c -> do
      --liftIO $ putStrLn $ "Whispering to " ++ show uid ++ " with " ++ show (s,c)
      jsonToRepJson $ zipJson ["type", "sender", "content"] ["whisper",s,c]
    MessageBoard ts -> do
      --liftIO $ putStrLn $ "Sending Tokens to " ++ show uid
      jsonToRepJson $ jsonMap [("type", jsonScalar "board"), 
                               ("tokens", jsonList $ map (\t -> zipJson ["x","y","image","name"] 
                                                                        $ map ($ t) [show.tokenX, show.tokenY, file, tokenName]) 
                                                         ts
                                )]
    MessageVars vs -> do
      let sorted = sortBy (comparing fst) . sortBy (comparing (fst.snd)) $ vs  -- sorted by nick and then by var name
      --liftIO $ putStrLn $ "Sending vars to " ++ show uid
      jsonToRepJson $ jsonMap [("type", jsonScalar "vars"),
                               ("vars", jsonList $ map (\v -> zipJson ["nick","var","value"]
                                                                      $ map ($ v) [fst, fst.snd, snd.snd])
                                                       vs
                               )]


postSayR :: Handler RepJson
postSayR = do
  (uid,u) <- requireAuth
  mmsg  <- lookupPostParam "message"
  let msg  = fromMaybe "" mmsg -- blank messages won't get sent
      nick = userNick u
  --liftIO $ putStrLn $ nick ++ " (" ++ show uid ++ ") said: " ++ msg
  res <- case msg of
           "" -> return $ ResponseSuccess
           _  -> runCommand uid u nick msg

  case res of
    ResponseSuccess -> jsonToRepJson $ zipJson ["status"] ["success"]
    ResponsePrivate s -> jsonToRepJson $ zipJson ["status","message"] ["private",s]


-- handles the main logic on an incoming chat message. does the actual feeding of clients with data
runCommand :: UserId -> User -> String -> String -> Handler CommandResponse
runCommand _ _ _ []    = return ResponseSuccess -- do nothing on empty messages
runCommand _ _ _ ['/'] = return ResponseSuccess -- do nothing on just a slash
runCommand uid u nick ('/':msg) = do
  let (cmd:args) = words msg -- guaranteed to be at least one by the ['/'] case above
  let mf = M.lookup cmd commandMap
  case mf of
    Just f  -> f uid u nick cmd args
    Nothing -> do 
      -- retrieve the user's saved commands from the DB
      cmds <- runDB $ selectList [CommandUserEq uid, CommandNameEq cmd] [] 0 0
      case cmds of
        []  -> return $ ResponsePrivate $ "Unknown command: '" ++ cmd ++ "'"
        [(_,Command _ _ usrcmd)] -> runCommand uid u nick usrcmd
        _   -> return $ ResponsePrivate $ "ERROR: Multiple possible commands returned. Can't happen."

runCommand uid u nick msg = send uid nick msg



getTableR :: Handler RepHtml
getTableR = defaultLayout $ do
  setTitle "Dice and Paper Online - Table"
  addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
  $(widgetFile "table")<commit_msg>Prevent loops in /defines<commit_after>{-# LANGUAGE TemplateHaskell, OverloadedStrings, QuasiQuotes #-}
module Handler.Handlers where

import DnP
import Control.Monad
import Control.Applicative
import Control.Arrow

import qualified Data.Map as M
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan

import Data.Maybe (fromMaybe)


import Data.List (sortBy)
import Data.Ord (comparing)

import Handler.Commands
import Handler.Util



getRootR :: Handler RepHtml
getRootR = do
    mu <- maybeAuth
    h2id <- newIdent
    defaultLayout $ do
        setTitle "Dice and Paper Online"
        addWidget $(widgetFile "homepage")


getCheckInR :: Handler RepJson
getCheckInR = do
  (uid,u) <- requireAuth
  --liftIO $ putStrLn $ "checkIn from " ++ show uid
  table <- getTable uid
  chan <- maybe (invalidArgs ["Invalid User ID"]) (return.channel) $ M.lookup uid (clients table)
  -- blocks until we have something to send
  msg <- liftIO . atomically $ readTChan chan
  case msg of
    MessageChat s c -> do
      --liftIO $ putStrLn $ "Responding to " ++ show uid ++ " with " ++ show (s,c)
      jsonToRepJson $ zipJson ["type", "sender", "content"] ["chat",s,c]
    MessageWhisper s c -> do
      --liftIO $ putStrLn $ "Whispering to " ++ show uid ++ " with " ++ show (s,c)
      jsonToRepJson $ zipJson ["type", "sender", "content"] ["whisper",s,c]
    MessageBoard ts -> do
      --liftIO $ putStrLn $ "Sending Tokens to " ++ show uid
      jsonToRepJson $ jsonMap [("type", jsonScalar "board"), 
                               ("tokens", jsonList $ map (\t -> zipJson ["x","y","image","name"] 
                                                                        $ map ($ t) [show.tokenX, show.tokenY, file, tokenName]) 
                                                         ts
                                )]
    MessageVars vs -> do
      let sorted = sortBy (comparing fst) . sortBy (comparing (fst.snd)) $ vs  -- sorted by nick and then by var name
      --liftIO $ putStrLn $ "Sending vars to " ++ show uid
      jsonToRepJson $ jsonMap [("type", jsonScalar "vars"),
                               ("vars", jsonList $ map (\v -> zipJson ["nick","var","value"]
                                                                      $ map ($ v) [fst, fst.snd, snd.snd])
                                                       vs
                               )]


postSayR :: Handler RepJson
postSayR = do
  (uid,u) <- requireAuth
  mmsg  <- lookupPostParam "message"
  let msg  = fromMaybe "" mmsg -- blank messages won't get sent
      nick = userNick u
  --liftIO $ putStrLn $ nick ++ " (" ++ show uid ++ ") said: " ++ msg
  res <- case msg of
           "" -> return $ ResponseSuccess
           _  -> runCommand uid u nick msg []

  case res of
    ResponseSuccess -> jsonToRepJson $ zipJson ["status"] ["success"]
    ResponsePrivate s -> jsonToRepJson $ zipJson ["status","message"] ["private",s]


-- handles the main logic on an incoming chat message. does the actual feeding of clients with data
runCommand :: UserId -> User -> String -> String -> [String] -> Handler CommandResponse
runCommand _ _ _ []    _ = return ResponseSuccess -- do nothing on empty messages
runCommand _ _ _ ['/'] _ = return ResponseSuccess -- do nothing on just a slash
runCommand uid u nick ('/':msg) prevcmds = do
  let (cmd:args) = words msg -- guaranteed to be at least one by the ['/'] case above
  when (not . null . filter (==cmd) $ prevcmds) $ sendPrivate "Loop detected. Illegal command."
  let mf = M.lookup cmd commandMap
  case mf of
    Just f  -> f uid u nick cmd args
    Nothing -> do 
      -- retrieve the user's saved commands from the DB
      cmds <- runDB $ selectList [CommandUserEq uid, CommandNameEq cmd] [] 0 0
      case cmds of
        []  -> return $ ResponsePrivate $ "Unknown command: '" ++ cmd ++ "'"
        [(_,Command _ _ usrcmd)] -> runCommand uid u nick usrcmd (cmd:prevcmds)
        _   -> return $ ResponsePrivate $ "ERROR: Multiple possible commands returned. Can't happen."

runCommand uid u nick msg _ = send uid nick msg



getTableR :: Handler RepHtml
getTableR = defaultLayout $ do
  setTitle "Dice and Paper Online - Table"
  addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
  $(widgetFile "table")
{'fraction_non_alphanumeric': 0.11538914400094195, 'fraction_numerical': 0.001412928293889085, 'mean_word_length': 2.2308862685431725, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 42, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 20, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '613675', 'n_tokens_mistral': 2491, 'n_tokens_neox': 2376, 'n_words': 836}