{-# LANGUAGE OverloadedStrings #-} module Network.Socketson.Protocol where -- data: import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import Data.Serialize (Serialize (..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT -- either transformer stuff: import Control.Error.Util (note) import Control.Monad.Error.Class import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Either import Data.Either.Combinators -- websockets: import qualified Network.WebSockets as WS -- types: import qualified Network.HTTP.Types.URI as HT -- concurrent: import Control.Concurrent.MVar.Lifted -- exception: import Control.Exception (catch, finally, throw) -- monad: import Control.Monad -- intern: import Network.Socketson.Internal.Utils import Network.Socketson.ProtocolException import Network.Socketson.Report import Network.Socketson.ServerState import Network.Socketson.SessionStore -- random: import Crypto.Random import Crypto.Random.DRBG -- | Possible reactions to an incoming data object and current session data. data Reaction a = Send a | Close | None socketsonapp :: (ToJSON sobj, FromJSON rcv, Serialize sessd) => MVar ServerState -- ^ global server state as an mvar. -> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj)) -- ^ protocl function. -> WS.ServerApp socketsonapp mstate pf pcon = eitherT (\e -> return ()) (\_ -> return ()) (do { n <- _appT mstate pf pcon; report n (Info Low "Exit app thread.") } `catchError` (report "global" . Error) ) where _appT mstate pf pcon = do ------------- -- Handshake: (nick, skey, mData, con) <- modifyMVarT mstate $ \state -> do (_nick, _skey, _mData, _mGen, _con) <- handshake state pcon return (_updateState state _mGen, (_nick, _skey, _mData, _con)) report nick (Info Middle "Accepted connection.") ---------------- -- protocol loop: (WebSockets signals the close request via exceptions; so we handle exceptions already inline.) liftIO $ _loop mstate nick con skey mData pf report nick (Info Middle "Loop escaped, client disconnected.") ------------- return nick {- The protocol loop exits if an exception happens. We invoke it again, if the exception just needs to get reported. If the exception was a close request (or any which implicates a disconnect), we disconnect the connection and change state. -} _loop mstate nick con skey mData pf = eitherT (\e -> case e of ConnectionException WS.ConnectionClosed -> _disconnect mstate con nick False -- close internally ConnectionException (WS.CloseRequest _ _) -> _disconnect mstate con nick True -- send close e -> do { runEitherT $ report nick (Error e); _loop mstate nick con skey mData pf } )-- error reported. Continue loop. (\_ -> _disconnect mstate con nick True) (protocolLoop mstate nick con skey mData pf) _disconnect mstate con nick friendly = do runEitherT (report nick (Info Low "Closing connection ... ")) when friendly $ WS.sendClose con ("Close connection to socketson." :: BS.ByteString) modifyMVar_ mstate $ \state -> return $ decClients state _updateState :: ServerState -> Maybe CtrDRBG -> ServerState _updateState state mg = case mg of Just g -> incClients state { randomGen = g } Nothing -> incClients state {-| Every communication starts with one of two possible handshakes: 1. open a new session, 2. restore an existing session. A handshake produces (or retrieves) - identifier of client, - session key, - maybe session data, - maybe a iterated random generator and - a connection handle. A handshake may fail on: 1. No capacity, too many clients are connected already. 2. No session exists for given session key. 3. Failure while generating a new session key. 4. Invalid request path. -} handshake :: (Serialize a) => ServerState -> WS.PendingConnection -> EitherT ProtocolException IO (T.Text, BS.ByteString, Maybe a, Maybe CtrDRBG, WS.Connection) handshake state pcon = do hoistEither $ checkCapacity state case HT.decodePath (WS.requestPath (WS.pendingRequest pcon)) of -- open request: (["open"], [("id", Just ident')]) -> let ident = T.decodeUtf8 ident' in do (skey, g) <- hoistEither (genSessionKey state) con <- establish pcon skey return (ident, skey, Nothing, Just g, con) -- restore request: ("restore" : [skey'], [("id", Just ident')]) -> let skey = T.encodeUtf8 skey' ident = T.decodeUtf8 ident' in do sessD <- restoreSessionData state skey con <- establish pcon skey return (ident, skey, Just sessD, Nothing, con) -- invalid request: _ -> left InvalidRequestPath where checkCapacity :: ServerState -> Either ProtocolException () checkCapacity state = unless (existsCapacity state) $ Left TooManyClientsConnected genSessionKey :: ServerState -> Either ProtocolException (BS.ByteString, CtrDRBG) genSessionKey state = mapLeft (CannotGenerateRandomNumber . show) (genBytes 1024 $ randomGen state) establish :: WS.PendingConnection -> BS.ByteString -> EitherT ProtocolException IO WS.Connection establish pcon skey = let skey' = B64.encode skey in do con <- liftIO $ WS.acceptRequest pcon liftIO $ WS.forkPingThread con 30 liftIO $ WS.sendBinaryData con skey' return con {-| After a successful handshake, the communication goes into the 'protocolLoop'. It stays in the loop until an exception happens. Since an exception might be just a signal (WebSockets throws exceptions if the client wants to close the connection), we handle some of them already in 'socketsonapp'. For more information on what the protocol loop does, look at the `README.md`. -} protocolLoop :: (ToJSON sobj, FromJSON rcv, Serialize sessd) => MVar ServerState -> T.Text -> WS.Connection -> BS.ByteString -> Maybe sessd -> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj)) -> EitherT ProtocolException IO () protocolLoop mstate nick con skey sessionData pf = do report nick (Info Low "Waiting for incoming object ...") rcvObj <- recvObject con report nick (Info Low "Received object.") -- ^ receive JSON string and decode it into object. (sessd, react) <- mapLeftT UserException $ pf sessionData rcvObj -- ^ apply the protocol function and return new session data and reaction. case sessd of Just sdata' -> liftIO (withMVar mstate $ \state -> saveSessionData state skey sdata') _ -> return () -- ^ save the new session data. case react of -- decide on reaction: None -> protocolLoop mstate nick con skey sessd pf Send encObj -> do { sndObject con encObj; protocolLoop mstate nick con skey sessd pf } Close -> return () where recvObject :: (FromJSON rcv) => WS.Connection -> EitherT ProtocolException IO rcv recvObject con = do recv <- tryTWS $ WS.receiveData con hoistEither $ mapLeft CannotParseRecvObject (eitherDecode recv) sndObject :: (ToJSON sobj) => WS.Connection -> sobj -> EitherT ProtocolException IO () sndObject con msg = let emsg = encode msg tmsg = LT.toStrict $ LT.decodeUtf8 emsg in tryTWS $ WS.sendBinaryData con emsg