--- | replace Service with Srv down in the Map
-expandSrv :: NmcDom -> NmcDom
-expandSrv base =
- let
- base' = base { domService = Nothing }
- in
- case domService base of
- Nothing -> base'
- Just sl -> foldr addSrvMx base' sl
- where
- addSrvMx sr acc = sub1 `mergeNmcDom` acc
- where
- sub1 = emptyNmcDom { domMap = Just (singleton proto sub2)
- , domMx = maybemx}
- sub2 = emptyNmcDom { domMap = Just (singleton srvid sub3) }
- sub3 = emptyNmcDom { domSrv = Just [srvStr] }
- proto = "_" ++ (srvProto sr)
- srvid = "_" ++ (srvName sr)
- srvStr = (show (srvPrio sr)) ++ " "
- ++ (show (srvWeight sr)) ++ " "
- ++ (show (srvPort sr)) ++ " "
- ++ (srvHost sr)
- maybemx =
- if srvName sr == "smtp"
- && srvProto sr == "tcp"
- && srvPort sr == 25
- then Just [(show (srvPrio sr)) ++ " " ++ (srvHost sr)]
- else Nothing
+-- | transfer some elements of `base` into `sub`, notably TLSA
+propagate :: NmcDom -> NmcDom -> NmcDom
+propagate base sub = sub `merge` (pickglobals base)
+ where
+ pickglobals dom = fromMaybe def (siftsubmap (siftsubmap taketlsa) dom)
+ siftsubmap f dom =
+ let
+ sdmap = fromMaybe empty (domSubmap dom)
+ sdmap' = foldrWithKey (\k x -> addifjust k (f x)) empty sdmap
+ addifjust k mdom acc = case mdom of
+ Nothing -> acc
+ Just dom -> insert k dom acc -- dups are impossible here
+ in
+ if null sdmap' then Nothing else Just $ def { domSubmap = Just sdmap'}
+ taketlsa dom = case domTlsa dom of
+ Nothing -> Nothing
+ Just tlsa -> case filter (\x -> tlsIncSubdoms x) tlsa of
+ [] -> Nothing
+ tlsa' -> Just $ def { domTlsa = Just tlsa' }