diff options
Diffstat (limited to 'keys.hs')
-rw-r--r-- | keys.hs | 67 |
1 files changed, 49 insertions, 18 deletions
@@ -1,5 +1,6 @@ | |||
1 | {-# LANGUAGE ViewPatterns #-} | 1 | {-# LANGUAGE ViewPatterns #-} |
2 | {-# LANGUAGE TupleSections #-} | 2 | {-# LANGUAGE TupleSections #-} |
3 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | module Main where | 4 | module Main where |
4 | 5 | ||
5 | import Data.Binary | 6 | import Data.Binary |
@@ -12,6 +13,7 @@ import Data.OpenPGP.CryptoAPI | |||
12 | import Data.Ord | 13 | import Data.Ord |
13 | import Data.Maybe | 14 | import Data.Maybe |
14 | import Data.Bits | 15 | import Data.Bits |
16 | import qualified Data.Text as T | ||
15 | 17 | ||
16 | getPackets :: IO [Packet] | 18 | getPackets :: IO [Packet] |
17 | getPackets = do | 19 | getPackets = do |
@@ -132,6 +134,35 @@ accBindings bs = as | |||
132 | (bc,_,bkind,bhashed,bclaimaints) | 134 | (bc,_,bkind,bhashed,bclaimaints) |
133 | = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) | 135 | = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) |
134 | 136 | ||
137 | |||
138 | data UserIDRecord = UserIDRecord { | ||
139 | uid_full :: String, | ||
140 | uid_user :: T.Text, | ||
141 | uid_subdomain :: T.Text, | ||
142 | uid_topdomain :: T.Text | ||
143 | } | ||
144 | |||
145 | isBracket '<' = True | ||
146 | isBracket '>' = True | ||
147 | isBracket _ = False | ||
148 | |||
149 | parseUID str = UserIDRecord { | ||
150 | uid_full = str, | ||
151 | uid_user = user, | ||
152 | uid_subdomain = subdomain, | ||
153 | uid_topdomain = topdomain | ||
154 | } | ||
155 | where | ||
156 | text = T.pack str | ||
157 | (T.strip-> realname, T.dropAround isBracket-> email) | ||
158 | = T.break (=='<') text | ||
159 | (user, T.tail-> hostname) = T.break (=='@') email | ||
160 | (T.reverse-> topdomain,T.reverse-> subdomain) | ||
161 | = T.break (=='.') | ||
162 | . T.reverse $ hostname | ||
163 | |||
164 | |||
165 | |||
135 | listKeys pkts = do | 166 | listKeys pkts = do |
136 | let (certs,bs) = getBindings pkts | 167 | let (certs,bs) = getBindings pkts |
137 | as = accBindings bs | 168 | as = accBindings bs |
@@ -158,9 +189,9 @@ listKeys pkts = do | |||
158 | 2 -> " <-- " | 189 | 2 -> " <-- " |
159 | 3 -> " <-> " | 190 | 3 -> " <-> " |
160 | formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' | 191 | formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' |
161 | " "++grip top ++ ar ++ formkind++" "++ fingerprint sub ++ "\n" | 192 | " " {- ++grip top -} ++ ar ++ formkind++" "++ fingerprint sub ++ "\n" |
162 | -- ++ ppShow hashed | 193 | -- ++ ppShow hashed |
163 | uid = maybe "" id . listToMaybe $ do | 194 | uid = {- maybe "" id . listToMaybe $ -} do |
164 | (keys,sigs) <- certs | 195 | (keys,sigs) <- certs |
165 | sig <- sigs | 196 | sig <- sigs |
166 | guard (isCertificationSig sig) | 197 | guard (isCertificationSig sig) |
@@ -168,24 +199,12 @@ listKeys pkts = do | |||
168 | sig_over <- signatures_over sig | 199 | sig_over <- signatures_over sig |
169 | guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top) | 200 | guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top) |
170 | let UserIDPacket uid = user_id sig | 201 | let UserIDPacket uid = user_id sig |
171 | return uid | 202 | parsed = parseUID uid |
203 | " " ++ " --> " ++ "@" ++ " " ++ uid_full parsed ++ "\n" | ||
172 | (_,sigs) = unzip certs | 204 | (_,sigs) = unzip certs |
173 | unlines | 205 | "master-key " ++ fingerprint top ++ "\n" ++ uid ++ subkeys ++ "\n" |
174 | [ uid | ||
175 | , "master-key " ++ fingerprint top ++ "\n" ++ subkeys ] | ||
176 | 206 | ||
177 | 207 | ||
178 | {- | ||
179 | , KeyFlagsPacket | ||
180 | { certify_keys = False | ||
181 | , sign_data = True | ||
182 | , encrypt_communication = True | ||
183 | , encrypt_storage = True | ||
184 | , split_key = False | ||
185 | , authentication = True | ||
186 | , group_key = False | ||
187 | } | ||
188 | -} | ||
189 | data PGPKeyFlags = | 208 | data PGPKeyFlags = |
190 | Special | 209 | Special |
191 | | Vouch | 210 | | Vouch |
@@ -231,12 +250,24 @@ keyflags flgs@(KeyFlagsPacket {}) = | |||
231 | .|. bit 0x2 sign_data | 250 | .|. bit 0x2 sign_data |
232 | .|. bit 0x4 encrypt_communication | 251 | .|. bit 0x4 encrypt_communication |
233 | .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags | 252 | .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags |
253 | -- other flags: | ||
254 | -- split_key | ||
255 | -- authentication | ||
256 | -- group_key | ||
234 | where | 257 | where |
235 | bit v f = if f flgs then v else 0 | 258 | bit v f = if f flgs then v else 0 |
236 | keyflags _ = Nothing | 259 | keyflags _ = Nothing |
237 | 260 | ||
238 | 261 | ||
262 | modifyUID (UserIDPacket str) = UserIDPacket str' | ||
263 | where | ||
264 | (fstname,rst) = break (==' ') str | ||
265 | str' = mod fstname ++ rst | ||
266 | mod "Bob" = "Bob Fucking" | ||
267 | mod x = x | ||
268 | modifyUID other = other | ||
269 | |||
239 | main = do | 270 | main = do |
240 | pkts <- getPackets | 271 | pkts <- getPackets |
241 | putStrLn $ listKeys pkts | 272 | putStrLn $ listKeys pkts -- (map modifyUID pkts) |
242 | return () | 273 | return () |