haskell xep client

Main.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad
import Data.Maybe
import Data.Either
import GHC.Generics
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import qualified Data.ByteString as BS
import qualified System.IO.Streams as S
import qualified System.IO.Streams.ByteString as SB
import System.IO.Streams.Network
import Data.Aeson
import Data.Aeson.Types
import qualified Data.HashMap.Strict as HM

data XepMessageType = Ping | Pong | Message | Unknown
    deriving (Generic, Show)
data XepMessage = XepMessage { msgType :: XepMessageType, msgId :: Integer, msgData :: Maybe Object }
    deriving (Generic, Show)

instance FromJSON XepMessageType where
    parseJSON (String txt) = return $ case txt of 
        "message" -> Message
        "ping" -> Ping
        "pong" -> Pong
        _ -> Unknown
    parseJSON _ = mempty

instance ToJSON XepMessageType where
    --toEncoding = genericToEncoding defaultOptions

instance FromJSON XepMessage where
    parseJSON (Object v) = XepMessage <$>
                            v .: "Type" <*>
                            v .: "ID" <*>
                            v .: "Data"
    parseJSON _ = mempty

instance ToJSON XepMessage where
    toJSON (XepMessage t i d) = object ["Type" .= t, "ID" .= i, "Data" .= d]
    --toEncoding (XepMessage t i d) = pairs ("Type" .= t <> "ID" .= i <> "Data" .= d)

maybeToEither :: e -> Maybe a -> Either e a
maybeToEither _ (Just v) = Right v
maybeToEither err (Nothing) = Left err

extractSender :: Maybe Object -> Parser String
extractSender Nothing = return ""
extractSender (Just v) = v .: "sender" .!= ""

main :: IO ()
main = withSocketsDo $ do
    addrinfos <- getAddrInfo Nothing (Just "d.ocsf.in") (Just "1985")
    sock <- socket AF_INET Stream defaultProtocol
    connect sock (addrAddress $ head addrinfos)
    (netInput, netOutput) <- socketToStreams sock
    msgInput <- SB.lines netInput
    forever $ do
        msgString <- S.read msgInput
        print msgString
        msg <- return (eitherDecodeStrict =<< maybeToEither "end of stream" msgString) :: IO (Either String XepMessage)
        case msg of
            Right m@(XepMessage mtype mid mdata) -> case mtype of
                Ping -> flip SB.writeLazyByteString netOutput $ encode $ XepMessage Pong (-1) Nothing
                Message -> flip SB.writeLazyByteString netOutput $
                    encode $ XepMessage Message mid $ Just $ HM.fromList [("body", toJSON $ sender ++ ": сасать.")]
                        where sender = fromMaybe "" $ parseMaybe extractSender mdata
            Left err -> putStrLn ("Error: " ++ show err) >> return ()
    sClose sock