GPG signing with stack sig sign sdist and stack upload --sign

src/Stack/Package.hs

@@ -33,9 +33,14 @@ module Stack.Package
   ,packageIdentifier
   ,autogenDir
   ,checkCabalFileName
-  ,printCabalFileWarning)
+  ,printCabalFileWarning
+  ,cabalFilePackageId)
   where
 
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative (Applicative, (<$>), (<*>))
+#endif
+
 import           Control.Arrow ((&&&))
 import           Control.Exception hiding (try,catch)
 import           Control.Monad
@@ -60,16 +65,21 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Text.Encoding (decodeUtf8, decodeUtf8With)
 import           Data.Text.Encoding.Error (lenientDecode)
+import           Data.Version (showVersion)
 import           Distribution.Compiler
 import           Distribution.ModuleName (ModuleName)
 import qualified Distribution.ModuleName as Cabal
 import           Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
+import qualified Distribution.Package as D
 import           Distribution.PackageDescription hiding (FlagName)
+import qualified Distribution.PackageDescription as D
 import           Distribution.PackageDescription.Parse
+import qualified Distribution.PackageDescription.Parse as D
 import           Distribution.ParseUtils
 import           Distribution.Simple.Utils
 import           Distribution.System (OS (..), Arch, Platform (..))
 import           Distribution.Text (display, simpleParse)
+import qualified Distribution.Verbosity as D
 import           Path as FL
 import           Path.Extra
 import           Path.Find
@@ -1094,3 +1104,16 @@ resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs
                  => FilePath.FilePath
                  -> m (Maybe (Path Abs Dir))
 resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe
+
+-- | Extract the @PackageIdentifier@ given an exploded haskell package
+-- path.
+cabalFilePackageId
+    :: (Applicative m, MonadIO m, MonadThrow m)
+    => Path Abs File -> m PackageIdentifier
+cabalFilePackageId fp = do
+    pkgDescr <- liftIO (D.readPackageDescription D.silent $ toFilePath fp)
+    (toStackPI . D.package . D.packageDescription) pkgDescr
+  where
+    toStackPI (D.PackageIdentifier (D.PackageName name) ver) =
+        PackageIdentifier <$> parsePackageNameFromString name <*>
+        parseVersionFromString (showVersion ver)

src/Stack/Sig.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+{-|
+Module      : Stack.Sig
+Description : GPG Signatures for Stack
+Copyright   : (c) FPComplete.com, 2015
+License     : BSD3
+Maintainer  : Tim Dysinger <tim@fpcomplete.com>
+Stability   : experimental
+Portability : POSIX
+-}
+
+module Stack.Sig
+       ( module Sig
+       , sigCmdName
+       , sigSignCmdName
+       , sigSignHackageCmdName
+       , sigSignHackageOpts
+       , sigSignSdistCmdName
+       , sigSignSdistOpts
+       )
+       where
+
+import Options.Applicative
+import Stack.Sig.GPG as Sig
+import Stack.Sig.Sign as Sig
+
+-- | The command name for dealing with signatures.
+sigCmdName :: String
+sigCmdName = "sig"
+
+-- | The command name for signing packages.
+sigSignCmdName :: String
+sigSignCmdName = "sign"
+
+-- | The command name for signing an sdist package file.
+sigSignSdistCmdName :: String
+sigSignSdistCmdName = "sdist"
+
+-- | The command name for signing all your packages from hackage.org.
+sigSignHackageCmdName :: String
+sigSignHackageCmdName = "hackage"
+
+-- | The URL of the running signature service to use (sig-service)
+url :: Parser String
+url = strOption
+        (long "url" <>
+         short 'u' <>
+         metavar "URL" <>
+         showDefault <>
+         value "https://sig.commercialhaskell.org")
+
+-- | Signature sign (sdist) options
+sigSignSdistOpts :: Parser (String, String)
+sigSignSdistOpts = helper <*>
+    ((,) <$> url <*>
+     argument str (metavar "PATH"))
+
+-- | Signature sign (hackage) options
+sigSignHackageOpts :: Parser (String, String)
+sigSignHackageOpts = helper <*>
+    ((,) <$> url <*>
+     argument str (metavar "USER"))

src/Stack/Sig/GPG.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE RankNTypes      #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-|
+Module      : Stack.Sig.GPG
+Description : GPG Functions
+Copyright   : (c) FPComplete.com, 2015
+License     : BSD3
+Maintainer  : Tim Dysinger <tim@fpcomplete.com>
+Stability   : experimental
+Portability : POSIX
+-}
+
+module Stack.Sig.GPG (fullFingerprint, signPackage, verifyFile)
+       where
+
+#if __GLASGOW_HASKELL__ < 710
+import           Control.Applicative ((<$>))
+#endif
+
+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
+import           Path
+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)
+    => Path Abs File -> m Signature
+signPackage path = do
+    (code,out,err) <-
+        liftIO
+            (readProcessWithExitCode
+                 "gpg"
+                 [ "--output"
+                 , "-"
+                 , "--use-agent"
+                 , "--detach-sig"
+                 , "--armor"
+                 , toFilePath path]
+                 [])
+    if code /= ExitSuccess
+        then throwM (GPGSignException (out ++ "\n" ++ err))
+        else return (Signature (C.pack out))
+
+-- | Verify the @Signature@ of a file path returning the
+-- @Fingerprint@.
+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
+    if code /= ExitSuccess
+        then throwM (GPGVerifyException (out ++ "\n" ++ err))
+        else maybe
+                 (throwM
+                      (GPGFingerprintException
+                           ("unable to extract short 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)))

src/Stack/Sig/Sign.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+{-|
+Module      : Stack.Sig.Sign
+Description : Signing Packages
+Copyright   : (c) FPComplete.com, 2015
+License     : BSD3
+Maintainer  : Tim Dysinger <tim@fpcomplete.com>
+Stability   : experimental
+Portability : POSIX
+-}
+
+module Stack.Sig.Sign (sign, signTarBytes) where
+
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Compression.GZip as GZip
+import           Control.Monad (when)
+import           Control.Monad.Catch
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Trans.Control
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy as L
+import           Data.Monoid ((<>))
+import qualified Data.Text as T
+import           Data.UUID (toString)
+import           Data.UUID.V4 (nextRandom)
+import           Network.HTTP.Conduit
+       (Response(..), RequestBody(..), Request(..), httpLbs, newManager,
+        tlsManagerSettings)
+import           Network.HTTP.Download
+import           Network.HTTP.Types (status200, methodPut)
+import           Path
+import           Path.IO
+import           Stack.Package
+import qualified Stack.Sig.GPG as GPG
+import           Stack.Types
+import qualified System.FilePath as FP
+
+-- | Sign a haskell package with the given url of the signature
+-- service and a path to a tarball.
+sign
+    :: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
+    => Maybe (Path Abs Dir) -> String -> Path Abs File -> m ()
+sign Nothing _ _ = throwM SigNoProjectRootException
+sign (Just projectRoot) url filePath = do
+    withStackWorkTempDir
+        projectRoot
+        (\tempDir ->
+              do bytes <-
+                     liftIO
+                         (fmap
+                              GZip.decompress
+                              (BS.readFile (toFilePath filePath)))
+                 maybePath <- extractCabalFile tempDir (Tar.read bytes)
+                 case maybePath of
+                     Nothing -> throwM SigInvalidSDistTarBall
+                     Just cabalPath -> do
+                         pkg <- cabalFilePackageId (tempDir </> cabalPath)
+                         signPackage url pkg filePath)
+  where
+    extractCabalFile tempDir (Tar.Next entry entries) = do
+        case Tar.entryContent entry of
+            (Tar.NormalFile lbs _) ->
+                case FP.splitFileName (Tar.entryPath entry) of
+                    (folder,file)
+                      | length (FP.splitDirectories folder) == 1 &&
+                            FP.takeExtension file == ".cabal" -> do
+                          cabalFile <- parseRelFile file
+                          liftIO
+                              (BS.writeFile
+                                   (toFilePath (tempDir </> cabalFile))
+                                   lbs)
+                          return (Just cabalFile)
+                    (_,_) -> extractCabalFile tempDir entries
+            _ -> extractCabalFile tempDir entries
+    extractCabalFile _ _ = return Nothing
+
+-- | Sign a haskell package with the given url to the signature
+-- service, a package tarball path (package tarball name) and a lazy
+-- bytestring of bytes that represent the tarball bytestream.  The
+-- function will write the bytes to the path in a temp dir and sign
+-- the tarball with GPG.
+signTarBytes
+    :: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
+    => Maybe (Path Abs Dir) -> String -> Path Rel File -> L.ByteString -> m ()
+signTarBytes Nothing _ _ _ = throwM SigNoProjectRootException
+signTarBytes (Just projectRoot) url tarPath bs =
+    withStackWorkTempDir
+        projectRoot
+        (\tempDir ->
+              do let tempTarBall = tempDir </> tarPath
+                 liftIO (L.writeFile (toFilePath tempTarBall) bs)
+                 sign (Just projectRoot) url tempTarBall)
+
+-- | Sign a haskell package given the url to the signature service, a
+-- @PackageIdentifier@ and a file path to the package on disk.
+signPackage
+    :: (MonadCatch m, 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))
+    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
+    req <-
+        parseUrl
+            (url <> "/upload/signature/" <> name <> "/" <> version <> "/" <>
+             T.unpack (fingerprintSample fingerprint))
+    let put =
+            req
+            { method = methodPut
+            , requestBody = RequestBodyBS signature
+            }
+    mgr <- liftIO (newManager tlsManagerSettings)
+    res <- liftIO (httpLbs put mgr)
+    when
+        (responseStatus res /= status200)
+        (throwM (GPGSignException "unable to sign & upload package"))
+
+withStackWorkTempDir
+    :: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m)
+    => Path Abs Dir -> (Path Abs Dir -> m ()) -> m ()
+withStackWorkTempDir projectRoot f = do
+    uuid <- liftIO nextRandom
+    uuidPath <- parseRelDir (toString uuid)
+    let tempDir = projectRoot </> workDirRel </> $(mkRelDir "tmp") </> uuidPath
+    bracket
+        (createTree tempDir)
+        (const (removeTree tempDir))
+        (const (f tempDir))

src/Stack/Types.hs

@@ -17,3 +17,4 @@ import Stack.Types.Image as X
 import Stack.Types.Build as X
 import Stack.Types.Package as X
 import Stack.Types.Compiler as X
+import Stack.Types.Sig as X