summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2014-04-21 23:03:40 -0400
committerJames Crayne <jim.crayne@gmail.com>2014-04-21 23:03:40 -0400
commit673ae2de0f6035ec81df5776dee999295a2eeb00 (patch)
treef08823da4f76a1db992a3f90e8a6ce987b58ec13
parentce4576743a98f225ed9e036ddc8d1eb02ced6dfa (diff)
Minor cleanup
-rw-r--r--HLintIgnores9
-rw-r--r--KeyRing.hs87
2 files changed, 50 insertions, 46 deletions
diff --git a/HLintIgnores b/HLintIgnores
new file mode 100644
index 0000000..473a245
--- /dev/null
+++ b/HLintIgnores
@@ -0,0 +1,9 @@
1{-# ANN module ("HLint: ignore Eta reduce"::String) #-}
2{-# ANN module ("HLint: ignore Use camelCase"::String) #-}
3{-# ANN module ("HLint: ignore Redundant bracket"::String) #-}
4{-# ANN module ("HLint: ignore Redundant $"::String) #-}
5{-# ANN module ("HLint: ignore Redundant do"::String) #-}
6{-# ANN module ("HLint: ignore Use String"::String) #-}
7{-# ANN module ("HLint: ignore Use ||"::String) #-}
8{-# ANN module ("HLint: ignore Use &&"::String) #-}
9{-# ANN module ("HLint: ignore Use ***"::String) #-}
diff --git a/KeyRing.hs b/KeyRing.hs
index 10baa98..869cbb3 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -280,7 +280,7 @@ instance ASN1Object PKCS8_RSAPublicKey where
280 : End Sequence 280 : End Sequence
281 : xs 281 : xs
282 where 282 where
283 pubkey = Start Sequence : IntVal n : IntVal e : End Sequence : [] 283 pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ]
284 bs = encodeASN1' DER pubkey 284 bs = encodeASN1' DER pubkey
285 285
286 fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = 286 fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
@@ -658,9 +658,9 @@ parseSpec grip spec = (topspec,subspec)
658 _ | null top && null grip -> KeyUidMatch sub 658 _ | null top && null grip -> KeyUidMatch sub
659 _ | null top -> KeyGrip grip 659 _ | null top -> KeyGrip grip
660 _ | toptyp=="fp" || (null toptyp && is40digitHex top) 660 _ | toptyp=="fp" || (null toptyp && is40digitHex top)
661 -> {- trace "using top" $ -} KeyGrip top 661 -> KeyGrip top
662 _ | toptyp=="u" -> KeyUidMatch top 662 _ | toptyp=="u" -> KeyUidMatch top
663 _ | otherwise -> KeyUidMatch top 663 _ -> KeyUidMatch top
664 subspec = case subtyp of 664 subspec = case subtyp of
665 "t" -> Just sub 665 "t" -> Just sub
666 "fp" | top=="" -> Nothing 666 "fp" | top=="" -> Nothing
@@ -721,12 +721,12 @@ seek_key (KeyGrip grip) sec = (pre, subs)
721 pred p@(PublicKeyPacket {}) = matchpr grip p == grip 721 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
722 pred _ = False 722 pred _ = False
723 723
724seek_key (KeyTag key tag) ps = if null bs 724seek_key (KeyTag key tag) ps
725 then (ps,[]) 725 | null bs = (ps, [])
726 else if null qs 726 | null qs =
727 then let (as',bs') = seek_key (KeyTag key tag) (tail bs) 727 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
728 in (as ++ (head bs:as'), bs') 728 (as ++ (head bs : as'), bs')
729 else (reverse (tail qs), head qs : reverse rs ++ bs) 729 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
730 where 730 where
731 (as,bs) = break (\p -> isSignaturePacket p 731 (as,bs) = break (\p -> isSignaturePacket p
732 && has_tag tag p 732 && has_tag tag p
@@ -738,15 +738,13 @@ seek_key (KeyTag key tag) ps = if null bs
738 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) 738 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
739 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) 739 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
740 740
741seek_key (KeyUidMatch pat) ps = if null bs 741seek_key (KeyUidMatch pat) ps
742 then (ps,[]) 742 | null bs = (ps, [])
743 else if null qs 743 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
744 then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs) 744 (as ++ (head bs : as'), bs')
745 in (as ++ (head bs:as'), bs') 745 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
746 else (reverse (tail qs), head qs : reverse rs ++ bs)
747 where 746 where
748 (as,bs) = break (isInfixOf pat . uidStr) 747 (as,bs) = break (isInfixOf pat . uidStr) ps
749 ps
750 (rs,qs) = break isKey (reverse as) 748 (rs,qs) = break isKey (reverse as)
751 749
752 uidStr (UserIDPacket s) = s 750 uidStr (UserIDPacket s) = s
@@ -844,7 +842,7 @@ mergeHostFiles krd db secring pubring = do
844 842
845 -- 2. replace gpg annotations with those in U 843 -- 2. replace gpg annotations with those in U
846 -- forM use_db 844 -- forM use_db
847 db' <- Traversable.mapM (setHostnames (\a -> not $ elem a outgoing_names) u1) db 845 db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
848 846
849 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) 847 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
850 848
@@ -882,7 +880,7 @@ writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names
882 let h = h1 `Hosts.plus` u 880 let h = h1 `Hosts.plus` u
883 d = Hosts.diff h0 h 881 d = Hosts.diff h0 h
884 rs = map ((fname,) . HostsDiff) d 882 rs = map ((fname,) . HostsDiff) d
885 when (not $ null d) $ L.writeFile fname $ Hosts.encode h 883 unless (null d) $ L.writeFile fname $ Hosts.encode h
886 return rs 884 return rs
887 return $ concat rss 885 return $ concat rss
888 886
@@ -969,7 +967,7 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
969 return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs ) 967 return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs )
970 968
971torhash :: Packet -> String 969torhash :: Packet -> String
972torhash key = maybe "" id $ derToBase32 <$> derRSA key 970torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
973 971
974derToBase32 :: ByteString -> String 972derToBase32 :: ByteString -> String
975derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy 973derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
@@ -1166,7 +1164,7 @@ coinKeysOwnedBy db wk = do
1166 (subkk,SubKey mp sigs) <- Map.toList subs 1164 (subkk,SubKey mp sigs) <- Map.toList subs
1167 let sub = packet mp 1165 let sub = packet mp
1168 guard $ isCryptoCoinKey sub 1166 guard $ isCryptoCoinKey sub
1169 tag <- take 1 $ mapMaybe getCryptoCoinTag (map (packet . fst) sigs) 1167 tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs
1170 return (tag,mp) 1168 return (tag,mp)
1171 1169
1172walletImportFormat :: Word8 -> Packet -> String 1170walletImportFormat :: Word8 -> Packet -> String
@@ -1432,14 +1430,14 @@ makeMemoizingDecrypter operation secring pubring = do
1432 decryptIt [] = return BadPassphrase 1430 decryptIt [] = return BadPassphrase
1433 decryptIt (getpw:getpws) = do 1431 decryptIt (getpw:getpws) = do
1434 pw <- getpw 1432 pw <- getpw
1435 let wkun = maybe wk id $ decryptSecretKey pw wk 1433 let wkun = fromMaybe wk $ decryptSecretKey pw wk
1436 case symmetric_algorithm wkun of 1434 case symmetric_algorithm wkun of
1437 Unencrypted -> do 1435 Unencrypted -> do
1438 writeIORef unkeysRef (Map.insert kk wkun unkeys) 1436 writeIORef unkeysRef (Map.insert kk wkun unkeys)
1439 return $ KikiSuccess wkun 1437 return $ KikiSuccess wkun
1440 _ -> decryptIt getpws 1438 _ -> decryptIt getpws
1441 1439
1442 getpws = mapMaybe (flip Map.lookup pws) fs 1440 getpws = mapMaybe (`Map.lookup` pws) fs
1443 1441
1444 case symmetric_algorithm wk of 1442 case symmetric_algorithm wk of
1445 Unencrypted -> return (KikiSuccess wk) 1443 Unencrypted -> return (KikiSuccess wk)
@@ -1521,7 +1519,7 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do
1521 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do 1519 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
1522 (fname,(rtyp,ftyp)) <- nonexistents 1520 (fname,(rtyp,ftyp)) <- nonexistents
1523 guard $ isMutable rtyp 1521 guard $ isMutable rtyp
1524 (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip) 1522 (topspec,subspec) <- fmap (parseSpec $ fromMaybe "" grip)
1525 $ getUsage ftyp 1523 $ getUsage ftyp
1526 -- ms will contain duplicates if a top key has multiple matching 1524 -- ms will contain duplicates if a top key has multiple matching
1527 -- subkeys. This is intentional. 1525 -- subkeys. This is intentional.
@@ -1552,7 +1550,7 @@ initializeMissingPEMFiles operation secring pubring grip decrypt db = do
1552 return (fname,subspec,ms,cmd) 1550 return (fname,subspec,ms,cmd)
1553 rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do 1551 rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do
1554 e <- systemEnv [ ("file",fname) 1552 e <- systemEnv [ ("file",fname)
1555 , ("usage",maybe "" id subspec) ] 1553 , ("usage",fromMaybe "" subspec) ]
1556 cmd 1554 cmd
1557 case e of 1555 case e of
1558 ExitFailure num -> return (tup,FailedExternal num) 1556 ExitFailure num -> return (tup,FailedExternal num)
@@ -1754,10 +1752,10 @@ secretToPublic pkt = pkt
1754slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) 1752slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
1755slurpWIPKeys stamp "" = ([],[]) 1753slurpWIPKeys stamp "" = ([],[])
1756slurpWIPKeys stamp cs = 1754slurpWIPKeys stamp cs =
1757 let (b58,xs) = Char8.span (\x -> elem x base58chars) cs 1755 let (b58,xs) = Char8.span (`elem` base58chars) cs
1758 mb = decode_btc_key stamp (Char8.unpack b58) 1756 mb = decode_btc_key stamp (Char8.unpack b58)
1759 in if L.null b58 1757 in if L.null b58
1760 then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs 1758 then let (ys,xs') = Char8.break (`elem` base58chars) cs
1761 (ks,js) = slurpWIPKeys stamp xs' 1759 (ks,js) = slurpWIPKeys stamp xs'
1762 in (ks,ys:js) 1760 in (ks,ys:js)
1763 else let (ks,js) = slurpWIPKeys stamp xs 1761 else let (ks,js) = slurpWIPKeys stamp xs
@@ -1810,14 +1808,11 @@ decode_btc_key timestamp str = do
1810 } 1808 }
1811 1809
1812rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey 1810rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
1813rsaKeyFromPacket p@(PublicKeyPacket {}) = do 1811rsaKeyFromPacket p | isKey p = do
1814 n <- lookup 'n' $ key p
1815 e <- lookup 'e' $ key p
1816 return $ RSAKey n e
1817rsaKeyFromPacket p@(SecretKeyPacket {}) = do
1818 n <- lookup 'n' $ key p 1812 n <- lookup 'n' $ key p
1819 e <- lookup 'e' $ key p 1813 e <- lookup 'e' $ key p
1820 return $ RSAKey n e 1814 return $ RSAKey n e
1815
1821rsaKeyFromPacket _ = Nothing 1816rsaKeyFromPacket _ = Nothing
1822 1817
1823 1818
@@ -1830,7 +1825,7 @@ readPacketsFromWallet wk fname = do
1830 modificationTime <$> getFileStatus fname 1825 modificationTime <$> getFileStatus fname
1831 input <- L.readFile fname 1826 input <- L.readFile fname
1832 let (ks,_) = slurpWIPKeys timestamp input 1827 let (ks,_) = slurpWIPKeys timestamp input
1833 when (not (null ks)) $ do 1828 unless (null ks) $ do
1834 -- decrypt wk 1829 -- decrypt wk
1835 -- create sigs 1830 -- create sigs
1836 -- return key/sig pairs 1831 -- return key/sig pairs
@@ -1862,7 +1857,7 @@ now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
1862signature_time :: SignatureOver -> Word32 1857signature_time :: SignatureOver -> Word32
1863signature_time ov = case if null cs then ds else cs of 1858signature_time ov = case if null cs then ds else cs of
1864 [] -> minBound 1859 [] -> minBound
1865 xs -> last (sort xs) 1860 xs -> maximum xs
1866 where 1861 where
1867 ps = signatures_over ov 1862 ps = signatures_over ov
1868 ss = filter isSignaturePacket ps 1863 ss = filter isSignaturePacket ps
@@ -1898,7 +1893,7 @@ findTag tag wk subkey subsigs = (xs',minsig,ys')
1898 guard (isSignaturePacket sig) 1893 guard (isSignaturePacket sig)
1899 guard $ flip isSuffixOf 1894 guard $ flip isSuffixOf
1900 (fingerprint wk) 1895 (fingerprint wk)
1901 . maybe "%bad%" id 1896 . fromMaybe "%bad%"
1902 . signature_issuer 1897 . signature_issuer
1903 $ sig 1898 $ sig
1904 listToMaybe $ 1899 listToMaybe $
@@ -1932,13 +1927,13 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do
1932 wkun <- doDecrypt top 1927 wkun <- doDecrypt top
1933 try wkun $ \wkun -> do 1928 try wkun $ \wkun -> do
1934 let grip = fingerprint wk 1929 let grip = fingerprint wk
1935 addOrigin new_sig = do 1930 addOrigin new_sig =
1936 flip (maybe $ return FailedToMakeSignature) 1931 flip (maybe $ return FailedToMakeSignature)
1937 (new_sig >>= listToMaybe . signatures_over) 1932 (new_sig >>= listToMaybe . signatures_over)
1938 $ \new_sig -> do 1933 $ \new_sig -> do
1939 let mp' = mappedPacket fname new_sig 1934 let mp' = mappedPacket fname new_sig
1940 return $ KikiSuccess (mp', Map.empty) 1935 return $ KikiSuccess (mp', Map.empty)
1941 parsedkey = [packet $ subkey_p] 1936 parsedkey = [packet subkey_p]
1942 hashed0 = 1937 hashed0 =
1943 [ KeyFlagsPacket 1938 [ KeyFlagsPacket
1944 { certify_keys = False 1939 { certify_keys = False
@@ -1997,7 +1992,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do
1997 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x 1992 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
1998 expires = liftA2 (+) stamp exp 1993 expires = liftA2 (+) stamp exp
1999 timestamp <- now 1994 timestamp <- now
2000 if fmap ( (< timestamp) . fromIntegral) expires == Just True then do 1995 if fmap ( (< timestamp) . fromIntegral) expires == Just True then
2001 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) 1996 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
2002 else do 1997 else do
2003 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) 1998 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
@@ -2091,7 +2086,7 @@ merge db filename (Message ps) = merge_ db filename qs
2091 _ | isKey p && is_subkey p -> (top,p,ret p) 2086 _ | isKey p && is_subkey p -> (top,p,ret p)
2092 _ | isUserID p -> (top,p,ret p) 2087 _ | isUserID p -> (top,p,ret p)
2093 _ | isTrust p -> (top,sub,updateTrust top sub prev p) 2088 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
2094 _ | otherwise -> (top,sub,ret p) 2089 _ -> (top,sub,ret p)
2095 2090
2096 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public 2091 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
2097 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public 2092 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
@@ -2226,7 +2221,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
2226 2221
2227unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] 2222unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
2228unsig fname isPublic (sig,trustmap) = 2223unsig fname isPublic (sig,trustmap) =
2229 [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) 2224 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
2230 where 2225 where
2231 f n _ = n==fname -- && trace ("fname=n="++show n) True 2226 f n _ = n==fname -- && trace ("fname=n="++show n) True
2232 asMapped n p = let m = mappedPacket fname p 2227 asMapped n p = let m = mappedPacket fname p
@@ -2290,7 +2285,7 @@ getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
2290 _ -> mzero 2285 _ -> mzero
2291 2286
2292 addr = fingerdress topk 2287 addr = fingerdress topk
2293 -- name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key? 2288 -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
2294 topk = packet topmp 2289 topk = packet topmp
2295 torkeys = do 2290 torkeys = do
2296 SubKey k sigs <- Map.elems subs 2291 SubKey k sigs <- Map.elems subs
@@ -2311,7 +2306,7 @@ getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
2311 guard . not . null $ signatures_over v' 2306 guard . not . null $ signatures_over v'
2312 return torsig 2307 return torsig
2313 guard (not $ null sigs') 2308 guard (not $ null sigs')
2314 return $ subk 2309 return subk
2315 has_tag tag p = isSignaturePacket p 2310 has_tag tag p = isSignaturePacket p
2316 && or [ tag `elem` mapMaybe usage (hashed_subpackets p) 2311 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
2317 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] 2312 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
@@ -2386,14 +2381,14 @@ setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
2386 psig = packet sig 2381 psig = packet sig
2387 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } 2382 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
2388 else psig 2383 else psig
2389 uh = unhashed_subpackets $ psig 2384 uh = unhashed_subpackets psig
2390 (ns,ps) = partition isName uh 2385 (ns,ps) = partition isName uh
2391 2386
2392fingerdress :: Packet -> SockAddr 2387fingerdress :: Packet -> SockAddr
2393fingerdress topk = maybe zero id $ Hosts.inet_pton addr_str 2388fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
2394 where 2389 where
2395 zero = SockAddrInet 0 0 2390 zero = SockAddrInet 0 0
2396 addr_str = colons $ "fd" ++ (drop 10 $ map toLower $ fingerprint topk) 2391 addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk)
2397 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs 2392 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
2398 colons xs = xs 2393 colons xs = xs
2399 2394
@@ -2403,5 +2398,5 @@ backsig _ = Nothing
2403 2398
2404socketFamily :: SockAddr -> Family 2399socketFamily :: SockAddr -> Family
2405socketFamily (SockAddrInet _ _) = AF_INET 2400socketFamily (SockAddrInet _ _) = AF_INET
2406socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 2401socketFamily (SockAddrInet6 {}) = AF_INET6
2407socketFamily (SockAddrUnix _) = AF_UNIX 2402socketFamily (SockAddrUnix _) = AF_UNIX