From f46e263327d20c700179b2d3a5896be82d3b4aca Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 30 May 2009 16:04:15 +0900 Subject: [PATCH] DB thingy --- .gitignore | 1 + DDNS/DB.hs | 39 ++++++ DDNS/DB/Records.hs | 76 +++++++++++ DDNS/DB/Zones.hs | 128 ++++++++++++++++++ DDNS/DBInfo.hs | 92 +++++++++++++ GNUmakefile | 12 +- Main.hs | 15 +- blackboard-ddns.cabal => blackboard-dns.cabal | 15 +- data/GNUmakefile | 17 +++ data/GenDBModules.hs | 5 + 10 files changed, 395 insertions(+), 5 deletions(-) create mode 100644 DDNS/DB.hs create mode 100644 DDNS/DB/Records.hs create mode 100644 DDNS/DB/Zones.hs create mode 100644 DDNS/DBInfo.hs rename blackboard-ddns.cabal => blackboard-dns.cabal (59%) create mode 100644 data/GNUmakefile create mode 100644 data/GenDBModules.hs diff --git a/.gitignore b/.gitignore index 30e9e85..181a84d 100644 --- 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 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 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 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 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 f258db0..b0ac41c 100644 --- 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 d82a4bd..163d01e 100644 --- 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 d30a78a..abcfe9c 100644 --- a/blackboard-ddns.cabal +++ b/blackboard-dns.cabal @@ -1,4 +1,4 @@ -Name: blackboard-ddns +Name: blackboard-dns Version: 0.1 Synopsis: Description: @@ -9,10 +9,19 @@ Maintainer: PHO 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 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 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 -- 2.40.0