Playing around with Data.Conduit.Network

test-client.hs

{-# LANGUAGE FlexibleContexts, OverloadedStrings, NoMonomorphismRestriction #-}
import Data.Conduit as C
import Data.Conduit.Network as CN
import Data.Maybe
import Data.Monoid
import System.IO (stdout)
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import Data.ByteString.Char8 (ByteString, pack)
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.ByteString.Char8 as SC
import Data.Word (Word8)
import Data.Char
--import Control.Lens
import Control.Monad (unless, liftM)
import Control.Applicative
import Control.Exception (assert)
import Control.Concurrent (threadDelay, forkIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Attoparsec.Char8 as A
import Data.Conduit.Attoparsec
import Data.HashMap.Strict as M
import System.Console.Readline

import Debug.Trace

type IrcParam = ByteString -- probably should actually be ByteString.Short

data RawIrc = RawIrc
	{ prefix :: IrcParam
	, cmd :: IrcParam
	, args :: [IrcParam]
	} deriving (Show, Eq)
--makeLenses ''RawIrc
emptyRawIrc = RawIrc S.empty S.empty []

-- should check to make sure that input is valid (no spaces etc)
mkRawIrc a b cs = RawIrc (pack a) (pack b) $ Prelude.map pack cs

sendRawIrc (RawIrc p c as) = flip SC.snoc '\n' $ S.intercalate " " $ concat $ [prefix, [c], fixlast as]
	where
		prefix	| S.null p  = []
			| otherwise = [SC.cons ':' p]
		fixlast [] = []
		fixlast (a:[]) = SC.cons ':' a : []
		fixlast (a:as) = a : fixlast as

main :: IO ()
main = do
    runTCPClient (clientSettings 3001 "localhost") $ \app -> do
	forkIO $ uiSource $$ (appSink app)
        (appSource app) $$ mapOutput parseIrc (linesmax 511) =$ uiSink

parseIrc ps = either (const emptyRawIrc) id $ parseOnly ircLine ps

ircLine = RawIrc <$> ircPrefix <*> ircCmd <*> ircArgs

ircTerm = takeWhile1 (not . (== ' ')) -- takeTill1 (== ' ')
ircPrefix = skipSpace *> option S.empty (char ':' *> ircTerm)
ircCmd = skipSpace *> ircTerm >>= (\a -> return $ f a)
	where f a = if S.length a == 3 && S.all isDigit_w8 a
		then a -- doNumeric (fromJust $ readInt a)
		else a -- cmdMap? (B.map toUpper a)

ircArgs = scan 15 -- max 15 arguments to an irc command
	where
		scan 1 = skipSpace *> (char ':' *> pure () <|> pure ()) *> toEnd
		scan n = skipSpace *> ((char ':' *> toEnd) <|> liftA2 (:) ircTerm (scan (n - 1)) <|> pure [])

		toEnd = liftA2 (:) takeByteString (pure [])

-- need to make this not overwrite the prompt... go for a real UI?
uiSink = CL.mapM_ print
uiSource = startIrc >> go
	where
		go = do
			maybeLine <- liftIO $ readline "IRC> "
			case maybeLine of
				Nothing -> return ()
				Just str -> yield (pack (str ++ "\n")) >> go

startIrc = do
	yield $ irc "NICK" ["Test"]
	yield $ irc "USER" ["test", "8", "*", "test client"]
	where
		irc a b = sendRawIrc $ mkRawIrc "" a b

{-
-- linesmax n0 splits input into lines of up to n0 characters (not including \n)
-- irc has telnet backwards compatibility so deal with \r\n EOLs
-- use a max of 511 for RFC behaviour
--	if we go to long we just start dropping until we get a \n
--	not specified in the RFC, but this is what the ircd source does
-}
linesmax :: Monad m => Int -> ConduitM ByteString ByteString m ()
--	if we do this we might buffer an unlimited amount into memory
--	so we end up with this monstrocity...  do we really need to worry about this?
linesmax n0 = mapOutput (stripCR . S.take n0) CB.lines
--	let's not worry about it, should probably keep this monster around though just for reference
{-
linesmax n0
	| n0 > 0 = mapOutput stripCR (loop n0 id)
	| otherwise = error "linesmax limit too short"
	where
		loop n front = await >>= maybe (finish front) (go n front)
		skipping = await >>= maybe (return ()) goskip

		goskip more = case S.elemIndex 10 more of
			Nothing -> skipping
			Just i -> go n0 id (S.unsafeDrop (i + 1) more)

		finish front =
			let final = front S.empty
			in unless (S.null final) (yield final)

		go n sofar more = case S.elemIndex 10 more of
			Nothing ->
				let rest = sofar more
				    len = S.length more
				in case len < n of
				True -> loop (n - len) $ S.append rest
				False -> startSkipping
			Just i -> case i <= n of
				True -> yield (sofar (S.unsafeTake i more))
					>> go n0 id (S.unsafeDrop (i + 1) more)
				False -> startSkipping
			where
				startSkipping = yield (sofar (S.unsafeTake n more))
					>> goskip (S.unsafeDrop n more) -- no newline here!
-}

toLower :: Word8 -> Word8
toLower w | w >= 65 && w <= 90 = w + 32
          | otherwise          = w

toUpper :: Word8 -> Word8
toUpper w | w >= 97 && w <= 122 = w - 32
          | otherwise          = w

stripCR ps = case unsnoc ps of
	Just (a,'\r') -> a
	Just _ -> ps
	Nothing -> S.empty

Note that the irc line extracting code is obsoleted by the new generic combinators introduced in http://www.yesodweb.com/blog/2014/03/network-conduit-async