Browse Source

Initial import

tags/v0.1.0.1
Peter J. Jones 10 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 @@
/dist/
/tmp/

+ 5
- 0
CHANGES.md View File

@@ -0,0 +1,5 @@
# Change Log / Release Notes

## 0.1.0.0 (October 18, 2018)

* Initial version.

+ 26
- 0
LICENSE View File

@@ -0,0 +1,26 @@
Copyright (c) 2018, Peter Jones <pjones@devalot.com>
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the
distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 7
- 0
README.md View File

@@ -0,0 +1,7 @@
# A Simple WebSocket Chat Server

This package includes a single executable: `wschat`. It's an
extremely simple chat server using WebSockets.

The primary goal of this package is to provide students who are
learning JavaScript a WebSocket server that they can talk to.

+ 2
- 0
Setup.hs View File

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

+ 2
- 0
default.nix View File

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

+ 210
- 0
src/Main.hs View File

@@ -0,0 +1,210 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package wschat. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/wschat.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Main where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Concurrent.STM.TVar
import Control.Concurrent.Supply (Supply)
import qualified Control.Concurrent.Supply as Supply
import Control.Exception (bracket)
import Control.Monad (forever)
import Control.Monad.STM (atomically)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as Aeson
import Data.Char (isAscii, isAlphaNum)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import GHC.Generics
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Handler.WebSockets (websocketsApp)
import qualified Network.WebSockets as WS
import System.Directory (doesFileExist)
import System.Environment (getArgs)
import System.Exit (die)
import System.FilePath ((</>))

--------------------------------------------------------------------------------
-- | Connected clients (with unique ID so they can be removed too).
type Clients = HashMap Text [(Int, WS.Connection)]

--------------------------------------------------------------------------------
-- | Internal state.
data State = State
{ clients :: TVar Clients
-- ^ Current clients.

, supply :: TVar Supply
-- ^ Fresh supply of unique IDs.

, codesDir :: FilePath
-- ^ Directory containing files whose names are checked to see if
-- there is a matching access code.
}

--------------------------------------------------------------------------------
-- | Valid messages to forward along to chat clients.
data Message = Message
{ sender :: Text
-- ^ The user who is sending the message.

, content :: Text
-- ^ The content of the message.

} deriving Generic

instance FromJSON Message
instance ToJSON Message

--------------------------------------------------------------------------------
-- | Error messages that can be sent to clients.
data Error = Error
{ error :: Text
-- ^ The error message.
} deriving Generic

instance FromJSON Error
instance ToJSON Error

--------------------------------------------------------------------------------
main :: IO ()
main = do
args <- getArgs

case args of
[port, dir] -> do
cs <- newTVarIO HashMap.empty
sup <- newTVarIO =<< Supply.newSupply
Warp.run (read port) (http $ State cs sup dir)

_ -> die "Usage: wschat <port> <directory>"

--------------------------------------------------------------------------------
-- | Test to see if an access code is valid.
--
-- An access code is valid if a file exists in a configured directory
-- whose name matches the access code.
--
-- For security reasons only alphanumeric ASCII characters are allowed
-- in access codes.
checkAccessCode :: FilePath -> Text -> IO Bool
checkAccessCode dir code = do
let code' = clean code
e <- doesFileExist (dir </> code')
return (not (null code') && e)

where
clean :: Text -> FilePath
clean = Text.unpack . Text.filter isAllowed

isAllowed :: Char -> Bool
isAllowed c = isAscii c && isAlphaNum c

--------------------------------------------------------------------------------
-- | HTTP request handler.
http :: State -> Wai.Application
http state request respond = do
let code = Text.decodeUtf8 (Wai.rawPathInfo request)
valid <- checkAccessCode (codesDir state) code

if valid
then go code
else respond (Wai.responseLBS HTTP.status401 [] "BAD")

where
go :: Text -> IO Wai.ResponseReceived
go code =
case websocketsApp WS.defaultConnectionOptions (ws state code) request of
Nothing -> respond (Wai.responseLBS HTTP.status400 [] "BAD")
Just res -> respond res

--------------------------------------------------------------------------------
-- | WebSocket application.
ws :: State -- ^ Internal state.
-> Text -- ^ Access code.
-> WS.ServerApp -- ^ WebSocket application.

ws state code pending = do
conn <- WS.acceptRequest pending
WS.forkPingThread conn 30

bracket (connect conn) disconnect
(\x -> welcome x >> reader x)

where

-- | Post-connection set up.
connect :: WS.Connection -> IO (Int, WS.Connection)
connect conn = atomically $ do
sup <- readTVar (supply state)

let (n, sup') = Supply.freshId sup
client = (n, conn)

writeTVar (supply state) sup'
modifyTVar' (clients state) (update code (client:))
return client

-- | Post-disconnect tear down.
disconnect :: (Int, WS.Connection) -> IO ()
disconnect c = atomically $ do
let f = \(n, _) -> filter ((/= n) . fst)
modifyTVar' (clients state) (update code $ f c)

-- | A welcome message sent to new clients:
welcome :: (Int, WS.Connection) -> IO ()
welcome (_, c) = WS.sendTextData c $ Aeson.encode $
Message "server" "Welcome to the chat!"

-- | Read incoming messages from the connection.
--
-- Messages are decoded from JSON to ensure they are valid and to
-- strip away any additional properties that are present.
reader :: (Int, WS.Connection) -> IO ()
reader (_, conn) = forever $ do
msg <- WS.receiveDataMessage conn

case Aeson.eitherDecode (WS.fromDataMessage msg) of
Right m -> broadcast m
Left e -> let e' = Aeson.encode (Error (Text.pack e))
in WS.sendTextData conn e'

-- | Broadcast message to all clients.
broadcast :: Message -> IO ()
broadcast msg = do
let msg' = Aeson.encode msg
cs <- readTVarIO (clients state)

case HashMap.lookup code cs of
Just cs' -> mapM_ (\(_, c) -> WS.sendTextData c msg') cs'
Nothing -> return ()

-- | Update the client list using a function.
update :: Text
-> ([(Int, WS.Connection)] -> [(Int, WS.Connection)])
-> Clients
-> Clients
update key f m = let vs = fromMaybe [] (HashMap.lookup key m)
in HashMap.insert key (f vs) m

+ 35
- 0
wschat.cabal View File

@@ -0,0 +1,35 @@
name: wschat
version: 0.1.0.0
synopsis: Simple WebSocket chat server
description: Extremely simple and limited WebSocket chat server.
license: BSD2
license-file: LICENSE
author: Peter Jones <pjones@devalot.com>
maintainer: Peter Jones <pjones@devalot.com>
copyright: Copyright (c) 2018 Peter J. Jones
category: Web
build-type: Simple
cabal-version: >=2.0

extra-source-files:
CHANGES.md

executable wschat
main-is: Main.hs
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N"

build-depends: base >= 4.11 && < 5
, aeson ^>= 1.3
, concurrent-supply ^>= 0.1
, directory >= 1.3
, filepath >= 1.0
, http-types ^>= 0.12
, stm ^>= 2.4
, text ^>= 1.2
, unordered-containers ^>= 0.2
, wai ^>= 3.2
, wai-websockets ^>= 3.0
, warp ^>= 3.2
, websockets ^>= 0.12

+ 17
- 0
wschat.nix View File

@@ -0,0 +1,17 @@
{ mkDerivation, aeson, base, concurrent-supply, directory, filepath
, http-types, stdenv, stm, text, unordered-containers, wai
, wai-websockets, warp, websockets
}:
mkDerivation {
pname = "wschat";
version = "0.1.0.0";
src = ./.;
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
aeson base concurrent-supply directory filepath http-types stm text
unordered-containers wai wai-websockets warp websockets
];
description = "Simple WebSocket chat server";
license = stdenv.lib.licenses.bsd2;
}

Loading…
Cancel
Save