NmcDom.hs

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