uniform-io/src/System/IO/Uniform.hs

{-# LANGUAGE ExistentialQuantification #-}

{- |
Uniform-IO provides a typeclass for uniform access of different types of targets,
and implementations for abstracting standard streams, files and network connections.
This module also provides TLS wraping over other IO targets.
-}
module System.IO.Uniform (
  UniformIO(..),
  TlsSettings(..),
  SomeIO(..),
  mapOverInput,
  uGetContents
  ) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Control.Exception
import System.IO.Error

import Data.Default.Class

-- | Typeclass for uniform IO targets.
class UniformIO a where
  {- |
  uRead fd n
  
  Reads a block of at most n bytes of data from the IO target.
  Reading will block if there's no data available, but will return immediately
  if any amount of data is availble.
    
  Must thow System.IO.Error.EOFError if reading beihond EOF.
  -}
  uRead  :: a -> Int -> IO ByteString
  -- | uPut fd text
  --
  --  Writes all the bytes of text into the IO target. Takes care of retrying if needed.
  uPut   :: a -> ByteString -> IO ()
  -- | fClose fd
  --
  --  Closes the IO target, releasing any allocated resource. Resources may leak if not called
  --  for every oppened fd.
  uClose :: a -> IO ()
  -- | startTLS fd
  --
  --  Starts a TLS connection over the IO target.
  startTls :: TlsSettings -> a -> IO a
  -- | isSecure fd
  --
  --  Indicates whether the data written or read from fd is secure at transport.
  isSecure :: a -> Bool
  
-- | A type that wraps any type in the UniformIO class.
data SomeIO = forall a. (UniformIO a) => SomeIO a

instance UniformIO SomeIO where
  uRead (SomeIO s) = uRead s
  uPut (SomeIO s)  = uPut s
  uClose (SomeIO s) = uClose s
  startTls set (SomeIO s) = SomeIO <$> startTls set s
  isSecure (SomeIO s) = isSecure s

-- | Settings for starttls functions.
data TlsSettings = TlsSettings {tlsPrivateKeyFile :: String, tlsCertificateChainFile :: String, tlsDHParametersFile :: String} deriving (Read, Show)

instance Default TlsSettings where
  def = TlsSettings "" "" ""
  
{- |
mapOverInput io block_size f initial

Reads io untill the end of file, evaluating a(i) <- f a(i-1) read_data
where a(0) = initial and the last value after io reaches EOF is returned.

Notice that the length of read_data might not be equal block_size.
-}
mapOverInput :: forall a io. UniformIO io => io -> Int -> (a -> ByteString -> IO a) -> a -> IO a
mapOverInput io block f initial = do
  a <- tryIOError $ uRead io block
  case a of
    Left e -> if isEOFError e then return initial else throw e -- EOF
    Right dt -> do
      i <- f initial dt
      mapOverInput io block f i

{- |
Returns the entire contents recieved from this target.
-}
uGetContents :: UniformIO io => io -> Int -> IO LBS.ByteString
uGetContents io block = LBS.fromChunks <$> mapOverInput io block atEnd []
  where
    atEnd :: [ByteString] -> ByteString -> IO [ByteString]
    atEnd bb b = return $ bb ++ [b]