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