NmcDom.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module NmcDom   ( NmcDom(..)
   4                 , NmcRRSrv(..)
   5                 , NmcRRI2p(..)
   6                 , NmcRRTlsa(..)
   7                 , NmcRRDs(..)
   8                 , merge
   9                 ) where
  10
  11 import Prelude hiding (length)
  12 import Control.Applicative ((<$>), (<*>), empty, pure)
  13 import Data.Char
  14 import Data.Text (Text, unpack)
  15 import Data.List (union)
  16 import Data.List.Split
  17 import Data.Vector ((!), length, singleton)
  18 import Data.Map (Map, unionWith)
  19 import qualified Data.HashMap.Strict as H (lookup)
  20 import Data.Aeson
  21 import Data.Aeson.Types
  22 import Data.Default.Class
  23
  24 -- Variant of Aeson's `.:?` that interprets a String as a
  25 -- single-element list, so it is possible to have either
  26 --      "ip":["1.2.3.4"]
  27 -- or
  28 --      "ip":"1.2.3.4"
  29 -- with the same result.
  30 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
  31 obj .:/ key = case H.lookup key obj of
  32                Nothing -> pure Nothing
  33                Just v  -> case v of
  34                         String s -> parseJSON $ Array (singleton v)
  35                         _        -> parseJSON v
  36
  37 makeMx :: Object -> Parser (Maybe [String])
  38 makeMx o = return Nothing -- FIXME
  39 {-
  40   case H.lookup "service" o of
  41     Nothing          -> pure Nothing
  42     Just (Array saa) -> return $ Just $ fmap mxStr $ filter mxMatch saa
  43       where
  44         mxMatch sa = (sa ! 0) == "smtp" && (sa ! 1) == "tcp" && (sa ! 4) == 25
  45         mxStr sa = (sa ! 2) ++ "\t" ++ (sa ! 5)
  46     _                -> empty
  47 -}
  48 makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
  49 makeSubmap o = o .:? "map" -- FIXME
  50
  51 class Mergeable a where
  52         merge :: a -> a -> a -- bias towads second arg
  53
  54 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
  55         merge mx my = unionWith merge my mx
  56
  57 -- Alas, the following is not possible in Haskell :-(
  58 -- instance Mergeable String where
  59 --         merge _ b = b
  60
  61 instance Mergeable Value where
  62         merge _ b = b
  63
  64 instance Mergeable a => Mergeable (Maybe a) where
  65         merge (Just x) (Just y) = Just (merge x y)
  66         merge Nothing  (Just y) = Just y
  67         merge (Just x) Nothing  = Just x
  68         merge Nothing  Nothing  = Nothing
  69
  70 instance Eq a => Mergeable [a] where
  71         merge xs ys = union xs ys
  72
  73 data NmcRRSrv = NmcRRSrv
  74                         { srvPrio       :: Int
  75                         , srvWeight     :: Int
  76                         , srvPort       :: Int
  77                         , srvHost       :: String
  78                         } deriving (Show, Eq)
  79
  80 instance Mergeable NmcRRSrv where
  81         merge _ b = b
  82
  83 data NmcRRI2p = NmcRRI2p
  84                         { i2pDestination :: Maybe String
  85                         , i2pName        :: Maybe String
  86                         , i2pB32         :: Maybe String
  87                         } deriving (Show, Eq)
  88
  89 instance FromJSON NmcRRI2p where
  90         parseJSON (Object o) = NmcRRI2p
  91                 <$> o .:? "destination"
  92                 <*> o .:? "name"
  93                 <*> o .:? "b32"
  94         parseJSON _ = empty
  95
  96 instance Mergeable NmcRRI2p where
  97         merge _ b = b
  98
  99 data NmcRRTlsa = NmcRRTlsa
 100                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
 101                         , tlsMatchValue :: String
 102                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
 103                         } deriving (Show, Eq)
 104
 105 instance Mergeable NmcRRTlsa where
 106         merge _ b = b
 107
 108 data NmcRRDs = NmcRRDs
 109                         { dsKeyTag      :: Int
 110                         , dsAlgo        :: Int
 111                         , dsHashType    :: Int
 112                         , dsHashValue   :: String
 113                         } deriving (Show, Eq)
 114
 115 instance FromJSON NmcRRDs where
 116         parseJSON (Array a) =
 117                 if length a == 4 then NmcRRDs
 118                         <$> parseJSON (a ! 0)
 119                         <*> parseJSON (a ! 1)
 120                         <*> parseJSON (a ! 2)
 121                         <*> parseJSON (a ! 3)
 122                 else empty
 123         parseJSON _ = empty
 124
 125 instance Mergeable NmcRRDs where
 126         merge _ b = b
 127
 128 data NmcDom = NmcDom    { domIp          :: Maybe [String]
 129                         , domIp6         :: Maybe [String]
 130                         , domTor         :: Maybe String
 131                         , domI2p         :: Maybe NmcRRI2p
 132                         , domFreenet     :: Maybe String
 133                         , domAlias       :: Maybe String
 134                         , domTranslate   :: Maybe String
 135                         , domEmail       :: Maybe String
 136                         , domLoc         :: Maybe String
 137                         , domInfo        :: Maybe Value
 138                         , domNs          :: Maybe [String]
 139                         , domDelegate    :: Maybe String
 140                         , domImport      :: Maybe [String]
 141                         , domSubmap      :: Maybe (Map String NmcDom)
 142                         , domFingerprint :: Maybe [String]
 143                         , domDs          :: Maybe [NmcRRDs]
 144                         , domMx          :: Maybe [String]    -- Synthetic
 145                         , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
 146                         , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
 147                         } deriving (Show, Eq)
 148
 149 instance Default NmcDom where
 150   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 151                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 152                Nothing Nothing Nothing Nothing Nothing
 153
 154 instance FromJSON NmcDom where
 155         -- Wherever we expect a domain object, there may be a string
 156         -- containing IPv4 address. Interpret it as such.
 157         -- Question: shall we try to recognize IPv6 addresses too?
 158         parseJSON (String s) =
 159                  return $ if isIPv4 s'
 160                             then def { domIp = Just [s'] }
 161                             else def
 162                           where
 163                             s' = unpack s
 164                             isIPv4 x = all isNibble $ splitOn "." x
 165                             isNibble x =
 166                               if all isDigit x then (read x :: Int) < 256
 167                               else False
 168         parseJSON (Object o) = NmcDom
 169                 <$> o .:/ "ip"
 170                 <*> o .:/ "ip6"
 171                 <*> o .:? "tor"
 172                 <*> o .:? "i2p"
 173                 <*> o .:? "freenet"
 174                 <*> o .:? "alias"
 175                 <*> o .:? "translate"
 176                 <*> o .:? "email"
 177                 <*> o .:? "loc"
 178                 <*> o .:? "info"
 179                 <*> o .:/ "ns"
 180                 <*> o .:? "delegate"
 181                 <*> o .:/ "import"
 182                 <*> makeSubmap o
 183                 <*> o .:/ "fingerprint"
 184                 <*> o .:? "ds"
 185                 <*> makeMx o
 186                 <*> return Nothing -- domSrv created in subdomains
 187                 <*> return Nothing -- domTlsa created in subdomains
 188         parseJSON _ = empty
 189
 190 instance Mergeable NmcDom where
 191         merge sub dom = dom     { domIp =          mergelm domIp
 192                                 , domIp6 =         mergelm domIp6
 193                                 , domTor =         choose  domTor
 194                                 , domI2p =         mergelm domI2p
 195                                 , domFreenet =     choose  domFreenet
 196                                 , domAlias =       choose  domAlias
 197                                 , domTranslate =   choose  domTranslate
 198                                 , domEmail =       choose  domEmail
 199                                 , domLoc =         choose  domLoc
 200                                 , domInfo =        mergelm domInfo
 201                                 , domNs =          mergelm domNs
 202                                 , domDelegate =    mergelm domDelegate
 203                                 , domImport =      mergelm domImport
 204                                 , domSubmap =      mergelm domSubmap
 205                                 , domFingerprint = mergelm domFingerprint
 206                                 , domDs =          mergelm domDs
 207                                 , domMx =          mergelm domMx
 208                                 , domSrv =         mergelm domSrv
 209                                 , domTlsa =        mergelm domTlsa
 210                                 }
 211           where
 212                 mergelm x = merge (x sub) (x dom)
 213 -- Because it is not possible to define instance of merge for Strings,
 214 -- we have to treat string elements separately, otherwise strings are
 215 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
 216                 choose field = case field dom of
 217                         Nothing -> field sub
 218                         Just x  -> Just x