Merge pull request #34 from fffej/broker-priority

Broker priority
fffej · Jul 20, 2015 · 6f6d235 · 6f6d235
2 parents 2940b13 + f7abf57
commit 6f6d235
Show file tree

Hide file tree

Showing 8 changed files with 142 additions and 7 deletions.
diff --git a/README.md b/README.md
@@ -2,7 +2,7 @@
 
 The goal of this package is to generate arbitrary SQL Server databases (in the form of create statements).  The SQL generated by this code should always be valid and run without errors (but warnings are acceptable).
 
-Currently supported (at various degrees of completion are:
+Currently supported (at various degrees of completion) are:
 * Tables
 * Sequences
 * Procedures
@@ -17,6 +17,8 @@ Currently supported (at various degrees of completion are:
 * Credentials
 * Message types
 * Contracts
+* Services
+* Broker Priorties
 
 Contributers more than welcome (especially if you know enough Haskell to help me simplify the code!).
 

diff --git a/cli/Main.hs b/cli/Main.hs
@@ -3,7 +3,7 @@ module Main where
 
 import System.Console.CmdArgs
 
-import Database.SqlServer.Definitions.Database
+import Database.SqlServer.Definition.Database
 
 data Arguments = Arguments
     {

diff --git a/sql-server-gen.cabal b/sql-server-gen.cabal
@@ -66,10 +66,14 @@ library
                        Database.SqlServer.Definition.Login,
                        Database.SqlServer.Definition.MessageType,
                        Database.SqlServer.Definition.Function,
-                       Database.SqlServer.Definition.Credential
+                       Database.SqlServer.Definition.Credential,
+                       Database.SqlServer.Definition.Contract,
+                       Database.SqlServer.Definition.BrokerPriority,
+                       Database.SqlServer.Definition.Service,
+                       Database.SqlServer.Definition.Entity
 
 
-  ghc-options:         -Wall
+  ghc-options:         -Wall -O2 -fwarn-tabs -Werror
 
   -- Modules included in this library but not exported.
   -- other-modules:       
@@ -105,7 +109,7 @@ Test-Suite tests
                         containers >= 0.5.6.2
 
 executable cli
-  ghc-options:          -Wall
+  ghc-options:          -Wall -O2 -fwarn-tabs -Werror
   main-is:              Main.hs
   hs-source-dirs:       cli
   default-language:     Haskell2010

diff --git a/src/Database/SqlServer/Definition/BrokerPriority.hs b/src/Database/SqlServer/Definition/BrokerPriority.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}
+
+module Database.SqlServer.Definition.BrokerPriority
+       (
+         BrokerPriority
+       ) where
+
+import Database.SqlServer.Definition.Service (Service)
+import Database.SqlServer.Definition.Contract (Contract)
+import Database.SqlServer.Definition.Identifier hiding (unwrap)
+import Database.SqlServer.Definition.Entity
+
+import Test.QuickCheck
+import Text.PrettyPrint
+import Data.DeriveTH
+
+data PriorityLevel = PriorityLevel Int
+
+instance Arbitrary PriorityLevel where
+  arbitrary = do
+    x <- choose (1,10)
+    return (PriorityLevel x)
+
+data BrokerPriority = BrokerPriority
+  {
+    priorityName :: RegularIdentifier
+  , contractName :: Maybe Contract
+  , localServiceName :: Maybe Service
+  , remoteServiceName :: Maybe RegularIdentifier
+  , priorityLevel :: Maybe PriorityLevel
+  }
+
+derive makeArbitrary ''BrokerPriority
+
+renderMaybeOrAny :: Maybe RegularIdentifier -> Doc
+renderMaybeOrAny = maybe (text "ANY") (quotes . renderRegularIdentifier)
+
+renderName' :: Entity a => Maybe a -> Doc
+renderName' = maybe (text "ANY") renderName
+
+renderPriorityLevel :: Maybe PriorityLevel -> Doc
+renderPriorityLevel = maybe (text "DEFAULT") (\(PriorityLevel z) -> int z)
+
+renderOptions :: BrokerPriority -> Doc
+renderOptions b = vcat $ punctuate comma
+  [
+    text "CONTRACT_NAME =" <+> renderName' (contractName b)
+  , text "LOCAL_SERVICE_NAME =" <+> renderName' (localServiceName b)
+  , text "REMOTE_SERVICE_NAME =" <+> renderMaybeOrAny (remoteServiceName b)
+  , text "PRIORITY_LEVEL =" <+> renderPriorityLevel (priorityLevel b)
+  ]
+
+renderPrerequisites :: Entity a => Maybe a -> Doc
+renderPrerequisites = maybe empty toDoc
+
+instance Entity BrokerPriority where
+  name = priorityName
+  toDoc b = renderPrerequisites (contractName b) $+$
+            renderPrerequisites (localServiceName b) $+$
+            text "GO" $+$
+            text "CREATE BROKER PRIORITY" <+> renderName b $+$
+            text "FOR CONVERSATION" $+$
+            text "SET" <+> parens (renderOptions b) <> text ";" $+$
+            text "GO\n"
+
+instance Show BrokerPriority where
+  show = show . toDoc
diff --git a/src/Database/SqlServer/Definition/Contract.hs b/src/Database/SqlServer/Definition/Contract.hs
@@ -72,7 +72,8 @@ instance Entity Contract where
   toDoc m = renderPrerequisites m $+$
             text "CREATE CONTRACT" <+> renderName m $+$
             maybe empty renderAuthorization (authorization m) $+$
-            parens (vcat $ punctuate comma (map renderMessageType (messageTypes m))) 
+            parens (vcat $ punctuate comma (map renderMessageType (messageTypes m))) $+$
+            text "GO\n"
 
 instance Show Contract where
   show = show . toDoc

diff --git a/src/Database/SqlServer/Definition/Database.hs b/src/Database/SqlServer/Definition/Database.hs
@@ -16,6 +16,8 @@ import Database.SqlServer.Definition.Function (Function)
 import Database.SqlServer.Definition.Credential (Credential)
 import Database.SqlServer.Definition.MessageType (MessageType)
 import Database.SqlServer.Definition.Contract (Contract)
+import Database.SqlServer.Definition.BrokerPriority (BrokerPriority)
+import Database.SqlServer.Definition.Service (Service)
 import Database.SqlServer.Definition.Entity
 
 import Test.QuickCheck
@@ -50,6 +52,8 @@ data DatabaseDefinition = DatabaseDefinition
                           , credentials :: [Credential]
                           , messages :: [MessageType]
                           , contracts :: [Contract]
+                          , brokerPriorities :: [BrokerPriority]
+                          , services :: [Service]
                           , masterKey :: MasterKey
                           }
 
@@ -77,6 +81,8 @@ renderDatabaseDefinition  dd = text "USE master" $+$
                                renderNamedEntities (credentials dd) $+$
                                renderNamedEntities (messages dd) $+$
                                renderNamedEntities (contracts dd) $+$
+                               renderNamedEntities (brokerPriorities dd) $+$
+                               renderNamedEntities (services dd) $+$
                                text "GO"
   where
     dbName = renderRegularIdentifier (databaseName dd)

diff --git a/src/Database/SqlServer/Definition/MessageType.hs b/src/Database/SqlServer/Definition/MessageType.hs
@@ -49,5 +49,6 @@ instance Entity MessageType where
   toDoc m = maybe empty renderPreRequisites (authorization m) $+$
             text "CREATE MESSAGE TYPE" <+> renderName m $+$
             maybe empty renderAuthorization (authorization m) $+$
-            maybe empty renderValidation (validation m) 
+            maybe empty renderValidation (validation m) $+$
+            text "GO\n"
 
diff --git a/src/Database/SqlServer/Definition/Service.hs b/src/Database/SqlServer/Definition/Service.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}
+
+module Database.SqlServer.Definition.Service
+       (
+         Service
+       ) where
+
+import Database.SqlServer.Definition.Queue (Queue)
+import Database.SqlServer.Definition.Contract (Contract)
+import Database.SqlServer.Definition.Identifier hiding (unwrap)
+import Database.SqlServer.Definition.Entity
+
+import Test.QuickCheck
+import Text.PrettyPrint
+import Data.DeriveTH
+
+-- An entity of type service cannot be owned by
+-- a role, a group, or by principals mapped to
+-- certificates or asymmetric keys.
+data Service = Service
+    {
+      serviceName :: RegularIdentifier
+    , queue :: Queue
+    , contracts :: [Contract]
+    }
+
+-- TODO Owner
+
+derive makeArbitrary ''Service
+
+renderContracts :: [Contract] -> Doc
+renderContracts [] = empty
+renderContracts xs = parens (vcat $ punctuate comma (map renderName xs)) $+$
+                     text "GO\n"
+
+renderPreRequisites :: Service -> Doc
+renderPreRequisites s = toDoc (queue s) $+$
+                        vcat (punctuate (text "GO") (map toDoc (contracts s))) $+$
+                        text "GO\n"
+
+instance Entity Service where
+  name = serviceName
+  toDoc s = renderPreRequisites s $+$
+            text "CREATE SERVICE" <+> renderName s $+$
+            text "ON QUEUE" <+> renderName (queue s) $+$
+            renderContracts (contracts s) $+$
+            text "GO\n" 
+
+instance Show Service where
+  show = show . toDoc