{-# LANGUAGE ForeignFunctionInterface, ViewPatterns #-}
module Crypto.PubKey.Xml
(
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
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
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
verifyXmlFilePem :: (MonadIO m) => FilePath
-> FilePath
-> 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
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