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

{-# LANGUAGE ExistentialQuantification #-}
-- {-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE ForeignFunctionInterface #-}
-- {-# LANGUAGE InterruptibleFFI #-}
-- {-# LANGUAGE EmptyDataDecls #-}

-- |
-- 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(..), TlsIO,
  mapOverInput
  ) where

import System.IO.Uniform.External

import Foreign
--import Foreign.C.Types
--import Foreign.C.String
import Foreign.C.Error
--import qualified Data.IP as IP
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
--import qualified Data.ByteString.Lazy as LBS
--import qualified Data.ByteString.Builder as BSBuild
--import qualified Data.List as L
import Control.Exception
import Control.Applicative ((<$>))
--import Data.Monoid (mappend)
--import qualified Network.Socket as Soc
import System.IO.Error
--import Control.Concurrent.MVar

import Data.Default.Class

import System.Posix.Types (Fd(..))

-- |
-- 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 TlsIO
  -- | 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) n = uRead s n
  uPut (SomeIO s) t  = uPut s t
  uClose (SomeIO s) = uClose s
  startTls set (SomeIO s) = 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 "" "" ""
  
-- | UniformIO wrapper that applies TLS to communication on IO target.
-- This type is constructed by calling startTls on other targets.
instance UniformIO TlsIO where
  uRead s n = do
    allocaArray n (
      \b -> do
        count <- c_recvTls (tls s) b $ fromIntegral n
        if count < 0
          then throwErrno "could not read"
          else BS.packCStringLen (b, fromIntegral count)
      )
  uPut s t = do
    BS.useAsCStringLen t (
      \(str, n) -> do
        count <- c_sendTls (tls s) str $ fromIntegral n
        if count < 0
          then throwErrno "could not write"
          else return ()
      )
  uClose s = do
    d <- c_closeTls (tls s)
    f <- Fd <$> c_prepareToClose d
    closeFd f
  startTls _ s = return s
  isSecure _ = True


-- | 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