SCardStatus can be shown, no need to export statusToString

{-# LANGUAGE ForeignFunctionInterface #-}

module Lowlevel.PCSCLite ( SCardStatus (..)
                         , SCardShare (..)
                         , SCardProtocol (..)
                         , SCardScope (..)
                         , SCardContext
                         , SCardAction (..)
                         , SCardCardState (..)
                         , fromCLong
                         , SCardIORequest
                         , toSCardProtocol
                         , mkSCardIORequestT0
                         , mkSCardIORequestT1
                         , mkSCardIORequestRaw)
where

import Data.Int
import Foreign
import Foreign.C
import Foreign.Storable
import Control.Monad
import Control.Applicative

#include <pcsclite_patched.h>

-- | Converts a 'SCardStatus' to the error message.
statusToString :: SCardStatus -> String
statusToString s = unsafePerformIO $
                   {#call pcsc_stringify_error as ^#} (fromIntegral $ fromEnum s) >>= peekCString

-- | Returncodes given by the PC\/SC daemon.
{#enum define SCardStatus { SCARD_S_SUCCESS             as Ok
                          , SCARD_F_INTERNAL_ERROR      as InternalError
                          , SCARD_E_CANCELLED           as Cancelled
                          , SCARD_E_INVALID_HANDLE      as InvalidHandle
                          , SCARD_E_INVALID_PARAMETER   as InvalidParameter
                          , SCARD_E_INVALID_TARGET      as InvalidTarget
                          , SCARD_E_NO_MEMORY           as NoMemory
                          , SCARD_F_WAITED_TOO_LONG     as WaitTooLong
                          , SCARD_E_INSUFFICIENT_BUFFER as InsufficientBuffer
                          , SCARD_E_UNKNOWN_READER      as ReaderUnknown
                          , SCARD_E_TIMEOUT             as Timeout
                          , SCARD_E_SHARING_VIOLATION   as SharingViolation
                          , SCARD_E_NO_SMARTCARD        as NoSmartCard
                          , SCARD_E_UNKNOWN_CARD        as UnknownCard
                          , SCARD_E_CANT_DISPOSE        as CannotDispose
                          , SCARD_E_PROTO_MISMATCH      as ProtocolMismatch
                          , SCARD_E_NOT_READY           as NotReady
                          , SCARD_E_INVALID_VALUE       as InvalidValue
                          , SCARD_E_SYSTEM_CANCELLED    as SystemCancelled
                          , SCARD_F_COMM_ERROR          as CommunicationError
                          , SCARD_F_UNKNOWN_ERROR       as UnknownError
                          , SCARD_E_INVALID_ATR         as InvalidATR
                          , SCARD_E_NOT_TRANSACTED      as NotTransacted
                          , SCARD_E_READER_UNAVAILABLE  as ReaderUnavailable
                          , SCARD_P_SHUTDOWN            as Shutdown
                          , SCARD_E_PCI_TOO_SMALL       as PciToSmall
                          , SCARD_E_READER_UNSUPPORTED  as ReaderUnsupported
                          , SCARD_E_DUPLICATE_READER    as DuplicateReader
                          , SCARD_E_CARD_UNSUPPORTED    as CardUnsupportedError
                          , SCARD_E_NO_SERVICE          as NoService
                          , SCARD_E_SERVICE_STOPPED     as ServiceStopped
                          , SCARD_E_UNSUPPORTED_FEATURE as UnsupportedFeatureOrUnexpected
                          , SCARD_E_ICC_INSTALLATION    as IccInstallation
                          , SCARD_E_ICC_CREATEORDER     as IccCreateOrder
                          , SCARD_E_DIR_NOT_FOUND       as DirectoryNotFound
                          , SCARD_E_FILE_NOT_FOUND      as FileNotFound
                          , SCARD_E_NO_DIR              as NoDirectory
                          , SCARD_E_NO_FILE             as NoFile
                          , SCARD_E_NO_ACCESS           as NoAccess
                          , SCARD_E_WRITE_TOO_MANY      as TooManyWrites
                          , SCARD_E_BAD_SEEK            as BadSeek
                          , SCARD_E_INVALID_CHV         as InvalidCHV
                          , SCARD_E_UNKNOWN_RES_MNG     as UnknownResMNG
                          , SCARD_E_NO_SUCH_CERTIFICATE as NoSuchCertificate
                          , SCARD_E_CERTIFICATE_UNAVAILABLE as CertificateUnavailable
                          , SCARD_E_NO_READERS_AVAILABLE as NoReaderAvailable
                          , SCARD_E_COMM_DATA_LOST      as CommunicationDataLost
                          , SCARD_E_NO_KEY_CONTAINER    as NoKeyContainer
                          , SCARD_E_SERVER_TOO_BUSY     as ServerToBusy
                          , SCARD_W_UNSUPPORTED_CARD    as CardUnsupportedWarning
                          , SCARD_W_UNRESPONSIVE_CARD   as UnresponsiveCard
                          , SCARD_W_UNPOWERED_CARD      as CardUnpowered
                          , SCARD_W_RESET_CARD          as CardReset
                          , SCARD_W_REMOVED_CARD        as CardRemoved
                          , SCARD_W_SECURITY_VIOLATION  as SecurityViolation
                          , SCARD_W_WRONG_CHV           as WrongCHV
                          , SCARD_W_CHV_BLOCKED         as CHVBlocked
                          , SCARD_W_EOF                 as EOF
                          , SCARD_W_CANCELLED_BY_USER   as CancelledByUser
                          , SCARD_W_CARD_NOT_AUTHENTICATED as CardNotAuthenticated}
                          deriving (Eq)
#}

instance Show SCardStatus where
  show = statusToString

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

{#
enum define SCardScope { SCARD_SCOPE_USER     as UserScope
                       , SCARD_SCOPE_TERMINAL as TerminalScope
                       , SCARD_SCOPE_SYSTEM   as SystemScope}
#}

type SCardContext = {#type SCARDCONTEXT#}

-- | These are the possible sharing modes for 'establishContext'
{#
enum define SCardShare { SCARD_SHARE_EXCLUSIVE as Exclusive
                       , SCARD_SHARE_SHARED    as Shared
                       , SCARD_SHARE_DIRECT    as Direct}
#}

{#
enum define SCardProtocol { SCARD_PROTOCOL_T1        as T1
                          , SCARD_PROTOCOL_T0        as T0
                          , SCARD_PROTOCOL_T15       as T15
                          , SCARD_PROTOCOL_UNDEFINED as Undefined
                          , SCARD_PROTOCOL_RAW       as Raw}
#}

-- | Converts a 'CULong' to the 'SCardProtocol'.
toSCardProtocol :: CULong -> SCardProtocol
toSCardProtocol = toEnum . fromIntegral

instance Show SCardProtocol where
  show T0        = "T0"
  show T1        = "T1"
  show T15       = "T15"
  show Raw       = "Raw"
  show Undefined = "Undefined"

{#
enum define SCardAction { SCARD_LEAVE_CARD   as LeaveCard
                        , SCARD_RESET_CARD   as ResetCard
                        , SCARD_UNPOWER_CARD as UnpowerCard
                        , SCARD_EJECT_CARD   as EjectCard}
#}

-- | Creates a 'SCardIORequest' setup for the 'T0' protocol.
mkSCardIORequestT0 :: SCardIORequest
mkSCardIORequestT0  = SCardIORequest { getProtocol = T0
                                     , getSize = {#sizeof SCARD_IO_REQUEST#}}

-- | Creates a 'SCardIORequest' setup for the 'T1' protocol.
mkSCardIORequestT1 :: SCardIORequest
mkSCardIORequestT1  = SCardIORequest { getProtocol = T1
                                     , getSize = {#sizeof SCARD_IO_REQUEST#}}

-- | Creates a 'SCardIORequest' setup for the 'Raw' protocol.
mkSCardIORequestRaw :: SCardIORequest
mkSCardIORequestRaw = SCardIORequest { getProtocol = Raw
                                     , getSize = {#sizeof SCARD_IO_REQUEST#}}

data SCardIORequest = SCardIORequest { getProtocol :: SCardProtocol
                                     , getSize     :: Int}

instance Storable SCardIORequest where
  sizeOf    _ = {#sizeof SCARD_IO_REQUEST #}
  alignment _ = {#alignof SCARD_IO_REQUEST#}
  peek p = SCardIORequest
       <$> liftM toSCardProtocol ({#get SCARD_IO_REQUEST->dwProtocol #} p)
       <*> liftM fromIntegral    ({#get SCARD_IO_REQUEST->cbPciLength #} p)
  poke p x = do
    {#set SCARD_IO_REQUEST.dwProtocol  #} p $ fromIntegral . fromEnum $ getProtocol x
    {#set SCARD_IO_REQUEST.cbPciLength #} p $ fromIntegral $ getSize x

{#
enum define SCardCardState { SCARD_UNKNOWN as Unknown
                           , SCARD_ABSENT  as Absent
                           , SCARD_PRESENT as Present
                           , SCARD_POWERED as Powered
                           , SCARD_NEGOTIABLE as Negotiable
                           , SCARD_SPECIFIC as Specific}
#}

instance Show SCardCardState where
  show Unknown    = "Unknown"
  show Absent     = "Absent"
  show Present    = "Present"
  show Powered    = "Powered"
  show Negotiable = "Negotiable"
  show Specific   = "Specific"

{-# LANGUAGE ForeignFunctionInterface #-}

module Lowlevel.PCSCLite ( statusToString
                         , SCardStatus (..)
                         , SCardShare (..)
                         , SCardProtocol (..)
                         , SCardScope (..)
                         , SCardContext
                         , SCardAction (..)
                         , SCardCardState (..)
                         , fromCLong
                         , SCardIORequest
                         , toSCardProtocol
                         , mkSCardIORequestT0
                         , mkSCardIORequestT1
                         , mkSCardIORequestRaw)
where

import Data.Int
import Foreign
import Foreign.C
import Foreign.Storable
import Control.Monad
import Control.Applicative

#include <pcsclite_patched.h>

-- | Converts a 'SCardStatus' to the error message.
statusToString :: SCardStatus -> String
statusToString s = unsafePerformIO $
                   {#call pcsc_stringify_error as ^#} (fromIntegral $ fromEnum s) >>= peekCString

-- | Returncodes given by the PC\/SC daemon.
{#enum define SCardStatus { SCARD_S_SUCCESS             as Ok
                          , SCARD_F_INTERNAL_ERROR      as InternalError
                          , SCARD_E_CANCELLED           as Cancelled
                          , SCARD_E_INVALID_HANDLE      as InvalidHandle
                          , SCARD_E_INVALID_PARAMETER   as InvalidParameter
                          , SCARD_E_INVALID_TARGET      as InvalidTarget
                          , SCARD_E_NO_MEMORY           as NoMemory
                          , SCARD_F_WAITED_TOO_LONG     as WaitTooLong
                          , SCARD_E_INSUFFICIENT_BUFFER as InsufficientBuffer
                          , SCARD_E_UNKNOWN_READER      as ReaderUnknown
                          , SCARD_E_TIMEOUT             as Timeout
                          , SCARD_E_SHARING_VIOLATION   as SharingViolation
                          , SCARD_E_NO_SMARTCARD        as NoSmartCard
                          , SCARD_E_UNKNOWN_CARD        as UnknownCard
                          , SCARD_E_CANT_DISPOSE        as CannotDispose
                          , SCARD_E_PROTO_MISMATCH      as ProtocolMismatch
                          , SCARD_E_NOT_READY           as NotReady
                          , SCARD_E_INVALID_VALUE       as InvalidValue
                          , SCARD_E_SYSTEM_CANCELLED    as SystemCancelled
                          , SCARD_F_COMM_ERROR          as CommunicationError
                          , SCARD_F_UNKNOWN_ERROR       as UnknownError
                          , SCARD_E_INVALID_ATR         as InvalidATR
                          , SCARD_E_NOT_TRANSACTED      as NotTransacted
                          , SCARD_E_READER_UNAVAILABLE  as ReaderUnavailable
                          , SCARD_P_SHUTDOWN            as Shutdown
                          , SCARD_E_PCI_TOO_SMALL       as PciToSmall
                          , SCARD_E_READER_UNSUPPORTED  as ReaderUnsupported
                          , SCARD_E_DUPLICATE_READER    as DuplicateReader
                          , SCARD_E_CARD_UNSUPPORTED    as CardUnsupportedError
                          , SCARD_E_NO_SERVICE          as NoService
                          , SCARD_E_SERVICE_STOPPED     as ServiceStopped
                          , SCARD_E_UNSUPPORTED_FEATURE as UnsupportedFeatureOrUnexpected
                          , SCARD_E_ICC_INSTALLATION    as IccInstallation
                          , SCARD_E_ICC_CREATEORDER     as IccCreateOrder
                          , SCARD_E_DIR_NOT_FOUND       as DirectoryNotFound
                          , SCARD_E_FILE_NOT_FOUND      as FileNotFound
                          , SCARD_E_NO_DIR              as NoDirectory
                          , SCARD_E_NO_FILE             as NoFile
                          , SCARD_E_NO_ACCESS           as NoAccess
                          , SCARD_E_WRITE_TOO_MANY      as TooManyWrites
                          , SCARD_E_BAD_SEEK            as BadSeek
                          , SCARD_E_INVALID_CHV         as InvalidCHV
                          , SCARD_E_UNKNOWN_RES_MNG     as UnknownResMNG
                          , SCARD_E_NO_SUCH_CERTIFICATE as NoSuchCertificate
                          , SCARD_E_CERTIFICATE_UNAVAILABLE as CertificateUnavailable
                          , SCARD_E_NO_READERS_AVAILABLE as NoReaderAvailable
                          , SCARD_E_COMM_DATA_LOST      as CommunicationDataLost
                          , SCARD_E_NO_KEY_CONTAINER    as NoKeyContainer
                          , SCARD_E_SERVER_TOO_BUSY     as ServerToBusy
                          , SCARD_W_UNSUPPORTED_CARD    as CardUnsupportedWarning
                          , SCARD_W_UNRESPONSIVE_CARD   as UnresponsiveCard
                          , SCARD_W_UNPOWERED_CARD      as CardUnpowered
                          , SCARD_W_RESET_CARD          as CardReset
                          , SCARD_W_REMOVED_CARD        as CardRemoved
                          , SCARD_W_SECURITY_VIOLATION  as SecurityViolation
                          , SCARD_W_WRONG_CHV           as WrongCHV
                          , SCARD_W_CHV_BLOCKED         as CHVBlocked
                          , SCARD_W_EOF                 as EOF
                          , SCARD_W_CANCELLED_BY_USER   as CancelledByUser
                          , SCARD_W_CARD_NOT_AUTHENTICATED as CardNotAuthenticated}
                          deriving (Eq)
#}

instance Show SCardStatus where
  show = statusToString

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

{#
enum define SCardScope { SCARD_SCOPE_USER     as UserScope
                       , SCARD_SCOPE_TERMINAL as TerminalScope
                       , SCARD_SCOPE_SYSTEM   as SystemScope}
#}

type SCardContext = {#type SCARDCONTEXT#}

-- | These are the possible sharing modes for 'establishContext'
{#
enum define SCardShare { SCARD_SHARE_EXCLUSIVE as Exclusive
                       , SCARD_SHARE_SHARED    as Shared
                       , SCARD_SHARE_DIRECT    as Direct}
#}

{#
enum define SCardProtocol { SCARD_PROTOCOL_T1        as T1
                          , SCARD_PROTOCOL_T0        as T0
                          , SCARD_PROTOCOL_T15       as T15
                          , SCARD_PROTOCOL_UNDEFINED as Undefined
                          , SCARD_PROTOCOL_RAW       as Raw}
#}

-- | Converts a 'CULong' to the 'SCardProtocol'.
toSCardProtocol :: CULong -> SCardProtocol
toSCardProtocol = toEnum . fromIntegral

instance Show SCardProtocol where
  show T0        = "T0"
  show T1        = "T1"
  show T15       = "T15"
  show Raw       = "Raw"
  show Undefined = "Undefined"

{#
enum define SCardAction { SCARD_LEAVE_CARD   as LeaveCard
                        , SCARD_RESET_CARD   as ResetCard
                        , SCARD_UNPOWER_CARD as UnpowerCard
                        , SCARD_EJECT_CARD   as EjectCard}
#}

-- | Creates a 'SCardIORequest' setup for the 'T0' protocol.
mkSCardIORequestT0 :: SCardIORequest
mkSCardIORequestT0  = SCardIORequest { getProtocol = T0
                                     , getSize = {#sizeof SCARD_IO_REQUEST#}}

-- | Creates a 'SCardIORequest' setup for the 'T1' protocol.
mkSCardIORequestT1 :: SCardIORequest
mkSCardIORequestT1  = SCardIORequest { getProtocol = T1
                                     , getSize = {#sizeof SCARD_IO_REQUEST#}}

-- | Creates a 'SCardIORequest' setup for the 'Raw' protocol.
mkSCardIORequestRaw :: SCardIORequest
mkSCardIORequestRaw = SCardIORequest { getProtocol = Raw
                                     , getSize = {#sizeof SCARD_IO_REQUEST#}}

data SCardIORequest = SCardIORequest { getProtocol :: SCardProtocol
                                     , getSize     :: Int}

instance Storable SCardIORequest where
  sizeOf    _ = {#sizeof SCARD_IO_REQUEST #}
  alignment _ = {#alignof SCARD_IO_REQUEST#}
  peek p = SCardIORequest
       <$> liftM toSCardProtocol ({#get SCARD_IO_REQUEST->dwProtocol #} p)
       <*> liftM fromIntegral    ({#get SCARD_IO_REQUEST->cbPciLength #} p)
  poke p x = do
    {#set SCARD_IO_REQUEST.dwProtocol  #} p $ fromIntegral . fromEnum $ getProtocol x
    {#set SCARD_IO_REQUEST.cbPciLength #} p $ fromIntegral $ getSize x

{#
enum define SCardCardState { SCARD_UNKNOWN as Unknown
                           , SCARD_ABSENT  as Absent
                           , SCARD_PRESENT as Present
                           , SCARD_POWERED as Powered
                           , SCARD_NEGOTIABLE as Negotiable
                           , SCARD_SPECIFIC as Specific}
#}

instance Show SCardCardState where
  show Unknown    = "Unknown"
  show Absent     = "Absent"
  show Present    = "Present"
  show Powered    = "Powered"
  show Negotiable = "Negotiable"
  show Specific   = "Specific"


Commit

Commit

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}

#include <git2/commit.h>

module Data.HGit2.Commit where

import Data.HGit2.Git2
import Data.HGit2.Errors
import Data.HGit2.Repository
import Data.HGit2.Types
import Data.HGit2.Signature
import Data.HGit2.OID
import Data.HGit2.Tree
import Data.Maybe ()
import Foreign
import Foreign.C.String
import Foreign.C.Types

newtype Commit = Commit CPtr

instance CWrapper Commit where
  unwrap (Commit c) = c

-- | Get the id of a commit.
commitId :: Commit -> OID
commitId (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p -> do
  o <- mkFPtr =<< {#call unsafe git_commit_id#} p
  return $ OID o

-- | Get the id of the tree pointed to by a commit. This differs from `tree` in
-- that no attempts are made to fetch an object from the ODB.
treeOID :: Commit -> OID
treeOID (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p -> do
  o <- mkFPtr =<< {#call unsafe git_commit_tree_oid#} p
  return $ OID o

-- | Get the short (one line) message of a commit.
shortCommitMsg :: Commit -> String
shortCommitMsg (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p ->
  peekCString =<< {#call unsafe git_commit_message_short#} p

-- | Get the full message of a commit.
commitMsg :: Commit -> String
commitMsg (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p ->
  peekCString =<< {#call unsafe git_commit_message#} p

-- | Get the commit time (i.e. committer time) of a commit.
commitTime :: Commit -> TimeT
commitTime (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p ->
  {#call unsafe git_commit_time#} p

-- | Get the commit timezone offset (i.e. committer's preferred timezone) of a
-- commit.
timeOffset :: Commit -> Int
timeOffset (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p ->
  retNum $ {#call unsafe git_commit_time_offset#} p

-- | Get the committer of a commit.
committer :: Commit -> Signature
committer (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p -> do
  o <- mkFPtr =<< {#call unsafe git_commit_committer#} p
  return $ Signature o

-- | Get the author of a commit.
author :: Commit -> Signature
author (Commit cfp) = unsafePerformIO $
  withForeignPtr cfp $ \p -> do
  o <- mkFPtr =<< {#call unsafe git_commit_author#} p
  return $ Signature o

-- | Get the tree pointed to by a commit.
tree :: Commit -> IOEitherErr Tree
tree (Commit cfp) =
  withForeignPtr cfp $ \c ->
  callPeek Tree (\out -> {#call git_commit_tree#} out c)

-- | Get the number of parents of this commit
parentCount :: Commit -> IO Int
parentCount (Commit cfp) =
  withForeignPtr cfp $ \p ->
  retNum $ {#call git_commit_parentcount#} p

-- | Get the specified parent of the commit.
parent :: Commit -> Int -> IOEitherErr Commit
parent (Commit cfp) n =
  withForeignPtr cfp $ \c ->
  callPeek Commit (\out -> {#call git_commit_parent#} out c (fromIntegral n))

-- | Get the oid of a specified parent for a commit. This is different from
-- `parent`, which will attempt to load the parent commit from the ODB.
parentOID :: Commit -> Int -> IO (Maybe OID)
parentOID (Commit cfp) n =
  withForeignPtr cfp $ \c -> do
  r <- mkFPtr =<< {#call git_commit_parent_oid#} c (fromIntegral n)
  retRes OID r

-- | Create a new commit in the repository
-- TODO: Support list of commits here
createCommit :: OID -> Repository -> Maybe String -> Signature -> Signature
             -> String -> Tree -> Commit -> IO (Maybe GitError)
createCommit (OID ofp) (Repository rfp) mref (Signature afp) (Signature cfp)
             msg (Tree tfp) (Commit mfp) =
  withForeignPtr ofp $ \o ->
  withForeignPtr rfp $ \r ->
  withForeignPtr afp $ \ausig ->
  withForeignPtr cfp $ \comsig ->
  withForeignPtr tfp $ \t ->
  withForeignPtr mfp $ \m ->
  withCString msg $ \msgStr -> do
  carr <- newArray [m]
  let cc' = cc carr o r ausig comsig t msgStr
  let ret = case mref of
              Nothing -> cc' nullPtr
              Just x  -> withCString x $ \str -> cc' str
  free carr
  ret
  where cc carr o r as cs t ms ref = retMaybe =<< {#call git_commit_create#} o
           r ref as cs ms t (fromIntegral (1 :: Int)) carr

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}

#include <git2/commit.h>

module Data.HGit2.Commit where

import Data.HGit2.Git2
import Data.HGit2.Errors
import Data.HGit2.Repository
import Data.HGit2.Types
import Data.HGit2.Signature
import Data.HGit2.OID
import Data.HGit2.Tree
import Data.Maybe ()
import Foreign
import Foreign.C.String
import Foreign.C.Types

newtype Commit = Commit CPtr

instance CWrapper Commit where
  unwrap (Commit c) = c

oidCall :: (Ptr () -> IO (Ptr ())) -> Commit -> OID
oidCall = undefined -- flipUSCall (return . OID)

strCall :: (Ptr () -> IO CString) -> Commit -> String
strCall = undefined -- flipUSCall peekCString

sigCall :: (Ptr () -> IO (Ptr ())) -> Commit -> Signature
sigCall = undefined -- flipUSCall (return . Signature)

commitId :: Commit -> OID
commitId = oidCall {#call unsafe git_commit_id#}

treeOID :: Commit -> OID
treeOID = oidCall {#call unsafe git_commit_tree_oid#}

shortCommitMsg :: Commit -> String
shortCommitMsg = strCall {#call unsafe git_commit_message_short#}

commitMsg :: Commit -> String
commitMsg = strCall {#call unsafe git_commit_message#}

commitTime :: Commit -> TimeT
commitTime = undefined -- usCall {#call unsafe git_commit_time#} (return =<<)

timeOffset :: Commit -> Int
timeOffset = undefined -- usCall {#call unsafe git_commit_time_offset#} retNum

committer :: Commit -> Signature
committer = sigCall {#call unsafe git_commit_committer#}

author :: Commit -> Signature
author = sigCall {#call unsafe git_commit_author#}

tree :: Commit -> IOEitherErr Tree
tree (Commit cfp) =
  withForeignPtr cfp $ \c ->
  callPeek Tree (\out -> {#call git_commit_tree#} out c)

parentCount :: Commit -> IO Int
parentCount = undefined -- wrapToMNum {#call git_commit_parentcount#}

parent :: Commit -> Int -> IOEitherErr Commit
parent (Commit cfp) n =
  withForeignPtr cfp $ \c ->
  callPeek Commit (\out -> {#call git_commit_parent#} out c (fromIntegral n))

parentOID :: Commit -> Int -> IO (Maybe OID)
parentOID (Commit cfp) n =
  withForeignPtr cfp $ \c -> do
  r <- mkFPtr =<< {#call git_commit_parent_oid#} c (fromIntegral n)
  retRes OID r

-- TODO: split up into two functions, so free doesn't need to be manual. use
-- automated machanisms instead
createCommit :: OID -> Repository -> Maybe String -> Signature -> Signature
             -> String -> Tree -> [Commit] -> IO (Maybe GitError)
createCommit (OID ofp) (Repository rfp) mref (Signature afp) (Signature cfp)
             msg (Tree tfp) ps =
  withForeignPtr ofp $ \o ->
  withForeignPtr rfp $ \r ->
  withForeignPtr afp $ \ausig ->
  withForeignPtr cfp $ \comsig ->
  withForeignPtr tfp $ \t ->
  withCString msg $ \msgStr -> do
  updRef <- case mref of
              Nothing -> return nullPtr
              Just x  -> newCString x
  {- carr   <- newArray [c | Commit c <- ps]-}
  {- let ret = retMaybe =<< {#call git_commit_create#} o r updRef ausig comsig-}
                               {- msgStr t (fromIntegral $ length ps) carr-}
  free updRef
  {- ret-}
  undefined


When streaming, do RECV_STATUS_ON_CLIENT in the background.

The end of a streaming RPC is defined by the RECV_STATUS_ON_CLIENT
event. "Subscribe" to the event by doing a callBatch without blocking
for the reply. Once the event is fired, update the statusEventFromServer
MVar in ClientReaderWriter.

-- 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.Monoid ((<>), Last(..))
import           Data.IORef

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

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

import qualified Network.Grpc.CompletionQueue as CQ
import Network.Grpc.Lib.PropagationBits
{#import Network.Grpc.Lib.ByteBuffer#}
{#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 --seconds

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

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

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

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

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

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 }

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

newClientContext :: Channel -> IO ClientContext
newClientContext chan = do
  cq <- completionQueueCreate 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 = B.ByteString
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) grpcCallDestroy $ \call0 -> newMVar call0 >>= \mcall -> do
    crw <- newClientReaderWriter ctx mcall

    sendInitOp <- opSendInitialMetadata (coMetadata 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

  sendInitOp <- opSendInitialMetadata (coMetadata co)
  sendCloseOp <- opSendCloseFromClient
  sendMessageOp <- opSendMessage arg

  res <- callBatch crw [
        OpX sendInitOp
      , OpX sendCloseOp
      , OpX sendMessageOp
      ]
  case res of
    RpcOk _ -> do
      res' <- callBatchStatusOnClient crw
      case res' of
        RpcOk _ -> return (RpcOk (Client crw defaultEncoder defaultDecoder))
        RpcError err -> return (RpcError err)
    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

  sendInitOp <- opSendInitialMetadata (coMetadata co)

  res <- callBatch crw [ OpX sendInitOp ]
  case res of
    RpcOk _ -> do
      res' <- callBatchStatusOnClient crw
      case res' of
        RpcOk _ -> return (RpcOk (Client crw defaultEncoder defaultDecoder))
        RpcError err -> return (RpcError err)
    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
  sendInitOp <- opSendInitialMetadata (coMetadata co)

  res <- callBatch crw [ OpX sendInitOp ]
  case res of
    RpcOk _ -> do
      res' <- callBatchStatusOnClient crw
      case res' of
        RpcOk _ -> return (RpcOk (Client crw defaultEncoder defaultDecoder))
        RpcError err -> return (RpcError err)
    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),
  statusFromServerTag :: !(MVar CQ.EventDesc)
}

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

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

callBatchStatusOnClient :: ClientReaderWriter -> IO (RpcReply ())
callBatchStatusOnClient crw@ClientReaderWriter{..} = do
  tag <- tryReadMVar statusFromServerTag
  case tag of
    Just _ -> return (RpcOk ()) -- already did this before
    Nothing -> do
      statusOp <- opRecvStatusOnClient crw
      arr <- toArray [ OpX statusOp ]
      let onBatchComplete = opArrFinishAndFree arr
      eDesc <- CQ.allocateEvent (ccWorker context) onBatchComplete
      putMVar statusFromServerTag eDesc
      callStatus <- withMVar callMVar_ $ \call ->
        grpcCallStartBatch call (opArrPtr arr) (opArrLen arr) (CQ.eventTag eDesc) reservedPtr
      case callStatus of
        CallOk -> return (RpcOk ())
        _ -> 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#} 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 <- fromByteString bs
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendMessage))
        {#set grpc_op->data.send_message#} p bb
      ]
    finish =
      byteBufferDestroy bb
  return (Op add value finish)

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

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

opRecvStatusOnClient :: ClientReaderWriter -> IO (OpT RpcStatus)
opRecvStatusOnClient (ClientReaderWriter{..}) = do
  trailingMetadataArrPtr <- mallocMetadataArray
  statusCodePtr <- C.malloc :: IO (Ptr StatusCodeT)
  ptrPtrStatusStr <- C.new C.nullPtr :: IO (Ptr (Ptr CChar))
  capacityPtr <- C.new 0 :: IO (Ptr SizeT)
  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
        {#set grpc_op->data.recv_status_on_client.status_details#} p ptrPtrStatusStr
        {#set grpc_op->data.recv_status_on_client.status_details_capacity#} p capacityPtr
      ]
    finish = do
      trailingMd <- readMetadataArray trailingMetadataArrPtr
      statusCode <- fmap toStatusCode (C.peek statusCodePtr)
      statusDetails <- B.packCString =<< C.peek ptrPtrStatusStr
      let status = RpcStatus trailingMd statusCode statusDetails
      writeIORef value status
      putMVar statusFromServer status
      free
    free = do
      freeMetadataArray trailingMetadataArrPtr
      C.free statusCodePtr
      C.free ptrPtrStatusStr
      C.free capacityPtr
  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 ClientReaderWriter{..} = do
  status <- readMVar statusFromServer
  return (RpcOk status)

clientClose :: ClientReaderWriter -> IO ()
clientClose (ClientReaderWriter{..}) = do
  withMVar callMVar_ $ \call ->
    grpcCallDestroy call

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 ClientReaderWriter{..} = do
  tag <- tryTakeMVar statusFromServerTag
  case tag of
    Nothing -> return ()
    Just eDesc ->
      CQ.releaseEvent (ccWorker context) eDesc
  withMVar callMVar_ $ \call ->
    grpcCallDestroy call

type Rpc req resp a = ReaderT (Client req resp) (ExceptT RpcError IO) a

askCrw :: Rpc req resp ClientReaderWriter
askCrw = asks clientCrw

askDecoder :: Rpc req resp (Decoder resp)
askDecoder = asks clientDecoder

askEncoder :: Rpc req resp (Encoder req)
askEncoder = asks clientEncoder

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

withNewClient :: RpcReply (Client req resp) -> Rpc req resp a -> IO (RpcReply a)
withNewClient r_client m = do
  case r_client of
    RpcOk client -> withClient client m
    RpcError err -> return (RpcError err)

withClient :: Client req resp -> Rpc req resp a -> IO (RpcReply a)
withClient client m = do
  e <- runExceptT (runReaderT m client)
  case e of
    Left err -> return (RpcError err)
    Right a -> return (RpcOk a)

clientRWOp :: (ClientReaderWriter -> IO a) -> Rpc req resp a
clientRWOp act = do
  crw <- askCrw
  liftIO (act crw)

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

abortIfStatus :: Rpc req resp ()
abortIfStatus = do
  status <- clientRWOp (tryReadMVar . statusFromServer)
  case status of
    Nothing -> return ()
    Just (RpcStatus _ code msg) ->
      -- call has ended. no further batch ops can be executed.
      -- doesn't have to be an error, could be 200!
      lift (throwE (StatusError code msg))

initialMetadata :: Rpc req resp [Metadata]
initialMetadata = do
  status <- clientRWOp (tryReadMVar . statusFromServer)
  case status of
    Nothing -> joinClientRWOp clientWaitForInitialMetadata
    Just (RpcStatus md _ _) -> do
      return md

waitForStatus :: Rpc req resp RpcStatus
waitForStatus = do
  status <- clientRWOp (tryReadMVar . statusFromServer)
  case status of
    Nothing -> joinClientRWOp clientWaitForStatus
    Just status' -> return status'

receiveMessage :: Rpc req resp (Maybe resp)
receiveMessage = do
  abortIfStatus
  msg <- joinClientRWOp clientRead
  case msg of
    Nothing -> return Nothing
    Just x -> do
      decoder <- askDecoder
      liftM Just (joinReply =<< liftIO (decoder x))

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

sendMessage :: req -> Rpc req resp ()
sendMessage req = do
  abortIfStatus
  encoder <- askEncoder
  bs <- joinReply =<< liftIO (encoder req)
  joinClientRWOp (\crw -> clientWrite crw bs)

sendHalfClose :: Rpc req resp ()
sendHalfClose = do
  abortIfStatus
  joinClientRWOp clientSendHalfClose

closeCall :: Rpc req resp ()
closeCall =
  clientRWOp clientClose

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.Monoid ((<>), Last(..))
import           Data.IORef

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

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

import qualified Network.Grpc.CompletionQueue as CQ
import Network.Grpc.Lib.PropagationBits
{#import Network.Grpc.Lib.ByteBuffer#}
{#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 --seconds

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

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

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

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

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

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 }

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

newClientContext :: Channel -> IO ClientContext
newClientContext chan = do
  cq <- completionQueueCreate 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 = B.ByteString
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) grpcCallDestroy $ \call0 -> newMVar call0 >>= \mcall -> do
    crw <- newClientReaderWriter ctx mcall

    sendInitOp <- opSendInitialMetadata (coMetadata 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

  sendInitOp <- opSendInitialMetadata (coMetadata co)
  sendCloseOp <- opSendCloseFromClient
  sendMessageOp <- opSendMessage arg

  res <- callBatch crw [
        OpX sendInitOp
      , OpX sendCloseOp
      , OpX sendMessageOp
      ]
  case res of
    RpcOk _ -> do
      return (RpcOk (Client crw defaultEncoder defaultDecoder))
    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

  sendInitOp <- opSendInitialMetadata (coMetadata co)

  res <- callBatch crw [ OpX sendInitOp ]
  case res of
    RpcOk _ -> do
      return (RpcOk (Client crw defaultEncoder defaultDecoder))
    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
  sendInitOp <- opSendInitialMetadata (coMetadata co)

  res <- callBatch crw [ OpX sendInitOp ]
  case res of
    RpcOk _ -> return (RpcOk (Client crw defaultEncoder defaultDecoder))
    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#} 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 <- fromByteString bs
  value <- newIORef ()
  let
    add =
      [ \p -> do
        {#set grpc_op->op#} p (fromIntegral (fromEnum OpSendMessage))
        {#set grpc_op->data.send_message#} p bb
      ]
    finish =
      byteBufferDestroy bb
  return (Op add value finish)

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

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

opRecvStatusOnClient :: ClientReaderWriter -> IO (OpT RpcStatus)
opRecvStatusOnClient (ClientReaderWriter{..}) = do
  trailingMetadataArrPtr <- mallocMetadataArray
  statusCodePtr <- C.malloc :: IO (Ptr StatusCodeT)
  ptrPtrStatusStr <- C.new C.nullPtr :: IO (Ptr (Ptr CChar))
  capacityPtr <- C.new 0 :: IO (Ptr SizeT)
  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
        {#set grpc_op->data.recv_status_on_client.status_details#} p ptrPtrStatusStr
        {#set grpc_op->data.recv_status_on_client.status_details_capacity#} p capacityPtr
      ]
    finish = do
      trailingMd <- readMetadataArray trailingMetadataArrPtr
      statusCode <- fmap toStatusCode (C.peek statusCodePtr)
      statusDetails <- B.packCString =<< C.peek ptrPtrStatusStr
      let status = RpcStatus trailingMd statusCode statusDetails
      writeIORef value status
      putMVar statusFromServer status
      free
    free = do
      freeMetadataArray trailingMetadataArrPtr
      C.free statusCodePtr
      C.free ptrPtrStatusStr
      C.free capacityPtr
  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@(ClientReaderWriter{..}) = do
  status <- tryReadMVar statusFromServer
  case status of
    Nothing -> do
      recvStatusOp <- opRecvStatusOnClient crw
      res <- callBatch crw [ OpX recvStatusOp ]
      case res of
        RpcOk _ -> do
          st <- opRead recvStatusOp
          return (RpcOk st)
        RpcError err -> do
          return (RpcError err)
    Just st -> return (RpcOk st)

clientClose :: ClientReaderWriter -> IO ()
clientClose (ClientReaderWriter{..}) = do
  withMVar callMVar_ $ \call ->
    grpcCallDestroy call

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 ClientReaderWriter { callMVar_ = callMVar } =
  withMVar callMVar $ \call ->
  grpcCallDestroy call

type Rpc req resp a = ReaderT (Client req resp) (ExceptT RpcError IO) a

askCrw :: Rpc req resp ClientReaderWriter
askCrw = asks clientCrw

askDecoder :: Rpc req resp (Decoder resp)
askDecoder = asks clientDecoder

askEncoder :: Rpc req resp (Encoder req)
askEncoder = asks clientEncoder

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

withNewClient :: RpcReply (Client req resp) -> Rpc req resp a -> IO (RpcReply a)
withNewClient r_client m = do
  case r_client of
    RpcOk client -> withClient client m
    RpcError err -> return (RpcError err)

withClient :: Client req resp -> Rpc req resp a -> IO (RpcReply a)
withClient client m = do
  e <- runExceptT (runReaderT m client)
  case e of
    Left err -> return (RpcError err)
    Right a -> return (RpcOk a)

clientRWOp :: (ClientReaderWriter -> IO a) -> Rpc req resp a
clientRWOp act = do
  crw <- askCrw
  liftIO (act crw)

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

abortIfStatus :: Rpc req resp ()
abortIfStatus = do
  status <- clientRWOp (tryReadMVar . statusFromServer)
  case status of
    Nothing -> return ()
    Just (RpcStatus _ code msg) ->
      -- call has ended. no further batch ops can be executed.
      -- doesn't have to be an error, could be 200!
      lift (throwE (StatusError code msg))

initialMetadata :: Rpc req resp [Metadata]
initialMetadata = do
  status <- clientRWOp (tryReadMVar . statusFromServer)
  case status of
    Nothing -> joinClientRWOp clientWaitForInitialMetadata
    Just (RpcStatus md _ _) -> do
      return md

waitForStatus :: Rpc req resp RpcStatus
waitForStatus = do
  status <- clientRWOp (tryReadMVar . statusFromServer)
  case status of
    Nothing -> joinClientRWOp clientWaitForStatus
    Just status' -> return status'

receiveMessage :: Rpc req resp (Maybe resp)
receiveMessage = do
  abortIfStatus
  msg <- joinClientRWOp clientRead
  case msg of
    Nothing -> return Nothing
    Just x -> do
      decoder <- askDecoder
      liftM Just (joinReply =<< liftIO (decoder x))

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

sendMessage :: req -> Rpc req resp ()
sendMessage req = do
  abortIfStatus
  encoder <- askEncoder
  bs <- joinReply =<< liftIO (encoder req)
  joinClientRWOp (\crw -> clientWrite crw bs)

sendHalfClose :: Rpc req resp ()
sendHalfClose = do
  abortIfStatus
  joinClientRWOp clientSendHalfClose

closeCall :: Rpc req resp ()
closeCall =
  clientRWOp clientClose

data RpcReply a
  = RpcOk a
  | RpcError RpcError
  deriving Show

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


More newtypes

More newtypes

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr
newtype Blob       = Blob CPtr
newtype ObjID      = ObjID CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Lookup a blob object from a repository.
 *
 * @param blob pointer to the looked up blob
 * @param repo the repo to use when locating the blob.
 * @param id identity of the blob to locate.
 * @return 0 on success; error code otherwise
 */
GIT_INLINE(int) git_blob_lookup(git_blob **blob, git_repository *repo, const git_oid *id)
-}
blobLookup :: Repository -> ObjID -> IO (Either GitError Blob)
blobLookup = undefined

{-

/**
 * Lookup a blob object from a repository,
 * given a prefix of its identifier (short id).
 *
 * @see git_object_lookup_prefix
 *
 * @param blob pointer to the looked up blob
 * @param repo the repo to use when locating the blob.
 * @param id identity of the blob to locate.
 * @param len the length of the short identifier
 * @return 0 on success; error code otherwise
 */
GIT_INLINE(int) git_blob_lookup_prefix(git_blob **blob, git_repository *repo, const git_oid *id, unsigned int len)
{
	return git_object_lookup_prefix((git_object **)blob, repo, id, len, GIT_OBJ_BLOB);
}
-}
blobLookupPrefix :: Repository -> ObjID -> Int -> IO (Either GitError Blob)
blobLookupPrefix = undefined

{-
/**
 * Close an open blob
 *
 * This is a wrapper around git_object_close()
 *
 * IMPORTANT:
 * It *is* necessary to call this method when you stop
 * using a blob. Failure to do so will cause a memory leak.
 *
 * @param blob the blob to close
 */

GIT_INLINE(void) git_blob_close(git_blob *blob)
{
	git_object_close((git_object *) blob);
}
-}
closeBlob :: Blob -> IO ()
closeBlob = undefined

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- Return raw bytestring ? :x
rawBlobContent = undefined

{-
/**
 * Get the size in bytes of the contents of a blob
 *
 * @param blob pointer to the blob
 * @return size on bytes
 */
GIT_EXTERN(int) git_blob_rawsize(git_blob *blob);
-}
rawBlobSize :: Blob -> Int
rawBlobSize = undefined

{-
/**
 * Read a file from the working folder of a repository
 * and write it to the Object Database as a loose blob
 *
 * @param oid return the id of the written blob
 * @param repo repository where the blob will be written.
 *	this repository cannot be bare
 * @param path file from which the blob will be created,
 *	relative to the repository's working dir
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_blob_create_fromfile(git_oid *oid, git_repository *repo, const char *path);
-}
createBlobFromFile :: ObjID -> Repository -> String -> IO (Maybe GitError)
createBlobFromFile (ObjID o) (Repository r) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} o r pathStr
  if res == 0
    then return Nothing
    else return $ Just . toEnum . fromIntegral $ res

{-
/**
 * Write an in-memory buffer to the ODB as a blob
 *
 * @param oid return the oid of the written blob
 * @param repo repository where to blob will be written
 * @param buffer data to be written into the blob
 * @param len length of the data
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_blob_create_frombuffer(git_oid *oid, git_repository *repo, const void *buffer, size_t len);
-}
-- createBlobFromBuffer :: ObjID -> Repository -> ... -> Int -> IO (Maybe GitError)
createBlobFromBuffer = undefined

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open3#} pprepo dirStr db idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path) spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_oid as OID {underscoreToCase}#}
{#enum git_blob as Blob {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Lookup a blob object from a repository.
 *
 * @param blob pointer to the looked up blob
 * @param repo the repo to use when locating the blob.
 * @param id identity of the blob to locate.
 * @return 0 on success; error code otherwise
 */
GIT_INLINE(int) git_blob_lookup(git_blob **blob, git_repository *repo, const git_oid *id)
-}
blobLookup :: Repository -> OID -> IO (Either GitError Blob)
blobLookup = undefined

{-

/**
 * Lookup a blob object from a repository,
 * given a prefix of its identifier (short id).
 *
 * @see git_object_lookup_prefix
 *
 * @param blob pointer to the looked up blob
 * @param repo the repo to use when locating the blob.
 * @param id identity of the blob to locate.
 * @param len the length of the short identifier
 * @return 0 on success; error code otherwise
 */
GIT_INLINE(int) git_blob_lookup_prefix(git_blob **blob, git_repository *repo, const git_oid *id, unsigned int len)
{
	return git_object_lookup_prefix((git_object **)blob, repo, id, len, GIT_OBJ_BLOB);
}
-}
blobLookupPrefix :: Repository -> OID -> Int -> IO (Either GitError Blob)
blobLookupPrefix = undefined

{-
/**
 * Close an open blob
 *
 * This is a wrapper around git_object_close()
 *
 * IMPORTANT:
 * It *is* necessary to call this method when you stop
 * using a blob. Failure to do so will cause a memory leak.
 *
 * @param blob the blob to close
 */

GIT_INLINE(void) git_blob_close(git_blob *blob)
{
	git_object_close((git_object *) blob);
}
-}
closeBlob :: Blob -> IO ()
closeBlob = undefined

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- Return raw bytestring ? :x
rawBlobContent = undefined

{-
/**
 * Get the size in bytes of the contents of a blob
 *
 * @param blob pointer to the blob
 * @return size on bytes
 */
GIT_EXTERN(int) git_blob_rawsize(git_blob *blob);
-}
rawBlobSize :: Blob -> Int
rawBlobSize = undefined

{-
/**
 * Read a file from the working folder of a repository
 * and write it to the Object Database as a loose blob
 *
 * @param oid return the id of the written blob
 * @param repo repository where the blob will be written.
 *	this repository cannot be bare
 * @param path file from which the blob will be created,
 *	relative to the repository's working dir
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_blob_create_fromfile(git_oid *oid, git_repository *repo, const char *path);
-}
createBlobFromFile :: OID -> Repository -> String -> IO (Maybe GitError)
createBlobFromFile (OID o) (Repository r) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} o r pathStr
  if res == 0
    then return Nothing
    else return $ Just . toEnum . fromIntegral $ res

{-
/**
 * Write an in-memory buffer to the ODB as a blob
 *
 * @param oid return the oid of the written blob
 * @param repo repository where to blob will be written
 * @param buffer data to be written into the blob
 * @param len length of the data
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_blob_create_frombuffer(git_oid *oid, git_repository *repo, const void *buffer, size_t len);
-}
-- createBlobFromBuffer :: OID -> Repository -> ... -> Int -> IO (Maybe GitError)
createBlobFromBuffer = undefined

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open3#} pprepo dirStr db idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path) spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------