pocket-dns (empty) → 0.1.0
raw patch · 12 files changed
+787/−0 lines, 12 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, cabal-test-bin, data-default, dns, hspec, hspec-contrib, hspec-server, hspec-test-sandbox, http-conduit, iproute, monad-control, network, optparse-applicative, persistent, persistent-sqlite, persistent-template, persistent-zookeeper, pocket-dns, shakespeare, shelly, test-sandbox, text, transformers, unordered-containers, yaml
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- Main.hs +88/−0
- Network/DNS/Pocket.hs +12/−0
- Network/DNS/Pocket/Server.hs +217/−0
- Network/DNS/Pocket/Sqlite.hs +59/−0
- Network/DNS/Pocket/Type.hs +48/−0
- Network/DNS/Pocket/Zookeeper.hs +59/−0
- README.md +84/−0
- Setup.hs +2/−0
- pocket-dns.cabal +101/−0
- tests/test.hs +84/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.1.0++* First Release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Junji Hashimoto++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Junji Hashimoto nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++--import Prelude hiding (FilePath)+import Network.DNS.Pocket+import Options.Applicative+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import Control.Monad+import System.Exit++default (T.Text)++data Command+ = Set FilePath String [String]+ | Get FilePath String+ | List FilePath+ | Delete FilePath String + | Daemon FilePath Port+ deriving Show++set :: Parser Command+set = Set+ <$> option str (long "conf" <> value "conf.yml" <> metavar "CONFILE")+ <*> (argument str (metavar "DOMAIN"))+ <*> many (argument str (metavar "IP..."))++get :: Parser Command+get = Get+ <$> option str (long "conf" <> value "conf.yml" <> metavar "CONFILE")+ <*> (argument str (metavar "DOMAIN"))++list :: Parser Command+list = List+ <$> option str (long "conf" <> value "conf.yml" <> metavar "CONFILE")++delete :: Parser Command+delete = Delete+ <$> option str (long "conf" <> value "conf.yml" <> metavar "CONFILE")+ <*> (argument str (metavar "DOMAIN"))++daemon :: Parser Command+daemon = Daemon+ <$> option str (long "conf" <> value "conf.yml" <> metavar "CONFILE")+ <*> option auto (long "port" <> value 53 <> metavar "PORT")++parse :: Parser Command+parse = subparser $ foldr1 (<>) [+ command "set" (info set (progDesc "set domain and ip"))+ , command "get" (info get (progDesc "get ip from domain"))+ , command "list" (info list (progDesc "list domain's ip"))+ , command "delete" (info delete (progDesc "delete domain"))+ , command "daemon" (info daemon (progDesc "start daemon"))+ ]++runCmd :: Command -> IO ()+runCmd (Set conf domain ips) = do+ v <- setDomain conf (B8.pack domain) $ map read ips+ if v+ then print "OK"+ else do+ print "Failed"+ exitWith $ ExitFailure 1++runCmd (Get conf domain) = do+ v <- getDomain conf $ B8.pack domain+ print v++runCmd (List conf) = do+ v <- listDomain conf+ forM_ v $ \(domain,ips) -> do+ B8.putStrLn domain+ forM_ ips $ \ip -> do+ putStr $ " "+ putStrLn $ show ip++runCmd (Delete conf domain) = do+ deleteDomain conf $ B8.pack domain+ +runCmd (Daemon conf port) = runServer conf port++opts :: ParserInfo Command+opts = info (parse <**> helper) idm++main :: IO ()+main = execParser opts >>= runCmd+
+ Network/DNS/Pocket.hs view
@@ -0,0 +1,12 @@+module Network.DNS.Pocket (+ Port+, runServer+, setDomain+, getDomain+, deleteDomain+, listDomain+ )+where++--import Network.DNS.Pocket.Type+import Network.DNS.Pocket.Server
+ Network/DNS/Pocket/Server.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}++module Network.DNS.Pocket.Server where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import qualified Data.ByteString as S+import Data.ByteString.Lazy hiding (putStrLn, filter, length)+import Data.Default+import Data.IP+import Data.Maybe+import Data.Monoid+import qualified Data.Aeson as A+import qualified Data.Yaml as Y+import qualified Data.HashMap.Strict as H+import Network.BSD+import Network.DNS hiding (lookup)+import Network.Socket hiding (recvFrom)+import Network.Socket.ByteString+import System.Timeout+import Database.Persist.Sqlite (SqliteConf)+import Database.Persist.Zookeeper (ZookeeperConf)+import Network.DNS.Pocket.Type+import Network.DNS.Pocket.Zookeeper ()+import Network.DNS.Pocket.Sqlite ()++type Port = Int++timeout' :: String -> Int -> IO a -> IO (Maybe a)+timeout' msg tm io = do+ result <- timeout tm io+ maybe (putStrLn msg) (const $ return ()) result+ return result++proxyRequest :: DnsConf -> ResolvConf -> DNSFormat -> IO (Maybe DNSFormat)+proxyRequest DnsConf{..} rc req = do+ let worker Resolver{..} = do+ let packet = mconcat . toChunks $ encode req+ sendAll dnsSock packet+ receive dnsSock+ rs <- makeResolvSeed rc+ withResolver rs $ \r ->+ (>>= check) <$> timeout' "proxy timeout" timeOut (worker r)+ where+ ident = identifier . header $ req+ check :: DNSFormat -> Maybe DNSFormat+ check rsp = let hdr = header rsp+ in if identifier hdr == ident+ then Just rsp+ else Nothing++handleRequest :: DnsBackend c => c -> DnsConf -> Conn c -> ResolvConf -> DNSFormat -> Int -> IO (Maybe DNSFormat)+handleRequest pconf conf conn rc req n = do+ mr <- lookupHosts+ case mr of+ Just _ -> return mr+ Nothing -> proxyRequest conf rc req+ where+ filterA = filter ((==A) . qtype)+ ident = identifier . header $ req+ lookupHosts :: IO (Maybe DNSFormat)+ lookupHosts = do+ let mq = listToMaybe . filterA . question $ req+ case mq of+ Just q -> do+ val <- getRecord pconf (qname q) conn+ -- print $ q+ -- print $ qname q+ -- print $ val+ let len = length val+ if len /= 0+ then + case (val !! (n `mod` len)) of+ IPv4 ip -> return $ Just $ responseA ident q ip+ IPv6 ip -> return $ Just $ responseAAAA ident q ip+ else+ return Nothing+ Nothing -> return Nothing++handlePacket :: DnsBackend c => c -> DnsConf -> Conn c -> Socket -> SockAddr -> S.ByteString -> Int -> IO ()+handlePacket pconf conf@DnsConf{..} conn sock addr bs n = case decode (fromChunks [bs]) of+ Right req -> do+ let rc = defaultResolvConf { resolvInfo = RCFilePath "/etc/resolv.conf" }+ mrsp <- handleRequest pconf conf conn rc req n+ case mrsp of+ Just rsp ->+ let packet = mconcat . toChunks $ encode rsp+ in void $ timeout' "send timeout" timeOut (sendAllTo sock packet addr)+ Nothing -> return ()+ Left msg -> putStrLn msg+++runServer' :: DnsBackend c => c -> Port -> IO ()+runServer' conf port = do+ withSocketsDo $ do+ mconn <- setup conf+ case mconn of+ Just conn -> do+ addrinfos <- getAddrInfo+ (Just (defaultHints {addrFlags = [AI_PASSIVE]}))+ Nothing (Just "domain")+ addrinfo <- maybe (fail "no addr info") return (listToMaybe addrinfos)+ addrinfo' <- do+ if port == 53+ then return addrinfo+ else do+ let sockaddr = addrAddress addrinfo+ let sockaddr' = case sockaddr of+ SockAddrInet _ addr -> SockAddrInet (fromIntegral port) addr+ SockAddrInet6 _ f h s -> SockAddrInet6 (fromIntegral port) f h s+ SockAddrUnix _ -> sockaddr+ return $ addrinfo { addrAddress = sockaddr' }+ sock <- socket (addrFamily addrinfo') Datagram defaultProtocol+ bindSocket sock (addrAddress addrinfo')+ loop sock conn def 0+ Nothing -> error $ "Setup failure"+ where+ loop sock conn def' n = do+ (bs, addr) <- recvFrom sock (bufSize def')+ _ <- forkIO $ handlePacket conf def' conn sock addr bs n+ case n of+ 255 -> loop sock conn def' 0+ _ -> loop sock conn def' (n+1)++loadConf :: FilePath -> IO (Maybe Conf)+loadConf yamlConfFile = do+ mconf <- Y.decodeFile yamlConfFile :: IO (Maybe Y.Value)+ case mconf of+ Just (Y.Object obj) -> do+-- let obj' = Y.encode $ Y.Object $ H.delete "backend" obj+ case H.lookup "backend" obj of+ Just (A.String "zookeeper") -> do+ v <- load yamlConfFile :: IO (Maybe ZookeeperConf)+ return $ fmap Zookeeper v+ Just (A.String "sqlite") -> do+ v <- load yamlConfFile :: IO (Maybe SqliteConf)+ return $ fmap Sqlite v+ _ -> return Nothing+ _ -> return Nothing+ +runServer :: FilePath -> Port -> IO ()+runServer file port = do+ mconf <- loadConf file+ case mconf of+ Just (Zookeeper conf) -> runServer' conf port+ Just (Sqlite conf) -> runServer' conf port+ Nothing -> error "Can not parse config-file"+++setDomain :: FilePath -> Domain -> [IP] -> IO Bool+setDomain file domain ips = do+ mconf <- loadConf file+ case mconf of+ Just (Zookeeper conf) -> setDomain' conf domain ips+ Just (Sqlite conf) -> setDomain' conf domain ips+ Nothing -> error "Can not parse config-file"+ where+ setDomain' :: DnsBackend c => c -> Domain -> [IP] -> IO Bool+ setDomain' conf domain' ips' = do+ withSocketsDo $ do+ mconn <- setup conf+ case mconn of+ Just conn -> setRecord conf domain' ips' conn+ Nothing -> error "Setup failure"++getDomain :: FilePath -> Domain -> IO [IP]+getDomain file domain = do+ mconf <- loadConf file+ case mconf of+ Just (Zookeeper conf) -> getDomain' conf domain+ Just (Sqlite conf) -> getDomain' conf domain+ Nothing -> error "Can not parse config-file"+ where+ getDomain' :: DnsBackend c => c -> Domain -> IO [IP]+ getDomain' conf domain' = do+ withSocketsDo $ do+ mconn <- setup conf+ case mconn of+ Just conn -> getRecord conf domain' conn+ Nothing -> error "Setup failure"++deleteDomain :: FilePath -> Domain -> IO ()+deleteDomain file domain = do+ mconf <- loadConf file+ case mconf of+ Just (Zookeeper conf) -> deleteDomain' conf domain+ Just (Sqlite conf) -> deleteDomain' conf domain+ Nothing -> error "Can not parse config-file"+ where+ deleteDomain' :: DnsBackend c => c -> Domain -> IO ()+ deleteDomain' conf domain' = do+ withSocketsDo $ do+ mconn <- setup conf+ case mconn of+ Just conn -> deleteRecord conf domain' conn+ Nothing -> error "Setup failure"++listDomain :: FilePath -> IO [(Domain,[IP])]+listDomain file = do+ mconf <- loadConf file+ case mconf of+ Just (Zookeeper conf) -> listDomain' conf+ Just (Sqlite conf) -> listDomain' conf+ Nothing -> error "Can not parse config-file"+ where+ listDomain' :: DnsBackend c => c -> IO [(Domain,[IP])]+ listDomain' conf = do+ withSocketsDo $ do+ mconn <- setup conf+ case mconn of+ Just conn -> listRecord conf conn+ Nothing -> error "Setup failure"
+ Network/DNS/Pocket/Sqlite.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.DNS.Pocket.Sqlite (+ DnsBackend+) where+import Data.IP+import Network.DNS hiding (lookup)+import Network.Socket hiding (recvFrom)+import Database.Persist+import Database.Persist.TH+import Database.Persist.Sqlite+import qualified Data.Yaml as Y+import Network.DNS.Pocket.Type++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+DnsRecord+ name Domain+ addr [IP]+ DnsRecordU name+ deriving Show+ deriving Eq+|]++instance DnsBackend SqliteConf where+ type Conn SqliteConf = ConnectionPool+ load file = do+ mconf <- Y.decodeFile file+ case mconf of+ Just val -> do + return $ Y.parseMonad Database.Persist.loadConfig val+ Nothing -> return Nothing+ setup p = do+ withSocketsDo $ do+ conn <- createPoolConfig p+ runPool p (runMigration migrateAll) conn+ return $ Just conn+ getRecord p domain conn = do+ mRecord <- runPool p (getBy (DnsRecordU domain)) conn+ case mRecord of+ Just (Entity _key val') -> do+ let val = dnsRecordAddr val'+ return val+ Nothing ->+ return []+ setRecord p domain ips conn = do+ a <- runPool p (insertUnique (DnsRecord domain ips)) conn+ case a of+ Just _ -> return True+ Nothing -> return False+ listRecord p conn = do+ a <- runPool p (selectList [] []) conn+ return $ map (\(Entity _key val) -> (dnsRecordName val,dnsRecordAddr val)) a+ deleteRecord p q conn = do+ runPool p (deleteBy (DnsRecordU q)) conn
+ Network/DNS/Pocket/Type.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.DNS.Pocket.Type where+import Data.Default+import Data.IP+import Network.DNS hiding (lookup)+import Database.Persist+import Database.Persist.Sqlite (SqliteConf)+import Database.Persist.Zookeeper (ZookeeperConf)++instance PersistField IP where+ toPersistValue (IPv4 ip) = toPersistValue $ fromIPv4 ip+ toPersistValue (IPv6 ip) = toPersistValue $ fromIPv6 ip+ fromPersistValue value = do+ v <- fromPersistValue value+ if length v == 4+ then return $ IPv4 $ toIPv4 $ v+ else return $ IPv6 $ toIPv6 $ v++data DnsConf = DnsConf {+ bufSize :: Int+ , timeOut :: Int+}++instance Default DnsConf where+ def = DnsConf {+ bufSize = 512+ , timeOut = 3 * 1000 * 1000+ }++class DnsBackend p where+ type Conn p+ load :: FilePath -> IO (Maybe p)+ setup :: p -> IO (Maybe (Conn p))+ getRecord :: p -> Domain -> Conn p -> IO [IP]+ setRecord :: p -> Domain -> [IP] -> Conn p -> IO Bool+ deleteRecord :: p -> Domain -> Conn p -> IO ()+ listRecord :: p -> Conn p -> IO [(Domain,[IP])]+++data Conf =+ Zookeeper ZookeeperConf+ | Sqlite SqliteConf
+ Network/DNS/Pocket/Zookeeper.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.DNS.Pocket.Zookeeper (+ DnsBackend+) where+import Data.IP+import Network.DNS hiding (lookup)+import Network.Socket hiding (recvFrom)+import Database.Persist+import Database.Persist.TH+import Database.Persist.Zookeeper+import qualified Data.Yaml as Y+import Network.DNS.Pocket.Type++let zookeeperSettings = defaultZookeeperSettings+ in share [mkPersist zookeeperSettings] [persistLowerCase|+DnsRecord+ name Domain+ addr [IP]+ DnsRecordU name+ deriving Show+ deriving Eq+|]++instance DnsBackend ZookeeperConf where+ type Conn ZookeeperConf = Connection+ load file = do+ mconf <- Y.decodeFile file+ case mconf of+ Just val -> do + return $ Y.parseMonad Database.Persist.loadConfig val+ Nothing -> return Nothing+ setup p = do+ withSocketsDo $ do+ conn <- createPoolConfig p+ return $ Just conn+ getRecord p domain conn = do+ mRecord <- runPool p (getBy (DnsRecordU domain)) conn+ case mRecord of+ Just (Entity _key val') -> do+ let val = dnsRecordAddr val'+ return val+ Nothing ->+ return []+ setRecord p domain ips conn = do+ a <- runPool p (insertUnique (DnsRecord domain ips)) conn+ case a of+ Just _ -> return True+ Nothing -> return False+ listRecord p conn = do+ a <- runPool p (selectList [] []) conn+ return $ map (\(Entity _key val) -> (dnsRecordName val,dnsRecordAddr val)) a+ deleteRecord p q conn = do+ runPool p (deleteBy (DnsRecordU q)) conn
+ README.md view
@@ -0,0 +1,84 @@+# PocketDNS: Multi-backend (zookeeper and sqlite) DNS Server using persistent-library++[](https://hackage.haskell.org/package/pocket-dns) [](https://travis-ci.org/junjihashimoto/pocket-dns)++PocketDNS is multi-backend (zookeeper and sqlite) DNS Server using persistent-library.++## Getting started++Install this from Hackage.++ cabal update && cabal install pocket-dns++## Usage++Set conf.yml which is backend settings.+When backend is zookeeper, conf.yml's format is below.++```+backend: zookeeper+coord: localhost:2181/+timeout: 300000+num-stripes: 1+idletime: 300000+max-resource: 30+```++When backend is sqlite, conf.yml's format is below.++```+backend: sqlite+database: pocket-dns.sqlite3+poolsize: 10+```++Then launch dns-server and set domain and ip-address.++```+pocket-dns daemon &+pocket-dns set <domain>. <ip-address>+```++When domain is not found, pocket-dns checks '/etc/resolv.conf'.++## Commands++### Set++Set ip-address of domain++```+pocket-dns set <domain-name>. <ip-address>+```++### get++Show ip-address of domain++```+pocket-dns get <domain-name>.+```++### list++Show all domain and ip-address++```+pocket-dns list+```++### delete++Delete domain++```+pocket-dns delete <domain-name>.+```++### daemon++Launch dns-server++```+pocket-dns daemon+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pocket-dns.cabal view
@@ -0,0 +1,101 @@+-- Initial pocket-dns.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: pocket-dns+version: 0.1.0+synopsis: Multi-backend (zookeeper and sqlite) DNS Server using persistent-library+description: Multi-backend (zookeeper and sqlite) DNS Server using persistent-library+license: BSD3+license-file: LICENSE+author: Junji Hashimoto+maintainer: junji.hashimoto@gmail.com+-- copyright: +stability: Experimental+category: Network+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++bug-reports: https://github.com/junjihashimoto/pocket-dns/issues++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/junjihashimoto/pocket-dns.git++library+ exposed-modules: Network.DNS.Pocket+ , Network.DNS.Pocket.Type+ , Network.DNS.Pocket.Server+ , Network.DNS.Pocket.Sqlite+ , Network.DNS.Pocket.Zookeeper+ -- other-modules: + -- other-extensions: + build-depends: base >=4 && <5+ ,dns+ ,network+ ,persistent-zookeeper+ ,persistent-sqlite+ ,persistent-template+ ,persistent+ ,optparse-applicative+ ,bytestring+ ,yaml+ ,iproute+ ,data-default+ ,text+ ,monad-control+ ,transformers+ ,aeson+ ,unordered-containers+ -- hs-source-dirs: + ghc-options: -Wall -O2+ default-language: Haskell2010++executable pocket-dns+ main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4 && <5+ ,dns+ ,network+ ,persistent-zookeeper+ ,persistent-sqlite+ ,persistent-template+ ,persistent+ ,optparse-applicative+ ,text+ ,shelly+ ,http-conduit+ ,bytestring+ ,data-default+ ,iproute+ ,yaml+ ,monad-control+ ,unordered-containers+ ,aeson+ -- hs-source-dirs: + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs: tests,dist/build/autogen+ ghc-options: -Wall++ build-depends: base+ , pocket-dns+ , transformers+ , hspec+ , hspec-contrib+ , hspec-server+ , test-sandbox+ , hspec-test-sandbox+ , cabal-test-bin+ , shakespeare+ , text+ Default-Language: Haskell2010
+ tests/test.hs view
@@ -0,0 +1,84 @@+{-#LANGUAGE OverloadedStrings#-}+{-#LANGUAGE TemplateHaskell#-}+{-#LANGUAGE QuasiQuotes#-}++import Data.Monoid+import Test.Sandbox+import Test.Hspec+import qualified Test.Hspec.Sandbox as S+--import Test.Hspec.Contrib.Retry+import Test.Hspec.Server+import Test.Cabal.Path+import qualified Data.Text as T+--import Control.Monad.IO.Class+--import Control.Monad.Trans.Reader+import Text.Shakespeare.Text+import Data.IORef++main :: IO ()+main = withSandbox $ \ref -> do+ bin <- getExePath "." "pocket-dns"+ conf <- newIORef $ error "do not eval this"+ p <- newIORef $ error "do not eval this"+ hspec $ do+ describe "setup(zookeeper)" $ S.with ref $ do+ it "start daemon" $ do+ port' <- getPort "dns"+ liftIO $ writeIORef p port'+ dat <- setFile "conf" $ T.unpack[sbt|backend: zookeeper+ |coord: localhost:2181/+ |timeout: 300000+ |num-stripes: 1+ |idletime: 300000+ |max-resource: 30+ |]+ liftIO $ writeIORef conf dat + register "daemon" bin ["daemon","--conf",dat,"--port",show port'] def >>= start+ describe "command-test(zookeeper)" $ with localhost $ do+ it "set" $ do+ dat <- liftIO $ readIORef conf+ command bin ["set","--conf",dat,"hogehoge.","192.168.10.10"] [] @>= exit 0+ it "get" $ do+ dat <- liftIO $ readIORef conf+ command bin ["get","--conf",dat,"hogehoge."] [] @>= exit 0 <> (stdout $ T.unpack [sbt|[192.168.10.10]+ |])+ it "dig" $ do+ port' <- liftIO $ readIORef p+ command "dig" ["@localhost","-p",show port',"hogehoge"] [] @>= exit 0+ it "list" $ do+ dat <- liftIO $ readIORef conf+ command bin ["list","--conf",dat] [] @>= exit 0 <> (stdout $ T.unpack [sbt|hogehoge.+ | 192.168.10.10+ |])+ it "delete" $ do+ dat <- liftIO $ readIORef conf+ command bin ["delete","--conf",dat,"hogehoge."] [] @>= exit 0 <> stdout ""+ describe "setup(sqlite)" $ S.with ref $ do+ it "start daemon(sqlite)" $ do+ port' <- getPort "sdns"+ liftIO $ writeIORef p port'+ dat <- setFile "sconf" $ T.unpack[sbt|backend: sqlite+ |database: pocket-dns.sqlite3+ |poolsize: 10+ |]+ liftIO $ writeIORef conf dat + register "sdaemon" bin ["daemon","--conf",dat,"--port",show port'] def >>= start+ describe "command-test(sqlite)" $ with localhost $ do+ it "set" $ do+ dat <- liftIO $ readIORef conf+ command bin ["set","--conf",dat,"hogehoge.","192.168.10.10"] [] @>= exit 0+ it "get" $ do+ dat <- liftIO $ readIORef conf+ command bin ["get","--conf",dat,"hogehoge."] [] @>= exit 0 <> (stdout $ T.unpack [sbt|[192.168.10.10]+ |])+ it "dig" $ do+ port' <- liftIO $ readIORef p+ command "dig" ["@localhost","-p",show port',"hogehoge"] [] @>= exit 0+ it "list" $ do+ dat <- liftIO $ readIORef conf+ command bin ["list","--conf",dat] [] @>= exit 0 <> (stdout $ T.unpack [sbt|hogehoge.+ | 192.168.10.10+ |])+ it "delete" $ do+ dat <- liftIO $ readIORef conf+ command bin ["delete","--conf",dat,"hogehoge."] [] @>= exit 0 <> stdout ""