Subversion Repositories colinrmitchell.com

Rev

Rev 663 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
332 colin 1
{-# LANGUAGE OverloadedStrings #-}
2
{-# LANGUAGE TemplateHaskell #-}
3
{-# LANGUAGE QuasiQuotes #-}
684 colin 4
{-# LANGUAGE ScopedTypeVariables #-}
332 colin 5
 
6
module Chat.Page.Page where
7
 
8
import Control.Concurrent.MVar
9
import Control.Monad.Trans (liftIO)
10
import Network.WebSockets as WS
344 colin 11
import System.Random
12
import Numeric (showHex)
332 colin 13
 
14
import Web.Scotty
15
import Text.Hamlet
334 colin 16
import Text.Julius
17
import Text.Lucius
18
import Text.Blaze.Html
332 colin 19
import Text.Blaze.Html.Renderer.Text (renderHtml)
684 colin 20
import Text.Printf
332 colin 21
 
22
import qualified Data.Text as T
656 colin 23
import Data.Text.Lazy (toStrict)
332 colin 24
import Data.Char as C
25
import Text.Read (readMaybe)
344 colin 26
import Data.List (sort)
332 colin 27
 
585 colin 28
registerForm :: Html -> Int -> Html
29
registerForm msg wsport =
332 colin 30
   $(shamletFile "src/Chat/Page/templates/master.hamlet")
31
   where
32
      bodyHtml = $(shamletFile "src/Chat/Page/templates/register.hamlet")
334 colin 33
      myScript = $(juliusFile "src/Chat/Page/templates/script.julius")
641 colin 34
      emojiScript = $(juliusFile "src/Chat/Page/templates/emoji.julius")
654 colin 35
      canvasScript = $(juliusFile "src/Chat/Page/templates/canvas.julius")
659 colin 36
      radioScript = $(juliusFile "src/Chat/Page/templates/radio.julius")
660 colin 37
      selfieScript = $(juliusFile "src/Chat/Page/templates/selfie.julius")
661 colin 38
      youtubeScript = $(juliusFile "src/Chat/Page/templates/youtube.julius")
334 colin 39
      styles = $(luciusFile "src/Chat/Page/templates/style.lucius")
654 colin 40
 
656 colin 41
chatForm :: T.Text -> Int -> Html
42
chatForm userName wsport =
332 colin 43
   $(shamletFile "src/Chat/Page/templates/master.hamlet")
44
   where
45
      bodyHtml = $(shamletFile "src/Chat/Page/templates/chat.hamlet")
654 colin 46
      canvasHtml = $(shamletFile "src/Chat/Page/templates/canvas.hamlet")
659 colin 47
      radioHtml = $(shamletFile "src/Chat/Page/templates/radio.hamlet")      
660 colin 48
      selfieHtml = $(shamletFile "src/Chat/Page/templates/selfie.hamlet")
663 colin 49
      youtubeHtml = $(shamletFile "src/Chat/Page/templates/youtube.hamlet")              
334 colin 50
      myScript = $(juliusFile "src/Chat/Page/templates/script.julius")
641 colin 51
      emojiScript = $(juliusFile "src/Chat/Page/templates/emoji.julius")
654 colin 52
      canvasScript = $(juliusFile "src/Chat/Page/templates/canvas.julius")
659 colin 53
      radioScript = $(juliusFile "src/Chat/Page/templates/radio.julius")
661 colin 54
      selfieScript = $(juliusFile "src/Chat/Page/templates/selfie.julius")  
55
      youtubeScript = $(juliusFile "src/Chat/Page/templates/youtube.julius")  
334 colin 56
      styles = $(luciusFile "src/Chat/Page/templates/style.lucius")
655 colin 57
 
585 colin 58
runWebServer :: MVar [(T.Text, T.Text, Maybe WS.Connection)] -> Int -> Int -> IO ()
59
runWebServer stVar port wsport =
60
   scotty port $ do
332 colin 61
      get "/" $ do
344 colin 62
         usersAndConns <- liftIO $ readMVar stVar
656 colin 63
         let users = map (\t -> userColorName t) usersAndConns
585 colin 64
         html . renderHtml $ registerForm
332 colin 65
            [shamlet|
344 colin 66
               <p>
656 colin 67
                  Users online:
68
                  <span>
69
                     $forall u <- users
70
                        ^{u}
332 colin 71
            |]
585 colin 72
            wsport
332 colin 73
      post "/" $ do
334 colin 74
         usersAndConns <- liftIO $ readMVar stVar
332 colin 75
         nameText <- param "myName"
585 colin 76
         color <- param "myColor"
656 colin 77
         let users = map (\t -> userColorName t) usersAndConns
684 colin 78
 
79
         realName <- liftIO $ verifyUserName nameText (map (\(n, _, _) -> n) usersAndConns)
80
 
81
         realColor <- liftIO $
82
                        case color of
83
                           "#000000" -> do
84
                              r :: Int <- fmap (flip mod 128) randomIO
85
                              g :: Int <- fmap (flip mod 128) randomIO
86
                              b :: Int <- fmap (flip mod 128) randomIO
87
 
88
                              return
89
                                 . T.pack
90
                                 $ printf "#%06X"
91
                                    (
92
                                       (b + 128) + 256 * (g + 128) + 256 * 256 * (r + 128)
93
                                    )
94
 
95
 
96
                           c -> return c
97
 
98
         case realName of
585 colin 99
            Left name -> do              
684 colin 100
               _ <- liftIO $ swapMVar stVar ((name, realColor, Nothing) : usersAndConns)
656 colin 101
               html . renderHtml $ chatForm name wsport
332 colin 102
            Right msg ->
585 colin 103
               html . renderHtml $ registerForm
332 colin 104
                  [shamlet|
344 colin 105
                     <p style="color: red;">
332 colin 106
                        #{msg}
344 colin 107
                     <p>
656 colin 108
                        Users online:
109
                        <span>
110
                           $forall u <- users
111
                              ^{u}
332 colin 112
                  |]
585 colin 113
                  wsport
352 colin 114
      get "/res" $ do
115
         fileName <- param "f"
116
         file $ "res/" ++ fileName
654 colin 117
 
656 colin 118
   where
119
      userColorName (n, c, _) =
120
         [shamlet|
121
            <span #name style="color: #{c}">
122
               #{n}
123
         |]
124
 
344 colin 125
userString users =
126
   T.intercalate ", " $ sort users
127
 
684 colin 128
verifyUserName :: T.Text -> [T.Text] -> IO (Either T.Text T.Text)
332 colin 129
verifyUserName s users
130
   | null s'
684 colin 131
      = do
132
         r1 :: Int <- fmap (flip mod (length firstNames)) $ randomIO
133
         r2 :: Int <- fmap (flip mod (length secondNames)) $ randomIO
134
         r3 :: Int <- fmap (flip mod (length flair)) $ randomIO
135
         r4 :: Int <- fmap (flip mod (length funnyNumbers)) $ randomIO
136
 
137
         return
138
            . Left
139
               . (flair !! r3)
140
               $ T.append
141
                  ((firstNames !! r1) `T.append` (secondNames !! r2))
142
                  (funnyNumbers !! r4)
143
 
332 colin 144
   | or $ map C.isSymbol s'
684 colin 145
      = return $ Right "Usernames cannot contain symbols."
332 colin 146
   | or $ map C.isSpace s'
684 colin 147
      = return $ Right "Usernames cannot contain spaces."
332 colin 148
   | or $ map C.isPunctuation s'
684 colin 149
      = return $ Right "Usernames cannot contain punctuation."
332 colin 150
   | elem s users
684 colin 151
      = return $ Right "That name has already been taken."
152
   | otherwise = return $ Left s
332 colin 153
   where
154
      s' = T.unpack s
684 colin 155
 
156
flair =
157
   [
158
      \s -> s,
159
      \s -> T.concat ["xX", s, "Xx"],
160
      \s -> T.concat ["Xx", s, "xX"],
161
      \s -> T.concat [".~", s, "~."],
162
      \s -> T.concat ["-ˋˏ [", s, "] ˎˊ"],
163
      \s -> T.concat [".·:*¨", s, "¨*:·."],
164
      \s -> T.concat ["○", s, "○"],
165
      \s -> T.concat ["(¯`·._", s, "_.·´¯)"],
166
      \s -> T.concat ["-☆̤̥̣", s, "-☆̤̥̣"],
167
      \s -> T.concat ["¡", s, "!"],
168
      \s -> T.concat ["¿", s, "?"]
169
   ]
170
 
171
funnyNumbers =
172
   [
173
      "",
174
      "69",
175
      "420",
176
      "314159",
177
      "2",
178
      "1988",
179
      "80085",
180
      "33"
181
   ]
182
 
183
firstNames :: [T.Text]
184
firstNames =
185
   [
186
      "dumb",
187
      "scum",
188
      "douche",
189
      "shit",
190
      "dick",
191
      "fuck",
192
      "dip",
193
      "ass",
194
      "cock",
195
      "butt",
196
      "dirt",
197
      "twat",
198
      "piss",
199
      "wank",
200
      "bum",
201
      "poop",
202
      "cum",
203
      "boob",
204
      "titty",
205
      "bitch"
206
   ]
207
 
208
secondNames :: [T.Text]
209
secondNames =
210
   [
211
      "ass",
212
      "bag",
213
      "head",
214
      "shit",
215
      "hat",
216
      "tard",
217
      "lord",
218
      "wit",
219
      "face",
220
      "wad",
221
      "sucker",
222
      "boy",
223
      "girl",
224
      "ho",
225
      "stain",
226
      "stick",
227
      "nozzle",
228
      "clown",
229
      "waffle",
230
      "goblin",
231
      "knob",
232
      "crunch",
233
      "sock",
234
      "butt",
235
      "boobs",
236
      "titty",
237
      "lips"
238
   ]