-
Notifications
You must be signed in to change notification settings - Fork 1
/
clusters.hs
223 lines (195 loc) · 9.16 KB
/
clusters.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
import System.Environment
import Debug.Trace
import qualified Util as Util
import qualified Graph as Graph
import qualified XML as XML
---- Data representation ----
data Class = Class { vendor :: String,
name :: String,
family :: String,
deviceType :: String }
deriving (Show)
data Expression = Literal String |
Range Int Int |
GreaterThan Int |
LessThan Int
deriving (Show)
data TestMap = TestMap [(String, [Expression])]
deriving (Show)
data ResponseMap = ResponseMap [(String, TestMap)]
deriving (Show)
data Fingerprint = Fingerprint { id :: String,
classes :: [Class],
responses :: ResponseMap }
deriving (Show)
---- Operations: ----
compare :: Expression -> Expression -> Bool
compare (Literal x) (Literal y) = x == y
compare (Literal x) (Range a b) = a <= n && n <= b
where n = Util.hexToInt x
compare (Literal x) (LessThan y) = n < y
where n = Util.hexToInt x
compare (Literal x) (GreaterThan y) = n > y
where n = Util.hexToInt x
compare (GreaterThan x) (Literal y) = Main.compare (Literal y)
(GreaterThan x)
compare (GreaterThan x) (Range a b) = x >= a
compare (GreaterThan x) (GreaterThan y) = True
compare (GreaterThan x) (LessThan y) = x < y
compare (LessThan x) (Literal y) = Main.compare (Literal y)
(LessThan x)
compare (LessThan x) (Range a b) = x <= b
compare (LessThan x) (GreaterThan y) = Main.compare (GreaterThan y)
(LessThan x)
compare (LessThan x) (LessThan y) = True
compare (Range a b) (Literal y) = Main.compare (Literal y) (Range a b)
compare (Range a b) (Range c d) = c <= b && a <= d
compare (Range a b) (GreaterThan y) = Main.compare (GreaterThan y)
(Range a b)
compare (Range a b) (LessThan y) = Main.compare (LessThan y)
(Range a b)
similarity :: Fingerprint -> Fingerprint -> Float
similarity (Fingerprint _ _ (ResponseMap a))
(Fingerprint _ _ (ResponseMap b)) =
compareResponseMaps a b
where compareResponseMaps ((k,(TestMap v)):xs) b =
(case lookup k b of
Nothing -> 0.0
Just (TestMap map) -> (compareTestMaps v map)) +
(compareResponseMaps xs b)
compareResponseMaps [] _ = 0.0
compareTestMaps ((k,v):xs) b =
(case lookup k b of
Nothing -> 0.0
Just a -> (compareExpressionLists v a)) +
(compareTestMaps xs b)
compareTestMaps [] _ = 0.0
compareExpressionLists xs ys
| or $ map (\x -> Main.compare (fst x) (snd x))
(Util.join xs ys) = 1.0
| otherwise = 0.0
distance :: Fingerprint -> Fingerprint -> Float
distance a b = (similarity a a) - (similarity a b)
---- Parsing ----
-- token, input, state, current, output, return
sections :: String -> [String] -> Int -> [String] -> [[String]] -> [[String]]
sections token (x:xs) state current output
-- entering section:
| (state == 0) &&
(not (null x)) &&
(Util.beginsWith token x) = sections token xs 1 (current ++ [x]) output
-- inside section:
| (state == 1) &&
(not (null x)) = sections token xs state (current ++ [x]) output
-- leaving section:
| (state == 1) &&
(null x) = sections token xs 0 [] (output ++ [current])
-- any other case:
| otherwise = sections token xs state current output
sections token [] state current output = (output ++ [current])
parse :: [String] -> String -> [Class] -> [(String, TestMap)] -> Fingerprint
parse (x:xs) id classes responses
-- XXX ignore CPE lines
| (Util.beginsWith "CPE " x) = parse xs id classes responses
| (Util.beginsWith fp x) = parse xs (drop (length fp) x) classes responses
| (Util.beginsWith cls x) = parse xs id (classes ++ [parseClass x]) responses
| otherwise = parse xs id classes (responses ++ [parseResponse x])
where fp = "Fingerprint "
cls = "Class "
parseClass x
| (Util.beginsWith cls x) = parseClass (drop (length cls) x)
| otherwise = let tokens = map Util.trim $ Util.split x '|'
in Class (tokens !! 0)
(tokens !! 1)
(tokens !! 2)
(tokens !! 3)
parseResponse x
| otherwise = (takeWhile (/= '(') x,
TestMap (parseTests $ takeWhile (/= ')')
$ tail
$ dropWhile (/= '(') x))
parseTests x = map parseTest $ Util.split x '%'
parseTest x
| otherwise = let pair = Util.split x '='
in (pair !! 0, parseExpressions (pair !! 0))
parseExpressions x = map parseExpression $ Util.split x '|'
parseExpression x
| null x = Literal ""
| '-' `elem` x = let r = Util.split x '-'
in Range (Util.hexToInt (r !! 0))
(Util.hexToInt (r !! 1))
| '>' == (head x) = GreaterThan $ Util.hexToInt $ tail x
| '<' == (head x) = LessThan $ Util.hexToInt $ tail x
| otherwise = Literal x
parse [] id classes responses = Fingerprint id classes (ResponseMap responses)
fingerprints :: [String] -> [Fingerprint]
fingerprints a = map (\s -> parse s "" [] [])
(sections "Fingerprint" a 0 [] [])
---- Output generation ----
number :: (Int, a) -> String
number (n,_) = "n" ++ (show n)
node :: (Int, Fingerprint) -> Graph.Statement
node x@(n,f) = Graph.Node (number x) [Graph.Label $ Main.id f]
nodes :: [(Int, Fingerprint)] -> [Graph.Statement]
nodes = map node
edge :: (Int, a) -> (Int, a) -> Graph.Statement
edge a b = Graph.Edge Graph.NonDirected (number a) (number b) []
edges :: [[(Int, a)]] -> [Graph.Statement]
edges xs =
foldr (\x a -> map (\y -> edge (fst y) (snd y)) (Util.connect x) ++ a) [] xs
color :: Int -> Int -> Int -> Graph.Attribute
color red green blue = Graph.Color ("#" ++ (Util.fixed (Util.toHexa red) 2) ++
(Util.fixed (Util.toHexa green) 2) ++
(Util.fixed (Util.toHexa blue) 2))
clusters :: [[(Int, Fingerprint)]] -> Int -> Int -> [Graph.Statement]
clusters (x:xs) n max
| (length x) > 1 = Graph.SubGraph
("cluster_" ++ (show n))
(Graph.Attributes
"graph"
[Graph.Style "filled",
color (div ((max - (length x)) * 255) max)
(div ((max - (length x)) * 255) max)
(div ((max - (length x)) * 255) max)]
: (nodes x))
: (clusters xs (n + 1) max)
| otherwise = (nodes x) ++ (clusters xs n max)
clusters [] _ _ = []
graph :: [[(Int,Fingerprint)]] -> Graph.Graph
graph xs = Graph.Graph Graph.NonDirected "clusters" $
[Graph.Attributes "node" [Graph.Color "#666666",
Graph.Style "filled",
Graph.Shape "box",
Graph.Fontname "Trebuchet MS",
Graph.Fillcolor "white",
Graph.Fontcolor "#666666"],
Graph.Attributes "edge" [Graph.Color "#666666",
Graph.Fontname "Trebuchet MS",
Graph.Fontsize 11]] ++
--(nodes $ concat xs) ++ (edges xs)
(clusters xs 0 $ maximum [length x | x <- xs])
elements :: [[(Int, Fingerprint)]] -> [XML.Element]
elements (x:xs)
| (length x) > 1 = XML.Element "cluster" [] (map element x) : (elements xs)
| otherwise = element (head x) : (elements xs)
where element (n,f) = XML.Element "os" [XML.Attribute "name" (Main.id f)] []
elements [] = []
document :: [[(Int,Fingerprint)]] -> XML.Document
document xs = XML.Document $ XML.Element "clusters" [] (elements xs)
-- [1,2,3] 3 -> [1,2,3,1,2,3,1,2,3]
multiply :: [a] -> Int -> [a]
multiply xs n = concat $ take n $ repeat xs
groupBy _ [] = []
groupBy eq (x:xs) = (x:ys) : groupBy eq zs
where (ys,zs) = span (eq x) xs
buildGraph input threshold = (length groups, graph groups)
where groups = groupBy
(\a b -> (distance (snd a) (snd b)) < threshold)
list
list = zip [0..] $ fingerprints $ lines input
main = do
(filename:threshold:output:_) <- getArgs
database <- readFile filename
let (count, graph) = buildGraph database (read threshold :: Float)
writeFile output (show graph)
putStrLn $ "Clusters count: " ++ (show count)