Merge pull request #218 from lolepezy/fix/use-cached-ta-cert

Allow using cache TA certificate when it's impossible to fetch one for a TA

package-template.yaml

@@ -1,5 +1,5 @@
 name:                rpki-prover
-version:             0.9.5
+version:             0.9.6
 github:              "lolepezy/rpki-prover"
 license:             BSD3
 author:              "Mikhail Puzanov"

src/RPKI/Messages.hs

@@ -172,7 +172,7 @@ toValidationMessage = \case
 
       NoValidatedVersion -> "No tree validations has been run, cannot validate the object"
 
-      NoAKI -> "NO AKI found"
+      NoAKI -> "No AKI found"
       ParentCertificateNotFound  -> "Could not find parent ceertificate for the object"
       ObjectNotOnManifest        -> "Object is not listed on the parent manifest"
 
@@ -182,8 +182,8 @@ toValidationMessage = \case
 
       TACertAKIIsNotEmpty u -> [i|TA certificate #{u} has an AKI.|]
 
-      TACertOlderThanPrevious {..} -> 
-          [i|New TA certificate has validity period of #{before}-#{after}, previous one has #{prevBefore}-#{prevAfter}. |] <>
+      TACertPreferCachedCopy TACertValidities {..} -> 
+          [i|New TA certificate has validity period of #{notBefore}-#{notAfter}, previous one has #{cachedNotBefore}-#{cachedNotAfter}. |] <>
           [i|Will use previous TA certificate. NOTE: this means something really bad happened to the TA, consider stopping to use it at all.|]
 
       CertNoPolicyExtension -> [i|Certificate has no policy extension.|]

src/RPKI/Orphans/Json.hs

@@ -424,6 +424,7 @@ instance ToJSON InternalError
 instance ToJSON SlurmError
 instance ToJSON a => ToJSON (ParseError a)
 instance ToJSON RpkiObjectType
+instance ToJSON TACertValidities
 instance ToJSON ValidationError
 instance ToJSON ObjectIdentity
 instance ToJSON StorageError

src/RPKI/Reporting.hs

@@ -48,6 +48,16 @@ newtype ParseError s = ParseError s
     deriving stock (Show, Eq, Ord, Generic)
     deriving anyclass (TheBinary, NFData)
 
+
+data TACertValidities = TACertValidities {
+        notBefore       :: Instant,
+        notAfter        :: Instant,
+        cachedNotBefore :: Instant,
+        cachedNotAfter  :: Instant    
+    }
+    deriving stock (Show, Eq, Ord, Generic)
+    deriving anyclass (TheBinary, NFData)    
+
 data ValidationError =  SPKIMismatch SPKI SPKI |
                         UnknownObjectAsTACert |
                         ObjectIsTooSmall Integer |
@@ -63,12 +73,7 @@ data ValidationError =  SPKIMismatch SPKI SPKI |
                         NotFoundOnChecklist Hash Text |
                         ChecklistFileNameMismatch Hash Text Text |
                         TACertAKIIsNotEmpty URI |
-                        TACertOlderThanPrevious { 
-                                before :: Instant,
-                                after :: Instant,
-                                prevBefore :: Instant,
-                                prevAfter :: Instant
-                            } |
+                        TACertPreferCachedCopy TACertValidities |
                         CertNoPolicyExtension |
                         CertBrokenExtension OID BS.ByteString |
                         UnknownCriticalCertificateExtension OID BS.ByteString |

src/RPKI/Store/Database.hs

@@ -68,7 +68,7 @@ import           RPKI.Time
 -- It is brittle and inconvenient, but so far seems to be 
 -- the only realistic option.
 currentDatabaseVersion :: Integer
-currentDatabaseVersion = 32
+currentDatabaseVersion = 33
 
 -- Some constant keys
 databaseVersionKey, lastValidMftKey, forAsyncFetchKey :: Text
@@ -559,6 +559,9 @@ getBySKI tx db@DB { objectStore = RpkiObjectStore {..} } ski = liftIO $ runMaybe
 saveTA :: (MonadIO m, Storage s) => Tx s 'RW -> DB s -> StorableTA -> m ()
 saveTA tx DB { taStore = TAStore s } ta = liftIO $ M.put tx s (getTaName $ tal ta) ta
 
+deleteTA :: (MonadIO m, Storage s) => Tx s 'RW -> DB s -> TAL -> m ()
+deleteTA tx DB { taStore = TAStore s } tal = liftIO $ M.delete tx s (getTaName tal)
+
 getTA :: (MonadIO m, Storage s) => Tx s mode -> DB s -> TaName -> m (Maybe StorableTA)
 getTA tx DB { taStore = TAStore s } name = liftIO $ M.get tx s name
 

src/RPKI/Store/MakeLmdb.hs

@@ -51,7 +51,7 @@ createDatabase env logger checkAction = do
             dbVersion <- getDatabaseVersion tx db
             case dbVersion of 
                 Nothing -> do
-                    logInfo logger [i|Cache version is not set, setting it to #{currentDatabaseVersion}, dropping the cache.|]
+                    logInfo logger [i|Cache version is not set, setting it to #{currentDatabaseVersion}, cleaning up the cache.|]
                     (_, ms) <- timedMS $ emptyDBMaps tx db
                     logDebug logger  [i|Erasing cache took #{ms}ms.|]
                     saveCurrentDatabaseVersion tx db

src/RPKI/Store/Types.hs

@@ -27,7 +27,8 @@ data StorableTA = StorableTA {
         tal                 :: TAL,
         taCert              :: CaCerObject,
         fetchStatus         :: FetchStatus,
-        initialRepositories :: PublicationPointAccess
+        initialRepositories :: PublicationPointAccess,
+        actualUrl           :: RpkiURL
     } 
     deriving (Show, Eq, Generic, TheBinary)
 

src/RPKI/Validation/ObjectValidation.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE DerivingStrategies  #-}
 {-# LANGUAGE OverloadedLabels    #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -145,21 +146,43 @@ validateTaCertAKI taCert u =
             | SKI ki == getSKI taCert -> pure ()
             | otherwise -> vPureError $ TACertAKIIsNotEmpty (getURL u)
 
--- | Compare new certificate and the previous one
--- If validaity period of the new certificate is somehow earlier than 
--- the one of the previoius certificate, emit a warning and use
--- the previous certificate.
 --
-validateTACertWithPreviousCert :: CaCerObject -> CaCerObject -> PureValidatorT CaCerObject
-validateTACertWithPreviousCert cert previousCert = do
+-- Use the tiebreaker logic proposed by 
+-- https://datatracker.ietf.org/doc/draft-spaghetti-sidrops-rpki-ta-tiebreaker/
+--
+-- Emit a warning when deciding to use the cached certificate 
+-- instead of the fetched one.
+-- 
+chooseTaCert :: CaCerObject -> CaCerObject -> PureValidatorT CaCerObject
+chooseTaCert cert cachedCert = do
     let validities = bimap Instant Instant . certValidity . cwsX509certificate . getCertWithSignature
-    let (before, after) = validities cert
-    let (prevBefore, prevAfter) = validities previousCert
-    if before < prevBefore || after < prevAfter
-        then do
-            void $ vPureWarning $ TACertOlderThanPrevious{..}
-            pure previousCert
-        else pure cert
+    let (notBefore, notAfter) = validities cert
+    let (cachedNotBefore, cachedNotAfter) = validities cachedCert
+    let bothValidities = TACertValidities {..}
+
+        {- 
+            Check whether the retrieved object has a more recent
+            notBefore than the locally cached copy of the retrieved TA.
+            If the notBefore of the retrieved object is less recent,
+            use the locally cached copy of the retrieved TA.        
+        -}
+    if | notBefore < cachedNotBefore -> do
+            void $ vPureWarning $ TACertPreferCachedCopy bothValidities
+            pure cachedCert
+
+        {- 
+            If the notBefore dates are equal, check whether the
+            retrieved object has a shorter validity period than the
+            locally cached copy of the retrieved TA.  If the validity
+            period of the retrieved object is longer, use the locally
+            cached copy of the retrieved TA.        
+        -}
+        | notBefore == cachedNotBefore && cachedNotAfter < notAfter -> do 
+            void $ vPureWarning $ TACertPreferCachedCopy bothValidities
+            pure cachedCert            
+
+        | otherwise -> pure cert
+
 
 -- | In general, resource certifcate validation is:
 --
@@ -205,53 +228,53 @@ validateResourceCert now cert parentCert vcrl = do
 
 validateObjectValidityPeriod :: WithValidityPeriod c => c -> Now -> PureValidatorT ()
 validateObjectValidityPeriod c (Now now) = do 
-    let (before, after) = getValidityPeriod c
-    when (now < before) $ 
-        vPureError $ ObjectValidityIsInTheFuture before after
-    when (now > after) $ 
-        vPureError $ ObjectIsExpired before after
+    let (notBefore, notAfter) = getValidityPeriod c
+    when (now < notBefore) $ 
+        vPureError $ ObjectValidityIsInTheFuture notBefore notAfter
+    when (now > notAfter) $ 
+        vPureError $ ObjectIsExpired notBefore notAfter
 
 
 validateResources ::
-    (WithRawResourceCertificate c, 
+    (WithRawResourceCertificate child, 
      WithRawResourceCertificate parent,
-     WithRFC c,
+     WithRFC child,
      OfCertType parent 'CACert) =>
     Maybe (VerifiedRS PrefixesAndAsns) ->
-    c ->
+    child ->
     parent ->
     PureValidatorT (VerifiedRS PrefixesAndAsns)
-validateResources verifiedResources cert parentCert =
+validateResources verifiedResources childCert parentCert =
     validateChildParentResources
-        (getRFC cert)
-        (getRawCert cert ^. typed)
+        (getRFC childCert)
+        (getRawCert childCert ^. typed)
         (getRawCert parentCert ^. typed)
         verifiedResources
 
 
 validateBgpCert ::
-    forall c parent.
-    ( WithRawResourceCertificate c
+    forall child parent.
+    ( WithRawResourceCertificate child
     , WithRawResourceCertificate parent
     , WithSKI parent
-    , WithAKI c
-    , WithSKI c
-    , WithValidityPeriod c
-    , WithSerial c
-    , OfCertType c 'BGPCert
-    , OfCertType parent 'CACert
+    , WithAKI child
+    , WithSKI child
+    , WithValidityPeriod child
+    , WithSerial child
+    , child `OfCertType` BGPCert
+    , parent `OfCertType` CACert
     ) =>
     Now ->
-    c ->
+    child ->
     parent ->
     Validated CrlObject ->
-    PureValidatorT (Validated c, BGPSecPayload)
+    PureValidatorT (Validated child, BGPSecPayload)
 validateBgpCert now bgpCert parentCert validCrl = do
     -- Validate BGP certificate according to 
     -- https://www.rfc-editor.org/rfc/rfc8209.html#section-3.3    
 
     -- Validate resource set
-    void $ validateResourceCert @_ @_ @'BGPCert now bgpCert parentCert validCrl
+    void $ validateResourceCert @_ @_ @BGPCert now bgpCert parentCert validCrl
 
     let cwsX509 = cwsX509certificate $ getCertWithSignature bgpCert
 
@@ -304,10 +327,12 @@ validateCrl now crlObject@CrlObject {..} parentCert = do
 
 
 validateMft ::
-  (WithRawResourceCertificate c, WithSKI c, OfCertType c 'CACert) =>
+  (WithRawResourceCertificate parent, 
+   WithSKI parent, 
+   parent `OfCertType` CACert) =>
   Now ->
   MftObject ->
-  c ->
+  parent ->
   Validated CrlObject ->
   Maybe (VerifiedRS PrefixesAndAsns) ->
   PureValidatorT (Validated MftObject)
@@ -329,10 +354,12 @@ validateMft now mft parentCert crl verifiedResources = do
 
 
 validateRoa ::
-    (WithRawResourceCertificate c, WithSKI c, OfCertType c 'CACert) =>
+    (WithRawResourceCertificate parent, 
+     WithSKI parent, 
+     OfCertType parent CACert) =>
     Now ->
     RoaObject ->
-    c ->
+    parent ->
     Validated CrlObject ->
     Maybe (VerifiedRS PrefixesAndAsns) ->
     PureValidatorT (Validated RoaObject)
@@ -365,10 +392,12 @@ validateRoa now roa parentCert crl verifiedResources = do
                     vPureError $ errorReport vrs
 
 validateSpl ::
-    (WithRawResourceCertificate c, WithSKI c, OfCertType c 'CACert) =>
+    (WithRawResourceCertificate parent, 
+     WithSKI parent, 
+     OfCertType parent CACert) =>
     Now ->
     SplObject ->
-    c ->
+    parent ->
     Validated CrlObject ->
     Maybe (VerifiedRS PrefixesAndAsns) ->
     PureValidatorT (Validated SplObject)