NmcDom.hs

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