Version 0.3 of Image.chs. Not tested yet.

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, TypeFamilies #-}
#include "cvWrapLeo.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq

-- import C2HSTools

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

-- Colorspaces
data GrayScale
data RGB
data RGBA
data LAB

-- Bit Depths
data D8
data D32
data D64

newtype Image channels depth = S BareImage

unS (S i) = i -- Unsafe and ugly

withImage :: Image c d -> (Ptr BareImage ->IO a) -> IO a
withImage (S i) op = withBareImage i op
--withGenNewImage (S i) op = withGenImage i op

-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr BareImage

instance NFData (Image a b) where
    rnf a@(S (BareImage fptr)) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return . S . BareImage $ fptr

creatingBareImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return . BareImage $ fptr

unImage (S (BareImage fptr)) = fptr

data Tag tp;
rgb = undefined :: Tag RGB
lab = undefined :: Tag LAB

composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannelImage (c1)
                         (c2)
                         (c3)
                         (c4)
                         totag
    = unsafePerformIO $ do
        res <- create (size) -- TODO: Check channel count -- This is NOT correct
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- Load Image as grayscale image.

--loadImage n = do
--              exists <- fileExist n
--              if not exists then return Nothing
--                            else do
--                              i <- withCString n $ \name ->
--                                     creatingImage ({#call cvLoadImage #} name (0))
--                              bw <- imageTo32F i
--                              return $ Just bw

loadImage :: FilePath -> IO (Maybe (Image GrayScale Double))
loadImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return . Just . S $ bw

loadColorImage :: FilePath -> IO (Maybe (Image RGB Double))
loadColorImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return . Just . S  $ bw

class IntSized a where
    getSize :: a -> (Int,Int)

instance IntSized BareImage where
   -- getSize :: (Integral a, Integral b) => Image c d -> (a,b)
    getSize image = unsafePerformIO $ withBareImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

instance IntSized (Image c d) where
    getSize = getSize . unS

--loadColorImage n = do
--              exists <- fileExist n
--              if not exists then return Nothing
--                            else do
--                              i <- withCString n $ \name ->
--                                     creatingImage ({#call cvLoadImage #} name 1)
--                              bw <- imageTo32F i
--                              return $ Just bw

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.

rgbToLab :: Image RGB Double -> Image LAB Double
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS

rgbToGray :: Image RGB Double -> Image GrayScale Double
rgbToGray = S . convertTo cvRGBtoGRAY 1 . unS

class GetPixel a where
    type P a :: *
    getPixel   :: (Integral i) => (i,i) -> a -> P a

instance GetPixel (Image GrayScale Double) where
    type P (Image GrayScale Double) = Double
    getPixel (fromIntegral -> x, fromIntegral -> y) image = realToFrac $ unsafePerformIO $
             withGenImage image $ \img -> {#call wrapGet32F2D#} img y x

instance  GetPixel (Image RGB Double) where
    type P (Image RGB Double) = (Double,Double,Double)
    getPixel (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

convertTo :: CInt -> CInt -> BareImage -> BareImage
convertTo code channels img = unsafePerformIO $ creatingBareImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withBareImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (fromIntegral -> w,fromIntegral -> h) = getSize img

class CreateImage a where
    create :: (Int,Int) -> IO a

instance CreateImage (Image GrayScale D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 4

emptyCopy img = create (getSize img)

-- | Save image. This will convert the image to 8 bit one before saving
saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit $ unS image
                           withCString  filename $ \name  ->
                            withGenBareImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getArea :: (IntSized a) => a -> Int
getArea = uncurry (*).getSize

getRegion :: (Int,Int) -> (Int,Int) -> Image c d -> Image c d
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = S . getRegion' (x,y) (w,h) $ unS image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (fromIntegral -> width,fromIntegral -> height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withBareImage image $ \i ->
                                 creatingBareImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
blitFix = blit
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 (fromIntegral y) (fromIntegral x))
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0

blitM :: (CreateImage (Image c d)) => (Int,Int) -> [((Int,Int),Image c d)] -> Image c d
blitM (rw,rh) imgs = resultPic
    where
     resultPic = unsafePerformIO $ do
                    r <- create (fromIntegral rw,fromIntegral rh)
                    sequence_ [blit r i (fromIntegral x, fromIntegral y)
                              | ((x,y),i) <- imgs ]
                    return r

subPixelBlit
  :: Image c d -> Image c d -> (CDouble, CDouble) -> IO ()

subPixelBlit (image1) (image2) (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

withClone img fun = do
                result <- cloneImage img
                fun result
                return result

imageTo32F img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure32F #} image)

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)

-- Manipulating regions of interest:
setROI (x,y) (w,h) image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h
resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI no image
    cres <- {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image
                        resetROI image
                        return x

-- Manipulating image pixels
--setPixel :: (CInt,CInt) -> CDouble -> Image c d -> IO ()
--setPixel (x,y) v image = withGenImage image $ \img ->
--                          {#call wrapSet32F2D#} img y x v

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (CreateImage (Image c d)) => (Int,Int) -> Int -> [Image c d] -> Image c d
montage (u',v') space' imgs = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- create (rw,rh)
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep) | y <- [0..v-1] , x <- [0..u-1] | i <- imgs ]
                    return r

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, TypeFamilies #-}
#include "cvWrapLeo.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq

-- import C2HSTools

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

-- Colorspaces
data GrayScale
data RGB
data RGBA
data LAB

-- Bit Depths
data D8
data D32
data D64

newtype Image channels depth = S BareImage

unS (S i) = i -- Unsafe and ugly

withImage :: Image c d -> (Ptr BareImage ->IO a) -> IO a
withImage (S i) op = withBareImage i op
--withGenNewImage (S i) op = withGenImage i op

-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr BareImage

instance NFData (Image a b) where
    rnf a@(S (BareImage fptr)) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return . S . BareImage $ fptr

creatingBareImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return . BareImage $ fptr

unImage (S (BareImage fptr)) = fptr

data Tag tp;
rgb = undefined :: Tag RGB
lab = undefined :: Tag LAB

composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannelImage (c1)
                         (c2)
                         (c3)
                         (c4)
                         totag
    = unsafePerformIO $ do
        res <- create (size) -- TODO: Check channel count -- This is NOT correct
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- Load Image as grayscale image.

--loadImage n = do
--              exists <- fileExist n
--              if not exists then return Nothing
--                            else do
--                              i <- withCString n $ \name ->
--                                     creatingImage ({#call cvLoadImage #} name (0))
--                              bw <- imageTo32F i
--                              return $ Just bw

loadImage :: FilePath -> IO (Maybe (Image GrayScale Double))
loadImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return . Just . S $ bw

loadColorImage :: FilePath -> IO (Maybe (Image RGB Double))
loadColorImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return . Just . S  $ bw

class Sized a where
    type SizeT a :: *
    getSize :: a -> SizeT a

instance Sized BareImage where
    type SizeT BareImage = (Int,Int)
   -- getSize :: (Integral a, Integral b) => Image c d -> (a,b)
    getSize image = unsafePerformIO $ withBareImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

instance Sized (Image c d) where
    type SizeT (Image c d) = (Int,Int)
    getSize = getSize . unS

--loadColorImage n = do
--              exists <- fileExist n
--              if not exists then return Nothing
--                            else do
--                              i <- withCString n $ \name ->
--                                     creatingImage ({#call cvLoadImage #} name 1)
--                              bw <- imageTo32F i
--                              return $ Just bw

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.

rgbToLab :: Image RGB Double -> Image LAB Double
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS

rgbToGray :: Image RGB Double -> Image GrayScale Double
rgbToGray = S . convertTo cvRGBtoGRAY 1 . unS

class GetPixel a where
    type P a :: *
    getPixel   :: (Integral i) => (i,i) -> a -> P a

instance GetPixel (Image GrayScale Double) where
    type P (Image GrayScale Double) = Double
    getPixel (fromIntegral -> x, fromIntegral -> y) image = realToFrac $ unsafePerformIO $
             withGenImage image $ \img -> {#call wrapGet32F2D#} img y x

instance  GetPixel (Image RGB Double) where
    type P (Image RGB Double) = (Double,Double,Double)
    getPixel (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

convertTo :: CInt -> CInt -> BareImage -> BareImage
convertTo code channels img = unsafePerformIO $ creatingBareImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withBareImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (fromIntegral -> w,fromIntegral -> h) = getSize img

class CreateImage a where
    create :: (Int,Int) -> IO a

instance CreateImage (Image GrayScale D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 4

emptyCopy img = create (getSize img)

saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit image
                           withCString  filename $ \name  ->
                            withGenImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

--getSize image = unsafePerformIO $ withImage image $ \i -> do
--                 w <- {#call getImageWidth#} i
--                 h <- {#call getImageHeight#} i
--                 return (fromIntegral w,fromIntegral h)

getArea = uncurry (*).getSize

getRegion :: (Integral a) => (a,a) -> (a,a) -> Image c d -> Image c d
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = S . getRegion' (x,y) (w,h) $ unS image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (width,height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withImage image $ \i ->
                                 creatingImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
blitFix = blit
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0

blitM :: (Int,Int) -> [((Int,Int),Image c d)] -> Image c d
blitM (rw,rh) imgs = resultPic
    where
     resultPic = unsafePerformIO $ do
                    r <- create (fromIntegral rw,fromIntegral rh)
                    sequence_ [blit r i (fromIntegral x, fromIntegral y)
                              | ((x,y),i) <- imgs ]
                    return r

subPixelBlit
  :: Image c d -> Image c d -> (CDouble, CDouble) -> IO ()

subPixelBlit (unS -> image1) (unS -> image2) (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

withClone img fun = do
                result <- cloneImage img
                fun result
                return result

imageTo32F img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure32F #} image)

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)

-- Manipulating regions of interest:
setROI (x,y) (w,h) image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h
resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI no image
    cres <- {#call wrapCreateImage32F#} w h 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image
                        resetROI image
                        return x

-- Manipulating image pixels
--setPixel :: (CInt,CInt) -> CDouble -> Image c d -> IO ()
--setPixel (x,y) v image = withGenImage image $ \img ->
--                          {#call wrapSet32F2D#} img y x v

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (Int,Int) -> Int -> [Image c d] -> Image c d
montage (u',v') space' imgs = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- create (rw,rh) 1
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep) | y <- [0..v-1] , x <- [0..u-1] | i <- imgs ]
                    return r


add rewireEdges

add rewireEdges

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IGraph.Algorithms.Generators
    ( full
    , star
    , ring
    , ErdosRenyiModel(..)
    , erdosRenyiGame
    , degreeSequenceGame
    , rewireEdges
    , rewire
    ) where

import           Data.Serialize                 (Serialize)
import Data.Singletons (SingI, Sing, sing, fromSing)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Map.Strict as M
import Control.Monad.Primitive (RealWorld)

import qualified Foreign.Ptr as C2HSImp
import Foreign

import           IGraph
import           IGraph.Mutable (MGraph(..))
{#import IGraph.Internal #}
{#import IGraph.Internal.Constants #}
{# import IGraph.Internal.Initialization #}

#include "haskell_igraph.h"

full :: forall d. SingI d
     => Int   -- ^ The number of vertices in the graph.
     -> Bool  -- ^ Whether to include self-edges (loops)
     -> Graph d () ()
full n hasLoop = unsafePerformIO $ do
    igraphInit
    gr <- igraphFull n directed hasLoop
    initializeNullAttribute gr
    return $ Graph gr M.empty
  where
    directed = case fromSing (sing :: Sing d) of
        D -> True
        U -> False
{#fun igraph_full as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `Int', `Bool', `Bool'
    } -> `CInt' void- #}

-- | Return the Star graph. The center node is always associated with id 0.
star :: Int    -- ^ The number of nodes
     -> Graph 'U () ()
star n = unsafePerformIO $ do
    igraphInit
    gr <- igraphStar n IgraphStarUndirected 0
    initializeNullAttribute gr
    return $ Graph gr M.empty
{#fun igraph_star as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `Int'
    , `StarMode'
    , `Int'
    } -> `CInt' void- #}

-- | Creates a ring graph, a one dimensional lattice.
ring :: Int -> Graph 'U () ()
ring n = unsafePerformIO $ do
    igraphInit
    gr <- igraphRing n False False True
    initializeNullAttribute gr
    return $ Graph gr M.empty
{#fun igraph_ring as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `Int'
    , `Bool'
    , `Bool'
    , `Bool'
    } -> `CInt' void- #}

data ErdosRenyiModel = GNP Int Double  -- ^ G(n,p) graph, every possible edge is
                                       -- included in the graph with probability p.
                     | GNM Int Int   -- ^ G(n,m) graph, m edges are selected
                                     -- uniformly randomly in a graph with n
                                     -- vertices.

erdosRenyiGame :: forall d. SingI d
               => ErdosRenyiModel
               -> Bool  -- ^ self-loop
               -> IO (Graph d () ())
erdosRenyiGame model self = do
    igraphInit
    gr <- case model of
        GNP n p -> igraphErdosRenyiGame IgraphErdosRenyiGnp n p directed self
        GNM n m -> igraphErdosRenyiGame IgraphErdosRenyiGnm n (fromIntegral m)
            directed self
    initializeNullAttribute gr
    return $ Graph gr M.empty
  where
    directed = case fromSing (sing :: Sing d) of
        D -> True
        U -> False
{#fun igraph_erdos_renyi_game as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `ErdosRenyi', `Int', `Double', `Bool', `Bool'
    } -> `CInt' void- #}

-- | Generates a random graph with a given degree sequence.
degreeSequenceGame :: [Int]   -- ^ Out degree
                   -> [Int]   -- ^ In degree
                   -> IO (Graph 'D () ())
degreeSequenceGame out_deg in_deg = do
    igraphInit
    withList out_deg $ \out_deg' ->
        withList in_deg $ \in_deg' -> do
            gr <- igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple
            initializeNullAttribute gr
            return $ Graph gr M.empty
{#fun igraph_degree_sequence_game as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , castPtr `Ptr Vector', castPtr `Ptr Vector', `Degseq'
    } -> `CInt' void- #}

-- | Rewire the edges of a graph with constant probability.
rewireEdges :: MGraph RealWorld d v e
            -> Double   -- ^ The rewiring probability a constant between zero and
                        -- one (inclusive).
            -> Bool     -- ^ whether loop edges are allowed in the new graph, or not.
            -> Bool     -- ^ whether multiple edges are allowed in the new graph.
            -> IO ()
rewireEdges gr p loop multi = igraphRewireEdges (_mgraph gr) p loop multi
{#fun igraph_rewire_edges as ^
    { `IGraph'
    , `Double'
    , `Bool'
    , `Bool'
    } -> `CInt' void- #}

-- | Randomly rewires a graph while preserving the degree distribution.
rewire :: (Serialize v, Ord v, Serialize e)
       => Int    -- ^ Number of rewiring trials to perform.
       -> Graph d v e
       -> IO (Graph d v e)
rewire n gr = do
    gr' <- thaw gr
    igraphRewire (_mgraph gr') n IgraphRewiringSimple
    unsafeFreeze gr'
{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `CInt' void-#}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IGraph.Algorithms.Generators
    ( full
    , star
    , ring
    , ErdosRenyiModel(..)
    , erdosRenyiGame
    , degreeSequenceGame
    , rewire
    ) where

import           Data.Serialize                 (Serialize)
import Data.Singletons (SingI, Sing, sing, fromSing)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Map.Strict as M

import qualified Foreign.Ptr as C2HSImp
import Foreign

import           IGraph
import           IGraph.Mutable (MGraph(..))
{#import IGraph.Internal #}
{#import IGraph.Internal.Constants #}
{# import IGraph.Internal.Initialization #}

#include "haskell_igraph.h"

full :: forall d. SingI d
     => Int   -- ^ The number of vertices in the graph.
     -> Bool  -- ^ Whether to include self-edges (loops)
     -> Graph d () ()
full n hasLoop = unsafePerformIO $ do
    igraphInit
    gr <- igraphFull n directed hasLoop
    initializeNullAttribute gr
    return $ Graph gr M.empty
  where
    directed = case fromSing (sing :: Sing d) of
        D -> True
        U -> False
{#fun igraph_full as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `Int', `Bool', `Bool'
    } -> `CInt' void- #}

-- | Return the Star graph. The center node is always associated with id 0.
star :: Int    -- ^ The number of nodes
     -> Graph 'U () ()
star n = unsafePerformIO $ do
    igraphInit
    gr <- igraphStar n IgraphStarUndirected 0
    initializeNullAttribute gr
    return $ Graph gr M.empty
{#fun igraph_star as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `Int'
    , `StarMode'
    , `Int'
    } -> `CInt' void- #}

-- | Creates a ring graph, a one dimensional lattice.
ring :: Int -> Graph 'U () ()
ring n = unsafePerformIO $ do
    igraphInit
    gr <- igraphRing n False False True
    initializeNullAttribute gr
    return $ Graph gr M.empty
{#fun igraph_ring as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `Int'
    , `Bool'
    , `Bool'
    , `Bool'
    } -> `CInt' void- #}

data ErdosRenyiModel = GNP Int Double
                     | GNM Int Int

erdosRenyiGame :: forall d. SingI d
               => ErdosRenyiModel
               -> Bool  -- ^ self-loop
               -> IO (Graph d () ())
erdosRenyiGame model self = do
    igraphInit
    gr <- case model of
        GNP n p -> igraphErdosRenyiGame IgraphErdosRenyiGnp n p directed self
        GNM n m -> igraphErdosRenyiGame IgraphErdosRenyiGnm n (fromIntegral m)
            directed self
    initializeNullAttribute gr
    return $ Graph gr M.empty
  where
    directed = case fromSing (sing :: Sing d) of
        D -> True
        U -> False
{#fun igraph_erdos_renyi_game as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , `ErdosRenyi', `Int', `Double', `Bool', `Bool'
    } -> `CInt' void- #}

-- | Generates a random graph with a given degree sequence.
degreeSequenceGame :: [Int]   -- ^ Out degree
                   -> [Int]   -- ^ In degree
                   -> IO (Graph 'D () ())
degreeSequenceGame out_deg in_deg = do
    igraphInit
    withList out_deg $ \out_deg' ->
        withList in_deg $ \in_deg' -> do
            gr <- igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple
            initializeNullAttribute gr
            return $ Graph gr M.empty
{#fun igraph_degree_sequence_game as ^
    { allocaIGraph- `IGraph' addIGraphFinalizer*
    , castPtr `Ptr Vector', castPtr `Ptr Vector', `Degseq'
    } -> `CInt' void- #}

-- | Randomly rewires a graph while preserving the degree distribution.
rewire :: (Serialize v, Ord v, Serialize e)
       => Int    -- ^ Number of rewiring trials to perform.
       -> Graph d v e
       -> IO (Graph d v e)
rewire n gr = do
    gr' <- thaw gr
    igraphRewire (_mgraph gr') n IgraphRewiringSimple
    unsafeFreeze gr'
{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `CInt' void-#}


Write export list for Network.Grpc.Core.Call.

-- Copyright (c) 2016, Google Inc.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of Google Inc. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL Google Inc. BE LIABLE FOR ANY
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
--------------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ExistentialQuantification, RecordWildCards, NamedFieldPuns #-}
module Network.Grpc.Core.Call
  ( Deadline(..)
  , ClientContext
  , CallOptions
  , withAbsoluteDeadline
  , withRelativeDeadlineSeconds
  , withRelativeDeadlineMillis
  , withParentContext
  , withParentContextPropagating
  , withMetadata
  , withCompression

  , newClientContext
  , destroyClientContext
  , MethodName
  , Arg

  , UnaryResult(..)
  , callUnary
  , callUpstream
  , callDownstream
  , callBidi
  , Client
  , Decoder
  , Encoder
  , Rpc
  , runRpc
  , joinReply

  , RpcReply(..)
  , RpcError(..)
  , RpcStatus(..)

  , initialMetadata
  , waitForStatus
  , sendMessage
  , receiveMessage
  , receiveAllMessages
  , closeCall
  , sendHalfClose
  , cancelCall
  , cancelCallWithStatus
  ) where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad

import qualified Data.ByteString              as B
import qualified Data.ByteString.Lazy         as L
import           Data.Maybe (maybeToList)
import           Data.Monoid ((<>), Last(..))
import           Data.IORef

import           Foreign.C.Types              as C
import qualified Foreign.Marshal.Alloc        as C
import qualified Foreign.Ptr                  as C
import           Foreign.Ptr (Ptr)
import qualified Foreign.ForeignPtr           as C
import qualified Foreign.Storable             as C

-- transformers
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except

import qualified Network.Grpc.CompletionQueue as CQ
import Network.Grpc.Lib.PropagationBits
{#import Network.Grpc.Lib.ByteBuffer#} (Slice, CSlice, ByteBuffer)
import qualified Network.Grpc.Lib.ByteBuffer as BB
{#import Network.Grpc.Lib.Metadata#}
{#import Network.Grpc.Lib.TimeSpec#}
{#import Network.Grpc.Lib.Core#}

#include <grpc/grpc.h>
#include "hs_grpc.h"

{#context lib = "grpc" prefix = "grpc" #}

data Deadline
  = AbsoluteDeadline TimeSpec
  | RelativeDeadline Int -- milliseconds

data ClientContext = ClientContext
  { ccChannel :: Channel
  , ccCQ :: CompletionQueue
  , ccWorker :: CQ.Worker
  }

data CallOptions = CallOptions
  { coDeadline :: Maybe Deadline
  , coParentContext :: Maybe () -- todo
  , coPropagationMask :: Maybe PropagationMask
  , coMetadata :: [Metadata]
  , coCompressionAlgo :: Maybe CompressionAlgorithm
  }

instance Monoid CallOptions where
  mempty = CallOptions Nothing Nothing Nothing [] Nothing
  mappend (CallOptions a b c d e) (CallOptions a' b' c' d' e') =
    CallOptions
      (getLast (Last a <> Last a'))
      (getLast (Last b <> Last b'))
      (getLast (Last c <> Last c'))
      (d <> d')
      (getLast (Last e <> Last e'))

withAbsoluteDeadline :: TimeSpec -> CallOptions
withAbsoluteDeadline deadline =
  mempty { coDeadline = Just (AbsoluteDeadline deadline) }

withRelativeDeadlineSeconds :: Int -> CallOptions
withRelativeDeadlineSeconds seconds =
  mempty { coDeadline = Just (RelativeDeadline (seconds*1000)) }

withRelativeDeadlineMillis :: Int -> CallOptions
withRelativeDeadlineMillis ms =
  mempty { coDeadline = Just (RelativeDeadline ms) }

withParentContext :: () -> CallOptions
withParentContext ctx =
  mempty { coParentContext = Just ctx }

withParentContextPropagating :: () -> PropagationMask -> CallOptions
withParentContextPropagating ctx prop =
  mempty { coParentContext   = Just ctx
         , coPropagationMask = Just prop }

withMetadata :: [Metadata] -> CallOptions
withMetadata md =
  mempty { coMetadata = md }

withCompression :: CompressionAlgorithm -> CallOptions
withCompression algo = mempty { coCompressionAlgo = Just algo }

compressionAsMetadata :: CompressionAlgorithm -> Metadata
compressionAsMetadata algo =
  Metadata
    compressionRequestAlgorithmMdKey
    (compressionAlgorithmName algo)
    0

metadataToSend :: CallOptions -> [Metadata]
metadataToSend co =
  maybeToList (compressionAsMetadata <$> coCompressionAlgo co)
  ++ coMetadata co

resolveDeadline :: CallOptions -> IO TimeSpec
resolveDeadline co =
  case coDeadline co of
    Nothing -> return gprInfFuture
    Just (AbsoluteDeadline deadline) -> return deadline
    Just (RelativeDeadline ms) ->
      millisFromNow (fromIntegral ms)

newClientContext :: Channel -> IO ClientContext
newClientContext chan = do
  cq <- completionQueueCreateForNext reservedPtr
  cqt <- CQ.startCompletionQueueThread cq
  return (ClientContext chan cq cqt)

destroyClientContext :: ClientContext -> IO ()
destroyClientContext ClientContext{ccCQ, ccWorker} = do
  completionQueueShutdown ccCQ
  CQ.waitWorkerTermination ccWorker

type MethodName = Slice
type Arg = B.ByteString

reservedPtr :: Ptr ()
reservedPtr = C.nullPtr

data UnaryResult a = UnaryResult [Metadata] [Metadata] a deriving Show

callUnary :: ClientContext -> CallOptions -> MethodName -> Arg -> IO (RpcReply (UnaryResult L.ByteString))
callUnary ctx@ClientContext{ccChannel, ccCQ} co method arg = do
  deadline <- resolveDeadline co
  bracket (grpcChannelCreateCall (cChannel ccChannel) C.nullPtr propagateDefaults ccCQ method (cHost ccChannel) deadline) grpcCallUnref $ \call0 -> newMVar call0 >>= \mcall -> do
    crw <- newClientReaderWriter ctx mcall

    sendInitOp <- opSendInitialMetadata (metadataToSend co)
    sendCloseOp <- opSendCloseFromClient
    sendMessageOp <- opSendMessage arg
    recvStatusOp <- opRecvStatusOnClient crw
    recvMessageOp <- opRecvMessage
    recvInitialMetadataOp <- opRecvInitialMetadata crw

    res <- callBatch crw [
          OpX sendInitOp
        , OpX sendCloseOp
        , OpX recvInitialMetadataOp
        , OpX recvMessageOp
        , OpX sendMessageOp
        , OpX recvStatusOp
        ]
    case res of
      RpcOk _ -> do
        (RpcStatus trailMD status statusDetails) <- opRead recvStatusOp
        case status of
          StatusOk -> do
            initMD <- opRead recvInitialMetadataOp
            answ <- opRead recvMessageOp
            let answ' = maybe L.empty id answ
            return (RpcOk (UnaryResult initMD trailMD answ'))
          _ -> return (RpcError (StatusError status statusDetails))
      RpcError err -> return (RpcError err)

callDownstream :: ClientContext -> CallOptions -> MethodName -> Arg -> IO (RpcReply (Client B.ByteString L.ByteString))
callDownstream ctx@ClientContext{ccChannel, ccCQ} co method arg = do
  deadline <- resolveDeadline co
  mcall <- grpcChannelCreateCall (cChannel ccChannel) C.nullPtr propagateDefaults ccCQ method (cHost ccChannel) deadline >>= newMVar

  crw <- newClientReaderWriter ctx mcall
  let client = RpcOk (Client crw defaultEncoder defaultDecoder)

  sendInitOp <- opSendInitialMetadata (metadataToSend co)
  sendCloseOp <- opSendCloseFromClient
  sendMessageOp <- opSendMessage arg
  res <- callBatch crw [
        OpX sendInitOp
      , OpX sendCloseOp
      , OpX sendMessageOp
      ]
  case res of
    RpcOk _ -> return client
    RpcError _ -> do
      clientCloseCall crw
      stat <- clientWaitForStatus crw
      case stat of
        RpcOk (RpcStatus _ code msg) -> return (RpcError (StatusError code msg))
        RpcError err -> return (RpcError err)

callUpstream :: ClientContext -> CallOptions -> MethodName -> IO (RpcReply (Client B.ByteString L.ByteString))
callUpstream ctx@ClientContext{ccChannel, ccCQ} co method = do
  deadline <- resolveDeadline co
  mcall <- grpcChannelCreateCall (cChannel ccChannel) C.nullPtr propagateDefaults ccCQ method (cHost ccChannel) deadline >>= newMVar

  crw <- newClientReaderWriter ctx mcall
  let client = RpcOk (Client crw defaultEncoder defaultDecoder)
  sendInitOp <- opSendInitialMetadata (metadataToSend co)
  res <- callBatch crw [ OpX sendInitOp ]

  case res of
    RpcOk _ -> return client
    RpcError _ -> do
      clientCloseCall crw
      stat <- clientWaitForStatus crw
      case stat of
        RpcOk (RpcStatus _ code msg) -> return (RpcError (StatusError code msg))
        RpcError err -> return (RpcError err)

callBidi :: ClientContext -> CallOptions -> MethodName -> IO (RpcReply (Client B.ByteString L.ByteString))
callBidi ctx@ClientContext{ccChannel, ccCQ} co method = do
  deadline <- resolveDeadline co
  mcall <- grpcChannelCreateCall (cChannel ccChannel) C.nullPtr propagateDefaults ccCQ method (cHost ccChannel) deadline >>= newMVar

  crw <- newClientReaderWriter ctx mcall
  let client = Client crw defaultEncoder defaultDecoder
  sendInitOp <- opSendInitialMetadata (metadataToSend co)
  res <- callBatch crw [ OpX sendInitOp ]

  case res of
    RpcOk _ -> return (RpcOk client)
    RpcError _ -> do
      clientCloseCall crw
      stat <- clientWaitForStatus crw
      case stat of
        RpcOk (RpcStatus _ code msg) -> return (RpcError (StatusError code msg))
        RpcError err -> return (RpcError err)

data Client req resp = Client
  { clientCrw :: ClientReaderWriter
  , clientEncoder :: Encoder req
  , clientDecoder :: Decoder resp
  }

type Decoder a = L.ByteString -> IO (RpcReply a)
type Encoder a = a -> IO (RpcReply B.ByteString)

defaultDecoder :: L.ByteString -> IO (RpcReply L.ByteString)
defaultDecoder bs = return (RpcOk bs)

defaultEncoder :: B.ByteString -> IO (RpcReply B.ByteString)
defaultEncoder bs = return (RpcOk bs)

data ClientReaderWriter = ClientReaderWriter {
  context :: ClientContext,
  callMVar_ :: MVar Call,
  initialMDRef :: !(IORef (Maybe [Metadata])),
  trailingMDRef :: !(IORef (Maybe [Metadata])),
  statusFromServer :: !(MVar RpcStatus)
}

newClientReaderWriter :: ClientContext -> MVar Call -> IO ClientReaderWriter
newClientReaderWriter ctx mcall = do
  initMD <- newIORef Nothing
  trailMD <- newIORef Nothing
  status <- newEmptyMVar
  return (ClientReaderWriter ctx mcall initMD trailMD status)

data OpX = forall t. OpX (OpT t)

data OpArray = OpArray { opArrPtr           :: !GrpcOpPtr
                       , opArrLen           :: !CULong
                       , opArrFinishAndFree :: !(IO ())
                       }

toArray :: [OpX] -> IO OpArray
toArray ops = do
  aptr <- C.mallocBytes (length ops * {#sizeof grpc_op#})
  let ptrs = iterate (`C.plusPtr` {#sizeof grpc_op#}) aptr
      ops' = concatMap (\(OpX op) -> opAdd op) ops
      free = C.free aptr >> sequence_ (map (\(OpX op) -> opFinish op) ops)
      write op p = do
        {#set grpc_op->flags#} p 0
        {#set grpc_op->reserved#} p C.nullPtr
        op p
  zipWithM_ write ops' ptrs
  return $! OpArray aptr (fromIntegral $ length ops) free

callBatch :: ClientReaderWriter -> [OpX] -> IO (RpcReply ())
callBatch crw ops = do
  let ctx = context crw
  arr <- toArray ops
  let onBatchComplete = opArrFinishAndFree arr
  CQ.withEvent (ccWorker ctx) onBatchComplete $ \eDesc -> do
    callStatus <- withMVar (callMVar_ crw) $ \call ->
      grpcCallStartBatch call (opArrPtr arr) (opArrLen arr) (CQ.eventTag eDesc) reservedPtr
    case callStatus of
      CallOk -> do
        e <- CQ.interruptibleWaitEvent eDesc
        case e of
          QueueOpComplete OpSuccess _ -> return (RpcOk ())
          QueueOpComplete OpError _ -> return (RpcError (Error "callBatch: op error"))
          QueueTimeOut -> return (RpcError DeadlineExceeded)
          QueueShutdown -> return (RpcError (Error "queue shutdown"))
      _ -> do
         return (RpcError (CallErrorStatus callStatus))

data OpT out = Op
  { opAdd    :: [Ptr GrpcOp -> IO ()]
  , opValue  :: IORef out
  , opFinish :: IO ()
  }

opRead :: OpT a -> IO a
opRead op = readIORef (opValue op)

opRecvInitialMetadata :: ClientReaderWriter -> IO (OpT [Metadata])
opRecvInitialMetadata crw = do
  arr <- mallocMetadataArray
  value <- newIORef (error "opRecvInitialMetadata never finished")
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpRecvInitialMetadata))
        {#set grpc_op->data.recv_initial_metadata.recv_initial_metadata#} p arr
      ]
    finish = do
      mds <- readMetadataArray arr
      writeIORef (initialMDRef crw) (Just mds)
      writeIORef value mds
      freeMetadataArray arr
  return (Op add value finish)

opSendMessage :: B.ByteString -> IO (OpT ())
opSendMessage bs = do
  bb <- BB.fromByteString bs
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendMessage))
        {#set grpc_op->data.send_message.send_message#} p bb
      ]
    finish =
      BB.byteBufferDestroy bb
  return (Op add value finish)

opRecvMessage :: IO (OpT (Maybe L.ByteString))
opRecvMessage = do
  bbptr <- C.malloc :: IO (Ptr (Ptr BB.CByteBuffer))
  value <- newIORef Nothing
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpRecvMessage))
        {#set grpc_op->data.recv_message.recv_message#} p bbptr
      ]
    finish = do
      bb <- C.peek bbptr
      C.free bbptr
      writeIORef value =<< if bb /= C.nullPtr
        then do
          lbs <- BB.toLazyByteString bb
          BB.byteBufferDestroy bb
          return (Just lbs)
        else return Nothing
  return (Op add value finish)

opSendInitialMetadata :: [Metadata] -> IO (OpT ())
opSendInitialMetadata elems = do
  (mdArrPtr, free) <- mallocMetadata elems
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendInitialMetadata))
        {#set grpc_op->data.send_initial_metadata.count#} p (fromIntegral (length elems))
        {#set grpc_op->data.send_initial_metadata.metadata#} p (C.castPtr mdArrPtr)
        {#set grpc_op->data.send_initial_metadata.maybe_compression_level.is_set#} p 0
        {#set grpc_op->data.send_initial_metadata.maybe_compression_level.level#} p 0
      ]
    finish = do
      free
  return (Op add value finish)

opRecvStatusOnClient :: ClientReaderWriter -> IO (OpT RpcStatus)
opRecvStatusOnClient (ClientReaderWriter{..}) = do
  trailingMetadataArrPtr <- mallocMetadataArray
  statusCodePtr <- C.malloc :: IO (Ptr StatusCodeT)
  statusSlice <- BB.mallocSlice
  value <- newIORef (error "opRecvStatusOnClient never ran")
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpRecvStatusOnClient))
        {#set grpc_op->data.recv_status_on_client.trailing_metadata#} p trailingMetadataArrPtr
        {#set grpc_op->data.recv_status_on_client.status#} p statusCodePtr
        C.withForeignPtr statusSlice $ \statusSlice' -> {#set grpc_op->data.recv_status_on_client.status_details#} p statusSlice'
      ]
    finish = do
      trailingMd <- readMetadataArray trailingMetadataArrPtr
      statusCode <- fmap toStatusCode (C.peek statusCodePtr)
      statusDetails <- BB.toByteString statusSlice
      let status = RpcStatus trailingMd statusCode statusDetails
      writeIORef value status
      putMVar statusFromServer status
      free
    free = do
      freeMetadataArray trailingMetadataArrPtr
      C.free statusCodePtr
      C.finalizeForeignPtr statusSlice
  return (Op add value finish)

opSendCloseFromClient :: IO (OpT ())
opSendCloseFromClient = do
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendCloseFromClient))
      ]
    finish =
      return ()
  return (Op add value finish)

clientWaitForInitialMetadata :: ClientReaderWriter -> IO (RpcReply [Metadata])
clientWaitForInitialMetadata crw@(ClientReaderWriter { .. }) = do
  initMD <- readIORef initialMDRef
  case initMD of
    Just md -> return (RpcOk md)
    Nothing -> do
      recvInitialMetadataOp <- opRecvInitialMetadata crw
      res <- callBatch crw [ OpX recvInitialMetadataOp ]
      case res of
        RpcOk _ -> do
          md <- opRead recvInitialMetadataOp
          writeIORef initialMDRef (Just md)
          return (RpcOk md)
        RpcError err ->
          return (RpcError err)

clientRead :: ClientReaderWriter -> IO (RpcReply (Maybe L.ByteString))
clientRead crw = do
  _ <- clientWaitForInitialMetadata crw
  recvMessage crw

recvMessage :: ClientReaderWriter -> IO (RpcReply (Maybe L.ByteString))
recvMessage crw = do
  recvMessageOp <- opRecvMessage
  res <- callBatch crw [ OpX recvMessageOp ]
  case res of
    RpcOk _ -> do
      bs <- opRead recvMessageOp
      return (RpcOk bs)
    RpcError err -> do
      putStrLn "recvMessage: callBatch failed"
      return (RpcError err)

clientWaitForStatus :: ClientReaderWriter -> IO (RpcReply RpcStatus)
clientWaitForStatus crw = do
  prev <- tryReadMVar (statusFromServer crw)
  case prev of
    Just stat -> do
      return (RpcOk stat)
    Nothing -> do
      statusOp <- opRecvStatusOnClient crw
      res <- callBatch crw [ OpX statusOp ]
      case res of
        RpcOk _ -> do
          status <- opRead statusOp
          return (RpcOk status)
        RpcError err ->
          return (RpcError err)

clientWrite :: ClientReaderWriter -> B.ByteString -> IO (RpcReply ())
clientWrite crw@(ClientReaderWriter{..}) arg = do
  sendMessageOp <- opSendMessage arg
  callBatch crw [ OpX sendMessageOp ]

clientSendHalfClose :: ClientReaderWriter -> IO (RpcReply ())
clientSendHalfClose crw@(ClientReaderWriter{..}) = do
  sendCloseOp <- opSendCloseFromClient
  callBatch crw [ OpX sendCloseOp ]

clientCloseCall :: ClientReaderWriter -> IO ()
clientCloseCall crw@ClientReaderWriter{..} = do
  _ <- clientWaitForStatus crw
  modifyMVar_ callMVar_ $ \call -> do
    grpcCallUnref call
    return (error "grpcCallUnref called on this Call")

clientCancelCall :: ClientReaderWriter -> IO (RpcReply ())
clientCancelCall ClientReaderWriter{..} = do
  err <- withMVar callMVar_ $ \call -> do
    grpcCallCancel call reservedPtr
  case err of
    CallOk -> return (RpcOk ())
    _ -> return (RpcError (CallErrorStatus err))

clientCancelCallWithStatus :: ClientReaderWriter -> StatusCode -> B.ByteString -> IO (RpcReply ())
clientCancelCallWithStatus ClientReaderWriter{..} status details = do
  err <- withMVar callMVar_ $ \call -> do
    grpcCallCancelWithStatus call status details reservedPtr
  case err of
    CallOk -> return (RpcOk ())
    _ -> return (RpcError (CallErrorStatus err))

type Rpc a = ExceptT RpcError IO a

joinReply :: RpcReply a -> Rpc a
joinReply (RpcOk a) = return a
joinReply (RpcError err) = throwE err

runRpc :: Rpc a -> IO (RpcReply a)
runRpc m = do
  e <- runExceptT m
  case e of
    Left err -> return (RpcError err)
    Right a -> return (RpcOk a)

clientRWOp :: Client req resp -> (ClientReaderWriter -> IO a) -> Rpc a
clientRWOp client act =
  liftIO (act (clientCrw client))

joinClientRWOp :: Client req resp -> (ClientReaderWriter -> IO (RpcReply a)) -> Rpc a
joinClientRWOp client act = do
  x <- clientRWOp client act
  joinReply x

branchOnClientStatus :: Client req resp
               -> Rpc a
               -> Rpc a
               -> (StatusCode -> B.ByteString -> Rpc a)
               -> Rpc a
branchOnClientStatus client onProcessing onSuccess onFail = do
  status <- clientRWOp client (tryReadMVar . statusFromServer)
  case status of
    Nothing -> onProcessing
    Just (RpcStatus _ code msg)
      | code == StatusOk -> onSuccess
      | otherwise -> onFail code msg

throwIfErrorStatus :: Client req resp -> Rpc ()
throwIfErrorStatus client =
  branchOnClientStatus
    client
    (return ())
    (return ())
    (\code msg -> throwE (StatusError code msg))

initialMetadata :: Client req resp -> Rpc [Metadata]
initialMetadata client = do
  joinClientRWOp client clientWaitForInitialMetadata

waitForStatus :: Client req resp -> Rpc RpcStatus
waitForStatus client = do
  _ <- clientRWOp client clientWaitForInitialMetadata
  joinClientRWOp client clientWaitForStatus

receiveMessage :: Client req resp -> Rpc (Maybe resp)
receiveMessage client = do
  throwIfErrorStatus client
  msg <- joinClientRWOp client clientRead
  case msg of
    Nothing -> return Nothing
    Just x -> do
      let decoder = clientDecoder client
      liftM Just (joinReply =<< liftIO (decoder x))

receiveAllMessages :: Client req resp -> Rpc [resp]
receiveAllMessages client = do
  let
    decoder = clientDecoder client
    go acc = do
        value <- joinClientRWOp client clientRead
        case value of
          Just x -> do
            y <- joinReply =<< (liftIO (decoder x))
            go (y:acc)
          Nothing -> return (reverse acc)
  go []

sendMessage :: Client req resp -> req -> Rpc ()
sendMessage client req = do
  throwIfErrorStatus client
  let encoder = clientEncoder client
  bs <- joinReply =<< liftIO (encoder req)
  joinClientRWOp client (\crw -> clientWrite crw bs)

sendHalfClose :: Client req resp -> Rpc ()
sendHalfClose client = do
  throwIfErrorStatus client
  joinClientRWOp client clientSendHalfClose

closeCall :: Client req resp -> Rpc ()
closeCall client = do
  status <- waitForStatus client
  clientRWOp client clientCloseCall
  case status of
    RpcStatus _ StatusOk _ -> return ()
    RpcStatus _ code detail -> throwE (StatusError code detail)

-- | Called by clients to cancel an RPC on the server.
-- Can be called multiple times, from any thread.
cancelCall :: Client req resp -> Rpc ()
cancelCall client = do
  _ <- clientRWOp client clientCancelCall
  return ()

-- | Called by clients to cancel an RPC on the server.
-- Can be called multiple times, from any thread.
-- If a status has not been received for the call, set it to the status code
-- and description passed in.
-- Importantly, this function does not send status nor description to the
-- remote endpoint.
cancelCallWithStatus :: Client req resp -> StatusCode -> B.ByteString -> Rpc ()
cancelCallWithStatus client status details =
  joinClientRWOp client (\crw -> clientCancelCallWithStatus crw status details)

data RpcStatus = RpcStatus [Metadata] StatusCode B.ByteString
  deriving Show

data RpcReply a
  = RpcOk a
  | RpcError RpcError
  deriving Show

data RpcError
  = DeadlineExceeded
  | Cancelled
  | Error String
  | CallErrorStatus CallError
  | StatusError StatusCode B.ByteString
  deriving Show

-- Copyright (c) 2016, Google Inc.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of Google Inc. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL Google Inc. BE LIABLE FOR ANY
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
--------------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ExistentialQuantification, RecordWildCards #-}
module Network.Grpc.Core.Call where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad

import qualified Data.ByteString              as B
import qualified Data.ByteString.Lazy         as L
import           Data.Maybe (maybeToList)
import           Data.Monoid ((<>), Last(..))
import           Data.IORef

import           Foreign.C.Types              as C
import qualified Foreign.Marshal.Alloc        as C
import qualified Foreign.Ptr                  as C
import           Foreign.Ptr (Ptr)
import qualified Foreign.ForeignPtr           as C
import qualified Foreign.Storable             as C

-- transformers
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except

import qualified Network.Grpc.CompletionQueue as CQ
import Network.Grpc.Lib.PropagationBits
{#import Network.Grpc.Lib.ByteBuffer#} (Slice, CSlice, ByteBuffer)
import qualified Network.Grpc.Lib.ByteBuffer as BB
{#import Network.Grpc.Lib.Metadata#}
{#import Network.Grpc.Lib.TimeSpec#}
{#import Network.Grpc.Lib.Core#}

#include <grpc/grpc.h>
#include "hs_grpc.h"

{#context lib = "grpc" prefix = "grpc" #}

data Deadline
  = AbsoluteDeadline TimeSpec
  | RelativeDeadline Int -- milliseconds

data ClientContext = ClientContext
  { ccChannel :: Channel
  , ccCQ :: CompletionQueue
  , ccWorker :: CQ.Worker
  }

data CallOptions = CallOptions
  { coDeadline :: Maybe Deadline
  , coParentContext :: Maybe () -- todo
  , coPropagationMask :: Maybe PropagationMask
  , coMetadata :: [Metadata]
  , coCompressionAlgo :: Maybe CompressionAlgorithm
  }

instance Monoid CallOptions where
  mempty = CallOptions Nothing Nothing Nothing [] Nothing
  mappend (CallOptions a b c d e) (CallOptions a' b' c' d' e') =
    CallOptions
      (getLast (Last a <> Last a'))
      (getLast (Last b <> Last b'))
      (getLast (Last c <> Last c'))
      (d <> d')
      (getLast (Last e <> Last e'))

withAbsoluteDeadline :: TimeSpec -> CallOptions
withAbsoluteDeadline deadline =
  mempty { coDeadline = Just (AbsoluteDeadline deadline) }

withRelativeDeadlineSeconds :: Int -> CallOptions
withRelativeDeadlineSeconds seconds =
  mempty { coDeadline = Just (RelativeDeadline (seconds*1000)) }

withRelativeDeadlineMillis :: Int -> CallOptions
withRelativeDeadlineMillis ms =
  mempty { coDeadline = Just (RelativeDeadline ms) }

withParentContext :: () -> CallOptions
withParentContext ctx =
  mempty { coParentContext = Just ctx }

withParentContextPropagating :: () -> PropagationMask -> CallOptions
withParentContextPropagating ctx prop =
  mempty { coParentContext   = Just ctx
         , coPropagationMask = Just prop }

withMetadata :: [Metadata] -> CallOptions
withMetadata md =
  mempty { coMetadata = md }

withCompression :: CompressionAlgorithm -> CallOptions
withCompression algo = mempty { coCompressionAlgo = Just algo }

compressionAsMetadata :: CompressionAlgorithm -> Metadata
compressionAsMetadata algo =
  Metadata
    compressionRequestAlgorithmMdKey
    (compressionAlgorithmName algo)
    0

metadataToSend :: CallOptions -> [Metadata]
metadataToSend co =
  maybeToList (compressionAsMetadata <$> coCompressionAlgo co)
  ++ coMetadata co

resolveDeadline :: CallOptions -> IO TimeSpec
resolveDeadline co =
  case coDeadline co of
    Nothing -> return gprInfFuture
    Just (AbsoluteDeadline deadline) -> return deadline
    Just (RelativeDeadline ms) ->
      millisFromNow (fromIntegral ms)

newClientContext :: Channel -> IO ClientContext
newClientContext chan = do
  cq <- completionQueueCreateForNext reservedPtr
  cqt <- CQ.startCompletionQueueThread cq
  return (ClientContext chan cq cqt)

destroyClientContext :: ClientContext -> IO ()
destroyClientContext (ClientContext _ cq w) = do
  completionQueueShutdown cq
  CQ.waitWorkerTermination w

type MethodName = Slice
type Arg = B.ByteString

-- | Run the IO function once, cache it in the MVar.
onceMVar :: MVar (Maybe a) -> IO a -> IO a
onceMVar mvar io = modifyMVar mvar $ \x ->
  case x of
    Just x' -> return (x, x')
    Nothing -> do
      x' <- io
      return (Just x', x')

reservedPtr :: Ptr ()
reservedPtr = C.nullPtr

data UnaryResult a = UnaryResult [Metadata] [Metadata] a deriving Show

callUnary :: ClientContext -> CallOptions -> MethodName -> Arg -> IO (RpcReply (UnaryResult L.ByteString))
callUnary ctx@(ClientContext chan cq _) co method arg = do
  deadline <- resolveDeadline co
  bracket (grpcChannelCreateCall (cChannel chan) C.nullPtr propagateDefaults cq method (cHost chan) deadline) grpcCallUnref $ \call0 -> newMVar call0 >>= \mcall -> do
    crw <- newClientReaderWriter ctx mcall

    sendInitOp <- opSendInitialMetadata (metadataToSend co)
    sendCloseOp <- opSendCloseFromClient
    sendMessageOp <- opSendMessage arg
    recvStatusOp <- opRecvStatusOnClient crw
    recvMessageOp <- opRecvMessage
    recvInitialMetadataOp <- opRecvInitialMetadata crw

    res <- callBatch crw [
          OpX sendInitOp
        , OpX sendCloseOp
        , OpX recvInitialMetadataOp
        , OpX recvMessageOp
        , OpX sendMessageOp
        , OpX recvStatusOp
        ]
    case res of
      RpcOk _ -> do
        (RpcStatus trailMD status statusDetails) <- opRead recvStatusOp
        case status of
          StatusOk -> do
            initMD <- opRead recvInitialMetadataOp
            answ <- opRead recvMessageOp
            let answ' = maybe L.empty id answ
            return (RpcOk (UnaryResult initMD trailMD answ'))
          _ -> return (RpcError (StatusError status statusDetails))
      RpcError err -> return (RpcError err)

callDownstream :: ClientContext -> CallOptions -> MethodName -> Arg -> IO (RpcReply (Client B.ByteString L.ByteString))
callDownstream ctx@(ClientContext chan cq _) co method arg = do
  deadline <- resolveDeadline co
  mcall <- grpcChannelCreateCall (cChannel chan) C.nullPtr propagateDefaults cq method (cHost chan) deadline >>= newMVar

  crw <- newClientReaderWriter ctx mcall
  let client = RpcOk (Client crw defaultEncoder defaultDecoder)

  sendInitOp <- opSendInitialMetadata (metadataToSend co)
  sendCloseOp <- opSendCloseFromClient
  sendMessageOp <- opSendMessage arg
  res <- callBatch crw [
        OpX sendInitOp
      , OpX sendCloseOp
      , OpX sendMessageOp
      ]
  case res of
    RpcOk _ -> return client
    RpcError _ -> do
      clientCloseCall crw
      stat <- clientWaitForStatus crw
      case stat of
        RpcOk (RpcStatus _ code msg) -> return (RpcError (StatusError code msg))
        RpcError err -> return (RpcError err)

callUpstream :: ClientContext -> CallOptions -> MethodName -> IO (RpcReply (Client B.ByteString L.ByteString))
callUpstream ctx@(ClientContext chan cq _) co method = do
  deadline <- resolveDeadline co
  mcall <- grpcChannelCreateCall (cChannel chan) C.nullPtr propagateDefaults cq method (cHost chan) deadline >>= newMVar

  crw <- newClientReaderWriter ctx mcall
  let client = RpcOk (Client crw defaultEncoder defaultDecoder)
  sendInitOp <- opSendInitialMetadata (metadataToSend co)
  res <- callBatch crw [ OpX sendInitOp ]

  case res of
    RpcOk _ -> return client
    RpcError _ -> do
      clientCloseCall crw
      stat <- clientWaitForStatus crw
      case stat of
        RpcOk (RpcStatus _ code msg) -> return (RpcError (StatusError code msg))
        RpcError err -> return (RpcError err)

callBidi :: ClientContext -> CallOptions -> MethodName -> IO (RpcReply (Client B.ByteString L.ByteString))
callBidi ctx@(ClientContext chan cq _) co method = do
  deadline <- resolveDeadline co
  mcall <- grpcChannelCreateCall (cChannel chan) C.nullPtr propagateDefaults cq method (cHost chan) deadline >>= newMVar

  crw <- newClientReaderWriter ctx mcall
  let client = Client crw defaultEncoder defaultDecoder
  sendInitOp <- opSendInitialMetadata (metadataToSend co)
  res <- callBatch crw [ OpX sendInitOp ]

  case res of
    RpcOk _ -> return (RpcOk client)
    RpcError _ -> do
      clientCloseCall crw
      stat <- clientWaitForStatus crw
      case stat of
        RpcOk (RpcStatus _ code msg) -> return (RpcError (StatusError code msg))
        RpcError err -> return (RpcError err)

data Client req resp = Client
  { clientCrw :: ClientReaderWriter
  , clientEncoder :: Encoder req
  , clientDecoder :: Decoder resp
  }

type Decoder a = L.ByteString -> IO (RpcReply a)
type Encoder a = a -> IO (RpcReply B.ByteString)

defaultDecoder :: L.ByteString -> IO (RpcReply L.ByteString)
defaultDecoder bs = return (RpcOk bs)

defaultEncoder :: B.ByteString -> IO (RpcReply B.ByteString)
defaultEncoder bs = return (RpcOk bs)

data ClientReaderWriter = ClientReaderWriter {
  context :: ClientContext,
  callMVar_ :: MVar Call,
  initialMDRef :: !(IORef (Maybe [Metadata])),
  trailingMDRef :: !(IORef (Maybe [Metadata])),
  statusFromServer :: !(MVar RpcStatus)
}

newClientReaderWriter :: ClientContext -> MVar Call -> IO ClientReaderWriter
newClientReaderWriter ctx mcall = do
  initMD <- newIORef Nothing
  trailMD <- newIORef Nothing
  status <- newEmptyMVar
  return (ClientReaderWriter ctx mcall initMD trailMD status)

data OpX = forall t. OpX (OpT t)

data OpArray = OpArray { opArrPtr           :: !GrpcOpPtr
                       , opArrLen           :: !CULong
                       , opArrFinishAndFree :: !(IO ())
                       }

toArray :: [OpX] -> IO OpArray
toArray ops = do
  aptr <- C.mallocBytes (length ops * {#sizeof grpc_op#})
  let ptrs = iterate (`C.plusPtr` {#sizeof grpc_op#}) aptr
      ops' = concatMap (\(OpX op) -> opAdd op) ops
      free = C.free aptr >> sequence_ (map (\(OpX op) -> opFinish op) ops)
      write op p = do
        {#set grpc_op->flags#} p 0
        {#set grpc_op->reserved#} p C.nullPtr
        op p
  zipWithM_ write ops' ptrs
  return $! OpArray aptr (fromIntegral $ length ops) free

callBatch :: ClientReaderWriter -> [OpX] -> IO (RpcReply ())
callBatch crw ops = do
  let ctx = context crw
  arr <- toArray ops
  let onBatchComplete = opArrFinishAndFree arr
  CQ.withEvent (ccWorker ctx) onBatchComplete $ \eDesc -> do
    callStatus <- withMVar (callMVar_ crw) $ \call ->
      grpcCallStartBatch call (opArrPtr arr) (opArrLen arr) (CQ.eventTag eDesc) reservedPtr
    case callStatus of
      CallOk -> do
        e <- CQ.interruptibleWaitEvent eDesc
        case e of
          QueueOpComplete OpSuccess _ -> return (RpcOk ())
          QueueOpComplete OpError _ -> return (RpcError (Error "callBatch: op error"))
          QueueTimeOut -> return (RpcError DeadlineExceeded)
          QueueShutdown -> return (RpcError (Error "queue shutdown"))
      _ -> do
         return (RpcError (CallErrorStatus callStatus))

data OpT out = Op
  { opAdd    :: [Ptr GrpcOp -> IO ()]
  , opValue  :: IORef out
  , opFinish :: IO ()
  }

opRead :: OpT a -> IO a
opRead op = readIORef (opValue op)

opRecvInitialMetadata :: ClientReaderWriter -> IO (OpT [Metadata])
opRecvInitialMetadata crw = do
  arr <- mallocMetadataArray
  value <- newIORef (error "opRecvInitialMetadata never finished")
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpRecvInitialMetadata))
        {#set grpc_op->data.recv_initial_metadata.recv_initial_metadata#} p arr
      ]
    finish = do
      mds <- readMetadataArray arr
      writeIORef (initialMDRef crw) (Just mds)
      writeIORef value mds
      freeMetadataArray arr
  return (Op add value finish)

opSendMessage :: B.ByteString -> IO (OpT ())
opSendMessage bs = do
  bb <- BB.fromByteString bs
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendMessage))
        {#set grpc_op->data.send_message.send_message#} p bb
      ]
    finish =
      BB.byteBufferDestroy bb
  return (Op add value finish)

opRecvMessage :: IO (OpT (Maybe L.ByteString))
opRecvMessage = do
  bbptr <- C.malloc :: IO (Ptr (Ptr BB.CByteBuffer))
  value <- newIORef Nothing
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpRecvMessage))
        {#set grpc_op->data.recv_message.recv_message#} p bbptr
      ]
    finish = do
      bb <- C.peek bbptr
      C.free bbptr
      writeIORef value =<< if bb /= C.nullPtr
        then do
          lbs <- BB.toLazyByteString bb
          BB.byteBufferDestroy bb
          return (Just lbs)
        else return Nothing
  return (Op add value finish)

opSendInitialMetadata :: [Metadata] -> IO (OpT ())
opSendInitialMetadata elems = do
  (mdArrPtr, free) <- mallocMetadata elems
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendInitialMetadata))
        {#set grpc_op->data.send_initial_metadata.count#} p (fromIntegral (length elems))
        {#set grpc_op->data.send_initial_metadata.metadata#} p (C.castPtr mdArrPtr)
        {#set grpc_op->data.send_initial_metadata.maybe_compression_level.is_set#} p 0
        {#set grpc_op->data.send_initial_metadata.maybe_compression_level.level#} p 0
      ]
    finish = do
      free
  return (Op add value finish)

opRecvStatusOnClient :: ClientReaderWriter -> IO (OpT RpcStatus)
opRecvStatusOnClient (ClientReaderWriter{..}) = do
  trailingMetadataArrPtr <- mallocMetadataArray
  statusCodePtr <- C.malloc :: IO (Ptr StatusCodeT)
  statusSlice <- BB.mallocSlice
  value <- newIORef (error "opRecvStatusOnClient never ran")
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpRecvStatusOnClient))
        {#set grpc_op->data.recv_status_on_client.trailing_metadata#} p trailingMetadataArrPtr
        {#set grpc_op->data.recv_status_on_client.status#} p statusCodePtr
        C.withForeignPtr statusSlice $ \statusSlice' -> {#set grpc_op->data.recv_status_on_client.status_details#} p statusSlice'
      ]
    finish = do
      trailingMd <- readMetadataArray trailingMetadataArrPtr
      statusCode <- fmap toStatusCode (C.peek statusCodePtr)
      statusDetails <- BB.toByteString statusSlice
      let status = RpcStatus trailingMd statusCode statusDetails
      writeIORef value status
      putMVar statusFromServer status
      free
    free = do
      freeMetadataArray trailingMetadataArrPtr
      C.free statusCodePtr
      C.finalizeForeignPtr statusSlice
  return (Op add value finish)

opSendCloseFromClient :: IO (OpT ())
opSendCloseFromClient = do
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendCloseFromClient))
      ]
    finish =
      return ()
  return (Op add value finish)

clientWaitForInitialMetadata :: ClientReaderWriter -> IO (RpcReply [Metadata])
clientWaitForInitialMetadata crw@(ClientReaderWriter { .. }) = do
  initMD <- readIORef initialMDRef
  case initMD of
    Just md -> return (RpcOk md)
    Nothing -> do
      recvInitialMetadataOp <- opRecvInitialMetadata crw
      res <- callBatch crw [ OpX recvInitialMetadataOp ]
      case res of
        RpcOk _ -> do
          md <- opRead recvInitialMetadataOp
          writeIORef initialMDRef (Just md)
          return (RpcOk md)
        RpcError err ->
          return (RpcError err)

clientReadInitialMetadata :: ClientReaderWriter -> IO (RpcReply (Maybe [Metadata]))
clientReadInitialMetadata (ClientReaderWriter {..}) = do
  md <- readIORef initialMDRef
  return (RpcOk md)

clientRead :: ClientReaderWriter -> IO (RpcReply (Maybe L.ByteString))
clientRead crw = do
  _ <- clientWaitForInitialMetadata crw
  recvMessage crw

recvMessage :: ClientReaderWriter -> IO (RpcReply (Maybe L.ByteString))
recvMessage crw = do
  recvMessageOp <- opRecvMessage
  res <- callBatch crw [ OpX recvMessageOp ]
  case res of
    RpcOk _ -> do
      bs <- opRead recvMessageOp
      return (RpcOk bs)
    RpcError err -> do
      putStrLn "recvMessage: callBatch failed"
      return (RpcError err)

clientWaitForStatus :: ClientReaderWriter -> IO (RpcReply RpcStatus)
clientWaitForStatus crw = do
  prev <- tryReadMVar (statusFromServer crw)
  case prev of
    Just stat -> do
      return (RpcOk stat)
    Nothing -> do
      statusOp <- opRecvStatusOnClient crw
      res <- callBatch crw [ OpX statusOp ]
      case res of
        RpcOk _ -> do
          status <- opRead statusOp
          return (RpcOk status)
        RpcError err ->
          return (RpcError err)

clientWrite :: ClientReaderWriter -> B.ByteString -> IO (RpcReply ())
clientWrite crw@(ClientReaderWriter{..}) arg = do
  sendMessageOp <- opSendMessage arg
  callBatch crw [ OpX sendMessageOp ]

clientSendHalfClose :: ClientReaderWriter -> IO (RpcReply ())
clientSendHalfClose crw@(ClientReaderWriter{..}) = do
  sendCloseOp <- opSendCloseFromClient
  callBatch crw [ OpX sendCloseOp ]

clientCloseCall :: ClientReaderWriter -> IO ()
clientCloseCall crw@ClientReaderWriter{..} = do
  _ <- clientWaitForStatus crw
  modifyMVar_ callMVar_ $ \call -> do
    grpcCallUnref call
    return (error "grpcCallUnref called on this Call")

clientCancelCall :: ClientReaderWriter -> IO (RpcReply ())
clientCancelCall ClientReaderWriter{..} = do
  err <- withMVar callMVar_ $ \call -> do
    grpcCallCancel call reservedPtr
  case err of
    CallOk -> return (RpcOk ())
    _ -> return (RpcError (CallErrorStatus err))

clientCancelCallWithStatus :: ClientReaderWriter -> StatusCode -> B.ByteString -> IO (RpcReply ())
clientCancelCallWithStatus ClientReaderWriter{..} status details = do
  err <- withMVar callMVar_ $ \call -> do
    grpcCallCancelWithStatus call status details reservedPtr
  case err of
    CallOk -> return (RpcOk ())
    _ -> return (RpcError (CallErrorStatus err))

type Rpc a = ExceptT RpcError IO a

joinReply :: RpcReply a -> Rpc a
joinReply (RpcOk a) = return a
joinReply (RpcError err) = throwE err

runRpc :: Rpc a -> IO (RpcReply a)
runRpc m = do
  e <- runExceptT m
  case e of
    Left err -> return (RpcError err)
    Right a -> return (RpcOk a)

clientRWOp :: Client req resp -> (ClientReaderWriter -> IO a) -> Rpc a
clientRWOp client act =
  liftIO (act (clientCrw client))

joinClientRWOp :: Client req resp -> (ClientReaderWriter -> IO (RpcReply a)) -> Rpc a
joinClientRWOp client act = do
  x <- clientRWOp client act
  joinReply x

branchOnClientStatus :: Client req resp
               -> Rpc a
               -> Rpc a
               -> (StatusCode -> B.ByteString -> Rpc a)
               -> Rpc a
branchOnClientStatus client onProcessing onSuccess onFail = do
  status <- clientRWOp client (tryReadMVar . statusFromServer)
  case status of
    Nothing -> onProcessing
    Just (RpcStatus _ code msg)
      | code == StatusOk -> onSuccess
      | otherwise -> onFail code msg

throwIfErrorStatus :: Client req resp -> Rpc ()
throwIfErrorStatus client =
  branchOnClientStatus
    client
    (return ())
    (return ())
    (\code msg -> throwE (StatusError code msg))

initialMetadata :: Client req resp -> Rpc [Metadata]
initialMetadata client = do
  joinClientRWOp client clientWaitForInitialMetadata

waitForStatus :: Client req resp -> Rpc RpcStatus
waitForStatus client = do
  _ <- clientRWOp client clientWaitForInitialMetadata
  joinClientRWOp client clientWaitForStatus

receiveMessage :: Client req resp -> Rpc (Maybe resp)
receiveMessage client = do
  throwIfErrorStatus client
  msg <- joinClientRWOp client clientRead
  case msg of
    Nothing -> return Nothing
    Just x -> do
      let decoder = clientDecoder client
      liftM Just (joinReply =<< liftIO (decoder x))

receiveAllMessages :: Client req resp -> Rpc [resp]
receiveAllMessages client = do
  let
    decoder = clientDecoder client
    go acc = do
        value <- joinClientRWOp client clientRead
        case value of
          Just x -> do
            y <- joinReply =<< (liftIO (decoder x))
            go (y:acc)
          Nothing -> return (reverse acc)
  go []

sendMessage :: Client req resp -> req -> Rpc ()
sendMessage client req = do
  throwIfErrorStatus client
  let encoder = clientEncoder client
  bs <- joinReply =<< liftIO (encoder req)
  joinClientRWOp client (\crw -> clientWrite crw bs)

sendHalfClose :: Client req resp -> Rpc ()
sendHalfClose client = do
  throwIfErrorStatus client
  joinClientRWOp client clientSendHalfClose

closeCall :: Client req resp -> Rpc ()
closeCall client = do
  status <- waitForStatus client
  clientRWOp client clientCloseCall
  case status of
    RpcStatus _ StatusOk _ -> return ()
    RpcStatus _ code detail -> throwE (StatusError code detail)

-- | Called by clients to cancel an RPC on the server.
-- Can be called multiple times, from any thread.
cancelCall :: Client req resp -> Rpc ()
cancelCall client = do
  _ <- clientRWOp client clientCancelCall
  return ()

-- | Called by clients to cancel an RPC on the server.
-- Can be called multiple times, from any thread.
-- If a status has not been received for the call, set it to the status code
-- and description passed in.
-- Importantly, this function does not send status nor description to the
-- remote endpoint.
cancelCallWithStatus :: Client req resp -> StatusCode -> B.ByteString -> Rpc ()
cancelCallWithStatus client status details =
  joinClientRWOp client (\crw -> clientCancelCallWithStatus crw status details)

data RpcStatus = RpcStatus [Metadata] StatusCode B.ByteString
  deriving Show

data RpcReply a
  = RpcOk a
  | RpcError RpcError
  deriving Show

data RpcError
  = DeadlineExceeded
  | Cancelled
  | Error String
  | CallErrorStatus CallError
  | StatusError StatusCode B.ByteString
  deriving Show


Added webDataSourceGetData

Added webDataSourceGetData

This requires a version of glib with GString patch applied.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
-----------------------------------------------------------------------------
--  Module      :  Graphics.UI.Gtk.WebKit.WebDataSource
--  Author      :  Andy Stewart
--  Copyright   :  (c) 2010 Andy Stewart <lazycat.manatee@gmail.com>
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Note
--
-- Function `webkit_web_data_source_get_data` haven't binding,
-- no idea how to handle `GString`
--
-- Access to the WebKit Web DataSource
-----------------------------------------------------------------------------

module Graphics.UI.Gtk.WebKit.WebDataSource (
-- * Description
-- | Data source encapsulates the content of a WebKitWebFrame. A WebKitWebFrame has a main resource and
-- subresources and the data source provides access to these resources. When a request gets loaded
-- initially, it is set to a provisional state. The application can request for the request that
-- initiated the load by asking for the provisional data source and invoking the
-- 'webDataSourceGetInitialRequest' method of WebKitWebDataSource. This data source may not
-- have enough data and some methods may return empty values. To get a "full" data source with the data
-- and resources loaded, you need to get the non-provisional data source through WebKitWebFrame's
-- 'webFrameGetDataSource' method. This data source will have the data after everything was
-- loaded. Make sure that the data source was finished loading before using any of its methods. You can
-- do this via 'webDataSourceIsLoading'.

-- * Types
  WebDataSource,
  WebDataSourceClass,

-- * Constructors
  webDataSourceNew,

-- * Methods
  webDataSourceGetData,
  webDataSourceGetEncoding,
  webDataSourceGetInitialRequest,
  webDataSourceGetMainResource,
  webDataSourceGetRequest,
  webDataSourceGetSubresources,
  webDataSourceGetUnreachableUri,
  webDataSourceGetWebFrame,
  webDataSourceIsLoading,
) where

import Control.Monad		(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList
import System.Glib.GString
import System.Glib.GError
import Graphics.UI.Gtk.Gdk.Events

{#import Graphics.UI.Gtk.Abstract.Object#}	(makeNewObject)
{#import Graphics.UI.Gtk.WebKit.Types#}
{#import System.Glib.GObject#}

{#context lib="webkit" prefix ="webkit"#}

-- | Creates a new 'WebDataSource' instance.
-- The URL of the 'WebDataSource' will be set to "about:blank".
webDataSourceNew :: IO WebDataSource
webDataSourceNew =
    wrapNewGObject mkWebDataSource $ {#call web_data_source_new#}

-- | Returns the raw data that represents the the frame's content.The data will be incomplete until the
-- data has finished loading. Returns 'Nothing' if the web frame hasn't loaded any data. Use
-- @webkitWebDataSourceIsLoading@ to test if data source is in the process of loading.
webDataSourceGetData :: WebDataSourceClass self => self
                     -> IO (Maybe String)
webDataSourceGetData ds = do
  gstr <- {#call webkit_web_data_source_get_data #}
                 (toWebDataSource ds)
  readGString gstr

-- | Returns the text encoding name as set in the 'WebView', or if not, the text encoding of the response.
webDataSourceGetEncoding ::
   WebDataSourceClass self => self
 -> IO String
webDataSourceGetEncoding ds =
  {#call web_data_source_get_encoding#} (toWebDataSource ds) >>= peekCString

-- | Returns a reference to the original request that was used to load the web content.
-- The NetworkRequest returned by this method is the
-- request prior to the "committed" load state.
-- See 'webDataSourceGetRequest' for getting the "committed" request.
webDataSourceGetInitialRequest ::
   WebDataSourceClass self => self
 -> IO NetworkRequest
webDataSourceGetInitialRequest ds =
  makeNewGObject mkNetworkRequest $ {# call web_data_source_get_initial_request#} (toWebDataSource ds)

-- | Returns the main resource of the data_source
webDataSourceGetMainResource ::
   WebDataSourceClass self => self
 -> IO WebResource
webDataSourceGetMainResource ds =
  makeNewGObject mkWebResource $ {#call web_data_source_get_main_resource#} (toWebDataSource ds)

-- | Returns a NetworkRequest that was used to create this 'WebDataSource'.
-- The NetworkRequest returned by this method is the request that was "committed",
-- and hence, different from the request you get from the 'webDataSourceGetInitialRequest' method.
webDataSourceGetRequest ::
   WebDataSourceClass self => self
 -> IO NetworkRequest
webDataSourceGetRequest ds =
  makeNewGObject mkNetworkRequest $ {# call web_data_source_get_request#} (toWebDataSource ds)

-- | Gives you a List of 'WebResource' objects that compose the 'WebView' to which this 'WebDataSource' is attached.
webDataSourceGetSubresources ::
   WebDataSourceClass self => self
 -> IO [WebResource]
webDataSourceGetSubresources ds = do
  glist <- {#call web_data_source_get_subresources#} (toWebDataSource ds)
  resourcePtr <- fromGList glist
  mapM (makeNewGObject mkWebResource . return) resourcePtr

-- | Return the unreachable URI of data_source.
-- The 'dataSource' will have an unreachable URL
-- if it was created using 'WebFrame''s
-- 'webFrameLoadAlternateHtmlString' method.
webDataSourceGetUnreachableUri ::
   WebDataSourceClass self => self
 -> IO String
webDataSourceGetUnreachableUri ds =
  {#call web_data_source_get_unreachable_uri#} (toWebDataSource ds) >>= peekCString

-- | Returns the 'WebFrame' that represents this data source
webDataSourceGetWebFrame ::
   WebDataSourceClass self => self
 -> IO WebFrame
webDataSourceGetWebFrame ds =
  makeNewGObject mkWebFrame $ {#call web_data_source_get_web_frame#} (toWebDataSource ds)

-- | Determines whether the data source is in the process of loading its content.
webDataSourceIsLoading ::
   WebDataSourceClass self => self
 -> IO Bool
webDataSourceIsLoading ds =
    liftM toBool $ {#call web_data_source_is_loading#} (toWebDataSource ds)

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
-----------------------------------------------------------------------------
--  Module      :  Graphics.UI.Gtk.WebKit.WebDataSource
--  Author      :  Andy Stewart
--  Copyright   :  (c) 2010 Andy Stewart <lazycat.manatee@gmail.com>
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Note
--
-- Function `webkit_web_data_source_get_data` haven't binding,
-- no idea how to handle `GString`
--
-- Access to the WebKit Web DataSource
-----------------------------------------------------------------------------

module Graphics.UI.Gtk.WebKit.WebDataSource (
-- * Description
-- | Data source encapsulates the content of a WebKitWebFrame. A WebKitWebFrame has a main resource and
-- subresources and the data source provides access to these resources. When a request gets loaded
-- initially, it is set to a provisional state. The application can request for the request that
-- initiated the load by asking for the provisional data source and invoking the
-- 'webDataSourceGetInitialRequest' method of WebKitWebDataSource. This data source may not
-- have enough data and some methods may return empty values. To get a "full" data source with the data
-- and resources loaded, you need to get the non-provisional data source through WebKitWebFrame's
-- 'webFrameGetDataSource' method. This data source will have the data after everything was
-- loaded. Make sure that the data source was finished loading before using any of its methods. You can
-- do this via 'webDataSourceIsLoading'.

-- * Types
  WebDataSource,
  WebDataSourceClass,

-- * Constructors
  webDataSourceNew,

-- * Methods
  -- webDataSourceGetData,
  webDataSourceGetEncoding,
  webDataSourceGetInitialRequest,
  webDataSourceGetMainResource,
  webDataSourceGetRequest,
  webDataSourceGetSubresources,
  webDataSourceGetUnreachableUri,
  webDataSourceGetWebFrame,
  webDataSourceIsLoading,
) where

import Control.Monad		(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList
import System.Glib.GError
import Graphics.UI.Gtk.Gdk.Events

{#import Graphics.UI.Gtk.Abstract.Object#}	(makeNewObject)
{#import Graphics.UI.Gtk.WebKit.Types#}
{#import System.Glib.GObject#}

{#context lib="webkit" prefix ="webkit"#}

-- | Creates a new 'WebDataSource' instance.
-- The URL of the 'WebDataSource' will be set to "about:blank".
webDataSourceNew :: IO WebDataSource
webDataSourceNew =
    wrapNewGObject mkWebDataSource $ {#call web_data_source_new#}

-- | Returns the raw data that represents the the frame's content.The data will be incomplete until the
-- data has finished loading. Returns 'Nothing' if the web frame hasn't loaded any data. Use
-- @webkitWebDataSourceIsLoading@ to test if data source is in the process of loading.
--
-- webDataSourceGetData :: WebDataSourceClass self => self
--                      -> IO (Maybe String)
-- webDataSourceGetData ds = do
--   ptr <- {#call webkit_web_data_source_get_data #}
--            (toWebDataSource ds)
--   if strPtr == nullPtr
--      then return Nothing
--      else liftM Just $ peekCStringLen (strPtr, strLen)

-- | Returns the text encoding name as set in the 'WebView', or if not, the text encoding of the response.
webDataSourceGetEncoding ::
   WebDataSourceClass self => self
 -> IO String
webDataSourceGetEncoding ds =
  {#call web_data_source_get_encoding#} (toWebDataSource ds) >>= peekCString

-- | Returns a reference to the original request that was used to load the web content.
-- The NetworkRequest returned by this method is the
-- request prior to the "committed" load state.
-- See 'webDataSourceGetRequest' for getting the "committed" request.
webDataSourceGetInitialRequest ::
   WebDataSourceClass self => self
 -> IO NetworkRequest
webDataSourceGetInitialRequest ds =
  makeNewGObject mkNetworkRequest $ {# call web_data_source_get_initial_request#} (toWebDataSource ds)

-- | Returns the main resource of the data_source
webDataSourceGetMainResource ::
   WebDataSourceClass self => self
 -> IO WebResource
webDataSourceGetMainResource ds =
  makeNewGObject mkWebResource $ {#call web_data_source_get_main_resource#} (toWebDataSource ds)

-- | Returns a NetworkRequest that was used to create this 'WebDataSource'.
-- The NetworkRequest returned by this method is the request that was "committed",
-- and hence, different from the request you get from the 'webDataSourceGetInitialRequest' method.
webDataSourceGetRequest ::
   WebDataSourceClass self => self
 -> IO NetworkRequest
webDataSourceGetRequest ds =
  makeNewGObject mkNetworkRequest $ {# call web_data_source_get_request#} (toWebDataSource ds)

-- | Gives you a List of 'WebResource' objects that compose the 'WebView' to which this 'WebDataSource' is attached.
webDataSourceGetSubresources ::
   WebDataSourceClass self => self
 -> IO [WebResource]
webDataSourceGetSubresources ds = do
  glist <- {#call web_data_source_get_subresources#} (toWebDataSource ds)
  resourcePtr <- fromGList glist
  mapM (makeNewGObject mkWebResource . return) resourcePtr

-- | Return the unreachable URI of data_source.
-- The 'dataSource' will have an unreachable URL
-- if it was created using 'WebFrame''s
-- 'webFrameLoadAlternateHtmlString' method.
webDataSourceGetUnreachableUri ::
   WebDataSourceClass self => self
 -> IO String
webDataSourceGetUnreachableUri ds =
  {#call web_data_source_get_unreachable_uri#} (toWebDataSource ds) >>= peekCString

-- | Returns the 'WebFrame' that represents this data source
webDataSourceGetWebFrame ::
   WebDataSourceClass self => self
 -> IO WebFrame
webDataSourceGetWebFrame ds =
  makeNewGObject mkWebFrame $ {#call web_data_source_get_web_frame#} (toWebDataSource ds)

-- | Determines whether the data source is in the process of loading its content.
webDataSourceIsLoading ::
   WebDataSourceClass self => self
 -> IO Bool
webDataSourceIsLoading ds =
    liftM toBool $ {#call web_data_source_is_loading#} (toWebDataSource ds)