DB thingy

diff --git a/.gitignore b/.gitignore
index 30e9e8597b061d03b7484e1c0826c0f8e02d3c46..181a84d3193c0e39d943df773e798e2cbdf8f919 100644 (file)
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,6 @@
 dist
 Setup
+data/GenDBModules
 
 *.o
 *.hi

diff --git a/DDNS/DB.hs b/DDNS/DB.hs
new file mode 100644 (file)
index 0000000..8f20df9
--- /dev/null
+++ b/DDNS/DB.hs
@@ -0,0 +1,39 @@
+---------------------------------------------------------------------------
+-- Generated by DB/Direct
+---------------------------------------------------------------------------
+module DDNS.DB where
+
+import Database.HaskellDB.DBLayout
+
+import qualified DDNS.DB.Zones
+import qualified DDNS.DB.Records
+
+blackboardDNS :: DBInfo
+blackboardDNS = DBInfo {dbname = "BlackboardDNS",
+                        opts = DBOptions {useBString = False},
+                        tbls = [TInfo {tname = "zones",
+                                       cols = [CInfo {cname = "zone",
+                                                      descr = (StringT, False)},
+                                               CInfo {cname = "ns",
+                                                      descr = (StringT, False)},
+                                               CInfo {cname = "owner",
+                                                      descr = (StringT, False)},
+                                               CInfo {cname = "serial",
+                                                      descr = (IntT, False)},
+                                               CInfo {cname = "refresh",
+                                                      descr = (IntT, False)},
+                                               CInfo {cname = "retry",
+                                                      descr = (IntT, False)},
+                                               CInfo {cname = "expire",
+                                                      descr = (IntT, False)},
+                                               CInfo {cname = "minTTL",
+                                                      descr = (IntT, False)}]},
+                                TInfo {tname = "records",
+                                       cols = [CInfo {cname = "name",
+                                                      descr = (StringT, False)},
+                                               CInfo {cname = "zone",
+                                                      descr = (StringT, False)},
+                                               CInfo {cname = "recType",
+                                                      descr = (StringT, False)},
+                                               CInfo {cname = "recData",
+                                                      descr = (StringT, False)}]}]}
\ No newline at end of file

diff --git a/DDNS/DB/Records.hs b/DDNS/DB/Records.hs
new file mode 100644 (file)
index 0000000..9b2872a
--- /dev/null
+++ b/DDNS/DB/Records.hs
@@ -0,0 +1,76 @@
+{-# OPTIONS_GHC -fcontext-stack44 #-}
+-- NOTE: use GHC flag -fcontext-stack44 with this module if GHC < 6.8.1
+---------------------------------------------------------------------------
+-- Generated by DB/Direct
+---------------------------------------------------------------------------
+module DDNS.DB.Records where
+
+import Database.HaskellDB.DBLayout
+
+---------------------------------------------------------------------------
+-- Table type
+---------------------------------------------------------------------------
+
+type Records =
+    (RecCons Name (Expr String)
+     (RecCons Zone (Expr String)
+      (RecCons RecType (Expr String)
+       (RecCons RecData (Expr String) RecNil))))
+
+---------------------------------------------------------------------------
+-- Table
+---------------------------------------------------------------------------
+records :: Table Records
+
+records = baseTable "records" $
+          hdbMakeEntry Name #
+          hdbMakeEntry Zone #
+          hdbMakeEntry RecType #
+          hdbMakeEntry RecData
+
+---------------------------------------------------------------------------
+-- Fields
+---------------------------------------------------------------------------
+---------------------------------------------------------------------------
+-- Name Field
+---------------------------------------------------------------------------
+
+data Name = Name
+
+instance FieldTag Name where fieldName _ = "name"
+
+name :: Attr Name String
+name = mkAttr Name
+
+---------------------------------------------------------------------------
+-- Zone Field
+---------------------------------------------------------------------------
+
+data Zone = Zone
+
+instance FieldTag Zone where fieldName _ = "zone"
+
+zone :: Attr Zone String
+zone = mkAttr Zone
+
+---------------------------------------------------------------------------
+-- RecType Field
+---------------------------------------------------------------------------
+
+data RecType = RecType
+
+instance FieldTag RecType where fieldName _ = "recType"
+
+recType :: Attr RecType String
+recType = mkAttr RecType
+
+---------------------------------------------------------------------------
+-- RecData Field
+---------------------------------------------------------------------------
+
+data RecData = RecData
+
+instance FieldTag RecData where fieldName _ = "recData"
+
+recData :: Attr RecData String
+recData = mkAttr RecData

diff --git a/DDNS/DB/Zones.hs b/DDNS/DB/Zones.hs
new file mode 100644 (file)
index 0000000..69653e4
--- /dev/null
+++ b/DDNS/DB/Zones.hs
@@ -0,0 +1,128 @@
+{-# OPTIONS_GHC -fcontext-stack48 #-}
+-- NOTE: use GHC flag -fcontext-stack48 with this module if GHC < 6.8.1
+---------------------------------------------------------------------------
+-- Generated by DB/Direct
+---------------------------------------------------------------------------
+module DDNS.DB.Zones where
+
+import Database.HaskellDB.DBLayout
+
+---------------------------------------------------------------------------
+-- Table type
+---------------------------------------------------------------------------
+
+type Zones =
+    (RecCons Zone (Expr String)
+     (RecCons Ns (Expr String)
+      (RecCons Owner (Expr String)
+       (RecCons Serial (Expr Int)
+        (RecCons Refresh (Expr Int)
+         (RecCons Retry (Expr Int)
+          (RecCons Expire (Expr Int)
+           (RecCons MinTTL (Expr Int) RecNil))))))))
+
+---------------------------------------------------------------------------
+-- Table
+---------------------------------------------------------------------------
+zones :: Table Zones
+
+zones = baseTable "zones" $
+        hdbMakeEntry Zone #
+        hdbMakeEntry Ns #
+        hdbMakeEntry Owner #
+        hdbMakeEntry Serial #
+        hdbMakeEntry Refresh #
+        hdbMakeEntry Retry #
+        hdbMakeEntry Expire #
+        hdbMakeEntry MinTTL
+
+---------------------------------------------------------------------------
+-- Fields
+---------------------------------------------------------------------------
+---------------------------------------------------------------------------
+-- Zone Field
+---------------------------------------------------------------------------
+
+data Zone = Zone
+
+instance FieldTag Zone where fieldName _ = "zone"
+
+zone :: Attr Zone String
+zone = mkAttr Zone
+
+---------------------------------------------------------------------------
+-- Ns Field
+---------------------------------------------------------------------------
+
+data Ns = Ns
+
+instance FieldTag Ns where fieldName _ = "ns"
+
+ns :: Attr Ns String
+ns = mkAttr Ns
+
+---------------------------------------------------------------------------
+-- Owner Field
+---------------------------------------------------------------------------
+
+data Owner = Owner
+
+instance FieldTag Owner where fieldName _ = "owner"
+
+owner :: Attr Owner String
+owner = mkAttr Owner
+
+---------------------------------------------------------------------------
+-- Serial Field
+---------------------------------------------------------------------------
+
+data Serial = Serial
+
+instance FieldTag Serial where fieldName _ = "serial"
+
+serial :: Attr Serial Int
+serial = mkAttr Serial
+
+---------------------------------------------------------------------------
+-- Refresh Field
+---------------------------------------------------------------------------
+
+data Refresh = Refresh
+
+instance FieldTag Refresh where fieldName _ = "refresh"
+
+refresh :: Attr Refresh Int
+refresh = mkAttr Refresh
+
+---------------------------------------------------------------------------
+-- Retry Field
+---------------------------------------------------------------------------
+
+data Retry = Retry
+
+instance FieldTag Retry where fieldName _ = "retry"
+
+retry :: Attr Retry Int
+retry = mkAttr Retry
+
+---------------------------------------------------------------------------
+-- Expire Field
+---------------------------------------------------------------------------
+
+data Expire = Expire
+
+instance FieldTag Expire where fieldName _ = "expire"
+
+expire :: Attr Expire Int
+expire = mkAttr Expire
+
+---------------------------------------------------------------------------
+-- MinTTL Field
+---------------------------------------------------------------------------
+
+data MinTTL = MinTTL
+
+instance FieldTag MinTTL where fieldName _ = "minTTL"
+
+minTTL :: Attr MinTTL Int
+minTTL = mkAttr MinTTL

diff --git a/DDNS/DBInfo.hs b/DDNS/DBInfo.hs
new file mode 100644 (file)
index 0000000..21cfe03
--- /dev/null
+++ b/DDNS/DBInfo.hs
@@ -0,0 +1,92 @@
+module DDNS.DBInfo
+    ( dbinfo
+    , indexDeclarations
+    )
+    where
+
+import           Database.HaskellDB.DBSpec
+import qualified Database.HaskellDB.DBSpec.PPHelpers as PP
+
+
+dbinfo :: DBInfo
+dbinfo = DBInfo {
+           dbname = "BlackboardDNS"
+         , opts   = DBOptions {
+                      useBString = False
+                    , makeIdent  = PP.mkIdentPreserving
+                    }
+         , tbls   = [ zones
+                    , records
+                    ]
+         }
+
+zones :: TInfo
+zones = TInfo {
+          tname = "zones"
+        , cols  = [ CInfo "zone"    (StringT, False)
+                  , CInfo "ns"      (StringT, False)
+                  , CInfo "owner"   (StringT, False)
+                  , CInfo "serial"  (IntT   , False)
+                  , CInfo "refresh" (IntT   , False)
+                  , CInfo "retry"   (IntT   , False)
+                  , CInfo "expire"  (IntT   , False)
+                  , CInfo "minTTL"  (IntT   , False)
+                  ]
+        }
+
+records :: TInfo
+records = TInfo {
+            tname = "records"
+          , cols  = [ CInfo "name"    (StringT, False)
+                    , CInfo "zone"    (StringT, False)
+                    , CInfo "recType" (StringT, False)
+                    , CInfo "recData" (StringT, False)
+                    ]
+          }
+
+-- This kind of dirty hack should go away someday.
+indexDeclarations :: [String]
+indexDeclarations
+    = [ "CREATE UNIQUE INDEX pkey_on_zones ON zones ( zone )"
+      , "CREATE INDEX pkey_on_records ON records ( name, zone )"
+      , "CREATE TRIGGER insert_into_records\n" ++
+        "  BEFORE INSERT ON records\n" ++
+        "  FOR EACH ROW\n" ++
+        "  WHEN\n" ++
+        "    NOT EXISTS (\n" ++
+        "      SELECT 1\n" ++
+        "        FROM zones\n" ++
+        "       WHERE zone = NEW.zone\n" ++
+        "    )\n" ++
+        "  BEGIN\n" ++
+        "    SELECT RAISE(ABORT, \"FK constraint failure\");\n" ++
+        "  END"
+      , "CREATE TRIGGER change_record_zone\n" ++
+        "  BEFORE UPDATE OF zone ON records\n" ++
+        "  FOR EACH ROW\n" ++
+        "  WHEN\n" ++
+        "    NOT EXISTS (\n" ++
+        "      SELECT 1\n" ++
+        "        FROM zones\n" ++
+        "       WHERE zone = NEW.zone\n" ++
+        "    )\n" ++
+        "  BEGIN\n" ++
+        "    SELECT RAISE(ABORT, \"FK constraint failure\");\n" ++
+        "  END"
+      , "CREATE TRIGGER update_zone_name\n" ++
+        "  AFTER UPDATE OF zone ON zones\n" ++
+        "  FOR EACH ROW\n" ++
+        "  BEGIN\n" ++
+        "    UPDATE records\n" ++
+        "       SET zone = NEW.zone\n" ++
+        "     WHERE zone = OLD.zone;\n" ++
+        "  END"
+      , "CREATE TRIGGER delete_zone\n" ++
+        "  AFTER DELETE ON zones\n" ++
+        "  FOR EACH ROW\n" ++
+        "  BEGIN\n" ++
+        "    DELETE\n" ++
+        "      FROM records\n" ++
+        "     WHERE zone = OLD.zone;\n" ++
+        "  END"
+      ]

diff --git a/GNUmakefile b/GNUmakefile
index f258db06771727c0db6e1368a2954e6168668cd2..b0ac41c73aef81e0dd9837af9d943155e3a35412 100644 (file)
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -1,3 +1,13 @@
-RUN_COMMAND = ./dist/build/blackboard-ddns/blackboard-ddns
+RUN_COMMAND = ./dist/build/blackboard-dns/blackboard-dns
+
+build: generated-sources
+
+clean: clean-sources
+
+generated-sources:
+       $(MAKE) -C data all
+
+clean-sources:
+       $(MAKE) -C data clean
 
 include cabal-package.mk

diff --git a/Main.hs b/Main.hs
index d82a4bd93b7e75a6ff9845150450ae0709b93086..163d01e41dedaff3fe660440c98401c0b705018e 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -1,4 +1,17 @@
 module Main where
 
+import           DDNS.DBInfo
+import qualified Database.HDBC as RAW
+import qualified Database.HDBC.Sqlite3 as RAW
+import           Database.HaskellDB.DBSpec
+import           Database.HaskellDB.HDBC.SQLite3
+
+
 main :: IO ()
-main = return ()
+main = do sqliteConnect "ddns.db" $ \ db ->
+              dbSpecToDatabase db dbinfo
+
+          rawCon <- RAW.connectSqlite3 "ddns.db"
+          mapM_ (\ sql -> RAW.run rawCon sql []) indexDeclarations
+          RAW.commit rawCon
+          RAW.disconnect rawCon

diff --git a/blackboard-ddns.cabal b/blackboard-dns.cabal
similarity index 59%
rename from blackboard-ddns.cabal
rename to blackboard-dns.cabal
index d30a78aa6c90b65f96b5299e8763bd5e8cb25813..abcfe9cdebf91703416c1d72ecbbcfe0d3b99aa6 100644 (file)
--- a/blackboard-ddns.cabal
+++ b/blackboard-dns.cabal
@@ -1,4 +1,4 @@
-Name:                blackboard-ddns
+Name:                blackboard-dns
 Version:             0.1
 Synopsis:            <Project description>
 Description:         <Project description>
@@ -9,10 +9,19 @@ Maintainer:          PHO <pho at cielonegro.org>
 Stability:           Experimental
 Cabal-Version:       >= 1.2
 Build-Type:          Simple
+Extra-Source-Files:
+    data/GNUmakefile
+    data/GenDBModules.hs
 
-Executable blackboard-ddns
+Executable blackboard-dns
     Build-Depends:
-        base, haskelldb
+        HDBC, HDBC-sqlite3, base, haskelldb, haskelldb-hdbc-sqlite3
+
+    Other-Modules:
+        DDNS.DB
+        DDNS.DB.Records
+        DDNS.DB.Zones
+        DDNS.DBInfo
 
     Main-Is:
         Main.hs

diff --git a/data/GNUmakefile b/data/GNUmakefile
new file mode 100644 (file)
index 0000000..519c56f
--- /dev/null
+++ b/data/GNUmakefile
@@ -0,0 +1,17 @@
+GHC ?= ghc
+
+all: db-modules
+
+db-modules: GenDBModules
+       ./GenDBModules
+
+GenDBModules: GenDBModules.hs ../DDNS/DBInfo.hs
+       $(GHC) --make GenDBModules -i..
+
+clean:
+       rm -f GenDBModules *.hi *.o
+       rm -f ../DDNS/DB.hs
+       rm -rf ../DDNS/DB
+       rm -f ../DDNS/*.hi ../DDNS/*.o
+
+.PHONY: all db-modules clean
\ No newline at end of file

diff --git a/data/GenDBModules.hs b/data/GenDBModules.hs
new file mode 100644 (file)
index 0000000..37a97d7
--- /dev/null
+++ b/data/GenDBModules.hs
@@ -0,0 +1,5 @@
+import           DDNS.DBInfo
+import           Database.HaskellDB.DBSpec.DBSpecToDBDirect
+
+main :: IO ()
+main = dbInfoToModuleFiles ".." "DDNS.DB" dbinfo