7 files changed, 155 insertions, 36 deletions

diff --git a/Base58.hs b/Base58.hs
index de35b01..3c1a113 100644
--- a/Base58.hs
+++ b/Base58.hs
@@ -1,6 +1,12 @@
+{-# LANGUAGE CPP #-}
 module Base58 where
 
+#if !defined(VERSION_cryptonite)
 import qualified Crypto.Hash.SHA256 as SHA256
+#else
+import Crypto.Hash
+import Data.ByteArray (convert)
+#endif
 import qualified Data.ByteString      as S
 import Data.Maybe
 import Data.List
@@ -28,7 +34,12 @@ base58_decode str = do
     
     let (rcksum,rpayload) = splitAt 4 $ rbytes
         a_payload = reverse rpayload
+#if !defined(VERSION_cryptonite)
         hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload
+#else
+        hash_result = S.take 4 . convert $ digest
+          where digest = hash (S.pack a_payload) :: Digest SHA256
+#endif
         expected_hash = S.pack $ reverse rcksum
         (network_id,payload) = splitAt 1 a_payload
     
@@ -37,11 +48,17 @@ base58_decode str = do
     return (network_id,payload)
 
 base58_encode :: S.ByteString -> String
-base58_encode hash = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits)
+base58_encode hsh = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits)
   where
-    zcount = S.length . S.takeWhile (==0) $ hash
-    cksum = S.take 4 . SHA256.hash . SHA256.hash $ hash
-    n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hash, cksum]
+    zcount = S.length . S.takeWhile (==0) $ hsh
+#if !defined(VERSION_cryptonite)
+    cksum = S.take 4 . SHA256.hash . SHA256.hash $ hsh
+#else
+    cksum = S.take 4 (convert digest2 :: S.ByteString)
+      where digest2 = hash ( convert digest1 :: S.ByteString) :: Digest SHA256
+            digest1 = hash hsh :: Digest SHA256
+#endif
+    n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hsh, cksum]
     asInteger x = fromIntegral x :: Integer
     rdigits = unfoldr getdigit n
      where
diff --git a/Compat.hs b/Compat.hs
new file mode 100644
index 0000000..43f62c0
--- /dev/null
+++ b/Compat.hs
@@ -0,0 +1,54 @@
+module Compat where
+
+import Data.Bits
+import Data.Word
+import Data.ASN1.Types
+import Data.ASN1.Encoding
+import Data.ASN1.BinaryEncoding
+import Crypto.PubKey.RSA as RSA
+
+instance ASN1Object PublicKey where
+    toASN1 pubKey = \xs -> Start Sequence
+                         : IntVal (public_n pubKey)
+                         : IntVal (public_e pubKey)
+                         : End Sequence
+                         : xs
+    fromASN1 (Start Sequence:IntVal smodulus:IntVal pubexp:End Sequence:xs) =
+        Right (PublicKey { public_size = calculate_modulus modulus 1
+                         , public_n    = modulus
+                         , public_e    = pubexp
+                         }
+              , xs)
+        where calculate_modulus n i = if (2 ^ (i * 8)) > n then i else calculate_modulus n (i+1)
+              -- some bad implementation will not serialize ASN.1 integer properly, leading
+              -- to negative modulus. if that's the case, we correct it.
+              modulus = toPositive smodulus
+    fromASN1 ( Start Sequence
+             : IntVal 0
+             : Start Sequence
+             : OID [1, 2, 840, 113549, 1, 1, 1]
+             : Null
+             : End Sequence
+             : OctetString bs
+             : xs
+             ) = let inner = either strError fromASN1 $ decodeASN1' BER bs
+                     strError = Left .
+                                ("fromASN1: RSA.PublicKey: " ++) . show
+                 in either Left (\(k, _) -> Right (k, xs)) inner
+    fromASN1 _ =
+        Left "fromASN1: RSA.PublicKey: unexpected format"
+
+
+toPositive :: Integer -> Integer
+toPositive int
+    | int < 0   = uintOfBytes $ bytesOfInt int
+    | otherwise = int
+  where uintOfBytes = foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0
+        bytesOfInt :: Integer -> [Word8]
+        bytesOfInt n = if testBit (head nints) 7 then nints else 0xff : nints
+          where nints = reverse $ plusOne $ reverse $ map complement $ bytesOfUInt (abs n)
+                plusOne []     = [1]
+                plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs
+                bytesOfUInt x = reverse (list x)
+                  where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8)
+
diff --git a/DNSKey.hs b/DNSKey.hs
index 38d336d..5c71c16 100644
--- a/DNSKey.hs
+++ b/DNSKey.hs
@@ -50,6 +50,7 @@ i2bs_unsized 0 = B.singleton 0
 i2bs_unsized i = B.reverse $ B.unfoldr (\i' -> if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8))) i
 {-# INLINE i2bs_unsized #-}
 
+{-
 main = do
     bs <- L.getContents
     let rsa = runGet (getRSA (fromIntegral $ L.length bs)) bs
@@ -57,3 +58,4 @@ main = do
         rsa' = runGet (getRSA (fromIntegral $ L.length bs)) bs'
     print rsa
     print rsa'
+-}
diff --git a/KeyRing.hs b/KeyRing.hs
index 776ded3..50702ae 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -133,10 +133,16 @@ import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
         , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
         , index )
 import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, putStr )
-import qualified Crypto.Types.PubKey.ECC as ECC
 import qualified Codec.Binary.Base32 as Base32
 import qualified Codec.Binary.Base64 as Base64
+#if !defined(VERSION_cryptonite)
 import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Crypto.Types.PubKey.ECC as ECC
+#else
+import qualified Crypto.Hash as Vincent
+import Data.ByteArray (convert)
+import qualified Crypto.PubKey.ECC.Types as ECC
+#endif
 import qualified Data.X509 as X509
 import qualified Crypto.PubKey.RSA as RSA
 import qualified Codec.Compression.GZip as GZip
@@ -173,8 +179,7 @@ import Debug.Trace
 #endif
 import Network.Socket -- (SockAddr)
 import qualified Data.ByteString.Lazy.Char8 as Char8
-
-
+import Compat
 
 import TimeUtil
 import PEM
@@ -1441,7 +1446,14 @@ torhash :: Packet -> String
 torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
 
 derToBase32 :: ByteString -> String
+#if !defined(VERSION_cryptonite)
 derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
+#else
+derToBase32 = map toLower . Base32.encode . S.unpack . sha1
+ where
+   sha1 :: L.ByteString -> S.ByteString
+   sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
+#endif
 
 derRSA :: Packet -> Maybe ByteString
 derRSA rsa = do
@@ -1480,6 +1492,8 @@ spemCert _ = Nothing
 toStrict :: L.ByteString -> S.ByteString
 toStrict = foldr1 (<>) . L.toChunks
 
+-- No instance for (ASN1Object RSA.PublicKey)
+
 parseCertBlob comp bs = do
     asn1 <- either (const Nothing) Just
                 $ decodeASN1 DER bs
@@ -1936,6 +1950,7 @@ writePEM typ dta = pem
             [ ["-----BEGIN " <> typ <> "-----"]
             , split64s dta
             , ["-----END " <> typ <> "-----"] ]
+    split64s :: String -> [String]
     split64s "" = []
     split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
 
diff --git a/TimeUtil.hs b/TimeUtil.hs
index 9035e50..879bc32 100644
--- a/TimeUtil.hs
+++ b/TimeUtil.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
 module TimeUtil
     ( now
     , IsTime(..)
@@ -14,8 +15,10 @@ import Data.Time.LocalTime
 import Data.Time.Format
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
-import System.Locale
-import Data.String 
+#if !MIN_VERSION_time(1,5,0)
+import System.Locale (defaultTimeLocale)
+#endif
+import Data.String
 import Control.Applicative
 import Data.Maybe
 import Data.Char
diff --git a/kiki.cabal b/kiki.cabal
index 450a3ab..e301d7f 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -11,21 +11,28 @@ Maintainer:          Joseph Crayne <oh.hello.joe@gmail.com>
 --Homepage:          TODO
 build-type:          Simple
 
+Flag cryptonite
+  Description: Use newer cryptonite-based x509 version 1.6 and higher
+  Default: True
+
 Executable kiki
     Main-is: kiki.hs
     -- base >=4.6 due to use of readEither in KikiD.Message
     Build-Depends:   base >=4.6.0.0,
                      directory -any,
                      openpgp-util -any,
-                     crypto-pubkey (>=0.2.3), cryptohash -any,
-                     crypto-pubkey-types -any,
-                     x509 (< 1.6), asn1-types -any, asn1-encoding -any,
+                     asn1-types -any, asn1-encoding -any,
                      dataenc -any, text -any, pretty -any, pretty-show -any,
-                     bytestring -any, openpgp (>=0.6.1.1), binary -any,
+                     bytestring -any, binary -any,
                      unix, time, 
                      containers -any, process -any, filepath -any,
                      network -any, old-locale -any, zlib -any,
                      hourglass -any
+    if !flag(cryptonite)
+      Build-Depends:   crypto-pubkey >=0.2.3, cryptohash -any,
+                       crypto-pubkey-types -any, x509 <1.6
+    else
+      Build-Depends:   cryptonite, x509 >=1.6, memory
     ghc-options:     -O2 -fwarn-unused-binds -fwarn-unused-imports
     c-sources: dotlock.c
 
@@ -33,20 +40,5 @@ Executable hosts
     Main-is: hosts.hs
     c-sources: dotlock.c
 
-Executable kikid
-    Main-is: kikid.hs
-    Build-Depends: base -any, 
-                   --kiki >=0.0.3,
-                   hdaemonize >= 0.5, 
-                   hsyslog -any,
-                   async >= 2.0.0,
-                   stm-chans >= 2.0.0,
-                   network >= 2.4 && < 3.0, 
-                   monad-loops -any,
-                   HTTP -any,
-                   stm >= 2.3,
-                   cereal -any,
-                   bytes -any
-
 library
     exposed-modules: KeyRing
diff --git a/kiki.hs b/kiki.hs
index 2d926a8..316da90 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -29,8 +29,14 @@ import System.Environment
 import System.Exit
 import System.IO (hPutStrLn,stderr)
 import qualified Codec.Binary.Base64 as Base64
-import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
+#if !defined(VERSION_cryptonite)
+-- import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
 import qualified Crypto.Hash.SHA256    as SHA256
+#else
+import Crypto.Hash.Algorithms (RIPEMD160(..))
+import Crypto.Hash
+import Data.ByteArray (convert)
+#endif
 import qualified Data.ByteString      as S
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
@@ -38,6 +44,7 @@ import qualified Data.Map as Map
 import Control.Arrow   (first,second)
 import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
 import Data.Monoid ( (<>) )
+import Data.Binary.Put
 
 import Data.OpenPGP.Util (verify,fingerprint)
 import ScanningParser
@@ -50,6 +57,7 @@ import qualified CryptoCoins
 import ProcessUtils
 import qualified SSHKey as SSH
 import Text.Printf
+import qualified DNSKey as DNS
 
 -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
 -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
@@ -279,13 +287,15 @@ show_whose_key input_key db =
         (_:_) -> error "ambiguous"
         [] -> return ()
 
-show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db
+show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket
 
-show_pem' keyspec wkgrip db = do
+show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket
+
+show_pem' keyspec wkgrip db keyfmt = do
     let s = parseSpec wkgrip keyspec
     flip (maybe . Left $ keyspec ++ ": not found")
          (selectPublicKey s db)
-         pemFromPacket
+         keyfmt
 
 pemFromPacket k = do
     let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
@@ -294,6 +304,15 @@ pemFromPacket k = do
     return $
         writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)
 
+dnsPresentationFromPacket k = do
+    let RSAKey (MPI n) (MPI e)  = fromJust $ rsaKeyFromPacket k
+        dnskey = DNS.RSA n e
+        bin = runPut (DNS.putRSA dnskey)
+        qq  = Base64.encode (L.unpack bin)
+    return $
+        writePEM "FIXME PUBLIC KEY" qq -- ("TODO "++show keyspec)
+
+
 show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db
 
 show_ssh' keyspec wkgrip db = do
@@ -331,6 +350,8 @@ show_torhash pubkey _ = do
             asn1 <- either (const Nothing) (Just) e
             k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
             return $ f (packetFromPublicRSAKey undefined) k
+
+        addy :: String -> String
         addy hsh = take 16 hsh ++ ".onion " ++ hsh
         pkcs1 = fmap ( parsekey (\f (RSAKey n e)  -> f n e) . pemBlob )
                      $ pemParser (Just "RSA PUBLIC KEY")
@@ -421,8 +442,14 @@ bitcoinAddress network_id k = address
             Just (MPI x) = lookup 'x' (key k)
             Just (MPI y) = lookup 'y' (key k)
             pub = cannonical_eckey x y
-            hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
-            address = base58_encode hash
+#if !defined(VERSION_cryptonite)
+            hsh = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
+#else
+            hsh = S.cons network_id . ripemd160 . sha256 . S.pack $ pub
+            sha256 x = convert (Crypto.Hash.hash x :: Digest SHA256) :: S.ByteString
+            ripemd160 x = convert (Crypto.Hash.hash x :: Digest RIPEMD160) :: S.ByteString
+#endif
+            address = base58_encode hsh
 
 whoseKey :: RSAPublicKey -> KeyDB -> [KeyData]
 whoseKey rsakey db = filter matchkey (Map.elems db)
@@ -484,6 +511,11 @@ kiki_usage bExport bImport bSecret cmd = putStr $
                 ,"           Shows the fingerprint and UIDs of the key that owns the one that"
                 ,"           is input on stdin in ssh-rsa format."
                 ,""
+                ,"     --dns SPEC"
+                ,"           Outputs the DNSKEY presentation format (RFC3110) of the public key"
+                ,"           corresponding to SPEC."
+                ,"           (See 'kiki help spec' for more information.)"
+                ,""
                 ,"     --pem SPEC"
                 ,"           Outputs the PKCS #8 public key corresponding to SPEC."
                 ,"           (See 'kiki help spec' for more information.)"
@@ -1130,6 +1162,7 @@ kiki "show" args = do
                    , ("--whose-key",0)
                    , ("--key",1)
                    , ("--pem",1)
+                   , ("--dns",1)
                    , ("--ssh",1)
                    , ("--wip",1)
                    , ("--cert",1)
@@ -1180,6 +1213,7 @@ kiki "show" args = do
                                       ,("--whose-key", const $ show_whose_key input_key)
                                       ,("--key",\[x] -> show_id x $ fromMaybe "" grip)
                                       ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip)
+                                      ,("--dns",\[x] -> show_dns x $ fromMaybe "" grip)
                                       ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip)
                                       ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip)
                                       ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip)
@@ -1253,6 +1287,7 @@ kiki "merge" args = do
                 w:xs -> w:map (drop 1) xs
                 []   -> []
         (goods,bads) = partition acceptable ws
+        acceptable :: String -> Bool
         acceptable "spill"   = True
         acceptable "fill"    = True
         acceptable "sync"    = True
@@ -1496,7 +1531,7 @@ kiki "init-key" args = do
             goti <- doesFileExist (ipsecpathpub)
             when (not goti) $ do
                 either warn (writeFile $ ipsecpathpub)
-                    $ show_pem' "strongswan" grip (rtKeyDB rt)
+                    $ show_pem' "strongswan" grip (rtKeyDB rt) pemFromPacket
         else return ()
 
 
@@ -1585,7 +1620,8 @@ interp vars raw = es >>= interp1
  where
     gs = groupBy (\_ c -> c/='%') raw
     es = dropWhile null $ gobbleEscapes ("":gs)
-            where gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs
+            where gobbleEscapes :: [String] -> [String]
+                  gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs
                   gobbleEscapes (g:gs)       = g : gobbleEscapes gs
                   gobbleEscapes []           = []
     interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest