NmcJson.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module NmcJson  ( NmcRes(..)
   4                 , NmcDom(..)
   5                 , emptyNmcDom
   6                 , descendNmc
   7                 ) where
   8
   9 import Data.ByteString.Lazy (ByteString)
  10 import Data.Map as M (Map, lookup)
  11 import Control.Applicative ((<$>), (<*>), empty)
  12 import Data.Aeson
  13
  14 data NmcRRService = NmcRRService -- unused
  15                         { srvName       :: String
  16                         , srvProto      :: String
  17                         , srvW1         :: Int
  18                         , srvW2         :: Int
  19                         , srvPort       :: Int
  20                         , srvHost       :: [String]
  21                         } deriving (Show, Eq)
  22
  23 instance FromJSON NmcRRService where
  24         parseJSON (Object o) = NmcRRService
  25                 <$> o .: "name"
  26                 <*> o .: "proto"
  27                 <*> o .: "w1"
  28                 <*> o .: "w2"
  29                 <*> o .: "port"
  30                 <*> o .: "host"
  31         parseJSON _ = empty
  32
  33 data NmcRRI2p = NmcRRI2p
  34                         { i2pDestination :: String
  35                         , i2pName        :: String
  36                         , i2pB32         :: String
  37                         } deriving (Show, Eq)
  38
  39 instance FromJSON NmcRRI2p where
  40         parseJSON (Object o) = NmcRRI2p
  41                 <$> o .: "destination"
  42                 <*> o .: "name"
  43                 <*> o .: "b32"
  44         parseJSON _ = empty
  45
  46 data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
  47                         , domIp          :: Maybe [String]
  48                         , domIp6         :: Maybe [String]
  49                         , domTor         :: Maybe String
  50                         , domI2p         :: Maybe NmcRRI2p
  51                         , domFreenet     :: Maybe String
  52                         , domAlias       :: Maybe String
  53                         , domTranslate   :: Maybe String
  54                         , domEmail       :: Maybe String
  55                         , domLoc         :: Maybe String
  56                         , domInfo        :: Maybe Value
  57                         , domNs          :: Maybe [String]
  58                         , domDelegate    :: Maybe [String]
  59                         , domImport      :: Maybe [[String]]
  60                         , domMap         :: Maybe (Map String NmcDom)
  61                         , domFingerprint :: Maybe [String]
  62                         , domTls         :: Maybe (Map String
  63                                                     (Map String [[String]]))
  64                         , domDs          :: Maybe [[String]]
  65                         } deriving (Show, Eq)
  66
  67 instance FromJSON NmcDom where
  68         parseJSON (Object o) = NmcDom
  69                 <$> o .:? "service"
  70                 <*> o .:? "ip"
  71                 <*> o .:? "ip6"
  72                 <*> o .:? "tor"
  73                 <*> o .:? "i2p"
  74                 <*> o .:? "freenet"
  75                 <*> o .:? "alias"
  76                 <*> o .:? "translate"
  77                 <*> o .:? "email"
  78                 <*> o .:? "loc"
  79                 <*> o .:? "info"
  80                 <*> o .:? "ns"
  81                 <*> o .:? "delegate"
  82                 <*> o .:? "import"
  83                 <*> o .:? "map"
  84                 <*> o .:? "fingerprint"
  85                 <*> o .:? "tls"
  86                 <*> o .:? "ds"
  87         parseJSON _ = empty
  88
  89 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
  90                      Nothing Nothing Nothing Nothing Nothing Nothing
  91                      Nothing Nothing Nothing Nothing Nothing Nothing
  92
  93 data NmcRes = NmcRes    { resName       :: String
  94                         , resValue      :: ByteString -- string with NmcDom
  95                         , resTxid       :: String
  96                         , resAddress    :: String
  97                         , resExpires_in :: Int
  98                         } deriving (Show)
  99 instance FromJSON NmcRes where
 100         parseJSON (Object o) = NmcRes
 101                 <$> o .: "name"
 102                 <*> o .: "value"
 103                 <*> o .: "txid"
 104                 <*> o .: "address"
 105                 <*> o .: "expires_in"
 106         parseJSON _ = empty
 107
 108 normalizeDom :: NmcDom -> NmcDom
 109 normalizeDom dom
 110   | domNs        dom /= Nothing = emptyNmcDom { domNs = domNs dom }
 111   | domDelegate  dom /= Nothing = emptyNmcDom -- FIXME
 112   | domTranslate dom /= Nothing = dom { domMap = Nothing }
 113   | otherwise                   = dom
 114
 115 descendNmc :: [String] -> NmcDom -> NmcDom
 116 descendNmc subdom rawdom =
 117   let dom = normalizeDom rawdom
 118   in case subdom of
 119     []   ->
 120       case domMap dom of
 121         Nothing  -> dom
 122         Just map ->
 123           case M.lookup "" map of         -- Stupid, but there are "" in the map
 124             Nothing  -> dom               -- Try to merge it with the root data
 125             Just sub -> mergeNmc sub dom  -- Or maybe drop it altogether...
 126     d:ds ->
 127       case domMap dom of
 128         Nothing  -> emptyNmcDom
 129         Just map ->
 130           case M.lookup d map of
 131             Nothing  -> emptyNmcDom
 132             Just sub -> descendNmc ds sub
 133
 134 -- FIXME -- I hope there exists a better way to merge records!
 135 mergeNmc :: NmcDom -> NmcDom -> NmcDom
 136 mergeNmc sub dom = dom  { domService = choose dom domService sub
 137                         , domIp = choose dom domIp sub
 138                         , domIp6 = choose dom domIp6 sub
 139                         , domTor = choose dom domTor sub
 140                         , domI2p = choose dom domI2p sub
 141                         , domFreenet = choose dom domFreenet sub
 142                         , domAlias = choose dom domAlias sub
 143                         , domTranslate = choose dom domTranslate sub
 144                         , domEmail = choose dom domEmail sub
 145                         , domLoc = choose dom domLoc sub
 146                         , domInfo = choose dom domInfo sub
 147                         , domNs = choose dom domNs sub
 148                         , domDelegate = choose dom domDelegate sub
 149                         , domImport = choose dom domImport sub
 150                         , domFingerprint = choose dom domFingerprint sub
 151                         , domTls = choose dom domTls sub
 152                         , domDs = choose dom domDs sub
 153                         }
 154   where
 155     choose :: NmcDom -> (NmcDom -> Maybe a) -> NmcDom -> Maybe a
 156     choose sub t dom = case t dom of
 157       Nothing -> t sub
 158       Just x  -> Just x