diff --git a/src/Stack/Sig/GPG.hs b/src/Stack/Sig/GPG.hs index d19f878e12..85c40d590e 100644 --- a/src/Stack/Sig/GPG.hs +++ b/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))) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index 4aaf44e998..0ade2565ad 100644 --- a/src/Stack/Sig/Sign.hs +++ b/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) diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs index 09527eb8a3..7763d26f86 100644 --- a/src/Stack/Types/Sig.hs +++ b/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