NmcDom.hs

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