IO.hs

{- This file is part of irc-fun-client.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Network.IRC.Fun.Client.IO
    ( Connection (..)
    , Handle
    , ircConnect
    , ircDisconnect
    , hPutIrcRaw
    , hPutIrcGeneric
    , hPutIrc
    , hGetIrcRaw
    , hGetIrcGenericOnce
    , hGetIrcGenericOnce'
    , hGetIrcGeneric
    , hGetIrcGeneric'
    , hGetIrcOnce
    , hGetIrcOnce'
    , hGetIrc
    , hGetIrc'
    )
where

import Control.Exception (bracketOnError)
import Control.Monad (liftM)
import Data.Maybe (fromMaybe)
import Network.IRC.Fun.Messages
import Network.IRC.Fun.Messages.Types
import Network.Socket
import System.IO

-- | Details of the connection to IRC.
data Connection = Connection
    { -- | IRC Server address, e.g. @"irc.freenode.net"@
      connServer   :: String
      -- | IRC server port, @6667@ should be a safe default
    , connPort     :: Int
      -- | Whether to make an encrypted connection via TLS (not implemented)
    , connTls      :: Bool
      -- | IRC nickname for the bot, e.g. @"funbot"@
    , connNick     :: String
    -- | Connection password, use if the nickname is registered
    , connPassword :: Maybe String
    }
    deriving (Eq, Show)

-- | Connect to an IRC server using the given connection parameters, and return
-- a handle to the open socket. This just opens a TCP connection, without
-- sending any IRC commands.
ircConnect :: Connection -> IO Handle
ircConnect conn = do
    let hints = defaultHints
            { addrSocketType = Stream
            , addrFlags      = [AI_ADDRCONFIG]
            }
    addrs <- getAddrInfo (Just hints)
                         (Just $ connServer conn)
                         (Just $ show $ connPort conn)
    let addr = head addrs
    bracketOnError
        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
        (\ sock -> close sock >> putStrLn "Connection failed") $
        \ sock -> do
            connect sock (addrAddress addr)
            handle <- socketToHandle sock ReadWriteMode
            hSetBuffering handle LineBuffering
            encoding <- mkTextEncoding "UTF-8//TRANSLIT"
            hSetEncoding handle encoding
            hSetNewlineMode handle (NewlineMode CRLF CRLF)
            return handle

-- | Disconnect from IRC by closing the client's side of the connection. This
-- function is mainly provided for completeness. You should probably use the
-- QUIT command of IRC to quit the network in a manner coordinated with the
-- server.
ircDisconnect :: Handle -> IO ()
ircDisconnect = hClose

-- | Send an IRC command, given in string form, to the server. The given
-- command string shouldn't contain any newlines.
hPutIrcRaw :: Handle -> String -> IO ()
hPutIrcRaw = hPutStrLn

-- | Send an IRC message represented in generic form to the server.
hPutIrcGeneric :: Handle -> GenericMessage -> IO ()
hPutIrcGeneric h = hPutIrcRaw h . serializeMessage

-- | Send an IRC message to the server.
hPutIrc :: Handle -> Message -> IO ()
hPutIrc h = hPutIrcGeneric h . buildMessage . SpecificMessage Nothing

-- | Receive an IRC message, given in string form, from the server. The
-- resulting string won't contain newlines.
hGetIrcRaw :: Handle -> IO String
hGetIrcRaw = hGetLine

-- | Receive an IRC message in generic form from the server. If parsing the
-- message read from the server fails, 'Nothing' is returned.
hGetIrcGenericOnce :: Handle -> IO (Maybe GenericMessage)
hGetIrcGenericOnce h = liftM parseMessage $ hGetIrcRaw h

-- | A variant of 'hGetIrcGenericOnce' which returns 'Left' the message if
-- parsing fails.
hGetIrcGenericOnce' :: Handle -> IO (Either String GenericMessage)
hGetIrcGenericOnce' h = do
    line <- hGetIrcRaw h
    return $ case parseMessage line of
        Just msg -> Right msg
        Nothing  -> Left line

-- | Receive the next valid (successfully parsed) IRC message in generic form
-- from the server.
hGetIrcGeneric :: Handle -> IO GenericMessage
hGetIrcGeneric h = hGetIrcGenericOnce h >>= maybe (hGetIrcGeneric h) return

-- | A variant of 'hGetIrcGeneric' which also returns a list of erronous IRC
-- lines received.
hGetIrcGeneric' :: Handle -> IO ([String], GenericMessage)
hGetIrcGeneric' h = do
    (l, gm) <- f []
    return (reverse l, gm)
    where
    f errs = do
        res <- hGetIrcGenericOnce' h
        case res of
            Left s   -> f $ s : errs
            Right gm -> return (errs, gm)

-- | Receive an IRC message from the server. If parsing the message read from
-- the server fails, 'Nothing' is returned.
hGetIrcOnce :: Handle -> IO (Maybe (Either SpecificReply SpecificMessage))
hGetIrcOnce h = hGetIrcGenericOnce h >>=
    return . maybe Nothing ((either (const Nothing) Just) .  analyze)

-- | A variant of 'hGetIrcOnce' which returns 'Left' some information if
-- parsing/analysis fails.
hGetIrcOnce' :: Handle
             -> IO (Either String (Either SpecificReply SpecificMessage))
hGetIrcOnce' h = do
    res <- hGetIrcGenericOnce' h
    return $ case res of
        Left s   -> Left s
        Right gm ->
            case analyze gm of
                Left err   -> Left $ err ++ " : " ++ show gm
                Right spec -> Right spec

-- | Receive the next valid (successfully parsed) IRC message from the server.
hGetIrc :: Handle -> IO (Either SpecificReply SpecificMessage)
hGetIrc h = hGetIrcOnce h >>= maybe (hGetIrc h) return

-- | A variant of 'hGetIrc' which also returns a list of error messages for
-- IRC lines whose parsing failed.
hGetIrc' :: Handle -> IO ([String], Either SpecificReply SpecificMessage)
hGetIrc' h = do
    (l, m) <- f []
    return (reverse l, m)
    where
    f errs = do
        res <- hGetIrcOnce' h
        case res of
            Left s  -> f $ s : errs
            Right m -> return (errs, m)