Skip to content

Commit d0d153a

Browse files
fffejfffej
committed
Merge pull request #16 from fffej/basic-users
Basic users
2 parents b96a26d + ca8825b commit d0d153a

6 files changed

Lines changed: 191 additions & 12 deletions

File tree

‎sql-server-gen.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -74,7 +74,8 @@ library
7474
derive >= 2.5.22,
7575
containers >= 0.5.6.2,
7676
pretty >= 1.1.2,
77-
uuid >= 1.3.10
77+
uuid >= 1.3.10,
78+
time >= 1.5.0.1
7879

7980
-- Directories containing source files.
8081
hs-source-dirs: src

‎src/Database/SqlServer/Types/Certificate.hs‎

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
4+
module Database.SqlServer.Types.Certificate where
5+
6+
import Database.SqlServer.Types.Identifiers
7+
import Database.SqlServer.Types.Entity
8+
9+
import Text.PrettyPrint
10+
import Data.Time.Calendar
11+
import Test.QuickCheck
12+
import Control.Monad
13+
14+
data CertificateDefinition = CertificateDefinition
15+
{
16+
certificateName :: RegularIdentifier
17+
, activeForBeginDialog :: Maybe (Maybe Bool)
18+
, expiryDate :: Maybe Day -- must be at least tomorrow
19+
, startDate :: Maybe Day -- must be at least 1st Jan 1970
20+
, subject :: RegularIdentifier
21+
, encryptPassword :: RegularIdentifier
22+
}
23+
24+
renderEncryptionByPassword :: RegularIdentifier -> Doc
25+
renderEncryptionByPassword s = text "ENCRYPTION BY PASSWORD = '" <> renderRegularIdentifier s <> text "'"
26+
27+
renderSubject :: RegularIdentifier -> Doc
28+
renderSubject s = text "WITH SUBJECT = '" <> renderRegularIdentifier s <> text "'"
29+
30+
renderExpiryDate :: Day -> Doc
31+
renderExpiryDate d = text "EXPIRY_DATE = '" <> text (filter (/= '-') (show d)) <> text "'"
32+
33+
renderStartDate :: Day -> Doc
34+
renderStartDate d = text "START_DATE = '" <> text (filter (/= '-') (show d)) <> text "'"
35+
36+
instance Arbitrary CertificateDefinition where
37+
arbitrary = do
38+
name <- arbitrary
39+
afbd <- arbitrary
40+
eDay <- liftM3 fromGregorian (elements [2016..3000]) (choose(1,12)) (choose(1,31))
41+
x <- choose(- 1000,- 1)
42+
ex <- elements [Just eDay, Nothing]
43+
str <- elements [Just (addDays x eDay), Nothing]
44+
ep <- arbitrary
45+
sub <- arbitrary
46+
return $ CertificateDefinition {
47+
certificateName = name
48+
, activeForBeginDialog = afbd
49+
, startDate = str
50+
, expiryDate = ex
51+
, encryptPassword = ep
52+
, subject = sub
53+
}
54+
55+
instance Entity CertificateDefinition where
56+
toDoc c = text "CREATE CERTIFICATE" <+> renderRegularIdentifier (certificateName c) $+$
57+
renderEncryptionByPassword (encryptPassword c) $+$
58+
hcat (punctuate comma $ filter (/= empty)
59+
[ renderSubject (subject c)
60+
, maybe empty renderExpiryDate (expiryDate c)
61+
, maybe empty renderStartDate (startDate c)])
62+

‎src/Database/SqlServer/Types/Database.hs‎

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,9 @@ import Database.SqlServer.Types.Table (TableDefinition)
77
import Database.SqlServer.Types.Sequence (SequenceDefinition)
88
import Database.SqlServer.Types.Procedure (ProcedureDefinition)
99
import Database.SqlServer.Types.Queue (QueueDefinition)
10+
import Database.SqlServer.Types.Certificate (CertificateDefinition)
11+
import Database.SqlServer.Types.Login (LoginDefinition)
12+
import Database.SqlServer.Types.User (UserDefinition)
1013
import Database.SqlServer.Types.Entity
1114

1215
import Test.QuickCheck
@@ -16,13 +19,24 @@ import Test.QuickCheck.Random
1619
import Text.PrettyPrint
1720
import Data.DeriveTH
1821

22+
data MasterKey = MasterKey
23+
24+
derive makeArbitrary ''MasterKey
25+
26+
instance Entity MasterKey where
27+
toDoc MasterKey = text "CREATE MASTER KEY ENCRYPTION BY PASSWORD = 'arbitrary_password'" $+$
28+
text "GO"
29+
1930
data DatabaseDefinition = DatabaseDefinition
2031
{
2132
databaseName :: RegularIdentifier
2233
, tableDefinitions :: [TableDefinition]
2334
, sequenceDefinitions :: [SequenceDefinition]
2435
, procedureDefinitions :: [ProcedureDefinition]
2536
, queueDefinitions :: [QueueDefinition]
37+
, certificateDefinitions :: [CertificateDefinition]
38+
, userDefinitions :: [UserDefinition]
39+
, masterKey :: MasterKey
2640
}
2741

2842
renderNamedEntities :: Entity a => [a] -> Doc
@@ -34,10 +48,14 @@ renderDatabaseDefinition dd = text "USE master" $+$
3448
text "CREATE DATABASE" <+> dbName $+$
3549
text "GO" $+$
3650
text "USE" <+> dbName $+$
51+
toDoc (masterKey dd) $+$
3752
renderNamedEntities (tableDefinitions dd) $+$
3853
renderNamedEntities (sequenceDefinitions dd) $+$
3954
renderNamedEntities (procedureDefinitions dd) $+$
40-
renderNamedEntities (queueDefinitions dd)
55+
renderNamedEntities (queueDefinitions dd) $+$
56+
renderNamedEntities (certificateDefinitions dd) $+$
57+
renderNamedEntities (userDefinitions dd) $+$
58+
text "GO"
4159
where
4260
dbName = renderRegularIdentifier (databaseName dd)
4361

‎src/Database/SqlServer/Types/Login.hs‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
4+
module Database.SqlServer.Types.Login where
5+
6+
import Database.SqlServer.Types.Identifiers
7+
import Database.SqlServer.Types.Entity
8+
9+
import Data.DeriveTH
10+
import Test.QuickCheck
11+
import Text.PrettyPrint
12+
13+
data LoginDefinition = LoginDefinition
14+
{
15+
loginName :: RegularIdentifier
16+
, password :: RegularIdentifier
17+
, mustChange :: Bool
18+
}
19+
20+
derive makeArbitrary ''LoginDefinition
21+
22+
renderPassword :: RegularIdentifier -> Doc
23+
renderPassword s = text "WITH PASSWORD = " <>
24+
(quotes (renderRegularIdentifier s))
25+
26+
renderMustChange :: Bool -> Doc
27+
renderMustChange False = empty
28+
renderMustChange True = text "MUST_CHANGE" <> comma <> text "CHECK_EXPIRATION=ON"
29+
30+
instance Entity LoginDefinition where
31+
toDoc a = text "CREATE LOGIN" <+> (renderRegularIdentifier (loginName a)) $+$
32+
renderPassword (password a) <+> renderMustChange (mustChange a)
33+
34+

‎src/Database/SqlServer/Types/Table.hs‎

Lines changed: 20 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -27,24 +27,25 @@ import Text.PrettyPrint
2727
import Data.DeriveTH
2828

2929

30-
-- https://msdn.microsoft.com/en-us/library/ms174979.aspx
31-
data TableDefinition = TableDefinition
32-
{
33-
tableName :: RegularIdentifier
34-
, columnDefinitions :: [ColumnDefinition]
35-
}
3630

3731
data ColumnDefinition = ColumnDefinition
3832
{
3933
columnName :: RegularIdentifier
4034
, dataType :: Type
4135
}
4236

37+
newtype ColumnDefinitions = ColumnDefinitions [ColumnDefinition]
38+
39+
data TableDefinition = TableDefinition
40+
{
41+
tableName :: RegularIdentifier
42+
, columnDefinitions :: ColumnDefinitions
43+
}
44+
4345
columnConstraintsSatisfied :: [ColumnDefinition] -> Bool
4446
columnConstraintsSatisfied xs = length (filter isTimeStamp xs) <= 1 &&
4547
totalColumnSizeBytes <= 8060 &&
4648
length (filter oneGuidCol xs) <= 1
47-
4849
where
4950
totalColumnSizeBits = 32 + sum (map (storageSize . dataType) xs)
5051
totalColumnSizeBytes = totalColumnSizeBits `div` 8 + (if totalColumnSizeBits `rem` 8 /= 0 then 1 else 0)
@@ -55,12 +56,21 @@ columnConstraintsSatisfied xs = length (filter isTimeStamp xs) <= 1 &&
5556
(UniqueIdentifier s) -> maybe False isRowGuidCol s
5657
_ -> False
5758

58-
derive makeArbitrary ''TableDefinition
59+
instance Arbitrary TableDefinition where
60+
arbitrary = do
61+
cols <- arbitrary
62+
nm <- arbitrary
63+
return $ TableDefinition nm cols
5964

6065
derive makeArbitrary ''ColumnDefinition
6166

62-
renderColumnDefinitions :: [ColumnDefinition] -> Doc
63-
renderColumnDefinitions xs = vcat (punctuate comma cols)
67+
instance Arbitrary ColumnDefinitions where
68+
arbitrary = do
69+
cols <- listOf1 arbitrary `suchThat` columnConstraintsSatisfied
70+
return $ ColumnDefinitions cols
71+
72+
renderColumnDefinitions :: ColumnDefinitions -> Doc
73+
renderColumnDefinitions (ColumnDefinitions xs) = vcat (punctuate comma cols)
6474
where
6575
cols = map renderColumnDefinition xs
6676

‎src/Database/SqlServer/Types/User.hs‎

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE TemplateHaskell #-}
3+
4+
module Database.SqlServer.Types.User where
5+
6+
import Database.SqlServer.Types.Identifiers
7+
import Database.SqlServer.Types.Entity
8+
import Database.SqlServer.Types.Certificate
9+
import Database.SqlServer.Types.Login
10+
11+
import Test.QuickCheck
12+
import Text.PrettyPrint
13+
import Data.DeriveTH
14+
15+
data ForFrom = For | From
16+
17+
-- TODO asymmetric key
18+
data UserDefinition = CreateUserWithoutLogin RegularIdentifier
19+
| CreateUserWithCertificate RegularIdentifier ForFrom CertificateDefinition
20+
| CreateUserWithLogin RegularIdentifier ForFrom LoginDefinition
21+
22+
23+
derive makeArbitrary ''ForFrom
24+
derive makeArbitrary ''UserDefinition
25+
26+
renderForFrom :: ForFrom -> Doc
27+
renderForFrom For = text "FOR"
28+
renderForFrom From = text "FROM"
29+
30+
renderCertificate :: CertificateDefinition -> Doc
31+
renderCertificate c = text "CERTIFICATE" <+>
32+
renderRegularIdentifier (certificateName c)
33+
34+
renderLogin :: LoginDefinition -> Doc
35+
renderLogin l = text "LOGIN" <+>
36+
renderRegularIdentifier (loginName l)
37+
38+
instance Entity UserDefinition where
39+
toDoc (CreateUserWithoutLogin x) = text "CREATE USER" <+>
40+
renderRegularIdentifier x <+>
41+
text "WITHOUT LOGIN"
42+
toDoc (CreateUserWithCertificate nm ff cert) = toDoc cert $+$
43+
text "GO" $+$
44+
text "CREATE USER" <+>
45+
renderRegularIdentifier nm <+>
46+
renderForFrom ff <+>
47+
renderCertificate cert
48+
toDoc (CreateUserWithLogin nm ff lg) = toDoc lg $+$
49+
text "GO" $+$
50+
text "CREATE USER" <+>
51+
renderRegularIdentifier nm <+>
52+
renderForFrom ff <+>
53+
renderLogin lg
54+

0 commit comments

Comments
 (0)