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