Chat.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module Lib.Chat (eioServer, ServerState (..)) where

import Prelude hiding (mapM_)

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader
import Data.Aeson ((.=))
import Data.Foldable (mapM_)

import qualified Control.Concurrent.STM as STM
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified Network.SocketIO as SocketIO
import Database.RethinkDB (next, fromDatum)
import Database.RethinkDB.Datum (resultToMaybe, Datum)
import Control.Concurrent
import Control.Exception
import Control.Monad

import qualified Model.User as User
import Model.Types.User (SecureUser, ChangeUser)


data AddUser = AddUser Text.Text

instance Aeson.FromJSON AddUser where
  parseJSON = Aeson.withText "AddUser" $ pure . AddUser


data NumConnected = NumConnected !Int

instance Aeson.ToJSON NumConnected where
  toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n]


data NewMessage = NewMessage Text.Text

instance Aeson.FromJSON NewMessage where
  parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage


data Said = Said Text.Text Text.Text

instance Aeson.ToJSON Said where
  toJSON (Said username message) = Aeson.object
    [ "username" .= username
    , "message" .= message
    ]

data UserName = UserName Text.Text

instance Aeson.ToJSON UserName where
  toJSON (UserName un) = Aeson.object [ "username" .= un ]


data UserJoined = UserJoined Text.Text Int

instance Aeson.ToJSON UserJoined where
  toJSON (UserJoined un n) = Aeson.object
    [ "username" .= un
    , "numUsers" .= n
    ]

data Connection = Connection [SecureUser]

instance Aeson.ToJSON Connection where
  toJSON (Connection c) = Aeson.object ["users" .= c]

data Changes = Changes ChangeUser

instance Aeson.ToJSON Changes where
  toJSON (Changes c) = Aeson.object ["users" .= c]

--------------------------------------------------------------------------------
data ServerState = ServerState { ssNConnected :: STM.TVar Int }

--server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap ()
eioServer state pool = do
  userNameMVar <- liftIO STM.newEmptyTMVarIO
  let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m

  -- get rethinkdb cursor
  cursor <- liftIO $ User.listRawChanges pool
  -- get socket for emitTo
  socket <- ask

  liftIO $ putStrLn "connected"
  liftIO $ forkIO $ forever $ next cursor >>= \c -> do
      case c of
          Nothing -> undefined
          Just x -> do
              let u = resultToMaybe $ fromDatum x :: Maybe ChangeUser
              case u of
                  Nothing -> undefined
                  Just user -> SocketIO.emitTo socket "changes" (Changes user)

  SocketIO.on "new message" $ \(NewMessage message) ->
    forUserName $ \userName ->
      SocketIO.broadcast "new message" (Said userName message)

  SocketIO.on "add user" $ \(AddUser userName) -> do
    n <- liftIO $ STM.atomically $ do
      n <- (+ 1) <$> STM.readTVar (ssNConnected state)
      STM.putTMVar userNameMVar userName
      STM.writeTVar (ssNConnected state) n
      return n

    SocketIO.emit "login" (NumConnected n)
    SocketIO.broadcast "user joined" (UserJoined userName n)

  SocketIO.appendDisconnectHandler $ do
    (n, mUserName) <- liftIO $ STM.atomically $ do
      n <- (+ (-1)) <$> STM.readTVar (ssNConnected state)
      mUserName <- STM.tryReadTMVar userNameMVar
      STM.writeTVar (ssNConnected state) n
      return (n, mUserName)

    case mUserName of
      Nothing -> return ()
      Just userName ->
        SocketIO.broadcast "user left" (UserJoined userName n)

  SocketIO.on "typing" $
    forUserName $ \userName ->
      SocketIO.broadcast "typing" (UserName userName)

  SocketIO.on "stop typing" $
    forUserName $ \userName ->
      SocketIO.broadcast "stop typing" (UserName userName)

error

Api/Main.hs:135:45:
    Couldn't match expected type ‘Control.Monad.Trans.State.Strict.StateT
                                    SocketIO.RoutingTable (ReaderT SocketIO.Socket WaiMonad) a0’
                with actual type ‘ReaderT SocketIO.Socket m0 ()’
    In the second argument of ‘($)’, namely ‘eioServer state p’
    In a stmt of a 'do' block:
      handler <- SocketIO.initialize waiAPI $ eioServer state p

Main.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}

import Servant hiding (Get, Post, Put, Delete, ReqBody)
import qualified Servant as S
import Data.Monoid ((<>))
import Data.Text (Text)
import System.Console.CmdArgs
import Data.Text.Lazy (pack)
import Network.Wai.Handler.Warp (run)
{-import Control.Monad.IO.Class (liftIO)-}
import Control.Monad.Morph (hoist)
{-import Control.Monad.Trans.Except-}
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader
import Network.Wai
import Network.Wai.Middleware.Cors
import Network.EngineIO.Wai
import qualified Network.SocketIO as SocketIO
import qualified Control.Concurrent.STM as STM

import Lib.Chat
import Lib.Config
import Lib.RethinkDB
import Model.Types.User (SecureUser)
import Model.Types.UserSignup (UserSignup)
import Model.Types.UserEdit (UserEdit)
import qualified Model.User as User

type Get a = S.Get '[JSON] a
type Post a = S.Post '[JSON] a
type Put a = S.Put '[JSON] a
type Delete a = S.Delete '[JSON] a
type ReqBody a = S.ReqBody '[JSON] a

type UsersAPI =
    Get [SecureUser]
    :<|> ReqBody UserSignup :> Post SecureUser
    :<|> Capture "id" Text :> ReqBody UserEdit :> Put SecureUser
    :<|> Capture "id" Text :> Delete ()

usersServer :: ServerT UsersAPI AppIO
usersServer =
    getUsers
    :<|> postUser
    :<|> putUser
    :<|> deleteUser

    where
        getUsers :: AppIO [SecureUser]
        getUsers = User.list

        postUser :: UserSignup -> AppIO SecureUser
        postUser = User.create

        putUser :: Text -> UserEdit -> AppIO SecureUser
        putUser = User.update

        deleteUser :: Text -> AppIO ()
        deleteUser = User.delete

type API =
    "info" :> Get ApiInfo
    :<|> "users" :> UsersAPI

serverT :: ServerT API AppIO
serverT = getApiInfo
    :<|> usersServer

    where
        getApiInfo :: AppIO ApiInfo
        getApiInfo = apiInfo

appIOToEither' :: AppConfig -> AppIO a -> EitherT ServantErr IO a
appIOToEither' t r = runReaderT (hoist (EitherT . runEitherT) r) t

appIOToEither :: AppConfig -> AppIO :~> EitherT ServantErr IO
appIOToEither t = Nat $ appIOToEither' t

server :: AppConfig -> Server API
server t = enter (appIOToEither t) serverT

type RawAPI =
    "socket.io" :> Raw
    :<|> Raw

rawServer :: WaiMonad () -> Server RawAPI
rawServer h = socketIO
    :<|> serveDirectory "resources"

    where
        socketIO :: Application
        socketIO req respond = toWaiApplication h req respond

corsResourcePolicy :: CorsResourcePolicy
corsResourcePolicy = CorsResourcePolicy
    { corsOrigins = Just (["chrome-extension://aicmkgpgakddgnaphhhpliifpcfhicfo", "http://getmetal.org"], True)
    , corsMethods = ["GET", "HEAD", "OPTIONS", "POST", "PUT", "DELETE"]
    , corsRequestHeaders = simpleResponseHeaders
    , corsExposedHeaders = Nothing
    , corsMaxAge = Nothing
    , corsVaryOrigin = False
    , corsRequireOrigin = False
    , corsIgnoreFailures = False
    }

stack :: Application -> Application
stack app = cors' $ app
    where
        cors' = cors (const $ Just corsResourcePolicy)

api :: Proxy (API :<|> RawAPI)
api = Proxy

app :: AppConfig -> WaiMonad () -> Application
app t h = serve api $ server t :<|> rawServer h

main :: IO ()
main = do
    -- setup environment
    args' <- cmdArgs $ AppOptions "development"

    -- Config
    cfg <- parseConfig (env args') (pack ".api")
    let dbh = dbHost cfg

    -- DB
    p <- createRethinkPool dbh
    let tn = AppConfig p cfg

    -- socketio
    state <- ServerState <$> STM.newTVarIO 0
    handler <- SocketIO.initialize waiAPI $ eioServer state p

    -- RethinkDB setup
    setupDB dbh

    putStrLn $ "Running on " <> show 3001
    run 3001 $ stack $ app tn handler