Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Data.Monoid ((<>))
import Data.Aeson
import GHC.Generics
import Network.Wai
import Servant
import Network.Wai.Handler.Warp (run)
{-import Chat (eioServer, ServerState (..))-}
import qualified Control.Concurrent.STM as STM
import qualified Network.SocketIO as SocketIO


import Control.Applicative
import Data.Maybe (maybeToList)
import Control.Arrow (second)
import Data.Text (pack, Text)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text.Lazy (fromStrict)
import Data.Conduit (($$), transPipe, Source)
import Data.Conduit.Lift (runCatchC)
import Data.Conduit.Attoparsec (sinkParser)
import Data.Attoparsec.ByteString (parseOnly, Parser)
import Data.Monoid (mappend)
import Control.Monad (unless, liftM)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Except (throwError)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader hiding (ask)
import Control.Monad.Reader (ask)
import Data.ByteString.Lazy (toStrict)
import Control.Exception (throwIO)
import Control.Monad.Trans.Control (control)
import Network.HTTP.Types.Header (hContentType)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Network.EngineIO as EIO
import qualified Data.HashMap.Strict as HashMap
import qualified Network.Wai as WAI
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import Network.HTTP.Types.Status as ST
import Network.HTTP.Types.URI as URI


type WaiMonad = ExceptT Response (ReaderT Request IO)


data AddUser = AddUser Text

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


data NumConnected = NumConnected !Int

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


data NewMessage = NewMessage Text

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


data Said = Said Text Text

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

data UserName = UserName Text

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


data UserJoined = UserJoined Text Int

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


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

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

    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)


queryToHashMap :: URI.Query -> HashMap.HashMap BS.ByteString [BS.ByteString]
queryToHashMap = HashMap.fromListWith (++) . map (second maybeToList)


servantEIOAPI :: EIO.ServerAPI WaiMonad
servantEIOAPI = EIO.ServerAPI
    { EIO.srvTerminateWithResponse = \code ct builder -> do
        let status = filter ((==) code . ST.statusCode) [ST.status100..ST.status511]
        case status of
            [] -> error "not a valid status code"
            (st:_) -> throwError (responseBuilder st [(hContentType, ct)] builder)

    , EIO.srvGetQueryParams = do
        fmap (queryToHashMap . WAI.queryString) ask

    , EIO.srvParseRequestBody = \p -> do
        req <- ask
        b <- liftIO $ WAI.lazyRequestBody req
        return (parseOnly p $ toStrict b)


    , EIO.srvGetRequestMethod = fmap (WAI.requestMethod) ask

    , EIO.srvRunWebSocket = \app -> liftIO $ WS.runServer "localhost" 4000 app
    }


data User = User
  { name :: String
  , age :: Int
  , email :: String
  } deriving (Eq, Show, Generic)

instance ToJSON User

type UserAPI = "users" :> Get '[JSON] [User]
    :<|> "socket.io" :> Raw
    :<|> Raw

users :: [User]
users =
  [ User "Isaac Newton"    372 "isaac@newton.co.uk"
  , User "Albert Einstein" 136 "ae@mc2.org"
  ]

userAPI :: Proxy UserAPI
userAPI = Proxy

server :: Server UserAPI
server = return users
    :<|> socketIOHandler
    :<|> serveDirectory "resources"

    where
        socketIOHandler req respond = do
            state <- ServerState <$> STM.newTVarIO 0
            handler <- SocketIO.initialize servantEIOAPI (servantEIOServer state)
            let r = runExceptT handler :: ReaderT Request IO (Either Response ())
            let s = runReaderT (runExceptT handler) :: Request -> IO (Either Response ())
            let t = runReaderT (runExceptT handler) req :: IO (Either Response ())
            u <- t
            case u of
                Left x -> respond x
                Right _ -> respond $ responseLBS status200 [("Content-Type", "text/html")] $ encodeUtf8 $ fromStrict "testing"

app :: Application
app = serve userAPI server

main :: IO ()
main = do
    putStrLn $ "Running on " <> show 3001
    run 3001 app