NmcDom.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module NmcDom   ( NmcDom(..)
   4                 , emptyNmcDom
   5                 , seedNmcDom
   6                 , descendNmcDom
   7                 ) where
   8
   9 import Data.ByteString.Lazy (ByteString)
  10 import qualified Data.Text as T (unpack)
  11 import Data.List.Split
  12 import Data.Char
  13 import Data.Map as M (Map, lookup, delete, size)
  14 import Control.Applicative ((<$>), (<*>), empty)
  15 import Data.Aeson
  16
  17 data NmcRRService = NmcRRService -- unused
  18                         { srvName       :: String
  19                         , srvProto      :: String
  20                         , srvW1         :: Int
  21                         , srvW2         :: Int
  22                         , srvPort       :: Int
  23                         , srvHost       :: [String]
  24                         } deriving (Show, Eq)
  25
  26 instance FromJSON NmcRRService where
  27         parseJSON (Object o) = NmcRRService
  28                 <$> o .: "name"
  29                 <*> o .: "proto"
  30                 <*> o .: "w1"
  31                 <*> o .: "w2"
  32                 <*> o .: "port"
  33                 <*> o .: "host"
  34         parseJSON _ = empty
  35
  36 data NmcRRI2p = NmcRRI2p
  37                         { i2pDestination :: String
  38                         , i2pName        :: String
  39                         , i2pB32         :: String
  40                         } deriving (Show, Eq)
  41
  42 instance FromJSON NmcRRI2p where
  43         parseJSON (Object o) = NmcRRI2p
  44                 <$> o .: "destination"
  45                 <*> o .: "name"
  46                 <*> o .: "b32"
  47         parseJSON _ = empty
  48
  49 data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
  50                         , domIp          :: Maybe [String]
  51                         , domIp6         :: Maybe [String]
  52                         , domTor         :: Maybe String
  53                         , domI2p         :: Maybe NmcRRI2p
  54                         , domFreenet     :: Maybe String
  55                         , domAlias       :: Maybe String
  56                         , domTranslate   :: Maybe String
  57                         , domEmail       :: Maybe String
  58                         , domLoc         :: Maybe String
  59                         , domInfo        :: Maybe Value
  60                         , domNs          :: Maybe [String]
  61                         , domDelegate    :: Maybe [String]
  62                         , domImport      :: Maybe String
  63                         , domMap         :: Maybe (Map String NmcDom)
  64                         , domFingerprint :: Maybe [String]
  65                         , domTls         :: Maybe (Map String
  66                                                     (Map String [[String]]))
  67                         , domDs          :: Maybe [[String]]
  68                         } deriving (Show, Eq)
  69
  70 instance FromJSON NmcDom where
  71         -- Wherever we expect a domain object, there may be a string
  72         -- containing IPv4 address. Interpret it as such.
  73         -- Question: shall we try to recognize IPv6 addresses too?
  74         parseJSON (String s) =
  75                  return $ if isIPv4 s'
  76                             then emptyNmcDom { domIp = Just [s'] }
  77                             else emptyNmcDom
  78                           where
  79                             s' = T.unpack s
  80                             isIPv4 x = all isNibble $ splitOn "." x
  81                             isNibble x =
  82                               if all isDigit x then (read x :: Int) < 256
  83                               else False
  84         parseJSON (Object o) = NmcDom
  85                 <$> o .:? "service"
  86                 <*> o .:? "ip"
  87                 <*> o .:? "ip6"
  88                 <*> o .:? "tor"
  89                 <*> o .:? "i2p"
  90                 <*> o .:? "freenet"
  91                 <*> o .:? "alias"
  92                 <*> o .:? "translate"
  93                 <*> o .:? "email"
  94                 <*> o .:? "loc"
  95                 <*> o .:? "info"
  96                 <*> o .:? "ns"
  97                 <*> o .:? "delegate"
  98                 <*> o .:? "import"
  99                 <*> o .:? "map"
 100                 <*> o .:? "fingerprint"
 101                 <*> o .:? "tls"
 102                 <*> o .:? "ds"
 103         parseJSON _ = empty
 104
 105 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
 106                      Nothing Nothing Nothing Nothing Nothing Nothing
 107                      Nothing Nothing Nothing Nothing Nothing Nothing
 108
 109 -- FIXME -- I hope there exists a better way to merge records!
 110 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
 111 mergeNmcDom sub dom = dom  { domService = choose domService
 112                         , domIp =          choose domIp
 113                         , domIp6 =         choose domIp6
 114                         , domTor =         choose domTor
 115                         , domI2p =         choose domI2p
 116                         , domFreenet =     choose domFreenet
 117                         , domAlias =       choose domAlias
 118                         , domTranslate =   choose domTranslate
 119                         , domEmail =       choose domEmail
 120                         , domLoc =         choose domLoc
 121                         , domInfo =        choose domInfo
 122                         , domNs =          choose domNs
 123                         , domDelegate =    choose domDelegate
 124                         , domImport =      choose domImport
 125                         , domMap =         choose domMap
 126                         , domFingerprint = choose domFingerprint
 127                         , domTls =         choose domTls
 128                         , domDs =          choose domDs
 129                         }
 130   where
 131     choose :: (NmcDom -> Maybe a) -> Maybe a
 132     choose field = case field dom of
 133       Nothing -> field sub
 134       Just x  -> Just x
 135
 136 -- | Perform query and return error string or parsed domain object
 137 queryNmcDom ::
 138   (String -> IO (Either String ByteString)) -- ^ query operation action
 139   -> String                                 -- ^ key
 140   -> IO (Either String NmcDom)              -- ^ error string or domain
 141 queryNmcDom queryOp key = do
 142   l <- queryOp key
 143   case l of
 144     Left estr -> return $ Left estr
 145     Right str -> case decode str :: Maybe NmcDom of
 146       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
 147       Just dom -> return $ Right dom
 148
 149 -- | Try to fetch "import" object and merge it into the base domain
 150 --   Original "import" element is removed, but new imports from the
 151 --   imported objects are processed recursively until there are none.
 152 mergeImport ::
 153   (String -> IO (Either String ByteString)) -- ^ query operation action
 154   -> NmcDom                                 -- ^ base domain
 155   -> IO (Either String NmcDom)              -- ^ result with merged import
 156 mergeImport queryOp base = do
 157   let
 158     mbase = mergeSelf base
 159     base' = mbase {domImport = Nothing}
 160   -- print base
 161   case domImport mbase of
 162     Nothing  -> return $ Right base'
 163     Just key -> do
 164       sub <- queryNmcDom queryOp key
 165       case sub of
 166         Left  e    -> return $ Left e
 167         Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'
 168
 169 -- | If there is an element in the map with key "", merge the contents
 170 --   and remove this element. Do this recursively.
 171 mergeSelf :: NmcDom -> NmcDom
 172 mergeSelf base =
 173   let
 174     map   = domMap base
 175     base' = base {domMap = removeSelf map}
 176     removeSelf Nothing    = Nothing
 177     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
 178       where map' = M.delete "" map
 179   in
 180     case map of
 181       Nothing   -> base'
 182       Just map' ->
 183         case M.lookup "" map' of
 184           Nothing  -> base'
 185           Just sub -> (mergeSelf sub) `mergeNmcDom` base'
 186
 187 -- | Presence of some elements require removal of some others
 188 normalizeDom :: NmcDom -> NmcDom
 189 normalizeDom dom = foldr id dom [ nsNormalizer
 190                                 , translateNormalizer
 191                                 ]
 192   where
 193     nsNormalizer dom = case domNs dom of
 194       Nothing  -> dom
 195       Just ns  -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
 196     translateNormalizer dom = case domTranslate dom of
 197       Nothing  -> dom
 198       Just tr  -> dom { domMap = Nothing }
 199
 200 -- | Merge imports and Selfs and follow the maps tree to get dom
 201 descendNmcDom ::
 202   (String -> IO (Either String ByteString)) -- ^ query operation action
 203   -> [String]                               -- ^ subdomain chain
 204   -> NmcDom                                 -- ^ base domain
 205   -> IO (Either String NmcDom)              -- ^ fully processed result
 206 descendNmcDom queryOp subdom base = do
 207   base' <- mergeImport queryOp base
 208   case subdom of
 209     []   -> return $ fmap normalizeDom base'
 210     d:ds ->
 211       case base' of
 212         Left err     -> return base'
 213         Right base'' ->
 214           case domMap base'' of
 215             Nothing  -> return $ Right emptyNmcDom
 216             Just map ->
 217               case M.lookup d map of
 218                 Nothing  -> return $ Right emptyNmcDom
 219                 Just sub -> descendNmcDom queryOp ds sub
 220
 221 -- | Initial NmcDom populated with "import" only, suitable for "descend"
 222 seedNmcDom ::
 223   String        -- ^ domain key (without namespace prefix)
 224   -> NmcDom     -- ^ resulting seed domain
 225 seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}