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