Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Network.Socketson
import Network.Socketson.Protocol

import Data.Aeson (ToJSON (..), FromJSON (..), object, (.=), (.:), Value (..))
import Data.List (isPrefixOf)
import Control.Monad.Trans.Either

import System.Environment (getArgs)

-- from server perspective:
-- outgoing object
data SObject = SObject Int String

instance ToJSON SObject where
  toJSON (SObject i s) = object [ "int" .= i, "str" .= s ]


-- incoming object
data RObject = RObject String

instance FromJSON RObject where
  parseJSON (Object v) = RObject <$>
                          v .: "str"

type SessionData = Int

{- We implement the following protocol:

  Incoming objects (sent by client): RObject, { "str" : <some string> }
  Outgoing objects (sent to client): SObject, { "str" : <same string>, "int" : <counter> }

where `<counter>` gets increment each time an object was received (on server side). This is realized via session data.

If `RObject "quit"` (on server side) is received, a close request gets sent.

If `RObject ("error":e)` is received, an user error with description `e` is thrown on server side (i.e. reported).

-}
protocolFunction :: (Maybe SessionData -> RObject -> EitherT String IO (Maybe SessionData, Reaction SObject))
protocolFunction msd (RObject str) =
  let n = case msd of
            Nothing -> 0
            Just i   -> i + 1
      sobj = SObject n str
  in case str of
        "quit"                      -> return (Just n, Close)
        e | "error:" `isPrefixOf` e -> left (drop 6 e)
          | otherwise               -> return (Just n, Send sobj)


main :: IO ()
main =
  do as <- getArgs
     case as of
       [port, path] -> do putStrLn $ "starting socketson at " ++ port
                          socketson path 2 (read port) protocolFunction
       _            -> putStrLn "usage: socketson-sample <port> <path for session storage>"