chatrooms.hs

module Main where

import "concur-core" Concur.Core.Types (Widget (step), unsafeBlockingIO)
import "concur-core" Control.MultiAlternative (orr)
import "concur-replica" Concur.Replica (HTML, stepWidget)
import "concur-replica" Concur.Replica.DOM (button, ul, li, text, input, p)
import "concur-replica" Concur.Replica.DOM.Events (BaseEvent (target), targetValue, onClick, onInput)
import "concur-replica" Concur.Replica.DOM.Props (value)
import "focus" Focus (Focus, adjust)
import "lens" Control.Lens (_1, (%~))
import "list-t" ListT (toList)
import "replica" Replica.VDOM (defaultIndex)
import "replica" Replica.VDOM.Render (renderHTML)
import "replica" Network.Wai.Handler.Replica (websocketApp)
import "stm" Control.Concurrent.STM (STM, TVar, atomically, newTVarIO, readTVar, modifyTVar')
import "stm" Control.Concurrent.STM.TChan (TChan, dupTChan, newTChan, newTChanIO, readTChan, writeTChan)
import "stm-containers" StmContainers.Map (focus, new, insert, lookup, listT)
import "websockets" Network.WebSockets (ServerApp)
import "websockets" Network.WebSockets.Connection (defaultConnectionOptions)
import "wai" Network.Wai (Application, Middleware, responseLBS)
import "wai" Network.Wai.Internal (Request (requestHeaders))
import "wai-extra" Network.Wai.Middleware.HttpAuth (basicAuth, extractBasicAuth)
import "wai-websockets" Network.Wai.Handler.WebSockets (websocketsApp)
import "warp" Network.Wai.Handler.Warp (run)
import "http-types" Network.HTTP.Types (status200)

import qualified Data.ByteString.Lazy           as BL
import qualified Data.Text.Encoding             as TE
import qualified Data.Text.Lazy                 as TL
import qualified Data.Text.Lazy.Builder         as TB

import qualified "stm-containers" StmContainers.Map as STM (Map)

import Cantor.Prelude hiding (Map, insert, toList, lookup)

-- A simple chat app demonstrating communication between clients using STM.
-- The chatWidget is waiting for either the user to send a message or
-- another client to alert a new message. When a client sends a message
-- the chatWidget will update the messageHistory and then alert the other
-- clients by writing to messageAlert.

type Message = Text

type Room = Text

type Chatroom = ([(Username, Message)], [Username], TChan (Username, Message))
type Chatrooms = STM.Map Room Chatroom

data EditorAction
    = Typing Message -- The message the user is currently typing
    | Send Message -- The message the user sends to other users

data ChatAction
    = NewMessageToPost Room (TChan (Username, Message)) Message -- Message from one client to the others
    | NewMessagePosted Room (Username, Message)

allChats :: Maybe Username -> Chatrooms -> Widget HTML ChatAction
allChats Nothing _ = p [] [text $ "Who are you?"]
allChats (Just username) chatroomsTMap = do
    rooms <- liftIO . atomically . toList . listT $ chatroomsTMap
    orr (uncurry (chatroom username) <$> rooms) >>= \case
        NewMessagePosted roomName (from, newMessage) -> do
            liftIO $ print $ "[POSTED] USER: " <> from <> ", ROOM: " <> roomName
            allChats (Just username) chatroomsTMap
        NewMessageToPost roomName roomChan newMessage -> do
            liftIO $ print $ "[TO POST] USER: " <> username <> ", ROOM: " <> roomName
            liftIO . atomically $ do
                focus (adjust (_1 %~ ((username, newMessage) :))) roomName chatroomsTMap
                writeTChan roomChan (username, newMessage)
            allChats (Just username) chatroomsTMap

newMessage :: Username -> Message -> Focus ([(Username, Message)], [Username]) STM ()
newMessage username newMessage = adjust (_1 %~ ((username, newMessage) :))

chatroom :: Username -> Room -> Chatroom -> Widget HTML ChatAction
chatroom username roomName (messageHistory, participants, roomChan) = do
    let participantsList = p [] [text $ "Participants: " <> intercalate ", " participants]
    let newMessageToPost = NewMessageToPost roomName roomChan <$> (messageEditor "" <|> messagesList messageHistory)
    let newMessagePosted = NewMessagePosted roomName <$> (liftIO . atomically . readTChan $ roomChan)
    participantsList <|> newMessagePosted <|> newMessageToPost

messageEditor :: Message -> Widget HTML Message
messageEditor typing = do
    let textInput = Typing . targetValue . target <$> input [value $ typing, onInput]
    let submitButton = Send typing <$ button [onClick] [text "Send"]
    -- Wait for whatever editorAction to happen first
    editorAction <- textInput <|> submitButton
    case editorAction of
        Typing tm -> messageEditor tm
        Send msg -> pure msg

participantsList :: [Username] -> Widget HTML Message
participantsList users = p [] [text $ "Participants: " <> intercalate ", " users]

messagesList :: [(Username, Message)] -> Widget HTML Message
messagesList messageHistory = ul [] $ uncurry messageItem <$> messageHistory where

    messageItem :: Username -> Message -> Widget HTML Message
    messageItem username message = li [] [text $ username <> ": " <> message]

type Username = Text

currentUser :: Request -> Maybe Username
currentUser request = TE.decodeUtf8 . fst <$>
    (find ((==) "Authorization" . fst) (requestHeaders request) >>= extractBasicAuth . snd)

backupApp :: Application
backupApp _ r = r . responseLBS status200 [("content-type", "text/html")]
    . BL.fromStrict . TE.encodeUtf8 . TL.toStrict . TB.toLazyText $ renderHTML (defaultIndex "Chat" [])

users :: [(ByteString, ByteString)]
users = [("admin","love"), ("user","evil"), ("newby","newby")]

authorization :: Middleware
authorization = flip basicAuth "Realm" $
    curry (pure . isJust . flip find users . (==))

main :: IO ()
main = do
    messageHistory <- newTVarIO []
    chatrooms :: Chatrooms <- atomically $ new
    atomically $ do
        newTChan >>= \mc -> insert ([],["admin","user","newby"], mc) "main" chatrooms
        newTChan >>= \uc -> insert ([],["admin","user","newby"], uc) "updates" chatrooms
    let replicaApp usr _ = allChats usr chatrooms
    let wsapp usr = websocketApp (step <$> replicaApp usr) stepWidget :: ServerApp
    let app req res = websocketsApp defaultConnectionOptions (wsapp $ currentUser req) req & maybe ((authorization backupApp) req res) res
    run 8080 app