{-# LANGUAGE ForeignFunctionInterface, ViewPatterns #-}

{-|
Description: Library for Verifying XML Signatures
-}


module Crypto.PubKey.Xml
( -- * Verifying
  verifyXml
, verifyXmlFile
, verifyXmlPem
, verifyXmlFilePem
) where

import Text.XML.HXT.Core
import Control.Monad.Trans
import Data.X509
import Data.PEM
import Data.Maybe
import qualified Data.ByteString as BS
import Crypto.Store.X509
import Foreign.C.Types
import Foreign.C.String
import Crypto.PubKey.Xml.Errors

foreign import ccall "verify_file" cVerifyFile :: CString -> CString -> CSize -> IO CInt
foreign import ccall "verify_file_pem" cVerifyFilePem :: CString -> CString -> IO CInt
foreign import ccall "verify_doc" cVerifyDoc :: CString -> CSize -> CString -> CSize -> IO CInt
foreign import ccall "verify_doc_pem" cVerifyDocPem :: CString -> CSize -> CString -> IO CInt

returnCode :: CInt -> Either XmlVerifyError Bool
returnCode :: CInt -> Either XmlVerifyError Bool
returnCode ( CInt
0 ) = Bool -> Either XmlVerifyError Bool
forall a b. b -> Either a b
Right Bool
True
returnCode (-1 ) = Bool -> Either XmlVerifyError Bool
forall a b. b -> Either a b
Right Bool
False
returnCode (-2 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlSecInitFailed
returnCode (-3 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlSecIncomp     
returnCode (-4 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlSecCryptoFail
returnCode (-5 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
CryptoInitFailed
returnCode (-6 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlCryptoFailed 
returnCode (-7 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlParseFail    
returnCode (-8 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlNoStartNode  
returnCode (-9 ) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlSigCreateFail
returnCode (-10) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlPemLoadFail  
returnCode (-11) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlPemNameFail  
returnCode (-12) = XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
VeryifyFail
returnCode  CInt
_    = Bool -> Either XmlVerifyError Bool
forall a b. b -> Either a b
Right Bool
False

-- | verify XML file with given public key
verifyXmlFile :: (MonadIO m) => FilePath -> PubKey -> m (Either XmlVerifyError Bool)
verifyXmlFile :: FilePath -> PubKey -> m (Either XmlVerifyError Bool)
verifyXmlFile FilePath
xml PubKey
key = do
  let pem :: ByteString
pem = [PubKey] -> ByteString
writePubKeyFileToMemory [PubKey
key]
  CInt
ret <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ FilePath -> (CString -> IO CInt) -> IO CInt
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
xml ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
    \CString
cXml -> ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
pem ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
    \(CString
cPem, Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> CSize
len) -> CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> CString -> CSize -> IO CInt
cVerifyFile CString
cXml CString
cPem CSize
len
  Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool))
-> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall a b. (a -> b) -> a -> b
$ CInt -> Either XmlVerifyError Bool
returnCode CInt
ret

-- | verify XML document with given public key
verifyXml :: (MonadIO m) => XmlTree -> PubKey -> m (Either XmlVerifyError Bool)
verifyXml :: XmlTree -> PubKey -> m (Either XmlVerifyError Bool)
verifyXml XmlTree
xml PubKey
key = do
  let pem :: ByteString
pem = [PubKey] -> ByteString
writePubKeyFileToMemory [PubKey
key]
  let xml' :: Maybe FilePath
xml' = [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe ([FilePath] -> Maybe FilePath) -> [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ LA XmlTree FilePath -> XmlTree -> [FilePath]
forall a b. LA a b -> a -> [b]
runLA (SysConfigList -> LA XmlTree FilePath
forall (a :: * -> * -> *).
ArrowXml a =>
SysConfigList -> a XmlTree FilePath
writeDocumentToString []) XmlTree
xml
  case Maybe FilePath
xml' of
    Maybe FilePath
Nothing  -> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool))
-> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall a b. (a -> b) -> a -> b
$ XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlParseFail
    Just FilePath
xml -> do
      CInt
ret <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ FilePath -> (CStringLen -> IO CInt) -> IO CInt
forall a. FilePath -> (CStringLen -> IO a) -> IO a
withCStringLen FilePath
xml ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
        \(CString
cXml, Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> CSize
xLen) -> ByteString -> (CStringLen -> IO CInt) -> IO CInt
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
pem ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
        \(CString
cPem, Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> CSize
pLen) -> CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> CSize -> CString -> CSize -> IO CInt
cVerifyDoc CString
cXml CSize
xLen CString
cPem CSize
pLen
      Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool))
-> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall a b. (a -> b) -> a -> b
$ CInt -> Either XmlVerifyError Bool
returnCode CInt
ret

-- | verify XML file against a public key in a pem file
verifyXmlFilePem :: (MonadIO m) => FilePath -- ^ XML document path
                                -> FilePath -- ^ PEM file path
                                -> m (Either XmlVerifyError Bool)
verifyXmlFilePem :: FilePath -> FilePath -> m (Either XmlVerifyError Bool)
verifyXmlFilePem FilePath
xml FilePath
pem = do
  CInt
ret <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ FilePath -> (CString -> IO CInt) -> IO CInt
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
xml ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
    \CString
cXml -> FilePath -> (CString -> IO CInt) -> IO CInt
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
pem ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ 
    \CString
cPem -> CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> CString -> IO CInt
cVerifyFilePem CString
cXml CString
cPem
  Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool))
-> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall a b. (a -> b) -> a -> b
$ CInt -> Either XmlVerifyError Bool
returnCode CInt
ret

-- | Verify XML against a public key provided in a pem file
verifyXmlPem :: (MonadIO m) => XmlTree -> FilePath -> m (Either XmlVerifyError Bool)
verifyXmlPem :: XmlTree -> FilePath -> m (Either XmlVerifyError Bool)
verifyXmlPem XmlTree
xml FilePath
pem = do
  let xml' :: Maybe FilePath
xml' = [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe ([FilePath] -> Maybe FilePath) -> [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ LA XmlTree FilePath -> XmlTree -> [FilePath]
forall a b. LA a b -> a -> [b]
runLA (SysConfigList -> LA XmlTree FilePath
forall (a :: * -> * -> *).
ArrowXml a =>
SysConfigList -> a XmlTree FilePath
writeDocumentToString []) XmlTree
xml
  case Maybe FilePath
xml' of
    Maybe FilePath
Nothing  -> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool))
-> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall a b. (a -> b) -> a -> b
$ XmlVerifyError -> Either XmlVerifyError Bool
forall a b. a -> Either a b
Left XmlVerifyError
XmlParseFail
    Just FilePath
xml -> do
      CInt
ret <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ FilePath -> (CStringLen -> IO CInt) -> IO CInt
forall a. FilePath -> (CStringLen -> IO a) -> IO a
withCStringLen FilePath
xml ((CStringLen -> IO CInt) -> IO CInt)
-> (CStringLen -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
        \(CString
cXml, Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> CSize
xLen) -> FilePath -> (CString -> IO CInt) -> IO CInt
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
pem ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
        \CString
cPem                         -> CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> CSize -> CString -> IO CInt
cVerifyDocPem CString
cXml CSize
xLen CString
cPem
      Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool))
-> Either XmlVerifyError Bool -> m (Either XmlVerifyError Bool)
forall a b. (a -> b) -> a -> b
$ CInt -> Either XmlVerifyError Bool
returnCode CInt
ret