From 2778374186c39d8f30347a1f943708efd22f7d29 Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 19 May 2009 12:18:26 +0900 Subject: [PATCH] Initial commit: serialisation and deserialisation of Message header --- .gitignore | 5 ++ Makefile | 30 +++++++++ Network/DNS/Message.hs | 141 +++++++++++++++++++++++++++++++++++++++++ Setup.lhs | 3 + dns.cabal | 21 ++++++ 5 files changed, 200 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 Network/DNS/Message.hs create mode 100644 Setup.lhs create mode 100644 dns.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..30e9e85 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +dist +Setup + +*.o +*.hi diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..00055ac --- /dev/null +++ b/Makefile @@ -0,0 +1,30 @@ +CABAL_FILE = dns.cabal +GHC = ghc + +build: dist/setup-config Setup + ./Setup build + +#run: build +# @echo ".:.:. Let's go .:.:." +# $(MAKE) -C examples run + +dist/setup-config: $(CABAL_FILE) Setup + ./Setup configure + +Setup: Setup.lhs + $(GHC) --make Setup + +clean: + rm -rf dist Setup Setup.o Setup.hi .setup-config *.buildinfo + find . -name '*~' -exec rm -f {} \; + +doc: dist/setup-config Setup + ./Setup haddock + +install: build + sudo ./Setup install + +sdist: Setup + ./Setup sdist + +.PHONY: build run clean install doc sdist diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs new file mode 100644 index 0000000..a3c0482 --- /dev/null +++ b/Network/DNS/Message.hs @@ -0,0 +1,141 @@ +module Network.DNS.Message + ( Header(..) + , Opcode(..) + , ResponseCode(..) + ) + where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import Data.Word + + +data Header + = QueryHeader { + hdMessageID :: !Word16 + , hdOpcode :: !Opcode + , hdIsTruncated :: !Bool + , hdIsRecursionDesired :: !Bool + } + | ResponseHeader { + hdMessageID :: !Word16 + , hdOpcode :: !Opcode + , hdIsAuthoritativeAnswer :: !Bool + , hdIsTruncated :: !Bool + , hdIsRecursionDesired :: !Bool + , hdIsRecursionAvailable :: !Bool + , hdResponseCode :: !ResponseCode + } + +data Opcode + = StandardQuery + | InverseQuery + | ServerStatusRequest + +data ResponseCode + = NoError + | FormatError + | ServerFailure + | NameError + | NotImplemented + | Refused + deriving (Show, Eq) + +hdIsResponse :: Header -> Bool +hdIsResponse (QueryHeader _ _ _ _ ) = False +hdIsResponse (ResponseHeader _ _ _ _ _ _ _) = True + +instance Binary Header where + put h = do putWord16be $ hdMessageID h + let qr = boolToNum $ hdIsResponse h + op = fromIntegral $ fromEnum $ hdOpcode h + aa = if hdIsResponse h then + boolToNum $ hdIsAuthoritativeAnswer h + else + 0 + tc = boolToNum $ hdIsTruncated h + rd = boolToNum $ hdIsRecursionDesired h + ra = if hdIsResponse h then + boolToNum $ hdIsRecursionAvailable h + else + 0 + rc = if hdIsResponse h then + fromIntegral $ fromEnum $ hdResponseCode h + else + 0 + flags = ((qr `shiftL` 15) .&. 0x01) .|. + ((op `shiftL` 11) .&. 0x0F) .|. + ((aa `shiftL` 10) .&. 0x01) .|. + ((tc `shiftL` 9) .&. 0x01) .|. + ((rd `shiftL` 8) .&. 0x01) .|. + ((ra `shiftL` 7) .&. 0x01) .|. + ((rc `shiftL` 0) .&. 0x0F) + putWord16be flags + where + boolToNum :: Num a => Bool -> a + boolToNum True = 1 + boolToNum False = 0 + + get = do mID <- getWord16be + flags <- getWord16be + let qr = testBit flags 15 + op = toEnum $ fromIntegral ((flags `shiftR` 11) .&. 0x0F) + aa = testBit flags 10 + tc = testBit flags 9 + rd = testBit flags 8 + ra = testBit flags 7 + rc = toEnum $ fromIntegral (flags .&. 0x0F) + hd = if qr then + ResponseHeader { + hdMessageID = mID + , hdOpcode = op + , hdIsAuthoritativeAnswer = aa + , hdIsTruncated = tc + , hdIsRecursionDesired = rd + , hdIsRecursionAvailable = ra + , hdResponseCode = rc + } + else + QueryHeader { + hdMessageID = mID + , hdOpcode = op + , hdIsTruncated = tc + , hdIsRecursionDesired = rd + } + return hd + +instance Enum Opcode where + fromEnum StandardQuery = 0 + fromEnum InverseQuery = 1 + fromEnum ServerStatusRequest = 2 + + toEnum 0 = StandardQuery + toEnum 1 = InverseQuery + toEnum 2 = ServerStatusRequest + toEnum _ = undefined + +instance Bounded Opcode where + minBound = StandardQuery + maxBound = ServerStatusRequest + +instance Enum ResponseCode where + fromEnum NoError = 0 + fromEnum FormatError = 1 + fromEnum ServerFailure = 2 + fromEnum NameError = 3 + fromEnum NotImplemented = 4 + fromEnum Refused = 5 + + toEnum 0 = NoError + toEnum 1 = FormatError + toEnum 2 = ServerFailure + toEnum 3 = NameError + toEnum 4 = NotImplemented + toEnum 5 = Refused + toEnum _ = undefined + +instance Bounded ResponseCode where + minBound = NoError + maxBound = Refused diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/dns.cabal b/dns.cabal new file mode 100644 index 0000000..93ab364 --- /dev/null +++ b/dns.cabal @@ -0,0 +1,21 @@ +Name: dns +Version: 0.1 +Synopsis: +Description: +Category: Network +License: PublicDomain +Author: PHO +Maintainer: PHO +Stability: Experimental +Cabal-Version: >= 1.2 +Build-Type: Simple + +Library + Build-Depends: + base, binary + + Exposed-Modules: + Network.DNS.Message + + GHC-Options: + -Wall -- 2.40.0