Subversion Repositories colinrmitchell.com

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Chat.Page.Page where

import Control.Concurrent.MVar
import Control.Monad.Trans (liftIO)
import Network.WebSockets as WS
import System.Random
import Numeric (showHex)

import Web.Scotty
import Text.Hamlet
import Text.Julius
import Text.Lucius
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Printf

import qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Char as C
import Text.Read (readMaybe)
import Data.List (sort)

registerForm :: Html -> Int -> Html
registerForm msg wsport =
   $(shamletFile "src/Chat/Page/templates/master.hamlet")
   where
      bodyHtml = $(shamletFile "src/Chat/Page/templates/register.hamlet")
      myScript = $(juliusFile "src/Chat/Page/templates/script.julius")
      emojiScript = $(juliusFile "src/Chat/Page/templates/emoji.julius")
      canvasScript = $(juliusFile "src/Chat/Page/templates/canvas.julius")
      radioScript = $(juliusFile "src/Chat/Page/templates/radio.julius")
      selfieScript = $(juliusFile "src/Chat/Page/templates/selfie.julius")
      youtubeScript = $(juliusFile "src/Chat/Page/templates/youtube.julius")
      styles = $(luciusFile "src/Chat/Page/templates/style.lucius")
 
chatForm :: T.Text -> Int -> Html
chatForm userName wsport =
   $(shamletFile "src/Chat/Page/templates/master.hamlet")
   where
      bodyHtml = $(shamletFile "src/Chat/Page/templates/chat.hamlet")
      canvasHtml = $(shamletFile "src/Chat/Page/templates/canvas.hamlet")
      radioHtml = $(shamletFile "src/Chat/Page/templates/radio.hamlet")      
      selfieHtml = $(shamletFile "src/Chat/Page/templates/selfie.hamlet")
      youtubeHtml = $(shamletFile "src/Chat/Page/templates/youtube.hamlet")              
      myScript = $(juliusFile "src/Chat/Page/templates/script.julius")
      emojiScript = $(juliusFile "src/Chat/Page/templates/emoji.julius")
      canvasScript = $(juliusFile "src/Chat/Page/templates/canvas.julius")
      radioScript = $(juliusFile "src/Chat/Page/templates/radio.julius")
      selfieScript = $(juliusFile "src/Chat/Page/templates/selfie.julius")  
      youtubeScript = $(juliusFile "src/Chat/Page/templates/youtube.julius")  
      styles = $(luciusFile "src/Chat/Page/templates/style.lucius")
   
runWebServer :: MVar [(T.Text, T.Text, Maybe WS.Connection)] -> Int -> Int -> IO ()
runWebServer stVar port wsport =
   scotty port $ do
      get "/" $ do
         usersAndConns <- liftIO $ readMVar stVar
         let users = map (\t -> userColorName t) usersAndConns
         html . renderHtml $ registerForm
            [shamlet|
               <p>
                  Users online:
                  <span>
                     $forall u <- users
                        ^{u}
            |]
            wsport
      post "/" $ do
         usersAndConns <- liftIO $ readMVar stVar
         nameText <- param "myName"
         color <- param "myColor"
         let users = map (\t -> userColorName t) usersAndConns
         
         realName <- liftIO $ verifyUserName nameText (map (\(n, _, _) -> n) usersAndConns)
         
         realColor <- liftIO $
                        case color of
                           "#000000" -> do
                              r :: Int <- fmap (flip mod 128) randomIO
                              g :: Int <- fmap (flip mod 128) randomIO
                              b :: Int <- fmap (flip mod 128) randomIO
                             
                              return
                                 . T.pack
                                 $ printf "#%06X"
                                    (
                                       (b + 128) + 256 * (g + 128) + 256 * 256 * (r + 128)
                                    )
                             
                             
                           c -> return c
                           
         case realName of
            Left name -> do              
               _ <- liftIO $ swapMVar stVar ((name, realColor, Nothing) : usersAndConns)
               html . renderHtml $ chatForm name wsport
            Right msg ->
               html . renderHtml $ registerForm
                  [shamlet|
                     <p style="color: red;">
                        #{msg}
                     <p>
                        Users online:
                        <span>
                           $forall u <- users
                              ^{u}
                  |]
                  wsport
      get "/res" $ do
         fileName <- param "f"
         file $ "res/" ++ fileName
 
   where
      userColorName (n, c, _) =
         [shamlet|
            <span #name style="color: #{c}">
               #{n}
         |]

userString users =
   T.intercalate ", " $ sort users

verifyUserName :: T.Text -> [T.Text] -> IO (Either T.Text T.Text)
verifyUserName s users
   | null s'
      = do
         r1 :: Int <- fmap (flip mod (length firstNames)) $ randomIO
         r2 :: Int <- fmap (flip mod (length secondNames)) $ randomIO
         r3 :: Int <- fmap (flip mod (length flair)) $ randomIO
         r4 :: Int <- fmap (flip mod (length funnyNumbers)) $ randomIO
         
         return
            . Left
               . (flair !! r3)
               $ T.append
                  ((firstNames !! r1) `T.append` (secondNames !! r2))
                  (funnyNumbers !! r4)
         
   | or $ map C.isSymbol s'
      = return $ Right "Usernames cannot contain symbols."
   | or $ map C.isSpace s'
      = return $ Right "Usernames cannot contain spaces."
   | or $ map C.isPunctuation s'
      = return $ Right "Usernames cannot contain punctuation."
   | elem s users
      = return $ Right "That name has already been taken."
   | otherwise = return $ Left s
   where
      s' = T.unpack s

flair =
   [
      \s -> s,
      \s -> T.concat ["xX", s, "Xx"],
      \s -> T.concat ["Xx", s, "xX"],
      \s -> T.concat [".~", s, "~."],
      \s -> T.concat ["-ˋˏ [", s, "] ˎˊ"],
      \s -> T.concat [".·:*¨", s, "¨*:·."],
      \s -> T.concat ["○", s, "○"],
      \s -> T.concat ["(¯`·._", s, "_.·´¯)"],
      \s -> T.concat ["-☆̤̥̣", s, "-☆̤̥̣"],
      \s -> T.concat ["¡", s, "!"],
      \s -> T.concat ["¿", s, "?"]
   ]
   
funnyNumbers =
   [
      "",
      "69",
      "420",
      "314159",
      "2",
      "1988",
      "80085",
      "33"
   ]

firstNames :: [T.Text]
firstNames =
   [
      "dumb",
      "scum",
      "douche",
      "shit",
      "dick",
      "fuck",
      "dip",
      "ass",
      "cock",
      "butt",
      "dirt",
      "twat",
      "piss",
      "wank",
      "bum",
      "poop",
      "cum",
      "boob",
      "titty",
      "bitch"
   ]

secondNames :: [T.Text]
secondNames =
   [
      "ass",
      "bag",
      "head",
      "shit",
      "hat",
      "tard",
      "lord",
      "wit",
      "face",
      "wad",
      "sucker",
      "boy",
      "girl",
      "ho",
      "stain",
      "stick",
      "nozzle",
      "clown",
      "waffle",
      "goblin",
      "knob",
      "crunch",
      "sock",
      "butt",
      "boobs",
      "titty",
      "lips"
   ]