use x509 and x509-validation.
This commit is contained in:
parent
b1478dd618
commit
026aba87e5
3 changed files with 20 additions and 34 deletions
|
@ -1,4 +1,3 @@
|
||||||
{-# LANGUAGE OverloadedStrings, CPP #-}
|
|
||||||
-- |
|
-- |
|
||||||
-- Module : Network.TLS.Extra.Certificate
|
-- Module : Network.TLS.Extra.Certificate
|
||||||
-- License : BSD-style
|
-- License : BSD-style
|
||||||
|
@ -11,23 +10,20 @@ module Network.TLS.Extra.Certificate
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import Data.X509
|
import Data.X509
|
||||||
import Data.X509.Validation
|
import Data.X509.Validation
|
||||||
import Data.X509.CertificateStore
|
import Data.X509.CertificateStore
|
||||||
|
|
||||||
import Network.TLS (CertificateUsage(..), CertificateRejectReason(..))
|
import Network.TLS (CertificateUsage(..), CertificateRejectReason(..))
|
||||||
|
|
||||||
import Data.Time.Calendar
|
|
||||||
import Data.List (find)
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
|
|
||||||
-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first
|
-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first
|
||||||
-- failure.
|
-- failure.
|
||||||
certificateChecks :: Checks -> CertificateChain -> IO CertificateUsage
|
certificateChecks :: Checks -> CertificateStore -> CertificateChain -> IO CertificateUsage
|
||||||
certificateChecks checks store cc = do
|
certificateChecks checks store cc = do
|
||||||
reasons <- validate checks store cc
|
reasons <- validate checks store cc
|
||||||
return $ case reasons of
|
return $ case reasons of
|
||||||
[] -> CertificateUsageAccept
|
[] -> CertificateUsageAccept
|
||||||
_ -> CertificateUsageReject
|
x:_ -> CertificateUsageReject (toRejectReason x)
|
||||||
|
where toRejectReason Expired = CertificateRejectExpired
|
||||||
|
toRejectReason InFuture = CertificateRejectExpired
|
||||||
|
toRejectReason UnknownCA = CertificateRejectUnknownCA
|
||||||
|
toRejectReason x = CertificateRejectOther (show x)
|
||||||
|
|
|
@ -17,9 +17,8 @@ import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import Data.Either
|
import Data.Either
|
||||||
import Data.PEM (PEM(..), pemParseBS)
|
import Data.PEM (PEM(..), pemParseBS)
|
||||||
import Data.Certificate.X509
|
import Data.X509.File
|
||||||
import qualified Data.Certificate.KeyRSA as KeyRSA
|
import Data.X509
|
||||||
import Network.TLS
|
|
||||||
|
|
||||||
-- | read one X509 certificate from a file.
|
-- | read one X509 certificate from a file.
|
||||||
--
|
--
|
||||||
|
@ -29,29 +28,20 @@ import Network.TLS
|
||||||
-- If no valid PEM encoded certificate is found in the file
|
-- If no valid PEM encoded certificate is found in the file
|
||||||
-- this function will raise an error.
|
-- this function will raise an error.
|
||||||
fileReadCertificate :: FilePath -> IO SignedCertificate
|
fileReadCertificate :: FilePath -> IO SignedCertificate
|
||||||
fileReadCertificate filepath = do
|
fileReadCertificate filepath = headError <$> readSignedObject filepath
|
||||||
certs <- rights . parseCerts . pemParseBS <$> B.readFile filepath
|
where headError [] = error ("read certificate: not found in " ++ show filepath)
|
||||||
case certs of
|
headError (x:_) = x
|
||||||
[] -> error "no valid certificate found"
|
{-
|
||||||
(x:_) -> return x
|
|
||||||
where parseCerts (Right pems) = map (decodeCertificate . L.fromChunks . (:[]) . pemContent)
|
|
||||||
$ filter (flip elem ["CERTIFICATE", "TRUSTED CERTIFICATE"] . pemName) pems
|
$ filter (flip elem ["CERTIFICATE", "TRUSTED CERTIFICATE"] . pemName) pems
|
||||||
parseCerts (Left err) = error ("cannot parse PEM file " ++ show err)
|
-}
|
||||||
|
|
||||||
-- | read one private key from a file.
|
-- | read one private key from a file.
|
||||||
--
|
--
|
||||||
-- the private key must be in the usual PEM format and at the moment only
|
-- the private key must be in the usual PEM format
|
||||||
-- RSA PRIVATE KEY are supported.
|
|
||||||
--
|
--
|
||||||
-- If no valid PEM encoded private key is found in the file
|
-- If no valid PEM encoded private key is found in the file
|
||||||
-- this function will raise an error.
|
-- this function will raise an error.
|
||||||
fileReadPrivateKey :: FilePath -> IO PrivateKey
|
fileReadPrivateKey :: FilePath -> IO PrivKey
|
||||||
fileReadPrivateKey filepath = do
|
fileReadPrivateKey filepath = headError <$> readKeyFile filepath
|
||||||
pk <- rights . parseKey . pemParseBS <$> B.readFile filepath
|
where headError [] = error ("read private key: no key found in " ++ show filepath)
|
||||||
case pk of
|
headError (x:_) = x
|
||||||
[] -> error "no valid RSA key found"
|
|
||||||
(x:_) -> return x
|
|
||||||
|
|
||||||
where parseKey (Right pems) = map (fmap (PrivRSA . snd) . KeyRSA.decodePrivate . L.fromChunks . (:[]) . pemContent)
|
|
||||||
$ filter ((== "RSA PRIVATE KEY") . pemName) pems
|
|
||||||
parseKey (Left err) = error ("Cannot parse PEM file " ++ show err)
|
|
||||||
|
|
|
@ -28,7 +28,7 @@ Library
|
||||||
, vector
|
, vector
|
||||||
, cipher-rc4
|
, cipher-rc4
|
||||||
, cipher-aes >= 0.1 && < 0.2
|
, cipher-aes >= 0.1 && < 0.2
|
||||||
, x509 >= 1.4.2 && < 1.5.0
|
, x509 >= 1.4.3 && < 1.5.0
|
||||||
, x509-store >= 1.4.0 && < 1.5.0
|
, x509-store >= 1.4.0 && < 1.5.0
|
||||||
, x509-validation >= 1.4.2 && < 1.5.0
|
, x509-validation >= 1.4.2 && < 1.5.0
|
||||||
, crypto-pubkey >= 0.1.4
|
, crypto-pubkey >= 0.1.4
|
||||||
|
|
Loading…
Reference in a new issue