{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module TahoeLAFS.Internal.Client where
import qualified "base64-bytestring" Data.ByteString.Base64 as Base64
import Crypto.Hash (Digest, hash)
import Crypto.Hash.Algorithms (SHA256)
import Data.ASN1.BinaryEncoding (DER (DER))
import Data.ASN1.Encoding (encodeASN1')
import Data.ASN1.Types (ASN1Object (toASN1))
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import Data.Default.Class (Default (def))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.X509 (
Certificate (certPubKey),
CertificateChain (CertificateChain),
PubKey,
Signed (signedObject),
SignedExact (getSigned),
)
import Data.X509.CertificateStore (CertificateStore)
import Data.X509.Validation (
FailedReason (AuthorityTooDeep, EmptyChain, InvalidSignature),
ServiceID,
SignatureFailure (SignaturePubkeyMismatch),
SignatureVerification (SignatureFailed, SignaturePass),
verifySignedSignature,
)
import Network.Connection (TLSSettings (..))
import Network.HTTP.Client (ManagerSettings, Request (requestHeaders), managerModifyRequest)
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types (Header)
import Network.TLS (
ClientHooks (onServerCertificate),
ClientParams (..),
Supported (..),
ValidationCache,
)
import Network.TLS.Extra.Cipher (ciphersuite_default)
newtype SPKIHash = SPKIHash B.ByteString deriving (SPKIHash -> SPKIHash -> Bool
(SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool) -> Eq SPKIHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SPKIHash -> SPKIHash -> Bool
$c/= :: SPKIHash -> SPKIHash -> Bool
== :: SPKIHash -> SPKIHash -> Bool
$c== :: SPKIHash -> SPKIHash -> Bool
Eq, Eq SPKIHash
Eq SPKIHash
-> (SPKIHash -> SPKIHash -> Ordering)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> Bool)
-> (SPKIHash -> SPKIHash -> SPKIHash)
-> (SPKIHash -> SPKIHash -> SPKIHash)
-> Ord SPKIHash
SPKIHash -> SPKIHash -> Bool
SPKIHash -> SPKIHash -> Ordering
SPKIHash -> SPKIHash -> SPKIHash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SPKIHash -> SPKIHash -> SPKIHash
$cmin :: SPKIHash -> SPKIHash -> SPKIHash
max :: SPKIHash -> SPKIHash -> SPKIHash
$cmax :: SPKIHash -> SPKIHash -> SPKIHash
>= :: SPKIHash -> SPKIHash -> Bool
$c>= :: SPKIHash -> SPKIHash -> Bool
> :: SPKIHash -> SPKIHash -> Bool
$c> :: SPKIHash -> SPKIHash -> Bool
<= :: SPKIHash -> SPKIHash -> Bool
$c<= :: SPKIHash -> SPKIHash -> Bool
< :: SPKIHash -> SPKIHash -> Bool
$c< :: SPKIHash -> SPKIHash -> Bool
compare :: SPKIHash -> SPKIHash -> Ordering
$ccompare :: SPKIHash -> SPKIHash -> Ordering
$cp1Ord :: Eq SPKIHash
Ord)
instance Show SPKIHash where
show :: SPKIHash -> String
show (SPKIHash ByteString
bs) = String
"SPKIHash " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (ByteString -> Text
T.decodeLatin1 (ByteString -> ByteString
Base64.encode ByteString
bs))
mkGBSManagerSettings ::
SPKIHash ->
T.Text ->
ManagerSettings
mkGBSManagerSettings :: SPKIHash -> Text -> ManagerSettings
mkGBSManagerSettings SPKIHash
requiredHash Text
swissnum =
(TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings (SPKIHash -> TLSSettings
gbsTLSSettings SPKIHash
requiredHash) Maybe SockSettings
forall a. Maybe a
sockSettings)
{ managerModifyRequest :: Request -> IO Request
managerModifyRequest = Text -> Request -> IO Request
forall (f :: * -> *). Applicative f => Text -> Request -> f Request
addAuthorization Text
swissnum
}
where
sockSettings :: Maybe a
sockSettings = Maybe a
forall a. Maybe a
Nothing
gbsTLSSettings :: SPKIHash -> TLSSettings
gbsTLSSettings :: SPKIHash -> TLSSettings
gbsTLSSettings SPKIHash
requiredHash =
ClientParams -> TLSSettings
TLSSettings
( ClientParams :: Maybe MaxFragmentEnum
-> (String, ByteString)
-> Bool
-> Maybe (ByteString, SessionData)
-> Shared
-> ClientHooks
-> Supported
-> DebugParams
-> Maybe ByteString
-> ClientParams
ClientParams
{ clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
clientUseMaxFragmentLength = Maybe MaxFragmentEnum
forall a. Maybe a
Nothing
, clientServerIdentification :: (String, ByteString)
clientServerIdentification = (String
"", ByteString
"")
, clientUseServerNameIndication :: Bool
clientUseServerNameIndication = Bool
True
, clientWantSessionResume :: Maybe (ByteString, SessionData)
clientWantSessionResume = Maybe (ByteString, SessionData)
forall a. Maybe a
Nothing
, clientShared :: Shared
clientShared = Shared
forall a. Default a => a
def
, clientHooks :: ClientHooks
clientHooks =
ClientHooks
forall a. Default a => a
def
{ onServerCertificate :: OnServerCertificate
onServerCertificate = SPKIHash -> OnServerCertificate
validateGBSCertificate SPKIHash
requiredHash
}
, clientSupported :: Supported
clientSupported = Supported
forall a. Default a => a
def{supportedCiphers :: [Cipher]
supportedCiphers = [Cipher]
ciphersuite_default}
, clientDebug :: DebugParams
clientDebug = DebugParams
forall a. Default a => a
def
, clientEarlyData :: Maybe ByteString
clientEarlyData = Maybe ByteString
forall a. Maybe a
Nothing
}
)
validateGBSCertificate :: SPKIHash -> CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason]
validateGBSCertificate :: SPKIHash -> OnServerCertificate
validateGBSCertificate SPKIHash
_ CertificateStore
_ ValidationCache
_ (String, ByteString)
_ (CertificateChain []) = [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
EmptyChain]
validateGBSCertificate SPKIHash
requiredSPKIFingerprint CertificateStore
_ ValidationCache
_ (String, ByteString)
_ (CertificateChain [SignedExact Certificate
signedExactCert]) =
case SignedExact Certificate -> PubKey -> SignatureVerification
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> PubKey -> SignatureVerification
verifySignedSignature SignedExact Certificate
signedExactCert PubKey
pubKey of
SignatureFailed SignatureFailure
failure -> [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
failure]
SignatureVerification
SignaturePass -> do
if Certificate -> SPKIHash
spkiFingerprint Certificate
cert SPKIHash -> SPKIHash -> Bool
forall a. Eq a => a -> a -> Bool
== SPKIHash
requiredSPKIFingerprint
then [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else do
[FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SignatureFailure -> FailedReason
InvalidSignature SignatureFailure
SignaturePubkeyMismatch]
where
pubKey :: PubKey
pubKey = Certificate -> PubKey
certPubKey Certificate
cert
cert :: Certificate
cert = Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
signedObject (Signed Certificate -> Certificate)
-> (SignedExact Certificate -> Signed Certificate)
-> SignedExact Certificate
-> Certificate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
getSigned (SignedExact Certificate -> Certificate)
-> SignedExact Certificate -> Certificate
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate
signedExactCert
validateGBSCertificate SPKIHash
_ CertificateStore
_ ValidationCache
_ (String, ByteString)
_ CertificateChain
_ = [FailedReason] -> IO [FailedReason]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FailedReason
AuthorityTooDeep]
sha256 :: B.ByteString -> B.ByteString
sha256 :: ByteString -> ByteString
sha256 = Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash :: B.ByteString -> Digest SHA256)
spki :: Certificate -> PubKey
spki :: Certificate -> PubKey
spki = Certificate -> PubKey
certPubKey
spkiBytes :: Certificate -> B.ByteString
spkiBytes :: Certificate -> ByteString
spkiBytes = DER -> [ASN1] -> ByteString
forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
encodeASN1' DER
DER ([ASN1] -> ByteString)
-> (Certificate -> [ASN1]) -> Certificate -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PubKey -> [ASN1] -> [ASN1]) -> [ASN1] -> PubKey -> [ASN1]
forall a b c. (a -> b -> c) -> b -> a -> c
flip PubKey -> [ASN1] -> [ASN1]
forall a. ASN1Object a => a -> [ASN1] -> [ASN1]
toASN1 [] (PubKey -> [ASN1])
-> (Certificate -> PubKey) -> Certificate -> [ASN1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> PubKey
spki
spkiFingerprint :: Certificate -> SPKIHash
spkiFingerprint :: Certificate -> SPKIHash
spkiFingerprint = ByteString -> SPKIHash
SPKIHash (ByteString -> SPKIHash)
-> (Certificate -> ByteString) -> Certificate -> SPKIHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
sha256 (ByteString -> ByteString)
-> (Certificate -> ByteString) -> Certificate -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> ByteString
spkiBytes
addAuthorization :: Applicative f => T.Text -> Request -> f Request
addAuthorization :: Text -> Request -> f Request
addAuthorization Text
swissnum Request
req =
Request -> f Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Request
req
{ requestHeaders :: RequestHeaders
requestHeaders = Header -> RequestHeaders -> RequestHeaders
addHeader Header
authz (RequestHeaders -> RequestHeaders)
-> (Request -> RequestHeaders) -> Request -> RequestHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RequestHeaders
requestHeaders (Request -> RequestHeaders) -> Request -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request
req
}
where
enc :: Text -> ByteString
enc = ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
authz :: Header
authz = (HeaderName
"Authorization", ByteString
"Tahoe-LAFS " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
enc Text
swissnum)
addHeader :: Header -> [Header] -> [Header]
addHeader :: Header -> RequestHeaders -> RequestHeaders
addHeader (HeaderName
name, ByteString
value) [] = [(HeaderName
name, ByteString
value)]
addHeader (HeaderName
name, ByteString
value) (o :: Header
o@(HeaderName
name', ByteString
_) : RequestHeaders
xs)
| HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name' = Header
o Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
xs
| Bool
otherwise = Header
o Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: Header -> RequestHeaders -> RequestHeaders
addHeader (HeaderName
name, ByteString
value) RequestHeaders
xs
addAuthorizationPrint :: T.Text -> Request -> IO Request
addAuthorizationPrint :: Text -> Request -> IO Request
addAuthorizationPrint Text
swissnum Request
req = do
String -> IO ()
p String
"Before"
Request -> IO ()
forall a. Show a => a -> IO ()
print Request
req
String -> IO ()
p String
"--------"
Request
r <- Text -> Request -> IO Request
forall (f :: * -> *). Applicative f => Text -> Request -> f Request
addAuthorization Text
swissnum Request
req
String -> IO ()
p String
"After"
Request -> IO ()
forall a. Show a => a -> IO ()
print Request
r
String -> IO ()
p String
"--------"
Request -> IO Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r
where
p :: String -> IO ()
p = String -> IO ()
forall a. Show a => a -> IO ()
print :: String -> IO ()