NmcDom.hs

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