Attempt at a simple tcp client that holds the socket handle as state.

socket-client-state-maybe.hs

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures
                -fno-warn-type-defaults
                -fno-warn-unused-do-bind
#-}

{-| Testing basic tcp server concepts and their interaction with pipes

TODO:



-}


module Main where

import           Control.Monad (forever)
import           Control.Monad.Trans.State.Strict
    (StateT, get, put, evalStateT)
import           Data.Foldable (forM_)
import           System.IO
    (Handle, hSetBuffering, hPutStr, hGetLine, BufferMode(..))

import qualified Network as N
import qualified Network.Socket as NS
import qualified Network.Simple.TCP as NST

import           Pipes
-- import        Pipes.Prelude as P
import           Pipes.Concurrent
-- import        Pipes.Lift

-- helpers
host1p = NST.Host "127.0.0.1" 
port  = show 9300

server :: NST.HostPreference -> NS.ServiceName -> IO ()
server hp p = NST.serve hp p $ \(sock, _laddr) -> do
    putStrLn "TCP server up"
    forever $ do
        s <- NST.recv sock 4096
        forM_ s (NST.send sock)

-- event, state

type Plug = Maybe Handle

data Event = Connect     -- initially connect to port
	   | Quit        -- disconnect
	   | Receive     -- print to stdout
	   | Send String -- send a stream

help :: IO ()
help = putStrLn "(c)onnect (q)uit (r)eceive (s)end"

-- keypress events
user :: IO Event
user = do
    command <- getLine
    case command of
	"c" -> return Connect
	"q" -> return Quit
	"r" -> return Receive
	('s':xs) -> return $ Send xs
	_   -> do
	       help
	       user

handler :: StateT Plug (Consumer Event IO) ()
handler = do
        event  <- lift await
        case event of
            Connect -> do
                h <- get
                case h of
                    Just _ -> return ()
                    Nothing -> do
                        hp <- lift . lift $
                              N.connectTo "127.0.0.1" $ N.PortNumber 9300
                        lift . lift $ hSetBuffering hp LineBuffering
                        put $ Just hp
            Quit -> return () -- mzero
            Receive -> do
                h <- get
                case h of
                    Nothing -> return ()
                    Just hp -> do
                               s <- lift . lift $ hGetLine hp
                               lift . lift $ putStrLn s
            Send x -> do
                h <- get
                case h of
                     Nothing -> return ()
                     Just hp -> lift . lift $ hPutStr hp x

-- uses Pipes.Concurrent gratuitously
main :: IO ()
main = do
    help
    forkIO $ server host1p port
    (input, output) <- spawn Unbounded
    forkIO $ do run $ lift user >~ toInput input
		performGC
    run $ fromOutput output >-> evalStateT handler Nothing
    return ()