<|start_filename|>backend/src/Backend/Examples/WebSocketChat/Server.hs<|end_filename|>
{-# LANGUAGE OverloadedStrings #-}

module Backend.Examples.WebSocketChat.Server where

import           Control.Concurrent (MVar, modifyMVar, modifyMVar_,
                                     readMVar)
import           Control.Exception  (finally)
import           Control.Monad      (forM_, forever)
import           Data.Aeson         (encode, decode)
import qualified Data.ByteString    as B
import           Data.ByteString.Lazy (toStrict)
import           Data.Char          (isPunctuation, isSpace)
import           Data.Semigroup     ((<>))
import           Data.Text          (Text)
import qualified Data.Text          as T
import qualified Data.Text.IO       as T
import qualified Network.WebSockets as WS

--------------------------------------------------------------------------------
import           Common.Examples.WebSocketChat.Message
--------------------------------------------------------------------------------

type Client = (Text, WS.Connection)

type ServerState = [Client]

newServerState :: ServerState
newServerState = []

numClients :: ServerState -> Int
numClients = length

clientExists :: Client -> ServerState -> Bool
clientExists client = any ((== fst client) . fst)

addClient :: Client -> ServerState -> ServerState
addClient client clients = client : clients

removeClient :: Client -> ServerState -> ServerState
removeClient client = filter ((/= fst client) . fst)

broadcast :: Text -> ServerState -> IO ()
broadcast message clients = do
    T.putStrLn message
    -- forM_ clients $ \(_, conn) -> WS.sendTextData conn message
    forM_ clients $ \(_, conn) -> WS.sendTextData conn $
        (toStrict . encode . S2Cbroadcast) message

application :: MVar ServerState -> WS.ServerApp
application state pending = do
    conn <- WS.acceptRequest pending
    WS.forkPingThread conn 30
    msgbs <- WS.receiveData conn :: IO B.ByteString
    let msgC = decode $ WS.toLazyByteString msgbs :: Maybe C2S
        -- msg = case msgC of
        --     Just (C2Sjoin txt) -> txt
        --     Just C2Sclose      -> "close msg"
        --     Just (C2Smsg txt)  -> txt
        --     Nothing            -> "hmm nothing"
    -- T.putStrLn $ "msg = " <> msg
    clients <- readMVar state
    case msgC of
        Nothing           ->
            T.putStrLn "Decoded msgC is nothing..."
        Just (C2Smsg txt) ->
            T.putStrLn $ "C2Smsg should not happen here, txt =" <> txt
        Just C2Sclose     ->
            T.putStrLn "C2Sclose should never happen here..."
        Just (C2Sjoin nm) ->
          case nm of
              _ | any ($ nm) [T.null, T.any isPunctuation, T.any isSpace] -> do
                        T.putStrLn $ ":" <> nm <> ":"
                        WS.sendTextData conn $ (toStrict . encode) S2Cnameproblem
                | clientExists client clients ->
                    WS.sendTextData conn $ (toStrict . encode) S2Cuserexists
                | otherwise -> flip finally disconnect $ do
                   modifyMVar_ state $ \s -> do
                       let s' = addClient client s
                       WS.sendTextData conn $ (toStrict . encode . S2Cwelcome) $
                           T.intercalate ", " (map fst s)
                       broadcast (nm <> " joined") s'
                       return s'
                   talk conn state client
          where
            client     = (nm,conn)
            disconnect = do
                -- Remove client and return new state
                s <- modifyMVar state $ \s ->
                    let s' = removeClient client s in return (s', s')
                broadcast (fst client <> " disconnected") s

talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
talk conn state (user, _) = forever $ do
    msgbs <- WS.receiveData conn :: IO B.ByteString
    case decode $ WS.toLazyByteString msgbs of
        Nothing           ->
            T.putStrLn "Decoded msgC is nothing..."
        Just C2Sclose     ->
            undefined -- TBD
        Just (C2Sjoin nm) ->
            T.putStrLn $ "C2Sjoin should not happen here, nm =" <> nm
        Just (C2Smsg txt) ->
            readMVar state >>= broadcast (user <> ": " <> txt)




<|start_filename|>common/src/Common/Examples/WebSocketChat/Message.hs<|end_filename|>
{-# LANGUAGE ScopedTypeVariables, DeriveGeneric #-}

module Common.Examples.WebSocketChat.Message where

import           Data.Aeson (ToJSON, FromJSON, toEncoding, parseJSON,
                            defaultOptions, Options,
                            genericToEncoding, genericParseJSON)
import qualified Data.Text as T
import           GHC.Generics (Generic)

data C2S = C2Sjoin T.Text
         | C2Sclose
         | C2Smsg T.Text
         deriving (Eq,Show, Generic)

options :: Options
options = defaultOptions -- { tagSingleConstructors = True }

instance ToJSON C2S where toEncoding = genericToEncoding options
instance FromJSON C2S where parseJSON = genericParseJSON options

data S2C = S2Cwelcome T.Text
         | S2Cbroadcast T.Text
         | S2Cuserexists
         | S2Cnameproblem
         deriving (Eq,Show, Generic)

instance ToJSON S2C where toEncoding = genericToEncoding options
instance FromJSON S2C where parseJSON = genericParseJSON options


<|start_filename|>frontend/src/Frontend/Examples/WebSocketChat/Main.hs<|end_filename|>
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecursiveDo       #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Frontend.Examples.WebSocketChat.Main where

import qualified Data.Aeson as Aeson
import           Data.ByteString    as B
import           Data.ByteString.Lazy (toStrict, fromStrict)
import           Data.Functor.Sum
import           Data.List.NonEmpty
import           Data.Monoid        ((<>))
import qualified Data.Text          as T
import           Data.Text (Text)
import           GHCJS.DOM.HTMLElement       (focus)
import           Language.Javascript.JSaddle
import           Obelisk.Route
import           Reflex
import           Reflex.Dom
import           Control.Monad.Fix (MonadFix)
import           Control.Monad      (void)
import           Text.URI

--------------------------------------------------------------------------------
import           Common.Examples.WebSocketChat.Message
import           Common.Route
--------------------------------------------------------------------------------

-- TODO
--  - factor out the performEvents (see keyboard -example)
--  - factor out the message forming
--  - factor out the textInput-button combos
--  - add close connection button and associated message handling
app
  :: ( DomBuilder t m
     , MonadFix m
     , MonadHold t m
     , PostBuild t m
     , PerformEvent t m
     , TriggerEvent t m
     , Prerender js m
     )
  => Maybe Text
  -> m ()
app r = do
  rec
    msgEvDyn <- widgetHold loginWidget (messagingWidget <$ loggedInEv)
    let
      msgSendEv = switch (current msgEvDyn)
      msgRecEv = fmapMaybe decodeOneMsg wsRespEv
      eRecRespTxt = fmap showMsg msgRecEv
      loggedInEv = fmapMaybe loginEv msgRecEv
    wsRespEv <- prerender (return never) $ do
      case checkEncoder backendRouteEncoder of
        Left err -> do
          el "div" $ text err
          return never
        Right encoder -> do
          let wsPath = fst $ encode encoder $ InL BackendRoute_WebSocketChat :/ ()
              sendEv = fmap ((:[]) . toStrict . Aeson.encode) msgSendEv
          let mUri = do
                uri' <- mkURI =<< r
                pathPiece <- nonEmpty =<< mapM mkPathPiece wsPath
                wsScheme <- case uriScheme uri' of
                  rtextScheme | rtextScheme == mkScheme "https" -> mkScheme "wss"
                  rtextScheme | rtextScheme == mkScheme "http" -> mkScheme "ws"
                  _ -> Nothing
                return $ uri'
                  { uriPath = Just (False, pathPiece)
                  , uriScheme = Just wsScheme
                  }
          case mUri of
            Nothing -> return never
            Just uri -> do
              ws <- webSocket (render uri) $ def & webSocketConfig_send .~ sendEv
              return (_webSocket_recv ws)
    receivedMessages <- foldDyn (\m ms -> ms ++ [m]) [] eRecRespTxt
    void $ el "div" $ do
      el "p" $ text "Responses from the backend chat -server:"
      el "ul" $ simpleList receivedMessages (\m -> el "li" $ dynText m)
  blank
  where
    loginEv = \case
      (S2Cwelcome _) -> Just ()
      _ -> Nothing

    decodeOneMsg :: B.ByteString -> Maybe S2C
    decodeOneMsg = Aeson.decode . fromStrict

    showMsg :: S2C -> Text
    showMsg = \case
      (S2Cbroadcast txt) -> txt
      (S2Cwelcome txt)  -> "Welcome! Users: " <> txt
      S2Cuserexists     -> "User already exists"
      S2Cnameproblem    -> "Name cannot contain punctuation or "

loginWidget
  :: ( DomBuilder t m
     , MonadFix m
     , PostBuild t m
     , PerformEvent t m
     , Prerender js m
     )
  => m (Event t C2S)
loginWidget = el "div" $ do
  rec
    tn <- inputElement $ def
      & inputElementConfig_setValue .~ fmap (const "") eNewName
      & inputElementConfig_elementConfig . elementConfig_initialAttributes .~
        ("placeholder" =: "Enter Username")
    doFocus tn
    bn <- button "Join"
    -- Clean the name a bit (todo, clean more):
    let eNewName = fmap T.strip
          $ tag (current $ value tn)
          $ leftmost [bn, keypress Enter tn]
  return $ C2Sjoin <$> eNewName

messagingWidget
  :: ( DomBuilder t m
     , MonadFix m
     , PostBuild t m
     , PerformEvent t m
     , Prerender js m
     )
  => m (Event t C2S)
messagingWidget = el "div" $ do
  rec
    t <- inputElement $ def & inputElementConfig_setValue .~ fmap (const "") newMessage
    doFocus t
    b <- button "Send"
    let newMessage = tag (current $ value t)
          $ leftmost [b, keypress Enter t]
  return $ C2Smsg <$> newMessage

doFocus
  :: ( DomBuilder t m
     , PostBuild t m
     , PerformEvent t m
     , Prerender js m
     )
  => InputElement EventResult (DomBuilderSpace m) t
  -> m ()
doFocus ie = prerender (return ()) $ do
  pb <- getPostBuild
  let h = _inputElement_raw ie
  performEvent_ (fmap (liftJSM . const (focus h)) pb)
  return ()
