Subversion Repositories colinrmitchell.com

Compare Revisions

Ignore whitespace Rev 683 → Rev 684

/Haskell/Chat/src/Chat/Page/Page.hs
1,6 → 1,7
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
 
module Chat.Page.Page where
 
16,6 → 17,7
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)
73,9 → 75,29
nameText <- param "myName"
color <- param "myColor"
let users = map (\t -> userColorName t) usersAndConns
case verifyUserName nameText (map (\(n, _, _) -> n) usersAndConns) of
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, color, Nothing) : usersAndConns)
_ <- liftIO $ swapMVar stVar ((name, realColor, Nothing) : usersAndConns)
html . renderHtml $ chatForm name wsport
Right msg ->
html . renderHtml $ registerForm
103,18 → 125,114
userString users =
T.intercalate ", " $ sort users
 
verifyUserName :: T.Text -> [T.Text] -> Either T.Text T.Text
verifyUserName :: T.Text -> [T.Text] -> IO (Either T.Text T.Text)
verifyUserName s users
| null s'
= Right "A valid username is required"
= 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'
= Right "Usernames cannot contain symbols."
= return $ Right "Usernames cannot contain symbols."
| or $ map C.isSpace s'
= Right "Usernames cannot contain spaces."
= return $ Right "Usernames cannot contain spaces."
| or $ map C.isPunctuation s'
= Right "Usernames cannot contain punctuation."
= return $ Right "Usernames cannot contain punctuation."
| elem s users
= Right "That name has already been taken."
| otherwise = Left s
= 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"
]
/Haskell/Chat/src/Chat/Page/templates/register.hamlet
3,11 → 3,18
<p>
<span>
Enter your name:
<input name="myName" type="text">
<small>
Leave empty for a random name.
<p>
<span>
Pick a text color:
<input name="myColor" type="color">
<small>
Leave as black for a random color.
<p>
<input type="submit" value="Continue">