Always use full fingerprints from GPG

src/Stack/Sig/GPG.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE CPP             #-}
-{-# LANGUAGE RankNTypes      #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
 
 {-|
 Module      : Stack.Sig.GPG
@@ -12,8 +10,7 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-module Stack.Sig.GPG (fullFingerprint, signPackage, verifyFile)
-       where
+module Stack.Sig.GPG (signPackage, verifyFile) where
 
 #if __GLASGOW_HASKELL__ < 710
 import           Control.Applicative ((<$>))
@@ -22,7 +19,6 @@ import           Control.Applicative ((<$>))
 import           Control.Monad.Catch (MonadThrow, throwM)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Data.ByteString.Char8 as C
-import           Data.Char (isSpace)
 import           Data.List (find)
 import           Data.Monoid ((<>))
 import qualified Data.Text as T
@@ -31,30 +27,6 @@ import           Stack.Types
 import           System.Exit (ExitCode(..))
 import           System.Process (readProcessWithExitCode)
 
--- | Extract the full long @fingerprint@ given a short (or long)
--- @fingerprint@
-fullFingerprint
-    :: (Monad m, MonadIO m, MonadThrow m)
-    => Fingerprint -> m Fingerprint
-fullFingerprint (Fingerprint fp) = do
-    (code,out,err) <-
-        liftIO
-            (readProcessWithExitCode "gpg" ["--fingerprint", T.unpack fp] [])
-    if code /= ExitSuccess
-        then throwM (GPGFingerprintException (out ++ "\n" ++ err))
-        else maybe
-                 (throwM
-                      (GPGFingerprintException
-                           ("unable to extract full fingerprint from output:\n " <>
-                            out)))
-                 return
-                 (let hasFingerprint =
-                          (==) ["Key", "fingerprint", "="] . take 3
-                      fingerprint =
-                          T.filter (not . isSpace) . T.pack . unwords . drop 3
-                  in Fingerprint . fingerprint <$>
-                     find hasFingerprint (map words (lines out)))
-
 -- | Sign a file path with GPG, returning the @Signature@.
 signPackage
     :: (Monad m, MonadIO m, MonadThrow m)
@@ -81,22 +53,21 @@ verifyFile
     :: (Monad m, MonadIO m, MonadThrow m)
     => Signature -> Path Abs File -> m Fingerprint
 verifyFile (Signature signature) path = do
-    let process =
-            readProcessWithExitCode
-                "gpg"
-                ["--verify", "-", toFilePath path]
-                (C.unpack signature)
-    (code,out,err) <- liftIO process
+    (code,out,err) <-
+        liftIO
+            (readProcessWithExitCode
+                 "gpg"
+                 ["--verify", "-", toFilePath path]
+                 (C.unpack signature))
     if code /= ExitSuccess
         then throwM (GPGVerifyException (out ++ "\n" ++ err))
         else maybe
                  (throwM
                       (GPGFingerprintException
-                           ("unable to extract short fingerprint from output\n: " <>
+                           ("unable to extract fingerprint from output\n: " <>
                             out)))
                  return
-                 (let hasFingerprint =
-                          (==) ["gpg:", "Signature", "made"] . take 3
-                      fingerprint = T.pack . last
-                  in Fingerprint . fingerprint <$>
-                     find hasFingerprint (map words (lines err)))
+                 (mkFingerprint . T.pack . concat . drop 3 <$>
+                  find
+                      ((==) ["Primary", "key", "fingerprint:"] . take 3)
+                      (map words (lines err)))

src/Stack/Sig/Sign.hs

@@ -46,7 +46,7 @@ sign
     :: (MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
     => Maybe (Path Abs Dir) -> String -> Path Abs File -> m ()
 sign Nothing _ _ = throwM SigNoProjectRootException
-sign (Just projectRoot) url filePath = do
+sign (Just projectRoot) url filePath =
     withStackWorkTempDir
         projectRoot
         (\tempDir ->
@@ -62,7 +62,7 @@ sign (Just projectRoot) url filePath = do
                          pkg <- cabalFilePackageId (tempDir </> cabalPath)
                          signPackage url pkg filePath)
   where
-    extractCabalFile tempDir (Tar.Next entry entries) = do
+    extractCabalFile tempDir (Tar.Next entry entries) =
         case Tar.entryContent entry of
             (Tar.NormalFile lbs _) ->
                 case FP.splitFileName (Tar.entryPath entry) of
@@ -102,17 +102,16 @@ signPackage
     :: (MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
     => String -> PackageIdentifier -> Path Abs File -> m ()
 signPackage url pkg filePath = do
-    $logInfo ("GPG signing " <> T.pack (toFilePath filePath))
+    $logInfo ("Signing " <> T.pack (toFilePath filePath))
     sig@(Signature signature) <- GPG.signPackage filePath
     let (PackageIdentifier n v) = pkg
         name = show n
         version = show v
-    verify <- GPG.verifyFile sig filePath
-    fingerprint <- GPG.fullFingerprint verify
+    fingerprint <- GPG.verifyFile sig filePath
     req <-
         parseUrl
             (url <> "/upload/signature/" <> name <> "/" <> version <> "/" <>
-             T.unpack (fingerprintSample fingerprint))
+             show fingerprint)
     let put =
             req
             { method = methodPut
@@ -123,6 +122,7 @@ signPackage url pkg filePath = do
     when
         (responseStatus res /= status200)
         (throwM (GPGSignException "unable to sign & upload package"))
+    $logInfo ("Signed successfully with key " <> (T.pack . show) fingerprint)
 
 withStackWorkTempDir
     :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env)

src/Stack/Types/Sig.hs

@@ -1,7 +1,7 @@
+{-# LANGUAGE CPP                #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RecordWildCards    #-}
 
 {-|
 Module      : Stack.Types.Sig
@@ -14,14 +14,17 @@ Portability : POSIX
 -}
 
 module Stack.Types.Sig
-       (Signature(..), Fingerprint(..), SigException(..))
-       where
+       (Signature(..), Fingerprint, mkFingerprint, SigException(..)) where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative ((<$>))
+#endif
 
 import           Control.Exception (Exception)
 import           Data.Aeson (Value(..), ToJSON(..), FromJSON(..))
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as SB
-import           Data.Char (isDigit, isAlpha, isSpace)
+import           Data.Char (isHexDigit)
 import           Data.Monoid ((<>))
 import           Data.String (IsString(..))
 import           Data.Text (Text)
@@ -42,27 +45,27 @@ instance Show Signature where
              else show (SB.take 140 s))
 
 -- | The GPG fingerprint.
-newtype Fingerprint = Fingerprint
-    { fingerprintSample :: Text
-    } deriving (Eq,Ord,Show)
+newtype Fingerprint =
+    Fingerprint Text
+    deriving (Eq,Ord)
+
+mkFingerprint :: Text -> Fingerprint
+mkFingerprint = Fingerprint . hexText
+
+hexText :: Text -> Text
+hexText = T.toUpper . T.dropWhile (not . isHexDigit)
+
+instance Show Fingerprint where
+    show (Fingerprint hex) = T.unpack (hexText hex)
 
 instance FromJSON Fingerprint where
-    parseJSON j = do
-        s <- parseJSON j
-        let withoutSpaces = T.filter (not . isSpace) s
-        if T.null withoutSpaces ||
-           T.all
-               (\c ->
-                     isAlpha c || isDigit c || isSpace c)
-               withoutSpaces
-            then return (Fingerprint withoutSpaces)
-            else fail ("Expected fingerprint, but got: " ++ T.unpack s)
+    parseJSON j = Fingerprint . hexText <$> parseJSON j
 
 instance ToJSON Fingerprint where
-    toJSON (Fingerprint txt) = String txt
+    toJSON (Fingerprint hex) = String (hexText hex)
 
 instance IsString Fingerprint where
-    fromString = Fingerprint . T.pack
+    fromString = Fingerprint . hexText . T.pack
 
 instance FromJSON (Aeson PackageName) where
     parseJSON j = do