Browse Source

Initial import

tags/v0.1.0.1
Peter J. Jones 8 months ago
commit
2cde189e39
Signed by: Peter Jones <pjones@devalot.com> GPG Key ID: 9DAFAA8D01941E49
9 changed files with 306 additions and 0 deletions
  1. 2
    0
      .gitignore
  2. 5
    0
      CHANGES.md
  3. 26
    0
      LICENSE
  4. 7
    0
      README.md
  5. 2
    0
      Setup.hs
  6. 2
    0
      default.nix
  7. 210
    0
      src/Main.hs
  8. 35
    0
      wschat.cabal
  9. 17
    0
      wschat.nix

+ 2
- 0
.gitignore View File

@@ -0,0 +1,2 @@
1
+/dist/
2
+/tmp/

+ 5
- 0
CHANGES.md View File

@@ -0,0 +1,5 @@
1
+# Change Log / Release Notes
2
+
3
+## 0.1.0.0 (October 18, 2018)
4
+
5
+  * Initial version.

+ 26
- 0
LICENSE View File

@@ -0,0 +1,26 @@
1
+Copyright (c) 2018, Peter Jones <pjones@devalot.com>
2
+All rights reserved.
3
+
4
+Redistribution and use in source and binary forms, with or without
5
+modification, are permitted provided that the following conditions are
6
+met:
7
+
8
+1. Redistributions of source code must retain the above copyright
9
+   notice, this list of conditions and the following disclaimer.
10
+
11
+2. Redistributions in binary form must reproduce the above copyright
12
+   notice, this list of conditions and the following disclaimer in the
13
+   documentation and/or other materials provided with the
14
+   distribution.
15
+
16
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
22
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
23
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
26
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 7
- 0
README.md View File

@@ -0,0 +1,7 @@
1
+# A Simple WebSocket Chat Server
2
+
3
+This package includes a single executable: `wschat`.  It's an
4
+extremely simple chat server using WebSockets.
5
+
6
+The primary goal of this package is to provide students who are
7
+learning JavaScript a WebSocket server that they can talk to.

+ 2
- 0
Setup.hs View File

@@ -0,0 +1,2 @@
1
+import Distribution.Simple
2
+main = defaultMain

+ 2
- 0
default.nix View File

@@ -0,0 +1,2 @@
1
+{ pkgs ? (import <nixpkgs> {}).pkgs }:
2
+pkgs.haskellPackages.callPackage ./wschat.nix { }

+ 210
- 0
src/Main.hs View File

@@ -0,0 +1,210 @@
1
+{-# LANGUAGE DeriveGeneric     #-}
2
+{-# LANGUAGE OverloadedStrings #-}
3
+
4
+{-
5
+
6
+This file is part of the package wschat. It is subject to the license
7
+terms in the LICENSE file found in the top-level directory of this
8
+distribution and at:
9
+
10
+  git://git.devalot.com/wschat.git
11
+
12
+No part of this package, including this file, may be copied, modified,
13
+propagated, or distributed except according to the terms contained in
14
+the LICENSE file.
15
+
16
+-}
17
+
18
+--------------------------------------------------------------------------------
19
+module Main where
20
+
21
+--------------------------------------------------------------------------------
22
+-- Library Imports:
23
+import Control.Concurrent.STM.TVar
24
+import Control.Concurrent.Supply (Supply)
25
+import qualified Control.Concurrent.Supply as Supply
26
+import Control.Exception (bracket)
27
+import Control.Monad (forever)
28
+import Control.Monad.STM (atomically)
29
+import Data.Aeson (FromJSON, ToJSON)
30
+import qualified Data.Aeson as Aeson
31
+import Data.Char (isAscii, isAlphaNum)
32
+import Data.HashMap.Strict (HashMap)
33
+import qualified Data.HashMap.Strict as HashMap
34
+import Data.Maybe (fromMaybe)
35
+import Data.Text (Text)
36
+import qualified Data.Text as Text
37
+import qualified Data.Text.Encoding as Text
38
+import GHC.Generics
39
+import qualified Network.HTTP.Types as HTTP
40
+import qualified Network.Wai as Wai
41
+import qualified Network.Wai.Handler.Warp as Warp
42
+import Network.Wai.Handler.WebSockets (websocketsApp)
43
+import qualified Network.WebSockets as WS
44
+import System.Directory (doesFileExist)
45
+import System.Environment (getArgs)
46
+import System.Exit (die)
47
+import System.FilePath ((</>))
48
+
49
+--------------------------------------------------------------------------------
50
+-- | Connected clients (with unique ID so they can be removed too).
51
+type Clients = HashMap Text [(Int, WS.Connection)]
52
+
53
+--------------------------------------------------------------------------------
54
+-- | Internal state.
55
+data State = State
56
+  { clients :: TVar Clients
57
+    -- ^ Current clients.
58
+
59
+  , supply :: TVar Supply
60
+    -- ^ Fresh supply of unique IDs.
61
+
62
+  , codesDir :: FilePath
63
+    -- ^ Directory containing files whose names are checked to see if
64
+    -- there is a matching access code.
65
+  }
66
+
67
+--------------------------------------------------------------------------------
68
+-- | Valid messages to forward along to chat clients.
69
+data Message = Message
70
+  { sender :: Text
71
+    -- ^ The user who is sending the message.
72
+
73
+  , content :: Text
74
+    -- ^ The content of the message.
75
+
76
+  } deriving Generic
77
+
78
+instance FromJSON Message
79
+instance ToJSON Message
80
+
81
+--------------------------------------------------------------------------------
82
+-- | Error messages that can be sent to clients.
83
+data Error = Error
84
+  { error :: Text
85
+    -- ^ The error message.
86
+  } deriving Generic
87
+
88
+instance FromJSON Error
89
+instance ToJSON Error
90
+
91
+--------------------------------------------------------------------------------
92
+main :: IO ()
93
+main = do
94
+  args <- getArgs
95
+
96
+  case args of
97
+    [port, dir] -> do
98
+      cs  <- newTVarIO HashMap.empty
99
+      sup <- newTVarIO =<< Supply.newSupply
100
+      Warp.run (read port) (http $ State cs sup dir)
101
+
102
+    _ -> die "Usage: wschat <port> <directory>"
103
+
104
+--------------------------------------------------------------------------------
105
+-- | Test to see if an access code is valid.
106
+--
107
+-- An access code is valid if a file exists in a configured directory
108
+-- whose name matches the access code.
109
+--
110
+-- For security reasons only alphanumeric ASCII characters are allowed
111
+-- in access codes.
112
+checkAccessCode :: FilePath -> Text -> IO Bool
113
+checkAccessCode dir code = do
114
+    let code' = clean code
115
+    e <- doesFileExist (dir </> code')
116
+    return (not (null code') && e)
117
+
118
+  where
119
+    clean :: Text -> FilePath
120
+    clean = Text.unpack . Text.filter isAllowed
121
+
122
+    isAllowed :: Char -> Bool
123
+    isAllowed c = isAscii c && isAlphaNum c
124
+
125
+--------------------------------------------------------------------------------
126
+-- | HTTP request handler.
127
+http :: State -> Wai.Application
128
+http state request respond = do
129
+    let code = Text.decodeUtf8 (Wai.rawPathInfo request)
130
+    valid <- checkAccessCode (codesDir state) code
131
+
132
+    if valid
133
+      then go code
134
+      else respond (Wai.responseLBS HTTP.status401 [] "BAD")
135
+
136
+  where
137
+    go :: Text -> IO Wai.ResponseReceived
138
+    go code =
139
+      case websocketsApp WS.defaultConnectionOptions (ws state code) request of
140
+        Nothing  -> respond (Wai.responseLBS HTTP.status400 [] "BAD")
141
+        Just res -> respond res
142
+
143
+--------------------------------------------------------------------------------
144
+-- | WebSocket application.
145
+ws :: State         -- ^ Internal state.
146
+   -> Text          -- ^ Access code.
147
+   -> WS.ServerApp  -- ^ WebSocket application.
148
+
149
+ws state code pending = do
150
+    conn <- WS.acceptRequest pending
151
+    WS.forkPingThread conn 30
152
+
153
+    bracket (connect conn) disconnect
154
+            (\x -> welcome x >> reader x)
155
+
156
+  where
157
+
158
+    -- | Post-connection set up.
159
+    connect :: WS.Connection -> IO (Int, WS.Connection)
160
+    connect conn = atomically $ do
161
+      sup <- readTVar (supply state)
162
+
163
+      let (n, sup') = Supply.freshId sup
164
+          client    = (n, conn)
165
+
166
+      writeTVar (supply state) sup'
167
+      modifyTVar' (clients state) (update code (client:))
168
+      return client
169
+
170
+    -- | Post-disconnect tear down.
171
+    disconnect :: (Int, WS.Connection) -> IO ()
172
+    disconnect c = atomically $ do
173
+      let f = \(n, _) -> filter ((/= n) . fst)
174
+      modifyTVar' (clients state) (update code $ f c)
175
+
176
+    -- | A welcome message sent to new clients:
177
+    welcome :: (Int, WS.Connection) -> IO ()
178
+    welcome (_, c) = WS.sendTextData c $ Aeson.encode $
179
+                     Message "server" "Welcome to the chat!"
180
+
181
+    -- | Read incoming messages from the connection.
182
+    --
183
+    -- Messages are decoded from JSON to ensure they are valid and to
184
+    -- strip away any additional properties that are present.
185
+    reader :: (Int, WS.Connection) -> IO ()
186
+    reader (_, conn) = forever $ do
187
+      msg <- WS.receiveDataMessage conn
188
+
189
+      case Aeson.eitherDecode (WS.fromDataMessage msg) of
190
+        Right m -> broadcast m
191
+        Left e  -> let e' = Aeson.encode (Error (Text.pack e))
192
+                   in WS.sendTextData conn e'
193
+
194
+    -- | Broadcast message to all clients.
195
+    broadcast :: Message -> IO ()
196
+    broadcast msg = do
197
+      let msg' = Aeson.encode msg
198
+      cs <- readTVarIO (clients state)
199
+
200
+      case HashMap.lookup code cs of
201
+        Just cs' -> mapM_ (\(_, c) -> WS.sendTextData c msg') cs'
202
+        Nothing  -> return ()
203
+
204
+    -- | Update the client list using a function.
205
+    update :: Text
206
+           -> ([(Int, WS.Connection)] -> [(Int, WS.Connection)])
207
+           -> Clients
208
+           -> Clients
209
+    update key f m = let vs  = fromMaybe [] (HashMap.lookup key m)
210
+                     in HashMap.insert key (f vs) m

+ 35
- 0
wschat.cabal View File

@@ -0,0 +1,35 @@
1
+name:           wschat
2
+version:        0.1.0.0
3
+synopsis:       Simple WebSocket chat server
4
+description:    Extremely simple and limited WebSocket chat server.
5
+license:        BSD2
6
+license-file:   LICENSE
7
+author:         Peter Jones <pjones@devalot.com>
8
+maintainer:     Peter Jones <pjones@devalot.com>
9
+copyright:      Copyright (c) 2018 Peter J. Jones
10
+category:       Web
11
+build-type:     Simple
12
+cabal-version:  >=2.0
13
+
14
+extra-source-files:
15
+  CHANGES.md
16
+
17
+executable wschat
18
+  main-is: Main.hs
19
+  hs-source-dirs: src
20
+  default-language: Haskell2010
21
+  ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N"
22
+
23
+  build-depends: base                  >= 4.11 && < 5
24
+               , aeson                ^>= 1.3
25
+               , concurrent-supply    ^>= 0.1
26
+               , directory             >= 1.3
27
+               , filepath              >= 1.0
28
+               , http-types           ^>= 0.12
29
+               , stm                  ^>= 2.4
30
+               , text                 ^>= 1.2
31
+               , unordered-containers ^>= 0.2
32
+               , wai                  ^>= 3.2
33
+               , wai-websockets       ^>= 3.0
34
+               , warp                 ^>= 3.2
35
+               , websockets           ^>= 0.12

+ 17
- 0
wschat.nix View File

@@ -0,0 +1,17 @@
1
+{ mkDerivation, aeson, base, concurrent-supply, directory, filepath
2
+, http-types, stdenv, stm, text, unordered-containers, wai
3
+, wai-websockets, warp, websockets
4
+}:
5
+mkDerivation {
6
+  pname = "wschat";
7
+  version = "0.1.0.0";
8
+  src = ./.;
9
+  isLibrary = false;
10
+  isExecutable = true;
11
+  executableHaskellDepends = [
12
+    aeson base concurrent-supply directory filepath http-types stm text
13
+    unordered-containers wai wai-websockets warp websockets
14
+  ];
15
+  description = "Simple WebSocket chat server";
16
+  license = stdenv.lib.licenses.bsd2;
17
+}

Loading…
Cancel
Save