gio: S.G.AsyncResult: specify module exports

darcs-hash:20081017163845-21862-9355813b9cfffba2bd0c953007eb7d87eb5748b6.gz

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gio -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 13-Oct-2008
--
--  Copyright (c) 2008 Peter Gavin
--
--  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 3 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.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GIO, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GIO documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.GIO.AsyncResult (
    AsyncResult,
    AsyncResultClass,
    AsyncReadyCallback
    ) where

import System.Glib.FFI

import System.GIO.Base
{#import System.GIO.Types#}

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gio -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 13-Oct-2008
--
--  Copyright (c) 2008 Peter Gavin
--
--  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 3 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.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GIO, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GIO documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.GIO.AsyncResult where

import System.Glib.FFI

import System.GIO.Base
{#import System.GIO.Types#}


gstreamer: M.S.G.Core.Bus documentation cleanup

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  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 3 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.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  An asynchronous message bus subsystem.
module Media.Streaming.GStreamer.Core.Bus (
-- * Detail
  -- | The 'Bus' is resposible for delivering 'Message's in a
  --   first-in, first-out order, from the streaming threads to the
  --   application.
  --
  --   Since the application typically only wants to deal with
  --   delivery of these messages from one thread, the 'Bus' will
  --   marshal the messages between different threads. This is
  --   important since the actual streaming of media is done in
  --   a thread separate from the application.
  --
  --   The 'Bus' provides support for 'System.Glib.MainLoop.Source'
  --   based notifications. This makes it possible to handle the
  --   delivery in the GLib 'System.Glib.MainLoop.Source'.
  --
  --   A message is posted on the bus with the 'busPost' method. With
  --   the 'busPeek' and 'busPop' methods one can look at or retrieve
  --   a previously posted message.
  --
  --   The bus can be polled with the 'busPoll' method. This methods
  --   blocks up to the specified timeout value until one of the
  --   specified messages types is posted on the bus. The application
  --   can then pop the messages from the bus to handle
  --   them. Alternatively the application can register an
  --   asynchronous bus function using 'busAddWatch'. This function
  --   will install a 'System.Glib.MainLoop.Source' in the default
  --   GLib main loop and will deliver messages a short while after
  --   they have been posted. Note that the main loop should be
  --   running for the asynchronous callbacks.
  --
  --   It is also possible to get messages from the bus without any
  --   thread marshalling with the 'busSetSyncHandler' method. This
  --   makes it possible to react to a message in the same thread that
  --   posted the message on the bus. This should only be used if the
  --   application is able to deal with messages from different
  --   threads.
  --
  --   Every 'Pipeline' has one bus.
  --
  --   Note that a 'Pipeline' will set its bus into flushing state
  --   when changing from 'StateReady' to 'StateNull'.

-- * Types
  Bus,
  -- | The result of a 'BusSyncHandler'.
  BusSyncReply,
  -- | A handler that will be invoked synchronously when a new message
  --   is injected into the bus. This function is mostly used internally.
  --   Only one sync handler may be attached to a given bus.
  BusSyncHandler,
  BusClass,
  castToBus,
  toBus,
-- * Bus Operations
  busGetFlags,
  busSetFlags,
  busUnsetFlags,
  busNew,
  busPost,
  busHavePending,
  busPeek,
  busPop,
  busTimedPop,
  busSetFlushing,
  busSetSyncHandler,
  busUseSyncSignalHandler,
  busCreateWatch,
  busAddWatch,
  busDisableSyncMessageEmission,
  busEnableSyncMessageEmission,
  busAddSignalWatch,
  busRemoveSignalWatch,
  busPoll,

-- * Bus Signals
  onBusMessage,
  afterBusMessage,
  onBusSyncMessage,
  afterBusSyncMessage

  ) where

import Control.Monad ( liftM
                     , when )
{#import Media.Streaming.GStreamer.Core.Object#}
{#import Media.Streaming.GStreamer.Core.Types#}
{#import Media.Streaming.GStreamer.Core.Signals#}
{#import System.Glib.MainLoop#}
import System.Glib.Flags
import System.Glib.FFI
{#import System.Glib.GObject#}
{#import System.Glib.MainLoop#}

{# context lib = "gstreamer" prefix = "gst" #}

-- | Get the flags set on this bus.
busGetFlags :: BusClass busT
            => busT
            -> IO [BusFlags]
busGetFlags = mkObjectGetFlags

-- | Set flags on this bus.
busSetFlags :: BusClass busT
            => busT
            -> [BusFlags]
            -> IO ()
busSetFlags = mkObjectSetFlags

-- | Unset flags on this bus.
busUnsetFlags :: BusClass busT
              => busT
              -> [BusFlags]
              -> IO ()
busUnsetFlags = mkObjectUnsetFlags

-- | Create a new bus.
busNew :: IO Bus
busNew =
    {# call bus_new #} >>= takeObject

-- | Post a message to the bus.
busPost :: BusClass busT
        => busT
        -> Message
        -> IO Bool
busPost bus message =
    do {# call gst_mini_object_ref #} (toMiniObject message)
       liftM toBool $ {# call bus_post #} (toBus bus) message

-- | Check if there are pending messages on the bus.
busHavePending :: BusClass busT
               => busT
               -> IO Bool
busHavePending bus =
    liftM toBool $ {# call bus_have_pending #} $ toBus bus

-- | Get the message at the front of the queue.  It will remain on the
--   queue.
busPeek :: BusClass busT
        => busT
        -> IO (Maybe Message)
busPeek bus =
    {# call bus_peek #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get the message at the front of the queue.  It will be removed
--   from the queue.
busPop :: BusClass busT
       => busT
       -> IO (Maybe Message)
busPop bus =
    {# call bus_pop #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get a message from the bus, waiting up to the specified timeout.
--   If the time given is 'Nothing', the function will wait forever.
--   If the time given is @0@, the function will behave like 'busPop'.
busTimedPop :: BusClass busT
            => busT
            -> Maybe ClockTime
            -> IO (Maybe Message)
busTimedPop bus timeoutM =
    let timeout = case timeoutM of
                    Just timeout' -> timeout'
                    Nothing       -> clockTimeNone
    in {# call bus_timed_pop #} (toBus bus) (fromIntegral timeout) >>=
           maybePeek takeMiniObject

-- | If @flushing@ is 'True', the bus will flush out any queued
--   messages, as well as any future messages, until the function is
--   called with @flushing@ set to 'False'.
busSetFlushing :: BusClass busT
               => busT
               -> Bool
               -> IO ()
busSetFlushing bus flushing =
    {# call bus_set_flushing #} (toBus bus) $ fromBool flushing

-- these will leak memory, maybe one day we can set a destroy notifier...

type CBusSyncHandler =  Ptr Bus
                     -> Ptr Message
                     -> {# type gpointer #}
                     -> IO {# type GstBusSyncReply #}
marshalBusSyncHandler :: BusSyncHandler
                      -> IO {# type GstBusSyncHandler #}
marshalBusSyncHandler busSyncHandler =
    makeBusSyncHandler cBusSyncHandler
    where cBusSyncHandler :: CBusSyncHandler
          cBusSyncHandler busPtr messagePtr _ =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 reply <- busSyncHandler bus message
                 when (reply == BusDrop) $
                     {# call gst_mini_object_unref #} (toMiniObject message)
                 return $ fromIntegral $ fromEnum reply
foreign import ccall "wrapper"
    makeBusSyncHandler :: CBusSyncHandler
                       -> IO {# type GstBusSyncHandler #}

-- the following mess is necessary to clean up safely after busSetSyncHandler.
-- gstreamer doesn't give us a nice way to do this (such as a DestroyNotify)
weakNotifyQuark, funPtrQuark :: Quark
weakNotifyQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerWeakNotify"
funPtrQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerFunPtr"

getWeakNotify :: BusClass busT
              => busT
              -> IO (Maybe GWeakNotify)
getWeakNotify = objectGetAttributeUnsafe weakNotifyQuark

setWeakNotify :: BusClass busT
              => busT
              -> Maybe GWeakNotify
              -> IO ()
setWeakNotify = objectSetAttribute weakNotifyQuark

getFunPtr :: BusClass busT
          => busT
          -> IO (Maybe {# type GstBusSyncHandler #})
getFunPtr = objectGetAttributeUnsafe funPtrQuark

setFunPtr :: BusClass busT
          => busT
          -> Maybe {# type GstBusSyncHandler #}
          -> IO ()
setFunPtr = objectSetAttribute funPtrQuark

unsetSyncHandler :: BusClass busT
                 => busT
                 -> IO ()
unsetSyncHandler bus = do
  {# call bus_set_sync_handler #} (toBus bus) nullFunPtr nullPtr
  oldWeakNotifyM <- getWeakNotify bus
  case oldWeakNotifyM of
    Just oldWeakNotify -> objectWeakunref bus oldWeakNotify
    Nothing            -> return ()
  setWeakNotify bus Nothing
  oldFunPtrM <- getFunPtr bus
  case oldFunPtrM of
    Just oldFunPtr -> freeHaskellFunPtr oldFunPtr
    Nothing        -> return ()
  setFunPtr bus Nothing

-- | Set the synchronous message handler on the bus. The function will
--   be called every time a new message is posted to the bus. Note
--   that the function will be called from the thread context of the
--   poster.
--
--   Calling this function will replace any previously set sync
--   handler. If 'Nothing' is passed to this function, it will unset
--   the handler.
busSetSyncHandler :: BusClass busT
                  => busT
                  -> Maybe BusSyncHandler
                  -> IO ()
busSetSyncHandler bus busSyncHandlerM = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    case busSyncHandlerM of
      Just busSyncHandler ->
          do funPtr <- marshalBusSyncHandler busSyncHandler
             setFunPtr bus $ Just funPtr
             weakNotify <- objectWeakref bus $ freeHaskellFunPtr funPtr
             setWeakNotify bus $ Just weakNotify
             {# call bus_set_sync_handler #} (toBus bus) funPtr nullPtr
      Nothing ->
          return ()

-- | Use a synchronous message handler that converts all messages to signals.
busUseSyncSignalHandler :: BusClass busT
                        => busT
                        -> IO ()
busUseSyncSignalHandler bus = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    {# call bus_set_sync_handler #} (toBus bus) cBusSyncSignalHandlerPtr nullPtr
foreign import ccall unsafe "&gst_bus_sync_signal_handler"
    cBusSyncSignalHandlerPtr :: {# type GstBusSyncHandler #}

-- | Create a watch for the bus. The 'Source' will dispatch a signal
--   whenever a message is on the bus. After the signal is dispatched,
--   the message is popped off the bus.
busCreateWatch :: BusClass busT
               => busT
               -> IO Source
busCreateWatch bus =
    liftM Source $ {# call bus_create_watch #} (toBus bus) >>=
        flip newForeignPtr sourceFinalizer
foreign import ccall unsafe "&g_source_unref"
    sourceFinalizer :: FunPtr (Ptr Source -> IO ())

type CBusFunc =  Ptr Bus
              -> Ptr Message
              -> {# type gpointer #}
              -> IO {# type gboolean #}
marshalBusFunc :: BusFunc
               -> IO {# type GstBusFunc #}
marshalBusFunc busFunc =
    makeBusFunc cBusFunc
    where cBusFunc :: CBusFunc
          cBusFunc busPtr messagePtr userData =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 liftM fromBool $ busFunc bus message
foreign import ccall "wrapper"
    makeBusFunc :: CBusFunc
                -> IO {# type GstBusFunc #}

-- | Adds a bus watch to the default main context with the given
--   priority. This function is used to receive asynchronous messages
--   in the main loop.
--
--   The watch can be removed by calling 'System.Glib.MainLoop.sourceRemove'.
busAddWatch :: BusClass busT
            => busT
            -> Priority
            -> BusFunc
            -> IO HandlerId
busAddWatch bus priority func =
    do busFuncPtr <- marshalBusFunc func
       destroyNotify <- mkFunPtrDestroyNotify busFuncPtr
       liftM fromIntegral $
           {# call bus_add_watch_full #}
               (toBus bus)
               (fromIntegral priority)
               busFuncPtr
               nullPtr
               destroyNotify

-- | Instructs GStreamer to stop emitting the @"sync-message"@ signal
--   for this bus. See 'busEnableSyncMessageEmission' for more
--   information.
--
--   In the event that multiple pieces of code have called
--   'busEnableSyncMessageEmission', the sync-message
--   emissions will only be stopped after all calls to
--   'busEnableSyncMessageEmission' were "cancelled" by
--   calling this function.
busDisableSyncMessageEmission :: BusClass busT
                              => busT
                              -> IO ()
busDisableSyncMessageEmission =
    {# call bus_disable_sync_message_emission #} . toBus

-- | Instructs GStreamer to emit the @"sync-message"@ signal after
--   running the bus's sync handler. This function is here so that
--   programmers can ensure that they can synchronously receive
--   messages without having to affect what the bin's sync handler is.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busDisableSyncMessageEmission'
--   as many times as this function is called.
--
--   While this function looks similar to 'busAddSignalWatch', it is
--   not exactly the same -- this function enables synchronous
--   emission of signals when messages arrive; 'busAddSignalWatch'
--   adds an idle callback to pop messages off the bus
--   asynchronously. The @"sync-message"@ signal comes from the thread
--   of whatever object posted the message; the @"message"@ signal is
--   marshalled to the main thread via the main loop.
busEnableSyncMessageEmission :: BusClass busT
                             => busT
                             -> IO ()
busEnableSyncMessageEmission =
    {# call bus_enable_sync_message_emission #} . toBus

-- | Adds a bus signal watch to the default main context with the
--   given priority. After calling this method, the bus will emit the
--   @"message"@ signal for each message posted on the bus.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busRemoveSignalWatch' as many
--   times.
busAddSignalWatch :: BusClass busT
                  => busT
                  -> Priority
                  -> IO ()
busAddSignalWatch bus priority =
    {# call bus_add_signal_watch_full #} (toBus bus) $ fromIntegral priority

-- | Remove the signal watch that was added with 'busAddSignalWatch'.
busRemoveSignalWatch :: BusClass busT
                     => busT
                     -> IO ()
busRemoveSignalWatch =
    {# call bus_remove_signal_watch #} . toBus

-- | Poll the bus for a message. Will block while waiting for messages
--   to come. You can specify the maximum amount of time to wait with
--   the @timeout@ parameter. If @timeout@ is negative, the function
--   will wait indefinitely.
--
--   Messages not in @events@ will be popped off the bus and ignored.
--
--   Because 'busPoll' is implemented using the @"message"@ signal
--   enabled by 'busAddSignalWatch', calling 'busPoll' will cause the
--   @"message"@ signal to be emitted for every message that the
--   function sees. Thus, a @"message"@ signal handler will see every
--   message that 'busPoll' sees -- neither will steal messages from
--   the other.
--
--   This function will run a main loop in the default main context
--   while polling.
busPoll :: Bus
        -> [MessageType]
        -> ClockTimeDiff
        -> IO Message
busPoll bus events timeout =
    {# call bus_poll #} bus
                        (fromIntegral $ fromFlags events)
                        (fromIntegral timeout) >>=
        takeMiniObject

-- | Connect to the @"message"@ signal. Emitted from a 'Source' added
--   to the mainloop. This signal will only be emitted when there is a
--   'MainLoop' running.
onBusMessage, afterBusMessage :: BusClass bus
                              => bus
                              -> (Message -> IO ())
                              -> IO (ConnectId bus)
onBusMessage =
    connect_BOXED__NONE "message" peekMiniObject False
afterBusMessage =
    connect_BOXED__NONE "message" peekMiniObject True

-- | A message has been posted on the bus. This signal is emitted from
--   the thread that posted the message so one has to be careful with
--   locking.
--
--   This signal will not be emitted by default, you must first call
--   'busUseSyncSignalHandler' if you want this signal to be emitted
--   when a message is posted on the bus.
onBusSyncMessage, afterBusSyncMessage :: BusClass bus
                                      => bus
                                      -> (Message -> IO ())
                                      -> IO (ConnectId bus)
onBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject False
afterBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject True

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  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 3 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.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
--
--   An asynchronous message bus subsystem.
--
module Media.Streaming.GStreamer.Core.Bus (
-- * Types
  -- | The 'Bus' is resposible for delivering 'Message's in a
  --   first-in, first-out order, from the streaming threads to the
  --   application.
  --
  --   Since the application typically only wants to deal with
  --   delivery of these messages from one thread, the 'Bus' will
  --   marshal the messages between different threads. This is
  --   important since the actual streaming of media is done in
  --   a thread separate from the application.
  --
  --   The 'Bus' provides support for 'System.Glib.MainLoop.Source'
  --   based notifications. This makes it possible to handle the
  --   delivery in the GLib 'System.Glib.MainLoop.Source'.
  --
  --   A message is posted on the bus with the 'busPost' method. With
  --   the 'busPeek' and 'busPop' methods one can look at or retrieve
  --   a previously posted message.
  --
  --   The bus can be polled with the 'busPoll' method. This methods
  --   blocks up to the specified timeout value until one of the
  --   specified messages types is posted on the bus. The application
  --   can then pop the messages from the bus to handle
  --   them. Alternatively the application can register an
  --   asynchronous bus function using 'busAddWatch'. This function
  --   will install a 'System.Glib.MainLoop.Source' in the default
  --   GLib main loop and will deliver messages a short while after
  --   they have been posted. Note that the main loop should be
  --   running for the asynchronous callbacks.
  --
  --   It is also possible to get messages from the bus without any
  --   thread marshalling with the 'busSetSyncHandler' method. This
  --   makes it possible to react to a message in the same thread that
  --   posted the message on the bus. This should only be used if the
  --   application is able to deal with messages from different
  --   threads.
  --
  --   Every 'Pipeline' has one bus.
  --
  --   Note that a 'Pipeline' will set its bus into flushing state
  --   when changing from 'StateReady' to 'StateNull'.
  Bus,
  -- | The result of a 'BusSyncHandler'.
  BusSyncReply,
  -- | A handler that will be invoked synchronously when a new message
  --   is injected into the bus. This function is mostly used internally.
  --   Only one sync handler may be attached to a given bus.
  BusSyncHandler,
  BusClass,
  castToBus,
  toBus,
-- * Bus Operations
  busGetFlags,
  busSetFlags,
  busUnsetFlags,
  busNew,
  busPost,
  busHavePending,
  busPeek,
  busPop,
  busTimedPop,
  busSetFlushing,
  busSetSyncHandler,
  busUseSyncSignalHandler,
  busCreateWatch,
  busAddWatch,
  busDisableSyncMessageEmission,
  busEnableSyncMessageEmission,
  busAddSignalWatch,
  busRemoveSignalWatch,
  busPoll,

-- * Bus Signals
  onBusMessage,
  afterBusMessage,
  onBusSyncMessage,
  afterBusSyncMessage

  ) where

import Control.Monad ( liftM
                     , when )
{#import Media.Streaming.GStreamer.Core.Object#}
{#import Media.Streaming.GStreamer.Core.Types#}
{#import Media.Streaming.GStreamer.Core.Signals#}
{#import System.Glib.MainLoop#}
import System.Glib.Flags
import System.Glib.FFI
{#import System.Glib.GObject#}
{#import System.Glib.MainLoop#}

{# context lib = "gstreamer" prefix = "gst" #}

-- | Get the flags set on this bus.
busGetFlags :: BusClass busT
            => busT
            -> IO [BusFlags]
busGetFlags = mkObjectGetFlags

-- | Set flags on this bus.
busSetFlags :: BusClass busT
            => busT
            -> [BusFlags]
            -> IO ()
busSetFlags = mkObjectSetFlags

-- | Unset flags on this bus.
busUnsetFlags :: BusClass busT
              => busT
              -> [BusFlags]
              -> IO ()
busUnsetFlags = mkObjectUnsetFlags

-- | Create a new bus.
busNew :: IO Bus
busNew =
    {# call bus_new #} >>= takeObject

-- | Post a message to the bus.
busPost :: BusClass busT
        => busT
        -> Message
        -> IO Bool
busPost bus message =
    do {# call gst_mini_object_ref #} (toMiniObject message)
       liftM toBool $ {# call bus_post #} (toBus bus) message

-- | Check if there are pending messages on the bus.
busHavePending :: BusClass busT
               => busT
               -> IO Bool
busHavePending bus =
    liftM toBool $ {# call bus_have_pending #} $ toBus bus

-- | Get the message at the front of the queue.  It will remain on the
--   queue.
busPeek :: BusClass busT
        => busT
        -> IO (Maybe Message)
busPeek bus =
    {# call bus_peek #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get the message at the front of the queue.  It will be removed
--   from the queue.
busPop :: BusClass busT
       => busT
       -> IO (Maybe Message)
busPop bus =
    {# call bus_pop #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get a message from the bus, waiting up to the specified timeout.
--   If the time given is 'Nothing', the function will wait forever.
--   If the time given is @0@, the function will behave like 'busPop'.
busTimedPop :: BusClass busT
            => busT
            -> Maybe ClockTime
            -> IO (Maybe Message)
busTimedPop bus timeoutM =
    let timeout = case timeoutM of
                    Just timeout' -> timeout'
                    Nothing       -> clockTimeNone
    in {# call bus_timed_pop #} (toBus bus) (fromIntegral timeout) >>=
           maybePeek takeMiniObject

-- | If @flushing@ is 'True', the bus will flush out any queued
--   messages, as well as any future messages, until the function is
--   called with @flushing@ set to 'False'.
busSetFlushing :: BusClass busT
               => busT
               -> Bool
               -> IO ()
busSetFlushing bus flushing =
    {# call bus_set_flushing #} (toBus bus) $ fromBool flushing

-- these will leak memory, maybe one day we can set a destroy notifier...

type CBusSyncHandler =  Ptr Bus
                     -> Ptr Message
                     -> {# type gpointer #}
                     -> IO {# type GstBusSyncReply #}
marshalBusSyncHandler :: BusSyncHandler
                      -> IO {# type GstBusSyncHandler #}
marshalBusSyncHandler busSyncHandler =
    makeBusSyncHandler cBusSyncHandler
    where cBusSyncHandler :: CBusSyncHandler
          cBusSyncHandler busPtr messagePtr _ =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 reply <- busSyncHandler bus message
                 when (reply == BusDrop) $
                     {# call gst_mini_object_unref #} (toMiniObject message)
                 return $ fromIntegral $ fromEnum reply
foreign import ccall "wrapper"
    makeBusSyncHandler :: CBusSyncHandler
                       -> IO {# type GstBusSyncHandler #}

-- the following mess is necessary to clean up safely after busSetSyncHandler.
-- gstreamer doesn't give us a nice way to do this (such as a DestroyNotify)
weakNotifyQuark, funPtrQuark :: Quark
weakNotifyQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerWeakNotify"
funPtrQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerFunPtr"

getWeakNotify :: BusClass busT
              => busT
              -> IO (Maybe GWeakNotify)
getWeakNotify = objectGetAttributeUnsafe weakNotifyQuark

setWeakNotify :: BusClass busT
              => busT
              -> Maybe GWeakNotify
              -> IO ()
setWeakNotify = objectSetAttribute weakNotifyQuark

getFunPtr :: BusClass busT
          => busT
          -> IO (Maybe {# type GstBusSyncHandler #})
getFunPtr = objectGetAttributeUnsafe funPtrQuark

setFunPtr :: BusClass busT
          => busT
          -> Maybe {# type GstBusSyncHandler #}
          -> IO ()
setFunPtr = objectSetAttribute funPtrQuark

unsetSyncHandler :: BusClass busT
                 => busT
                 -> IO ()
unsetSyncHandler bus = do
  {# call bus_set_sync_handler #} (toBus bus) nullFunPtr nullPtr
  oldWeakNotifyM <- getWeakNotify bus
  case oldWeakNotifyM of
    Just oldWeakNotify -> objectWeakunref bus oldWeakNotify
    Nothing            -> return ()
  setWeakNotify bus Nothing
  oldFunPtrM <- getFunPtr bus
  case oldFunPtrM of
    Just oldFunPtr -> freeHaskellFunPtr oldFunPtr
    Nothing        -> return ()
  setFunPtr bus Nothing

-- | Set the synchronous message handler on the bus. The function will
--   be called every time a new message is posted to the bus. Note
--   that the function will be called from the thread context of the
--   poster.
--
--   Calling this function will replace any previously set sync
--   handler. If 'Nothing' is passed to this function, it will unset
--   the handler.
busSetSyncHandler :: BusClass busT
                  => busT
                  -> Maybe BusSyncHandler
                  -> IO ()
busSetSyncHandler bus busSyncHandlerM = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    case busSyncHandlerM of
      Just busSyncHandler ->
          do funPtr <- marshalBusSyncHandler busSyncHandler
             setFunPtr bus $ Just funPtr
             weakNotify <- objectWeakref bus $ freeHaskellFunPtr funPtr
             setWeakNotify bus $ Just weakNotify
             {# call bus_set_sync_handler #} (toBus bus) funPtr nullPtr
      Nothing ->
          return ()

-- | Use a synchronous message handler that converts all messages to signals.
busUseSyncSignalHandler :: BusClass busT
                        => busT
                        -> IO ()
busUseSyncSignalHandler bus = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    {# call bus_set_sync_handler #} (toBus bus) cBusSyncSignalHandlerPtr nullPtr
foreign import ccall unsafe "&gst_bus_sync_signal_handler"
    cBusSyncSignalHandlerPtr :: {# type GstBusSyncHandler #}

-- | Create a watch for the bus. The 'Source' will dispatch a signal
--   whenever a message is on the bus. After the signal is dispatched,
--   the message is popped off the bus.
busCreateWatch :: BusClass busT
               => busT
               -> IO Source
busCreateWatch bus =
    liftM Source $ {# call bus_create_watch #} (toBus bus) >>=
        flip newForeignPtr sourceFinalizer
foreign import ccall unsafe "&g_source_unref"
    sourceFinalizer :: FunPtr (Ptr Source -> IO ())

type CBusFunc =  Ptr Bus
              -> Ptr Message
              -> {# type gpointer #}
              -> IO {# type gboolean #}
marshalBusFunc :: BusFunc
               -> IO {# type GstBusFunc #}
marshalBusFunc busFunc =
    makeBusFunc cBusFunc
    where cBusFunc :: CBusFunc
          cBusFunc busPtr messagePtr userData =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 liftM fromBool $ busFunc bus message
foreign import ccall "wrapper"
    makeBusFunc :: CBusFunc
                -> IO {# type GstBusFunc #}

-- | Adds a bus watch to the default main context with the given
--   priority. This function is used to receive asynchronous messages
--   in the main loop.
--
--   The watch can be removed by calling 'System.Glib.MainLoop.sourceRemove'.
busAddWatch :: BusClass busT
            => busT
            -> Priority
            -> BusFunc
            -> IO HandlerId
busAddWatch bus priority func =
    do busFuncPtr <- marshalBusFunc func
       destroyNotify <- mkFunPtrDestroyNotify busFuncPtr
       liftM fromIntegral $
           {# call bus_add_watch_full #}
               (toBus bus)
               (fromIntegral priority)
               busFuncPtr
               nullPtr
               destroyNotify

-- | Instructs GStreamer to stop emitting the @"sync-message"@ signal
--   for this bus. See 'busEnableSyncMessageEmission' for more
--   information.
--
--   In the event that multiple pieces of code have called
--   'busEnableSyncMessageEmission', the sync-message
--   emissions will only be stopped after all calls to
--   'busEnableSyncMessageEmission' were "cancelled" by
--   calling this function.
busDisableSyncMessageEmission :: BusClass busT
                              => busT
                              -> IO ()
busDisableSyncMessageEmission =
    {# call bus_disable_sync_message_emission #} . toBus

-- | Instructs GStreamer to emit the @"sync-message"@ signal after
--   running the bus's sync handler. This function is here so that
--   programmers can ensure that they can synchronously receive
--   messages without having to affect what the bin's sync handler is.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busDisableSyncMessageEmission'
--   as many times as this function is called.
--
--   While this function looks similar to 'busAddSignalWatch', it is
--   not exactly the same -- this function enables synchronous
--   emission of signals when messages arrive; 'busAddSignalWatch'
--   adds an idle callback to pop messages off the bus
--   asynchronously. The @"sync-message"@ signal comes from the thread
--   of whatever object posted the message; the @"message"@ signal is
--   marshalled to the main thread via the main loop.
busEnableSyncMessageEmission :: BusClass busT
                             => busT
                             -> IO ()
busEnableSyncMessageEmission =
    {# call bus_enable_sync_message_emission #} . toBus

-- | Adds a bus signal watch to the default main context with the
--   given priority. After calling this method, the bus will emit the
--   @"message"@ signal for each message posted on the bus.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busRemoveSignalWatch' as many
--   times.
busAddSignalWatch :: BusClass busT
                  => busT
                  -> Priority
                  -> IO ()
busAddSignalWatch bus priority =
    {# call bus_add_signal_watch_full #} (toBus bus) $ fromIntegral priority

-- | Remove the signal watch that was added with 'busAddSignalWatch'.
busRemoveSignalWatch :: BusClass busT
                     => busT
                     -> IO ()
busRemoveSignalWatch =
    {# call bus_remove_signal_watch #} . toBus

-- | Poll the bus for a message. Will block while waiting for messages
--   to come. You can specify the maximum amount of time to wait with
--   the @timeout@ parameter. If @timeout@ is negative, the function
--   will wait indefinitely.
--
--   Messages not in @events@ will be popped off the bus and ignored.
--
--   Because 'busPoll' is implemented using the @"message"@ signal
--   enabled by 'busAddSignalWatch', calling 'busPoll' will cause the
--   @"message"@ signal to be emitted for every message that the
--   function sees. Thus, a @"message"@ signal handler will see every
--   message that 'busPoll' sees -- neither will steal messages from
--   the other.
--
--   This function will run a main loop in the default main context
--   while polling.
busPoll :: Bus
        -> [MessageType]
        -> ClockTimeDiff
        -> IO Message
busPoll bus events timeout =
    {# call bus_poll #} bus
                        (fromIntegral $ fromFlags events)
                        (fromIntegral timeout) >>=
        takeMiniObject

-- | Connect to the @"message"@ signal. Emitted from a 'Source' added
--   to the mainloop. This signal will only be emitted when there is a
--   'MainLoop' running.
onBusMessage, afterBusMessage :: BusClass bus
                              => bus
                              -> (Message -> IO ())
                              -> IO (ConnectId bus)
onBusMessage =
    connect_BOXED__NONE "message" peekMiniObject False
afterBusMessage =
    connect_BOXED__NONE "message" peekMiniObject True

-- | A message has been posted on the bus. This signal is emitted from
--   the thread that posted the message so one has to be careful with
--   locking.
--
--   This signal will not be emitted by default, you must first call
--   'busUseSyncSignalHandler' if you want this signal to be emitted
--   when a message is posted on the bus.
onBusSyncMessage, afterBusSyncMessage :: BusClass bus
                                      => bus
                                      -> (Message -> IO ())
                                      -> IO (ConnectId bus)
onBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject False
afterBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject True


Use the #fun feature of c2hs

Use the #fun feature of c2hs

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"
#include "constants.h"

module Bindings.MPI.Internal (init, finalize, send, recv, Comm, Datatype, commWorld, int) where

import Prelude hiding (init)
import C2HS

{# context prefix = "MPI" #}

type Comm = {# type MPI_Comm #}
type Datatype = {# type MPI_Datatype #}

foreign import ccall "mpi_comm_world" commWorld :: Comm
foreign import ccall "mpi_int" int :: Datatype

init = {# call unsafe init_wrapper as ^ #}

-- int MPI_Finalize(void)
finalize = {# call unsafe MPI_Finalize as ^  #}

-- int MPI_Send(void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm)
-- send = {# call unsafe MPI_Send as ^ #}
{# fun unsafe Send as ^ { id `Ptr ()', `Int', id `Datatype', `Int', `Int', id `Comm' } -> `Int' #}

-- int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, int tag, MPI_Comm comm, MPI_Status *status)
recv = {# call unsafe MPI_Recv as ^ #}

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"
#include "constants.h"

module Bindings.MPI.Internal (init, finalize, send, recv, Comm, Datatype, commWorld, int) where

import Prelude hiding (init)
import C2HS

type Comm = {# type MPI_Comm #}
type Datatype = {# type MPI_Datatype #}

foreign import ccall "mpi_comm_world" commWorld :: Comm
foreign import ccall "mpi_int" int :: Datatype

init = {# call init_wrapper as ^ #}

-- int MPI_Finalize(void)
finalize = {# call MPI_Finalize as ^ #}

-- int MPI_Send(void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm)
send = {# call MPI_Send as ^ #}

-- int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, int tag, MPI_Comm comm, MPI_Status *status)
recv = {# call MPI_Recv as ^ #}


implement more detailed signature verification

-- | Bindings to GPGMe
--
-- partial bindings to gpgme

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}

#include <gpgme.h>
#include <signal.h>

module Bindings where

import           Control.Applicative ((<$>), (<*>))
import qualified Control.Exception as Ex
import           Data.Bits
import qualified Data.ByteString as BS
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as BS
import           Data.Data
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import           Foreign.C
import           Foreign.ForeignPtr
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable

import           System.Posix.IO
import           System.Posix.Types

fromEnum' :: (Enum a, Num b) => a -> b
fromEnum' = fromIntegral . fromEnum

toEnum' :: (Enum c, Integral a) => a -> c
toEnum' = toEnum . fromIntegral

fromFlags :: (Enum a, Num b, Data.Bits.Bits b) => [a] -> b
fromFlags = foldr (.|.) 0 . map fromEnum'

toFlags :: (Data.Bits.Bits a, Eq a, Num a, Enum b, Bounded b) =>
           a
        -> [b]
toFlags x = filter (\y -> let y' = fromEnum' y in x .&. y' /= 0)
              [minBound..maxBound]

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

{#pointer gpgme_ctx_t as Ctx foreign newtype#}

instance Show Ctx where
    show _ = "<GpgMe.CTX>"

{#enum gpgme_err_code_t as ErrorCode {underscoreToCase}
       with prefix = "GPG"
       deriving (Show) #}

{#enum gpgme_err_source_t as ErrorSource {underscoreToCase}
       with prefix = "GPG"

       deriving (Show) #}

data Error = Error { errCode :: ErrorCode
                   , errSource :: ErrorSource
                   , errorString :: Text.Text
                   } deriving (Show, Typeable )

noError :: Error
noError = Error ErrNoError ErrSourceUnknown ""

instance Ex.Exception Error

throwError :: CUInt -> IO ()
throwError e' = do
    mbe <- toError e'
    case mbe of
        Nothing -> return ()
        Just e -> Ex.throwIO e

#c
gpgme_err_code_t gpgme_err_code_uninlined (gpgme_error_t err);
gpgme_err_source_t gpgme_err_source_uninlined (gpgme_error_t err);
#endc

toError :: CUInt -> IO (Maybe Error)
toError err = case err of
    0 -> return Nothing
    _ -> Just <$>
         (allocaBytes 256 $ \buff -> do -- We hope that any error message will
                                        -- be less than 256 bytes long
               _ <- {#call strerror_r#} err buff 256
               Error <$> (toEnum . fromIntegral
                          <$> {# call err_code_uninlined #} err)
                     <*> (toEnum . fromIntegral
                          <$> {# call err_source_uninlined #} err)
                     <*> (Text.pack <$> peekCString buff))

checkVersion :: Maybe Text -> IO (Maybe Text)
checkVersion Nothing = Just . Text.pack <$>
                         (peekCString =<< {#call check_version#} nullPtr)
checkVersion (Just txt) = withCString (Text.unpack txt) $ \buf -> do
    _ <- {#call check_version#} buf
    return Nothing

{#enum gpgme_protocol_t as Protocol {underscoreToCase} deriving (Show, Eq)#}
-- gpgme_engine_check_version (gpgme_protocol_t protocol)

foreign import ccall unsafe "&gpgme_release"
    releaseCtx :: FunPtr (Ptr Ctx -> IO ())

mkContext :: Ptr (Ptr Ctx) -> IO Ctx
mkContext p = do
    if p == nullPtr
        then Ex.throw (Ex.AssertionFailed "nullPtr")
        else fmap Ctx $ newForeignPtr releaseCtx  . castPtr =<< peek p

-- withCtx :: Ctx -> (Ptr Ctx -> IO t) -> IO t
-- withCtx x f = withForeignPtr (fromCtx x) f

{#fun new as ctxNew'
   {alloca- `Ctx' mkContext*}
   -> `()' throwError*- #}

-- | Check that version constraint is satisfied and create a new context
ctxNew :: Maybe Text -> IO Ctx
ctxNew minVersion = do
    _ <- checkVersion minVersion
    ctxNew'

{#enum validity_t as Validity {underscoreToCase} deriving (Show) #}
{#enum attr_t as Attr {underscoreToCase} deriving (Show) #}

------------------------------------
-- Keys
------------------------------------

{#pointer gpgme_key_t as Key foreign newtype #}

withKeysArray :: [Key] -> (Ptr (Ptr Key) -> IO b) -> IO b
withKeysArray ks' f = withKeys ks' $ \ksPtrs -> withArray0 nullPtr ksPtrs f
  where
    withKeys []     g = g []
    withKeys (k:ks) g = withKey k $ \kPtr -> withKeys ks (g . (kPtr:))

foreign import ccall "gpgme.h &gpgme_key_unref"
    unrefPtr :: FunPtr (Ptr Key -> IO ())

getKeys :: Ctx
        -> Bool -- ^ Only keys with secret
        -> IO [Key]
getKeys ctx secretOnly = withCtx ctx $ \ctxPtr -> do
    _ <- {#call gpgme_op_keylist_start #} ctxPtr nullPtr (fromEnum' secretOnly)
    alloca $ takeKeys ctxPtr
  where
    takeKeys ctxPtr (buf :: Ptr (Ptr Key)) = do
        err <- toError =<< {#call gpgme_op_keylist_next#} ctxPtr buf
        case err of
            Nothing -> do
                keyPtr <- peek buf
                key <- newForeignPtr unrefPtr keyPtr
                (Key key :) <$> takeKeys ctxPtr buf
            Just e -> case errCode e of
                ErrEof -> return []
                _ -> error "takeKeys"

reserved :: (Ptr a -> t) -> t
reserved f = f nullPtr

reserved0 :: Num a => (a -> t) -> t
reserved0 f = f 0

{#fun key_get_string_attr as ^
   { withKey* `Key'
   , fromEnum' `Attr'
   , reserved- `Ptr()'
   , `Int'
   } -> `Maybe BS.ByteString' toMaybeText* #}

-------------------------------
-- Data Buffers
-------------------------------

newtype DataBuffer = DataBuffer {fromDataBuffer :: Ptr ()}
mkDataBuffer :: Ptr (Ptr ()) -> IO DataBuffer
mkDataBuffer = fmap DataBuffer . peek

withDataBuffer :: DataBuffer -> (Ptr () -> t) -> t
withDataBuffer (DataBuffer buf) f = f buf

toMaybeText :: Ptr CChar -> IO (Maybe BS.ByteString)
toMaybeText ptr = maybePeek BS.packCString ptr

withMaybeText :: Maybe Text -> (Ptr CChar -> IO a) -> IO a
withMaybeText Nothing = ($ nullPtr)
withMaybeText (Just txt) = withCString (Text.unpack txt)

{#fun data_new as ^
   { alloca- `DataBuffer' mkDataBuffer* }
   -> `()' throwError*- #}

peekInt :: (Storable a, Num b, Integral a) => Ptr a -> IO b
peekInt = fmap fromIntegral . peek

{#fun data_release_and_get_mem as ^
   { fromDataBuffer `DataBuffer'
   , alloca- `Int' peekInt*
   } -> `Ptr ()' castPtr #}

getDataBufferBytes :: DataBuffer -> IO BS.ByteString
getDataBufferBytes db = do
    (dt, len) <- dataReleaseAndGetMem db
    res <- if dt == nullPtr then return BS.empty
                            else do
               bs <- BS.packCStringLen (castPtr dt, len)
               {#call free#} dt
               return bs
    return res

{# fun gpgme_op_export_keys as opExportKeys
   { withCtx* `Ctx'
   , withKeysArray* `[Key]'
   , reserved0- `CUInt'
   , fromDataBuffer `DataBuffer'
   } -> `Error' throwError*- #}

data ImportStatus = ImportStatus { isFprint :: BS.ByteString
                                 , isResult :: Maybe Error
                                 , isStatus :: Int -- TODO: convert to flags
                                 } deriving (Show)

importKeyBuffer :: Ctx -> DataBuffer -> IO [ImportStatus]
importKeyBuffer ctx keyBuffer = withCtx ctx $ \ctxPtr ->
                          withDataBuffer keyBuffer $ \keyPtr -> do
    throwError =<< {#call op_import#} ctxPtr keyPtr
    result <- {#call op_import_result #} ctxPtr
    walkImports =<< {#get import_result_t.imports#} result
  where
    walkImports p = if p == nullPtr
                      then return []
                      else do
        is <- ImportStatus <$> (BS.packCString
                                  =<< {#get import_status_t.fpr #} p)
                           <*> (toError =<< {#get import_status_t.result #} p)
                           <*> (fromIntegral <$> {#get import_status_t.status #} p)
        (is:) <$> (walkImports =<< {#get import_status_t.next #} p)

importKeys :: Ctx -> ByteString -> IO [ImportStatus]
importKeys ctx bs = withBSData bs $ importKeyBuffer ctx

exportKeys :: Ctx -> [Key] -> IO BS.ByteString
exportKeys ctx keys = withBSBuffer $ opExportKeys ctx keys

unsafeUseAsCStringLen' :: Num t =>
                          BS.ByteString
                       -> ((Ptr CChar, t) -> IO a)
                       -> IO a
unsafeUseAsCStringLen' bs f =
    BS.unsafeUseAsCStringLen bs $ \(bs', l) -> f (bs', fromIntegral l)

{# fun data_new_from_mem as ^
   { alloca- `DataBuffer' mkDataBuffer*
   , unsafeUseAsCStringLen' * `BS.ByteString'&
   , fromEnum' `Bool'
   } -> `Error' throwError*- #}

{# fun data_release as ^
   { withDataBuffer* `DataBuffer'} -> `()' #}

{# fun set_armor as ^
     { withCtx* `Ctx'
     , fromEnum' `Bool'
     } -> `()' #}

withBSData :: BS.ByteString -> (DataBuffer -> IO c) -> IO c
withBSData bs =
    Ex.bracket (dataNewFromMem bs True)
               dataRelease

withBSBuffer :: (DataBuffer -> IO a) -> IO BS.ByteString
withBSBuffer f =
    Ex.bracketOnError dataNew
                      dataRelease
                      $ \db -> do
                          _ <- f db
                          getDataBufferBytes db

-----------------------------------
-- Signing
-----------------------------------

{#fun signers_clear as ^
    {withCtx* `Ctx'} -> `()'#}

{#fun signers_add as ^
    { withCtx* `Ctx'
    , withKey* `Key'
    } -> `()' throwError* #}

{# enum sig_mode_t as SigMode {underscoreToCase}
       with prefix = "GPGME"
       deriving (Show) #}

{#fun op_sign as ^
    { withCtx* `Ctx'
    , withDataBuffer* `DataBuffer'
    , withDataBuffer* `DataBuffer'
    , fromEnum' `SigMode'
    } -> `()' throwError*- #}
--     exportKey

-- | Sign a text using a private signing key from the GPG keychain
sign :: Ctx
     -> BS.ByteString -- ^ Text to sign
     -> Key -- ^ Signing key to use
     -> SigMode -- ^ Signing mode
     -> IO BS.ByteString
sign ctx plain key mode = withBSData plain $ \plainData ->
                          withBSBuffer $ \outData -> (do
    signersClear ctx
    signersAdd ctx key
    opSign ctx plainData outData mode)
       `Ex.finally` signersClear ctx

{# enum sigsum_t as SigSummary {underscoreToCase} deriving (Bounded, Show)#}
{# enum sig_stat_t as SigStat {underscoreToCase} deriving (Bounded, Show)#}

{#fun op_verify as ^
   { withCtx* `Ctx'
   , withDataBuffer* `DataBuffer' -- sig
   , withDataBuffer* `DataBuffer' -- signed-text
   , withDataBuffer* `DataBuffer' -- plain
   } -> `()' throwError*- #}

data VerifyResult = VerifyResult { summary :: [SigSummary]
                                 , fingerprint :: ByteString
                                 , status :: SigStat
                                 , timestamp :: Integer
                                 , expTimestamp :: Integer
                                 , wrongKeyUsage :: Bool
                                 , pkaTrust :: Int
                                 , chainModel :: Bool
                                 , validity :: Validity
                                 , validityReason :: ErrorCode
                                 } deriving Show

peekVerifyResults :: Ptr () -> IO [VerifyResult]
peekVerifyResults ptr | ptr == nullPtr = return []
                      | otherwise = do
    summary <- toFlags <$> {#get gpgme_signature_t->summary#} ptr
    fingerprint <- BS.packCString =<<{# get gpgme_signature_t->fpr#} ptr
    status' <- gpgme_err_code_uninlined =<< {#get gpgme_signature_t->status#} ptr
    let status = case toEnum' status' of
               ErrNoError -> SigStatGood
               ErrBadSignature -> SigStatBad
               ErrNoPubkey -> SigStatNokey
               ErrNoData -> SigStatNosig
               ErrSigExpired -> SigStatGoodExp
               ErrKeyExpired -> SigStatGoodExpkey
               _ -> SigStatError
    timestamp <- fromIntegral <$> {#get gpgme_signature_t->timestamp#} ptr
    expTimestamp <- fromIntegral <$> {#get gpgme_signature_t->exp_timestamp#} ptr
    wrongKeyUsage <- toEnum' <$> {#get gpgme_signature_t->wrong_key_usage#} ptr
    pkaTrust <- fromIntegral <$> {#get gpgme_signature_t->pka_trust#} ptr
    chainModel <- toEnum' <$> {#get gpgme_signature_t->chain_model #} ptr
    validity <- toEnum' <$> {#get gpgme_signature_t->validity #} ptr
    validityReason <- toEnum' <$> {#get gpgme_signature_t->validity_reason#} ptr
    let res = VerifyResult { summary = summary
                           , fingerprint = fingerprint
                           , status = status
                           , timestamp = timestamp
                           , expTimestamp = expTimestamp
                           , wrongKeyUsage = wrongKeyUsage
                           , pkaTrust = pkaTrust
                           , chainModel = chainModel
                           , validity = validity
                           , validityReason = validityReason
                           }
    next <- {#get gpgme_signature_t->next #} ptr
    nextResult <- peekVerifyResults next
    return (res : nextResult)

verifyResult :: Ctx -> IO [VerifyResult]
verifyResult ctx = withCtx ctx $ \ctxPtr -> do
    res <- {# call gpgme_op_verify_result #} ctxPtr
    peekVerifyResults =<< {#get verify_result_t->signatures#} res

-- | Verify a signature created in 'SigModeDetach' mode
verifyDetach :: Ctx
             -> BS.ByteString -- ^ The source text that the signature pertains to
             -> BS.ByteString -- ^ The signature
             -> IO [VerifyResult]
verifyDetach ctx signedText sig = withBSData signedText $ \stData ->
                                  withBSData sig $ \sigData -> do
    opVerify ctx sigData stData (DataBuffer nullPtr)
    verifyResult ctx

-- | Verify a signature created in 'SigModeNormal' or 'SigModeClear' mode
verify :: Ctx
        -> BS.ByteString -- ^ Text and attached Signature
        -> IO ([VerifyResult], BS.ByteString) -- ^ result and extracted plain text
verify ctx sig = withBSData sig $ \sigData -> do
    plain <- withBSBuffer $ \plainData ->
        opVerify ctx sigData (DataBuffer nullPtr) plainData
    res <- verifyResult ctx
    return (res, plain)

--------------------------------
-- Passphrases
--------------------------------

-- gpgme_error_t (*gpgme_passphrase_cb_t)(void *hook, const char *uid_hint, const char *passphrase_info, int prev_was_bad, int fd)

type PassphraseCallback = Ptr () -- ^ Hook
                        -> Ptr CChar -- ^ Uid Hint
                        -> Ptr CChar -- ^ passphrase info
                        -> CInt -- ^ Was Bad?
                        -> CInt -- ^ fd
                        -> IO CUInt

foreign import ccall "wrapper"
  mkPasswordCallback  :: PassphraseCallback -> IO (FunPtr PassphraseCallback)

setPassphraseCallback :: Ctx
                      -> (String -> String -> Bool -> IO String)
                      -> IO ()
setPassphraseCallback ctx f = do
    let cbFun _ uidHint pInfo bad fd = do
               uidHintString <- peekCString uidHint
               pInfoString <- peekCString pInfo
               out <- f uidHintString pInfoString (bad == 0)
               _ <- fdWrite (Fd fd) (filter (/= '\n') out ++ "\n" )
               return 0
    cb <- mkPasswordCallback cbFun
    withCtx ctx $ \ctxPtr -> {# call set_passphrase_cb #} ctxPtr cb nullPtr

data Engine = Engine { engineProtocol   :: Protocol
                     , engineFilename   :: Maybe String
                     , engineHomeDir    :: Maybe String
                     , engineVersion    :: Maybe String
                     , engineReqVersion :: Maybe String
                     } deriving (Show)

getEngines :: Ctx -> IO [Engine]
getEngines ctx = withCtx ctx $ \ctxPtr ->  do
    goEngines =<< {#call ctx_get_engine_info #} ctxPtr
  where
    goEngines this = if this == nullPtr
                     then return []
                     else do
        engine <- Engine <$> (toEnum' <$> {# get engine_info_t.protocol#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.file_name#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.home_dir#}    this)
                         <*> (peekCSM =<< {#get engine_info_t.version#}     this)
                         <*> (peekCSM =<< {#get engine_info_t.req_version#} this)
        next <- {# get gpgme_engine_info_t.next #} this
        (engine:) <$> goEngines next
    peekCSM cString = if cString == nullPtr
                      then return Nothing
                      else Just <$> peekCString cString

setEngine :: Ctx -> Engine -> IO ()
setEngine ctx eng = withCtx ctx $ \ctxPtr->
                    withMBCString (engineFilename eng) $ \fNamePtr ->
                    withMBCString (engineHomeDir eng)  $ \hDirPtr ->
    throwError =<< {#call ctx_set_engine_info #} ctxPtr
                                                 (fromEnum' $ engineProtocol eng)
                                                 fNamePtr
                                                 hDirPtr
  where
    withMBCString Nothing f = f nullPtr
    withMBCString (Just str) f = withCString str f

{# enum pinentry_mode_t as PinentryMode {underscoreToCase} #}

{# fun set_pinentry_mode as ^
   { withCtx* `Ctx'
   , fromEnum' `PinentryMode'
   } -> `()' throwError*- #}

-------------------------------------------
-- Key Creation ---------------------------
-------------------------------------------
data GenKeyResult = GenKeyResult { genKeyhasPrimary :: Bool
                                 , genKeyhasSubKey :: Bool
                                 , genKeyFingerprint :: Maybe BS.ByteString
                                 } deriving (Show)

genKey :: Ctx -> String -> IO GenKeyResult
genKey ctx params = withCtx ctx $ \ctxPtr ->
                    withCString params $ \paramsPtr -> do
    putStrLn "starting key genearion"
    throwError =<< {#call gpgme_op_genkey#} ctxPtr paramsPtr nullPtr nullPtr
    putStrLn "retrieving result"
    res <- {#call gpgme_op_genkey_result#} ctxPtr
    putStrLn "Extracting result data"
    prim <- toEnum' <$> {#get gpgme_genkey_result_t.primary#} res
    sub <- toEnum' <$> {#get gpgme_genkey_result_t.sub#} res
    fprint <- maybePeek BS.packCString =<< {#get gpgme_genkey_result_t.fpr#} res
    return $ GenKeyResult prim sub fprint

------------------------------------------
-- Key Deletion --------------------------
------------------------------------------

{# fun gpgme_op_delete as deleteKey
 { withCtx* `Ctx'
 , withKey* `Key'
 , fromEnum' `Bool'
 } -> `()' throwError*- #}

------------------------------------------
-- Key Editing ---------------------------
------------------------------------------

-- gpgme_error_t (*gpgme_edit_cb_t) (void *handle, gpgme_status_code_t status, const char *args, int fd)

{# enum gpgme_status_code_t as StatusCode {underscoreToCase} deriving (Show, Read, Eq, Data, Typeable, Bounded) #}

type EditCallback' = Ptr () -> CInt -> CString -> CInt -> IO CUInt
type EditCallback = StatusCode -> Text -> Fd -> IO Error

foreign import ccall "wrapper"
    mkEditCallback :: EditCallback' -> IO (FunPtr EditCallback')

#c
gpgme_error_t gpgme_err_make_uninlined ( gpgme_err_source_t err_source
                                       , gpgme_err_code_t err_code);
#endc

{# fun gpgme_err_make_uninlined as mkError
   { fromEnum'  `ErrorSource'
   , fromEnum' `ErrorCode'
   }
   -> `CUInt' id #}

editKey :: Ctx -> Key -> EditCallback -> IO ByteString
editKey ctx key callback = do
    let callback' _ scInt cStr fdInt = do
            str <- if (cStr == nullPtr) then return "" else peekCString cStr
            err <- callback (toEnum $ fromIntegral scInt) (Text.pack str)
                            (Fd fdInt)
            mkError (errSource err) (errCode err)
    Ex.bracket (mkEditCallback callback') freeHaskellFunPtr
        $ \cb ->
        withCtx ctx $ \ctxPtr ->
        withKey key $ \keyPtr ->
        withBSBuffer $ \buffer ->
        withDataBuffer buffer $ \bufferPtr ->
        throwError =<< {#call gpgme_op_edit#} ctxPtr keyPtr cb nullPtr bufferPtr

-----------------------------------------
-- Process ------------------------------
-----------------------------------------

{# fun kill as ^
    { fromIntegral `CPid'
    , fromIntegral `Int'
    } -> `Int' fromIntegral #}

-- | Bindings to GPGMe
--
-- partial bindings to gpgme

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}

#include <gpgme.h>
#include <signal.h>

module Bindings where

import           Control.Applicative ((<$>), (<*>))
import qualified Control.Exception as Ex
import           Data.Bits
import qualified Data.ByteString as BS
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as BS
import           Data.Data
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import           Foreign.C
import           Foreign.ForeignPtr
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable

import           System.Posix.IO
import           System.Posix.Types

fromEnum' :: (Enum a, Num b) => a -> b
fromEnum' = fromIntegral . fromEnum

toEnum' :: (Enum c, Integral a) => a -> c
toEnum' = toEnum . fromIntegral

fromFlags :: (Enum a, Num b, Data.Bits.Bits b) => [a] -> b
fromFlags = foldr (.|.) 0 . map fromEnum'

toFlags x = filter (\y -> let y' = fromEnum' y in x .|. y' == y')
              [minBound..maxBound]

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

{#pointer gpgme_ctx_t as Ctx foreign newtype#}

instance Show Ctx where
    show _ = "<GpgMe.CTX>"

{#enum gpgme_err_code_t as ErrorCode {underscoreToCase}
       with prefix = "GPG"
       deriving (Show) #}

{#enum gpgme_err_source_t as ErrorSource {underscoreToCase}
       with prefix = "GPG"

       deriving (Show) #}

data Error = Error { errCode :: ErrorCode
                   , errSource :: ErrorSource
                   , errorString :: Text.Text
                   } deriving (Show, Typeable )

noError :: Error
noError = Error ErrNoError ErrSourceUnknown ""

instance Ex.Exception Error

throwError :: CUInt -> IO ()
throwError e' = do
    mbe <- toError e'
    case mbe of
        Nothing -> return ()
        Just e -> Ex.throwIO e

#c
gpgme_err_code_t gpgme_err_code_uninlined (gpgme_error_t err);
gpgme_err_source_t gpgme_err_source_uninlined (gpgme_error_t err);
#endc

toError :: CUInt -> IO (Maybe Error)
toError err = case err of
    0 -> return Nothing
    _ -> Just <$>
         (allocaBytes 256 $ \buff -> do -- We hope that any error message will
                                        -- be less than 256 bytes long
               _ <- {#call strerror_r#} err buff 256
               Error <$> (toEnum . fromIntegral
                          <$> {# call err_code_uninlined #} err)
                     <*> (toEnum . fromIntegral
                          <$> {# call err_source_uninlined #} err)
                     <*> (Text.pack <$> peekCString buff))

checkVersion :: Maybe Text -> IO (Maybe Text)
checkVersion Nothing = Just . Text.pack <$>
                         (peekCString =<< {#call check_version#} nullPtr)
checkVersion (Just txt) = withCString (Text.unpack txt) $ \buf -> do
    _ <- {#call check_version#} buf
    return Nothing

{#enum gpgme_protocol_t as Protocol {underscoreToCase} deriving (Show, Eq)#}
-- gpgme_engine_check_version (gpgme_protocol_t protocol)

foreign import ccall unsafe "&gpgme_release"
    releaseCtx :: FunPtr (Ptr Ctx -> IO ())

mkContext :: Ptr (Ptr Ctx) -> IO Ctx
mkContext p = do
    if p == nullPtr
        then Ex.throw (Ex.AssertionFailed "nullPtr")
        else fmap Ctx $ newForeignPtr releaseCtx  . castPtr =<< peek p

-- withCtx :: Ctx -> (Ptr Ctx -> IO t) -> IO t
-- withCtx x f = withForeignPtr (fromCtx x) f

{#fun new as ctxNew'
   {alloca- `Ctx' mkContext*}
   -> `()' throwError*- #}

-- | Check that version constraint is satisfied and create a new context
ctxNew :: Maybe Text -> IO Ctx
ctxNew minVersion = do
    _ <- checkVersion minVersion
    ctxNew'

{#enum validity_t as Validity {underscoreToCase} deriving (Show) #}
{#enum attr_t as Attr {underscoreToCase} deriving (Show) #}

------------------------------------
-- Keys
------------------------------------

{#pointer gpgme_key_t as Key foreign newtype #}

withKeysArray :: [Key] -> (Ptr (Ptr Key) -> IO b) -> IO b
withKeysArray ks' f = withKeys ks' $ \ksPtrs -> withArray0 nullPtr ksPtrs f
  where
    withKeys []     g = g []
    withKeys (k:ks) g = withKey k $ \kPtr -> withKeys ks (g . (kPtr:))

foreign import ccall "gpgme.h &gpgme_key_unref"
    unrefPtr :: FunPtr (Ptr Key -> IO ())

getKeys :: Ctx
        -> Bool -- ^ Only keys with secret
        -> IO [Key]
getKeys ctx secretOnly = withCtx ctx $ \ctxPtr -> do
    _ <- {#call gpgme_op_keylist_start #} ctxPtr nullPtr (fromEnum' secretOnly)
    alloca $ takeKeys ctxPtr
  where
    takeKeys ctxPtr (buf :: Ptr (Ptr Key)) = do
        err <- toError =<< {#call gpgme_op_keylist_next#} ctxPtr buf
        case err of
            Nothing -> do
                keyPtr <- peek buf
                key <- newForeignPtr unrefPtr keyPtr
                (Key key :) <$> takeKeys ctxPtr buf
            Just e -> case errCode e of
                ErrEof -> return []
                _ -> error "takeKeys"

reserved :: (Ptr a -> t) -> t
reserved f = f nullPtr

reserved0 :: Num a => (a -> t) -> t
reserved0 f = f 0

{#fun key_get_string_attr as ^
   { withKey* `Key'
   , fromEnum' `Attr'
   , reserved- `Ptr()'
   , `Int'
   } -> `Maybe BS.ByteString' toMaybeText* #}

-------------------------------
-- Data Buffers
-------------------------------

newtype DataBuffer = DataBuffer {fromDataBuffer :: Ptr ()}
mkDataBuffer :: Ptr (Ptr ()) -> IO DataBuffer
mkDataBuffer = fmap DataBuffer . peek

withDataBuffer :: DataBuffer -> (Ptr () -> t) -> t
withDataBuffer (DataBuffer buf) f = f buf

toMaybeText :: Ptr CChar -> IO (Maybe BS.ByteString)
toMaybeText ptr = maybePeek BS.packCString ptr

withMaybeText :: Maybe Text -> (Ptr CChar -> IO a) -> IO a
withMaybeText Nothing = ($ nullPtr)
withMaybeText (Just txt) = withCString (Text.unpack txt)

{#fun data_new as ^
   { alloca- `DataBuffer' mkDataBuffer* }
   -> `()' throwError*- #}

peekInt :: (Storable a, Num b, Integral a) => Ptr a -> IO b
peekInt = fmap fromIntegral . peek

{#fun data_release_and_get_mem as ^
   { fromDataBuffer `DataBuffer'
   , alloca- `Int' peekInt*
   } -> `Ptr ()' castPtr #}

getDataBufferBytes :: DataBuffer -> IO BS.ByteString
getDataBufferBytes db = do
    (dt, len) <- dataReleaseAndGetMem db
    res <- if dt == nullPtr then return BS.empty
                            else do
               bs <- BS.packCStringLen (castPtr dt, len)
               {#call free#} dt
               return bs
    return res

{# fun gpgme_op_export_keys as opExportKeys
   { withCtx* `Ctx'
   , withKeysArray* `[Key]'
   , reserved0- `CUInt'
   , fromDataBuffer `DataBuffer'
   } -> `Error' throwError*- #}

data ImportStatus = ImportStatus { isFprint :: BS.ByteString
                                 , isResult :: Maybe Error
                                 , isStatus :: Int -- TODO: convert to flags
                                 } deriving (Show)

importKeyBuffer :: Ctx -> DataBuffer -> IO [ImportStatus]
importKeyBuffer ctx keyBuffer = withCtx ctx $ \ctxPtr ->
                          withDataBuffer keyBuffer $ \keyPtr -> do
    throwError =<< {#call op_import#} ctxPtr keyPtr
    result <- {#call op_import_result #} ctxPtr
    walkImports =<< {#get import_result_t.imports#} result
  where
    walkImports p = if p == nullPtr
                      then return []
                      else do
        is <- ImportStatus <$> (BS.packCString
                                  =<< {#get import_status_t.fpr #} p)
                           <*> (toError =<< {#get import_status_t.result #} p)
                           <*> (fromIntegral <$> {#get import_status_t.status #} p)
        (is:) <$> (walkImports =<< {#get import_status_t.next #} p)

importKeys :: Ctx -> ByteString -> IO [ImportStatus]
importKeys ctx bs = withBSData bs $ importKeyBuffer ctx

exportKeys :: Ctx -> [Key] -> IO BS.ByteString
exportKeys ctx keys = withBSBuffer $ opExportKeys ctx keys

unsafeUseAsCStringLen' :: Num t =>
                          BS.ByteString
                       -> ((Ptr CChar, t) -> IO a)
                       -> IO a
unsafeUseAsCStringLen' bs f =
    BS.unsafeUseAsCStringLen bs $ \(bs', l) -> f (bs', fromIntegral l)

{# fun data_new_from_mem as ^
   { alloca- `DataBuffer' mkDataBuffer*
   , unsafeUseAsCStringLen' * `BS.ByteString'&
   , fromEnum' `Bool'
   } -> `Error' throwError*- #}

{# fun data_release as ^
   { withDataBuffer* `DataBuffer'} -> `()' #}

{# fun set_armor as ^
     { withCtx* `Ctx'
     , fromEnum' `Bool'
     } -> `()' #}

withBSData :: BS.ByteString -> (DataBuffer -> IO c) -> IO c
withBSData bs =
    Ex.bracket (dataNewFromMem bs True)
               dataRelease

withBSBuffer :: (DataBuffer -> IO a) -> IO BS.ByteString
withBSBuffer f =
    Ex.bracketOnError dataNew
                      dataRelease
                      $ \db -> do
                          _ <- f db
                          getDataBufferBytes db

-----------------------------------
-- Signing
-----------------------------------

{#fun signers_clear as ^
    {withCtx* `Ctx'} -> `()'#}

{#fun signers_add as ^
    { withCtx* `Ctx'
    , withKey* `Key'
    } -> `()' throwError* #}

{# enum sig_mode_t as SigMode {underscoreToCase}
       with prefix = "GPGME"
       deriving (Show) #}

{#fun op_sign as ^
    { withCtx* `Ctx'
    , withDataBuffer* `DataBuffer'
    , withDataBuffer* `DataBuffer'
    , fromEnum' `SigMode'
    } -> `()' throwError*- #}
--     exportKey

-- | Sign a text using a private signing key from the GPG keychain
sign :: Ctx
     -> BS.ByteString -- ^ Text to sign
     -> Key -- ^ Signing key to use
     -> SigMode -- ^ Signing mode
     -> IO BS.ByteString
sign ctx plain key mode = withBSData plain $ \plainData ->
                          withBSBuffer $ \outData -> (do
    signersClear ctx
    signersAdd ctx key
    opSign ctx plainData outData mode)
       `Ex.finally` signersClear ctx

{# enum sigsum_t as SigSummary {underscoreToCase} deriving (Bounded, Show)#}
{# enum sig_stat_t as SigStat {underscoreToCase} deriving (Bounded, Show)#}

{#fun op_verify as ^
   { withCtx* `Ctx'
   , withDataBuffer* `DataBuffer' -- sig
   , withDataBuffer* `DataBuffer' -- signed-text
   , withDataBuffer* `DataBuffer' -- plain
   } -> `()' throwError*- #}

checkVerifyResult :: Ctx -> IO SigStat
checkVerifyResult ctx = withCtx ctx $ \ctx' -> do
    alloca $ \sigStatPtr -> do
        res <- {#call get_sig_status#} ctx' 0 sigStatPtr nullPtr
        if (res == nullPtr)
            then return SigStatNosig
            else do
                sigStat <- peek sigStatPtr
                return $! (toEnum' sigStat :: SigStat)

-- | Verify a signature created in 'SigModeDetach' mode
verifyDetach :: Ctx
             -> BS.ByteString -- ^ The source text that the signature pertains to
             -> BS.ByteString -- ^ The signature
             -> IO SigStat
verifyDetach ctx signedText sig = withBSData signedText $ \stData ->
                                  withBSData sig $ \sigData -> do
    opVerify ctx sigData stData (DataBuffer nullPtr)
    checkVerifyResult ctx

-- | Verify a signature created in 'SigModeNormal' or 'SigModeClear' mode
verify :: Ctx
        -> BS.ByteString -- ^ Text and attached Signature
        -> IO (SigStat, BS.ByteString) -- ^ result and extracted plain text
verify ctx sig = withBSData sig $ \sigData -> do
    plain <- withBSBuffer $ \plainData ->
        opVerify ctx sigData (DataBuffer nullPtr) plainData
    res <- checkVerifyResult ctx
    return (res, plain)

--------------------------------
-- Passphrases
--------------------------------

-- gpgme_error_t (*gpgme_passphrase_cb_t)(void *hook, const char *uid_hint, const char *passphrase_info, int prev_was_bad, int fd)

type PassphraseCallback = Ptr () -- ^ Hook
                        -> Ptr CChar -- ^ Uid Hint
                        -> Ptr CChar -- ^ passphrase info
                        -> CInt -- ^ Was Bad?
                        -> CInt -- ^ fd
                        -> IO CUInt

foreign import ccall "wrapper"
  mkPasswordCallback  :: PassphraseCallback -> IO (FunPtr PassphraseCallback)

setPassphraseCallback :: Ctx
                      -> (String -> String -> Bool -> IO String)
                      -> IO ()
setPassphraseCallback ctx f = do
    let cbFun _ uidHint pInfo bad fd = do
               uidHintString <- peekCString uidHint
               pInfoString <- peekCString pInfo
               out <- f uidHintString pInfoString (bad == 0)
               _ <- fdWrite (Fd fd) (filter (/= '\n') out ++ "\n" )
               return 0
    cb <- mkPasswordCallback cbFun
    withCtx ctx $ \ctxPtr -> {# call set_passphrase_cb #} ctxPtr cb nullPtr

data Engine = Engine { engineProtocol   :: Protocol
                     , engineFilename   :: Maybe String
                     , engineHomeDir    :: Maybe String
                     , engineVersion    :: Maybe String
                     , engineReqVersion :: Maybe String
                     } deriving (Show)

getEngines :: Ctx -> IO [Engine]
getEngines ctx = withCtx ctx $ \ctxPtr ->  do
    goEngines =<< {#call ctx_get_engine_info #} ctxPtr
  where
    goEngines this = if this == nullPtr
                     then return []
                     else do
        engine <- Engine <$> (toEnum' <$> {# get engine_info_t.protocol#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.file_name#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.home_dir#}    this)
                         <*> (peekCSM =<< {#get engine_info_t.version#}     this)
                         <*> (peekCSM =<< {#get engine_info_t.req_version#} this)
        next <- {# get gpgme_engine_info_t.next #} this
        (engine:) <$> goEngines next
    peekCSM cString = if cString == nullPtr
                      then return Nothing
                      else Just <$> peekCString cString

setEngine :: Ctx -> Engine -> IO ()
setEngine ctx eng = withCtx ctx $ \ctxPtr->
                    withMBCString (engineFilename eng) $ \fNamePtr ->
                    withMBCString (engineHomeDir eng)  $ \hDirPtr ->
    throwError =<< {#call ctx_set_engine_info #} ctxPtr
                                                 (fromEnum' $ engineProtocol eng)
                                                 fNamePtr
                                                 hDirPtr
  where
    withMBCString Nothing f = f nullPtr
    withMBCString (Just str) f = withCString str f

{# enum pinentry_mode_t as PinentryMode {underscoreToCase} #}

{# fun set_pinentry_mode as ^
   { withCtx* `Ctx'
   , fromEnum' `PinentryMode'
   } -> `()' throwError*- #}

-------------------------------------------
-- Key Creation ---------------------------
-------------------------------------------
data GenKeyResult = GenKeyResult { genKeyhasPrimary :: Bool
                                 , genKeyhasSubKey :: Bool
                                 , genKeyFingerprint :: Maybe BS.ByteString
                                 } deriving (Show)

genKey :: Ctx -> String -> IO GenKeyResult
genKey ctx params = withCtx ctx $ \ctxPtr ->
                    withCString params $ \paramsPtr -> do
    putStrLn "starting key genearion"
    throwError =<< {#call gpgme_op_genkey#} ctxPtr paramsPtr nullPtr nullPtr
    putStrLn "retrieving result"
    res <- {#call gpgme_op_genkey_result#} ctxPtr
    putStrLn "Extracting result data"
    prim <- toEnum' <$> {#get gpgme_genkey_result_t.primary#} res
    sub <- toEnum' <$> {#get gpgme_genkey_result_t.sub#} res
    fprint <- maybePeek BS.packCString =<< {#get gpgme_genkey_result_t.fpr#} res
    return $ GenKeyResult prim sub fprint

------------------------------------------
-- Key Deletion --------------------------
------------------------------------------

{# fun gpgme_op_delete as deleteKey
 { withCtx* `Ctx'
 , withKey* `Key'
 , fromEnum' `Bool'
 } -> `()' throwError*- #}

------------------------------------------
-- Key Editing ---------------------------
------------------------------------------

-- gpgme_error_t (*gpgme_edit_cb_t) (void *handle, gpgme_status_code_t status, const char *args, int fd)

{# enum gpgme_status_code_t as StatusCode {underscoreToCase} deriving (Show, Read, Eq, Data, Typeable, Bounded) #}

type EditCallback' = Ptr () -> CInt -> CString -> CInt -> IO CUInt
type EditCallback = StatusCode -> Text -> Fd -> IO Error

foreign import ccall "wrapper"
    mkEditCallback :: EditCallback' -> IO (FunPtr EditCallback')

#c
gpgme_error_t gpgme_err_make_uninlined ( gpgme_err_source_t err_source
                                       , gpgme_err_code_t err_code);
#endc

{# fun gpgme_err_make_uninlined as mkError
   { fromEnum'  `ErrorSource'
   , fromEnum' `ErrorCode'
   }
   -> `CUInt' id #}

editKey :: Ctx -> Key -> EditCallback -> IO ByteString
editKey ctx key callback = do
    let callback' _ scInt cStr fdInt = do
            str <- if (cStr == nullPtr) then return "" else peekCString cStr
            err <- callback (toEnum $ fromIntegral scInt) (Text.pack str)
                            (Fd fdInt)
            mkError (errSource err) (errCode err)
    Ex.bracket (mkEditCallback callback') freeHaskellFunPtr
        $ \cb ->
        withCtx ctx $ \ctxPtr ->
        withKey key $ \keyPtr ->
        withBSBuffer $ \buffer ->
        withDataBuffer buffer $ \bufferPtr ->
        throwError =<< {#call gpgme_op_edit#} ctxPtr keyPtr cb nullPtr bufferPtr

-----------------------------------------
-- Process ------------------------------
-----------------------------------------

{# fun kill as ^
    { fromIntegral `CPid'
    , fromIntegral `Int'
    } -> `Int' fromIntegral #}


Fix SourceLanguage.chs docs.

Fix SourceLanguage.chs docs.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceView
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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)
--
module Graphics.UI.Gtk.SourceView.SourceLanguage (
-- * Types
  SourceLanguage,
  SourceLanguageClass,

-- * Methods
  castToSourceLanguage,
  sourceLanguageGetId,
  sourceLanguageGetName,
  sourceLanguageGetSection,
  sourceLanguageGetHidden,
  sourceLanguageGetMetadata,
  sourceLanguageGetMimeTypes,
  sourceLanguageGetGlobs,

-- * Attributes
  sourceLanguageHidden,
  sourceLanguageId,
  sourceLanguageName,
  sourceLanguageSection
  ) where

import Control.Monad	(liftM)
import Data.Maybe (fromMaybe)

import System.Glib.FFI
import System.Glib.UTFString
{#import System.Glib.Properties#}
import System.Glib.Attributes
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.SourceStyleScheme#}

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

-- methods

-- | Returns the ID of the language. The ID is not locale-dependent.
--
sourceLanguageGetId :: SourceLanguage
                    -> IO String -- ^ returns  the ID of language. The returned string is owned by language and should not be freed or modified.
sourceLanguageGetId sl =
  {#call unsafe source_language_get_id#} sl >>= peekUTFString

-- | Returns the localized name of the language.
--
sourceLanguageGetName :: SourceLanguage
                      -> IO String -- ^ returns  the name of language. The returned string is owned by language and should not be freed or modified.
sourceLanguageGetName sl =
  {#call unsafe source_language_get_name#} sl >>= peekUTFString

-- | Returns the localized section of the language. Each language belong to a section (ex. HTML belogs to
-- the Markup section).
--
sourceLanguageGetSection :: SourceLanguage
                         -> IO String -- ^ returns  the section of language. The returned string is owned by language and should not be freed or modified.
sourceLanguageGetSection sl =
  {#call unsafe source_language_get_section#} sl >>= peekUTFString

-- | Returns whether the language should be hidden from the user.
--
sourceLanguageGetHidden :: SourceLanguage
                        -> IO Bool -- ^ returns  'True' if the language should be hidden, 'False' otherwise.
sourceLanguageGetHidden sl = liftM toBool $
  {#call unsafe source_language_get_hidden#} sl

-- |
--
sourceLanguageGetMetadata :: SourceLanguage
                          -> String  -- ^ @name@     metadata property name.
                          -> IO String -- ^ returns  value of property name stored in the metadata of language or emtpy if language doesn't contain that metadata
sourceLanguageGetMetadata sl name = do
  withUTFString name ({#call unsafe source_language_get_metadata#} sl) >>= peekUTFString

-- | Returns the mime types associated to this language. This is just an utility wrapper around
-- 'sourceLanguageGetMetadata ' to retrieve the "mimetypes" metadata property and split it into
-- an array.
--
sourceLanguageGetMimeTypes :: SourceLanguage
                           -> IO [String] -- ^ returns  an array containing the mime types or emtpy if no mime types are found. The
sourceLanguageGetMimeTypes sl = do
  mimeTypesArray <- {#call unsafe source_language_get_mime_types#} sl
  mimeTypes <- liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 mimeTypesArray
  {# call g_strfreev #} mimeTypesArray
  return mimeTypes

-- | Returns the globs associated to this language. This is just an utility wrapper around
-- 'sourceLanguageGetMetadata' to retrieve the "globs" metadata property and split it into an
-- array.
--
sourceLanguageGetGlobs :: SourceLanguage
                       -> IO [String] -- ^ returns  an array containing the globs or empty if no globs are found.
sourceLanguageGetGlobs sl = do
  globsArray <- {#call unsafe source_language_get_globs#} sl
  globs <- liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 globsArray
  {# call g_strfreev #} globsArray
  return globs

-- | Whether the language should be hidden from the user.
--
-- Default value: 'False'
--
sourceLanguageHidden :: ReadAttr SourceLanguage Bool
sourceLanguageHidden = readAttrFromBoolProperty "hidden"

-- | Language id.
--
-- Default value: \"\"
--
sourceLanguageId :: ReadAttr SourceLanguage String
sourceLanguageId = readAttrFromStringProperty "id"

-- | Language name.
--
-- Default value: \"\"
--
sourceLanguageName :: ReadAttr SourceLanguage String
sourceLanguageName = readAttrFromStringProperty "name"

-- | Language section.
--
-- Default value: \"\"
--
sourceLanguageSection :: ReadAttr SourceLanguage String
sourceLanguageSection = readAttrFromStringProperty "section"

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceView
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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)
--
module Graphics.UI.Gtk.SourceView.SourceLanguage (
  SourceLanguage,
  SourceLanguageClass,
  castToSourceLanguage,
  sourceLanguageGetId,
  sourceLanguageGetName,
  sourceLanguageGetSection,
  sourceLanguageGetHidden,
  sourceLanguageGetMetadata,
  sourceLanguageGetMimeTypes,
  sourceLanguageGetGlobs,
  sourceLanguageHidden,
  sourceLanguageId,
  sourceLanguageName,
  sourceLanguageSection
  ) where

import Control.Monad	(liftM)
import Data.Maybe (fromMaybe)

import System.Glib.FFI
import System.Glib.UTFString
{#import System.Glib.Properties#}
import System.Glib.Attributes
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.SourceStyleScheme#}

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

-- methods

-- |
--
sourceLanguageGetId :: SourceLanguage -> IO String
sourceLanguageGetId sl =
  {#call unsafe source_language_get_id#} sl >>= peekUTFString

-- |
--
sourceLanguageGetName :: SourceLanguage -> IO String
sourceLanguageGetName sl =
  {#call unsafe source_language_get_name#} sl >>= peekUTFString

-- |
--
sourceLanguageGetSection :: SourceLanguage -> IO String
sourceLanguageGetSection sl =
  {#call unsafe source_language_get_section#} sl >>= peekUTFString

-- |
--
sourceLanguageGetHidden :: SourceLanguage -> IO Bool
sourceLanguageGetHidden sl = liftM toBool $
  {#call unsafe source_language_get_hidden#} sl

-- |
--
sourceLanguageGetMetadata :: SourceLanguage -> String -> IO String
sourceLanguageGetMetadata sl name = do
  withUTFString name ({#call unsafe source_language_get_metadata#} sl) >>= peekUTFString

-- |
--
sourceLanguageGetMimeTypes :: SourceLanguage -> IO [String]
sourceLanguageGetMimeTypes sl = do
  mimeTypesArray <- {#call unsafe source_language_get_mime_types#} sl
  mimeTypes <- liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 mimeTypesArray
  {# call g_strfreev #} mimeTypesArray
  return mimeTypes

-- |
--
sourceLanguageGetGlobs :: SourceLanguage -> IO [String]
sourceLanguageGetGlobs sl = do
  globsArray <- {#call unsafe source_language_get_globs#} sl
  globs <- liftM (fromMaybe []) $ maybePeek peekUTFStringArray0 globsArray
  {# call g_strfreev #} globsArray
  return globs

-- |
--
sourceLanguageHidden :: ReadAttr SourceLanguage Bool
sourceLanguageHidden = readAttrFromBoolProperty "hidden"

-- |
--
sourceLanguageId :: ReadAttr SourceLanguage String
sourceLanguageId = readAttrFromStringProperty "id"

-- |
--
sourceLanguageName :: ReadAttr SourceLanguage String
sourceLanguageName = readAttrFromStringProperty "name"

-- |
--
sourceLanguageSection :: ReadAttr SourceLanguage String
sourceLanguageSection = readAttrFromStringProperty "section"