kevin-0.9.0: Kevin/Base.hs

module Kevin.Base (
    module Kevin.Types,
    KevinException(..),
    _KevinException,
    KevinServer(..),
    User(..),

    module K,

    io,
    runPrinter,

    printf
) where

import Control.Applicative ((<$>))
import Control.Concurrent as K (forkIO)
import Control.Concurrent.Chan as K
import Control.Concurrent.STM.TVar as K
import Control.Exception
import Control.Exception as K (IOException)
import Control.Exception.Lens
import Control.Lens as K
import Control.Monad.CatchIO as K
import Control.Monad.Reader as K
import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable
import Kevin.Chatrooms as K
import Kevin.Settings as K
import Kevin.Types
import Kevin.Util.Logger
import Network as K
import System.IO as K
import System.IO.Error

runPrinter :: Chan T.Text -> Handle -> IO ()
runPrinter ch h = void . forkIO . forever $ readChan ch >>= T.hPutStr h . T.encodeUtf8

io :: MonadIO m => IO a -> m a
io = liftIO

class KevinServer a where
    readClient, readServer   :: a -> IO T.Text
    writeServer              :: a -> T.Text -> IO ()
    writeClient              :: a -> T.Text -> IO ()
    closeClient, closeServer :: a -> IO ()

data KevinException = ParseFailure
    deriving (Show, Typeable)

instance Exception KevinException

_KevinException :: Prism' SomeException KevinException
_KevinException = exception

-- actions

hGetCharTimeout :: Handle -> Int -> IO Char
hGetCharTimeout h t = do hSetBuffering h NoBuffering
                         ready <- hWaitForInput h t
                         if ready
                            then hGetChar h
                            else throwIO $ mkIOError eofErrorType "read timeout" (Just h) Nothing

hGetSep :: Char -> Handle -> IO String
hGetSep sep h = fix (\f -> do ch <- hGetCharTimeout h 180000
                              if ch == sep
                                 then return ""
                                 else (ch:) <$> f)

instance KevinServer Kevin where
    readClient k = do line <- T.decodeUtf8 <$> T.hGetLine (irc k)
                      return $ T.init line
    readServer k = T.pack <$> hGetSep '\NUL' (damn k)

    writeClient k = writeChan (iChan k)
    writeServer k = writeChan (dChan k)

    closeClient = hClose . irc
    closeServer = hClose . damn