Initial commit: serialisation and deserialisation of Message header

diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
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 (file)
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 (file)
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 (file)
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 (file)
index 0000000..93ab364
--- /dev/null
+++ b/dns.cabal
@@ -0,0 +1,21 @@
+Name:                dns
+Version:             0.1
+Synopsis:            <Project description>
+Description:         <Project description>
+Category:            Network
+License:             PublicDomain
+Author:              PHO <pho at cielonegro.org>
+Maintainer:          PHO <pho at cielonegro.org>
+Stability:           Experimental
+Cabal-Version:       >= 1.2
+Build-Type:          Simple
+
+Library
+    Build-Depends:
+        base, binary
+
+    Exposed-Modules:
+        Network.DNS.Message
+
+    GHC-Options:
+        -Wall