{-# LINE 1 "SAML2/XML/LibXML2.hsc" #-}
module SAML2.XML.LibXML2
  ( Doc
  , fromXmlTrees
  , C14NMode(..)
  , c14n
  ) where

import Control.Exception (bracket)
import Control.Monad ((<=<))
import Data.Bits ((.|.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Unsafe as BSU
import Data.Maybe (fromMaybe)
import Data.String.Unicode (unicodeCharToUtf8')
import Data.Word (Word8)
import Foreign.C.Error (throwErrnoIf, throwErrnoIfNull)
import Foreign.C.String (CString, withCString)
import Foreign.C.Types (CInt(..))
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
import Foreign.Marshal (alloca, withArray0, withMany, maybeWith)
import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr)
import Foreign.Storable (peek, peekByteOff)
import qualified Text.XML.HXT.Core as HXT
import qualified Text.XML.HXT.DOM.ShowXml as HXTS





type XMLChar = Word8
{-# LINE 32 "SAML2/XML/LibXML2.hsc" #-}
data XMLDoc
data XMLXPathContext
data XMLXPathObject
data XMLNodeSet

foreign import ccall unsafe "libxml/parser.h xmlReadMemory"
  xmlReadMemory :: CString -> CInt -> CString -> CString -> CInt -> IO (Ptr XMLDoc)

foreign import ccall unsafe "libxml/tree.h &xmlFreeDoc"
  xmlFreeDoc :: FunPtr ((Ptr XMLDoc) -> IO ())

foreign import ccall unsafe "libxml/xpath.h xmlXPathNewContext"
  xmlXPathNewContext :: Ptr XMLDoc -> IO (Ptr XMLXPathContext)

foreign import ccall unsafe "libxml/xpath.h xmlXPathFreeContext"
  xmlXPathFreeContext :: Ptr XMLXPathContext -> IO ()

foreign import ccall unsafe "libxml/xpath.h xmlXPathEval"
  xmlXPathEval :: Ptr XMLChar -> Ptr XMLXPathContext -> IO (Ptr XMLXPathObject)

foreign import ccall unsafe "libxml/xpath.h xmlXPathFreeObject"
  xmlXPathFreeObject :: Ptr XMLXPathObject -> IO ()

foreign import ccall unsafe "libxml/c14n.h xmlC14NDocDumpMemory"
  xmlC14NDocDumpMemory :: Ptr XMLDoc -> Ptr XMLNodeSet -> CInt -> Ptr (Ptr XMLChar) -> CInt -> Ptr (Ptr XMLChar) -> IO CInt

foreign import ccall unsafe "xmlFree_stub"
  xmlFree :: Ptr a -> IO ()

newtype Doc = Doc{ Doc -> ForeignPtr XMLDoc
unDoc :: ForeignPtr XMLDoc }

newDoc :: Ptr XMLDoc -> IO Doc
newDoc :: Ptr XMLDoc -> IO Doc
newDoc = (ForeignPtr XMLDoc -> Doc) -> IO (ForeignPtr XMLDoc) -> IO Doc
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr XMLDoc -> Doc
Doc (IO (ForeignPtr XMLDoc) -> IO Doc)
-> (Ptr XMLDoc -> IO (ForeignPtr XMLDoc)) -> Ptr XMLDoc -> IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinalizerPtr XMLDoc -> Ptr XMLDoc -> IO (ForeignPtr XMLDoc)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr XMLDoc
xmlFreeDoc

fromBytes :: BS.ByteString -> IO Doc
fromBytes :: ByteString -> IO Doc
fromBytes ByteString
s = do
  Ptr XMLDoc
d <- ByteString -> (CStringLen -> IO (Ptr XMLDoc)) -> IO (Ptr XMLDoc)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
s ((CStringLen -> IO (Ptr XMLDoc)) -> IO (Ptr XMLDoc))
-> (CStringLen -> IO (Ptr XMLDoc)) -> IO (Ptr XMLDoc)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
p, Int
l) ->
    String -> IO (Ptr XMLDoc) -> IO (Ptr XMLDoc)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull String
"xmlReadMemory" (IO (Ptr XMLDoc) -> IO (Ptr XMLDoc))
-> IO (Ptr XMLDoc) -> IO (Ptr XMLDoc)
forall a b. (a -> b) -> a -> b
$
      Ptr CChar
-> CInt -> Ptr CChar -> Ptr CChar -> CInt -> IO (Ptr XMLDoc)
xmlReadMemory Ptr CChar
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) Ptr CChar
forall a. Ptr a
nullPtr Ptr CChar
forall a. Ptr a
nullPtr (CInt
2 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
4 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
8 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
2048 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
65536)
{-# LINE 71 "SAML2/XML/LibXML2.hsc" #-}
  newDoc d

fromXmlTrees :: HXT.XmlTrees -> IO Doc
fromXmlTrees :: XmlTrees -> IO Doc
fromXmlTrees = ByteString -> IO Doc
fromBytes (ByteString -> IO Doc)
-> (XmlTrees -> ByteString) -> XmlTrees -> IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (XmlTrees -> ByteString) -> XmlTrees -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> StringFct)
-> (Char -> StringFct)
-> (Char -> StringFct)
-> XmlTrees
-> ByteString
HXTS.xshow' Char -> StringFct
cq Char -> StringFct
aq Char -> StringFct
unicodeCharToUtf8'
  where
  cq :: Char -> StringFct
cq Char
'&'   = (String
"&amp;"  String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  cq Char
'<'   = (String
"&lt;"   String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  cq Char
'>'   = (String
"&gt;"   String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  cq Char
'\13' = (String
"&#xD;"  String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  cq Char
c = (Char
cChar -> StringFct
forall a. a -> [a] -> [a]
:)
  aq :: Char -> StringFct
aq Char
'"'   = (String
"&quot;" String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  aq Char
'\9'  = (String
"&#x9;"  String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  aq Char
'\10' = (String
"&#xA;"  String -> StringFct
forall a. [a] -> [a] -> [a]
++)
  aq Char
c = Char -> StringFct
cq Char
c

withXMLXPathNodeList :: Ptr XMLDoc -> String -> (Ptr XMLNodeSet -> IO a) -> IO a
withXMLXPathNodeList :: forall a. Ptr XMLDoc -> String -> (Ptr XMLNodeSet -> IO a) -> IO a
withXMLXPathNodeList Ptr XMLDoc
d String
s Ptr XMLNodeSet -> IO a
f = 
  IO (Ptr XMLXPathContext)
-> (Ptr XMLXPathContext -> IO ())
-> (Ptr XMLXPathContext -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Ptr XMLDoc -> IO (Ptr XMLXPathContext)
xmlXPathNewContext Ptr XMLDoc
d) Ptr XMLXPathContext -> IO ()
xmlXPathFreeContext ((Ptr XMLXPathContext -> IO a) -> IO a)
-> (Ptr XMLXPathContext -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr XMLXPathContext
c ->
  String -> (Ptr CChar -> IO a) -> IO a
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
s ((Ptr CChar -> IO a) -> IO a) -> (Ptr CChar -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
p ->
  IO (Ptr XMLXPathObject)
-> (Ptr XMLXPathObject -> IO ())
-> (Ptr XMLXPathObject -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (String -> IO (Ptr XMLXPathObject) -> IO (Ptr XMLXPathObject)
forall a. String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull String
"xmlXPathEval" (IO (Ptr XMLXPathObject) -> IO (Ptr XMLXPathObject))
-> IO (Ptr XMLXPathObject) -> IO (Ptr XMLXPathObject)
forall a b. (a -> b) -> a -> b
$ Ptr XMLChar -> Ptr XMLXPathContext -> IO (Ptr XMLXPathObject)
xmlXPathEval ((Ptr CChar -> Ptr XMLChar
forall a b. Ptr a -> Ptr b
castPtr :: CString -> Ptr Word8) Ptr CChar
p) Ptr XMLXPathContext
c)
    Ptr XMLXPathObject -> IO ()
xmlXPathFreeObject
    ((Ptr XMLXPathObject -> IO a) -> IO a)
-> (Ptr XMLXPathObject -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Ptr XMLNodeSet -> IO a
f (Ptr XMLNodeSet -> IO a)
-> (Ptr XMLXPathObject -> IO (Ptr XMLNodeSet))
-> Ptr XMLXPathObject
-> IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (\Ptr XMLXPathObject
hsc_ptr -> Ptr XMLXPathObject -> Int -> IO (Ptr XMLNodeSet)
forall b. Ptr b -> Int -> IO (Ptr XMLNodeSet)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr XMLXPathObject
hsc_ptr Int
8)
{-# LINE 94 "SAML2/XML/LibXML2.hsc" #-}

data C14NMode
  = C14N_1_0
  | C14N_EXCLUSIVE_1_0
  | C14N_1_1

c14nmode :: C14NMode -> CInt
c14nmode :: C14NMode -> CInt
c14nmode C14NMode
C14N_1_0           = CInt
0
{-# LINE 102 "SAML2/XML/LibXML2.hsc" #-}
c14nmode C14N_EXCLUSIVE_1_0 = 1
{-# LINE 103 "SAML2/XML/LibXML2.hsc" #-}
c14nmode C14N_1_1           = 2
{-# LINE 104 "SAML2/XML/LibXML2.hsc" #-}

c14n :: C14NMode -> Maybe [String] -> Bool -> Maybe String -> Doc -> IO BS.ByteString
c14n :: C14NMode
-> Maybe [String] -> Bool -> Maybe String -> Doc -> IO ByteString
c14n C14NMode
m Maybe [String]
i Bool
c Maybe String
s Doc
d =
  ForeignPtr XMLDoc -> (Ptr XMLDoc -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Doc -> ForeignPtr XMLDoc
unDoc Doc
d) ((Ptr XMLDoc -> IO ByteString) -> IO ByteString)
-> (Ptr XMLDoc -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr XMLDoc
dp ->
  (String -> (Ptr CChar -> IO ByteString) -> IO ByteString)
-> [String] -> ([Ptr CChar] -> IO ByteString) -> IO ByteString
forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany String -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString ([String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
i) (([Ptr CChar] -> IO ByteString) -> IO ByteString)
-> ([Ptr CChar] -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \[Ptr CChar]
il ->
  ([Ptr CChar]
 -> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> Maybe [Ptr CChar]
-> (Ptr (Ptr CChar) -> IO ByteString)
-> IO ByteString
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith (Ptr CChar
-> [Ptr CChar]
-> (Ptr (Ptr CChar) -> IO ByteString)
-> IO ByteString
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 Ptr CChar
forall a. Ptr a
nullPtr) ([Ptr CChar]
il [Ptr CChar] -> Maybe [String] -> Maybe [Ptr CChar]
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe [String]
i) ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
ip ->
  (String -> (Ptr XMLNodeSet -> IO ByteString) -> IO ByteString)
-> Maybe String
-> (Ptr XMLNodeSet -> IO ByteString)
-> IO ByteString
forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith (Ptr XMLDoc
-> String -> (Ptr XMLNodeSet -> IO ByteString) -> IO ByteString
forall a. Ptr XMLDoc -> String -> (Ptr XMLNodeSet -> IO a) -> IO a
withXMLXPathNodeList Ptr XMLDoc
dp) Maybe String
s ((Ptr XMLNodeSet -> IO ByteString) -> IO ByteString)
-> (Ptr XMLNodeSet -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr XMLNodeSet
sn ->
  (Ptr (Ptr XMLChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr XMLChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr XMLChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr XMLChar)
p -> do
    CInt
r <- (CInt -> Bool) -> String -> IO CInt -> IO CInt
forall a. (a -> Bool) -> String -> IO a -> IO a
throwErrnoIf (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) String
"xmlC14NDocDumpMemory" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
      Ptr XMLDoc
-> Ptr XMLNodeSet
-> CInt
-> Ptr (Ptr XMLChar)
-> CInt
-> Ptr (Ptr XMLChar)
-> IO CInt
xmlC14NDocDumpMemory Ptr XMLDoc
dp Ptr XMLNodeSet
sn (C14NMode -> CInt
c14nmode C14NMode
m) ((Ptr (Ptr CChar) -> Ptr (Ptr XMLChar)
forall a b. Ptr a -> Ptr b
castPtr :: Ptr CString -> Ptr (Ptr Word8)) Ptr (Ptr CChar)
ip) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
c) Ptr (Ptr XMLChar)
p
    Ptr XMLChar
pp <- Ptr (Ptr XMLChar) -> IO (Ptr XMLChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr XMLChar)
p
    Ptr XMLChar -> Int -> IO () -> IO ByteString
BSU.unsafePackCStringFinalizer Ptr XMLChar
pp (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
r) (Ptr XMLChar -> IO ()
forall a. Ptr a -> IO ()
xmlFree Ptr XMLChar
pp)