Initial import
[pdns-pipe-nmc.git] / pdns-pipe-nmc.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import Control.Applicative
6 import Control.Monad
7 import Data.ConfigFile
8 import Data.Either.Utils
9 import Data.List.Split
10 import Data.Aeson (decode)
11 import Network.JsonRpc.Client
12 import NmcJson
13
14 confFile = "/etc/namecoin.conf"
15
16 -- Config file handling
17
18 data Config = Config { rpcuser       :: String
19                      , rpcpassword   :: String
20                      , rpchost       :: String
21                      , rpcport       :: String
22                      } deriving (Show)
23
24 readConfig :: String -> IO Config
25 readConfig f = do
26   cp <- return . forceEither =<< readfile emptyCP f
27   return (Config     { rpcuser       = getSetting cp "rpcuser"     ""
28                      , rpcpassword   = getSetting cp "rpcpassword" ""
29                      , rpchost       = getSetting cp "rpchost"     "localhost"
30                      , rpcport       = getSetting cp "rpcport"     "8336"
31                      })
32     where
33       getSetting cp x dfl = case get cp "DEFAULT" x of
34                               Left _  -> dfl
35                               Right x -> x
36
37 -- NMC interface
38
39 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
40 queryNmc uri fqdn qtype qid = do
41   case reverse  (splitOn "." fqdn) of
42     "bit":dn:xs -> do
43       ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn
44       let mdom = decode (resValue ans) :: Maybe NmcDom
45       case mdom of
46         Nothing  -> return $ Left ("Unparseable: " ++ (show (resValue ans)))
47         Just dom -> return $ Right dom
48     _           ->
49       return $ Left "Only \".bit\" domain is supported"
50
51 -- PowerDNS ABI
52
53 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
54             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
55             | RRTypeNS    | RRTypeDS
56             | RRTypeANY   | RRTypeError String 
57         deriving (Show)
58
59 data PdnsRequest = PdnsRequestQ
60                    { qName              :: String
61                    , qType              :: RRType
62                    , iD                 :: String
63                    , remoteIpAddress    :: String
64                    , localIpAddress     :: Maybe String
65                    , ednsSubnetAddress  :: Maybe String
66                    }
67                  | PdnsRequestAXFR String
68                  | PdnsRequestPing
69         deriving (Show)
70
71 pdnsParse ver s =
72   let
73     getQt qt = case qt of
74       "SRV"     -> RRTypeSRV   
75       "A"       -> RRTypeA
76       "AAAA"    -> RRTypeAAAA
77       "CNAME"   -> RRTypeCNAME
78       "DNAME"   -> RRTypeDNAME 
79       "SOA"     -> RRTypeSOA 
80       "RP"      -> RRTypeRP   
81       "LOC"     -> RRTypeLOC
82       "NS"      -> RRTypeNS    
83       "DS"      -> RRTypeDS
84       "ANY"     -> RRTypeANY
85       _         -> RRTypeError qt
86     getLIp ver xs
87       | ver >= 2  = case xs of
88                       x:_       -> Just x
89                       _         -> Nothing
90       | otherwise = Nothing
91     getRIp ver xs
92       | ver >= 3  = case xs of
93                       _:x:_     -> Just x
94                       _         -> Nothing
95       | otherwise = Nothing
96   in
97     case words s of
98       "PING":[]                 -> Right PdnsRequestPing
99       "AXFR":x:[]               -> Right (PdnsRequestAXFR x)
100       "Q":qn:"IN":qt:id:rip:xs  -> Right (PdnsRequestQ
101                                         { qName = qn
102                                         , qType = getQt qt
103                                         , iD = id
104                                         , remoteIpAddress = rip
105                                         , localIpAddress = getLIp ver xs
106                                         , ednsSubnetAddress = getRIp ver xs
107                                         })
108       _                         -> Left s
109
110 pdnsOut :: String -> Either String PdnsRequest -> IO ()
111 pdnsOut _   (Left e)   = putStrLn ("ERROR\tUnparseable request: " ++ e)
112 pdnsOut uri (Right rq) = case rq of
113     PdnsRequestQ qn qt id lip rip eip -> do
114       dom <- queryNmc uri qn qt id
115       case dom of
116         Left  e      -> putStrLn ("ERROR\tNmc query error: " ++ e)
117         Right result -> print result
118     PdnsRequestAXFR xfrreq ->
119       putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
120     PdnsRequestPing -> putStrLn "OK"
121
122 -- Main entry
123
124 main = do
125   cfg <- readConfig confFile
126   let uri = "http://" ++ rpcuser cfg ++ ":" ++ rpcpassword cfg ++
127             "@" ++ rpchost cfg ++ ":" ++ rpcport cfg ++ "/"
128   ver <- do
129     let
130       loopErr e = forever $ do
131         putStrLn $ "FAIL\t" ++ e
132         _ <- getLine
133         return ()
134     s <- getLine
135     case words s of
136       ["HELO", "1"] -> return 1
137       ["HELO", "2"] -> return 2
138       ["HELO", "3"] -> return 3
139       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
140       _             -> loopErr $ "bad HELO " ++ (show s)
141
142   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
143   forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)