Skip to content

Commit 6f6d235

Browse files
fffejfffej
committed
Merge pull request #34 from fffej/broker-priority
Broker priority
2 parents 2940b13 + f7abf57 commit 6f6d235

8 files changed

Lines changed: 142 additions & 7 deletions

File tree

‎README.md‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33
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).
44

5-
Currently supported (at various degrees of completion are:
5+
Currently supported (at various degrees of completion) are:
66
* Tables
77
* Sequences
88
* Procedures
@@ -17,6 +17,8 @@ Currently supported (at various degrees of completion are:
1717
* Credentials
1818
* Message types
1919
* Contracts
20+
* Services
21+
* Broker Priorties
2022

2123
Contributers more than welcome (especially if you know enough Haskell to help me simplify the code!).
2224

‎cli/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@ module Main where
33

44
import System.Console.CmdArgs
55

6-
import Database.SqlServer.Definitions.Database
6+
import Database.SqlServer.Definition.Database
77

88
data Arguments = Arguments
99
{

‎sql-server-gen.cabal‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -66,10 +66,14 @@ library
6666
Database.SqlServer.Definition.Login,
6767
Database.SqlServer.Definition.MessageType,
6868
Database.SqlServer.Definition.Function,
69-
Database.SqlServer.Definition.Credential
69+
Database.SqlServer.Definition.Credential,
70+
Database.SqlServer.Definition.Contract,
71+
Database.SqlServer.Definition.BrokerPriority,
72+
Database.SqlServer.Definition.Service,
73+
Database.SqlServer.Definition.Entity
7074

7175

72-
ghc-options: -Wall
76+
ghc-options: -Wall -O2 -fwarn-tabs -Werror
7377

7478
-- Modules included in this library but not exported.
7579
-- other-modules:
@@ -105,7 +109,7 @@ Test-Suite tests
105109
containers >= 0.5.6.2
106110

107111
executable cli
108-
ghc-options: -Wall
112+
ghc-options: -Wall -O2 -fwarn-tabs -Werror
109113
main-is: Main.hs
110114
hs-source-dirs: cli
111115
default-language: Haskell2010

‎src/Database/SqlServer/Definition/BrokerPriority.hs‎

Lines changed: 69 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,69 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
{-# LANGUAGE GADTs #-}
4+
5+
module Database.SqlServer.Definition.BrokerPriority
6+
(
7+
BrokerPriority
8+
) where
9+
10+
import Database.SqlServer.Definition.Service (Service)
11+
import Database.SqlServer.Definition.Contract (Contract)
12+
import Database.SqlServer.Definition.Identifier hiding (unwrap)
13+
import Database.SqlServer.Definition.Entity
14+
15+
import Test.QuickCheck
16+
import Text.PrettyPrint
17+
import Data.DeriveTH
18+
19+
data PriorityLevel = PriorityLevel Int
20+
21+
instance Arbitrary PriorityLevel where
22+
arbitrary = do
23+
x <- choose (1,10)
24+
return (PriorityLevel x)
25+
26+
data BrokerPriority = BrokerPriority
27+
{
28+
priorityName :: RegularIdentifier
29+
, contractName :: Maybe Contract
30+
, localServiceName :: Maybe Service
31+
, remoteServiceName :: Maybe RegularIdentifier
32+
, priorityLevel :: Maybe PriorityLevel
33+
}
34+
35+
derive makeArbitrary ''BrokerPriority
36+
37+
renderMaybeOrAny :: Maybe RegularIdentifier -> Doc
38+
renderMaybeOrAny = maybe (text "ANY") (quotes . renderRegularIdentifier)
39+
40+
renderName' :: Entity a => Maybe a -> Doc
41+
renderName' = maybe (text "ANY") renderName
42+
43+
renderPriorityLevel :: Maybe PriorityLevel -> Doc
44+
renderPriorityLevel = maybe (text "DEFAULT") (\(PriorityLevel z) -> int z)
45+
46+
renderOptions :: BrokerPriority -> Doc
47+
renderOptions b = vcat $ punctuate comma
48+
[
49+
text "CONTRACT_NAME =" <+> renderName' (contractName b)
50+
, text "LOCAL_SERVICE_NAME =" <+> renderName' (localServiceName b)
51+
, text "REMOTE_SERVICE_NAME =" <+> renderMaybeOrAny (remoteServiceName b)
52+
, text "PRIORITY_LEVEL =" <+> renderPriorityLevel (priorityLevel b)
53+
]
54+
55+
renderPrerequisites :: Entity a => Maybe a -> Doc
56+
renderPrerequisites = maybe empty toDoc
57+
58+
instance Entity BrokerPriority where
59+
name = priorityName
60+
toDoc b = renderPrerequisites (contractName b) $+$
61+
renderPrerequisites (localServiceName b) $+$
62+
text "GO" $+$
63+
text "CREATE BROKER PRIORITY" <+> renderName b $+$
64+
text "FOR CONVERSATION" $+$
65+
text "SET" <+> parens (renderOptions b) <> text ";" $+$
66+
text "GO\n"
67+
68+
instance Show BrokerPriority where
69+
show = show . toDoc

‎src/Database/SqlServer/Definition/Contract.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,8 @@ instance Entity Contract where
7272
toDoc m = renderPrerequisites m $+$
7373
text "CREATE CONTRACT" <+> renderName m $+$
7474
maybe empty renderAuthorization (authorization m) $+$
75-
parens (vcat $ punctuate comma (map renderMessageType (messageTypes m)))
75+
parens (vcat $ punctuate comma (map renderMessageType (messageTypes m))) $+$
76+
text "GO\n"
7677

7778
instance Show Contract where
7879
show = show . toDoc

‎src/Database/SqlServer/Definition/Database.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,8 @@ import Database.SqlServer.Definition.Function (Function)
1616
import Database.SqlServer.Definition.Credential (Credential)
1717
import Database.SqlServer.Definition.MessageType (MessageType)
1818
import Database.SqlServer.Definition.Contract (Contract)
19+
import Database.SqlServer.Definition.BrokerPriority (BrokerPriority)
20+
import Database.SqlServer.Definition.Service (Service)
1921
import Database.SqlServer.Definition.Entity
2022

2123
import Test.QuickCheck
@@ -50,6 +52,8 @@ data DatabaseDefinition = DatabaseDefinition
5052
, credentials :: [Credential]
5153
, messages :: [MessageType]
5254
, contracts :: [Contract]
55+
, brokerPriorities :: [BrokerPriority]
56+
, services :: [Service]
5357
, masterKey :: MasterKey
5458
}
5559

@@ -77,6 +81,8 @@ renderDatabaseDefinition dd = text "USE master" $+$
7781
renderNamedEntities (credentials dd) $+$
7882
renderNamedEntities (messages dd) $+$
7983
renderNamedEntities (contracts dd) $+$
84+
renderNamedEntities (brokerPriorities dd) $+$
85+
renderNamedEntities (services dd) $+$
8086
text "GO"
8187
where
8288
dbName = renderRegularIdentifier (databaseName dd)

‎src/Database/SqlServer/Definition/MessageType.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -49,5 +49,6 @@ instance Entity MessageType where
4949
toDoc m = maybe empty renderPreRequisites (authorization m) $+$
5050
text "CREATE MESSAGE TYPE" <+> renderName m $+$
5151
maybe empty renderAuthorization (authorization m) $+$
52-
maybe empty renderValidation (validation m)
52+
maybe empty renderValidation (validation m) $+$
53+
text "GO\n"
5354

‎src/Database/SqlServer/Definition/Service.hs‎

Lines changed: 52 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,52 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
{-# LANGUAGE GADTs #-}
4+
5+
module Database.SqlServer.Definition.Service
6+
(
7+
Service
8+
) where
9+
10+
import Database.SqlServer.Definition.Queue (Queue)
11+
import Database.SqlServer.Definition.Contract (Contract)
12+
import Database.SqlServer.Definition.Identifier hiding (unwrap)
13+
import Database.SqlServer.Definition.Entity
14+
15+
import Test.QuickCheck
16+
import Text.PrettyPrint
17+
import Data.DeriveTH
18+
19+
-- An entity of type service cannot be owned by
20+
-- a role, a group, or by principals mapped to
21+
-- certificates or asymmetric keys.
22+
data Service = Service
23+
{
24+
serviceName :: RegularIdentifier
25+
, queue :: Queue
26+
, contracts :: [Contract]
27+
}
28+
29+
-- TODO Owner
30+
31+
derive makeArbitrary ''Service
32+
33+
renderContracts :: [Contract] -> Doc
34+
renderContracts [] = empty
35+
renderContracts xs = parens (vcat $ punctuate comma (map renderName xs)) $+$
36+
text "GO\n"
37+
38+
renderPreRequisites :: Service -> Doc
39+
renderPreRequisites s = toDoc (queue s) $+$
40+
vcat (punctuate (text "GO") (map toDoc (contracts s))) $+$
41+
text "GO\n"
42+
43+
instance Entity Service where
44+
name = serviceName
45+
toDoc s = renderPreRequisites s $+$
46+
text "CREATE SERVICE" <+> renderName s $+$
47+
text "ON QUEUE" <+> renderName (queue s) $+$
48+
renderContracts (contracts s) $+$
49+
text "GO\n"
50+
51+
instance Show Service where
52+
show = show . toDoc

0 commit comments

Comments
 (0)