Skip to content

Commit bcf73ec

Browse files
dysingerdysinger
committed
GPG signing with stack sig sign sdist and stack upload --sign 
1 parent 6d2310f commit bcf73ec

9 files changed

Lines changed: 499 additions & 9 deletions

File tree

‎src/Stack/Package.hs‎

Lines changed: 24 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,9 +33,14 @@ module Stack.Package
3333
,packageIdentifier
3434
,autogenDir
3535
,checkCabalFileName
36-
,printCabalFileWarning)
36+
,printCabalFileWarning
37+
,cabalFilePackageId)
3738
where
3839

40+
#if __GLASGOW_HASKELL__ < 710
41+
import Control.Applicative (Applicative, (<$>), (<*>))
42+
#endif
43+
3944
import Control.Arrow ((&&&))
4045
import Control.Exception hiding (try,catch)
4146
import Control.Monad
@@ -60,16 +65,21 @@ import Data.Text (Text)
6065
import qualified Data.Text as T
6166
import Data.Text.Encoding (decodeUtf8, decodeUtf8With)
6267
import Data.Text.Encoding.Error (lenientDecode)
68+
import Data.Version (showVersion)
6369
import Distribution.Compiler
6470
import Distribution.ModuleName (ModuleName)
6571
import qualified Distribution.ModuleName as Cabal
6672
import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
73+
import qualified Distribution.Package as D
6774
import Distribution.PackageDescription hiding (FlagName)
75+
import qualified Distribution.PackageDescription as D
6876
import Distribution.PackageDescription.Parse
77+
import qualified Distribution.PackageDescription.Parse as D
6978
import Distribution.ParseUtils
7079
import Distribution.Simple.Utils
7180
import Distribution.System (OS (..), Arch, Platform (..))
7281
import Distribution.Text (display, simpleParse)
82+
import qualified Distribution.Verbosity as D
7383
import Path as FL
7484
import Path.Extra
7585
import Path.Find
@@ -1094,3 +1104,16 @@ resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs
10941104
=> FilePath.FilePath
10951105
-> m (Maybe (Path Abs Dir))
10961106
resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe
1107+
1108+
-- | Extract the @PackageIdentifier@ given an exploded haskell package
1109+
-- path.
1110+
cabalFilePackageId
1111+
:: (Applicative m, MonadIO m, MonadThrow m)
1112+
=> Path Abs File -> m PackageIdentifier
1113+
cabalFilePackageId fp = do
1114+
pkgDescr <- liftIO (D.readPackageDescription D.silent $ toFilePath fp)
1115+
(toStackPI . D.package . D.packageDescription) pkgDescr
1116+
where
1117+
toStackPI (D.PackageIdentifier (D.PackageName name) ver) =
1118+
PackageIdentifier <$> parsePackageNameFromString name <*>
1119+
parseVersionFromString (showVersion ver)

‎src/Stack/Sig.hs‎

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,65 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
5+
{-|
6+
Module : Stack.Sig
7+
Description : GPG Signatures for Stack
8+
Copyright : (c) FPComplete.com, 2015
9+
License : BSD3
10+
Maintainer : Tim Dysinger <tim@fpcomplete.com>
11+
Stability : experimental
12+
Portability : POSIX
13+
-}
14+
15+
module Stack.Sig
16+
( module Sig
17+
, sigCmdName
18+
, sigSignCmdName
19+
, sigSignHackageCmdName
20+
, sigSignHackageOpts
21+
, sigSignSdistCmdName
22+
, sigSignSdistOpts
23+
)
24+
where
25+
26+
import Options.Applicative
27+
import Stack.Sig.GPG as Sig
28+
import Stack.Sig.Sign as Sig
29+
30+
-- | The command name for dealing with signatures.
31+
sigCmdName :: String
32+
sigCmdName = "sig"
33+
34+
-- | The command name for signing packages.
35+
sigSignCmdName :: String
36+
sigSignCmdName = "sign"
37+
38+
-- | The command name for signing an sdist package file.
39+
sigSignSdistCmdName :: String
40+
sigSignSdistCmdName = "sdist"
41+
42+
-- | The command name for signing all your packages from hackage.org.
43+
sigSignHackageCmdName :: String
44+
sigSignHackageCmdName = "hackage"
45+
46+
-- | The URL of the running signature service to use (sig-service)
47+
url :: Parser String
48+
url = strOption
49+
(long "url" <>
50+
short 'u' <>
51+
metavar "URL" <>
52+
showDefault <>
53+
value "https://sig.commercialhaskell.org")
54+
55+
-- | Signature sign (sdist) options
56+
sigSignSdistOpts :: Parser (String, String)
57+
sigSignSdistOpts = helper <*>
58+
((,) <$> url <*>
59+
argument str (metavar "PATH"))
60+
61+
-- | Signature sign (hackage) options
62+
sigSignHackageOpts :: Parser (String, String)
63+
sigSignHackageOpts = helper <*>
64+
((,) <$> url <*>
65+
argument str (metavar "USER"))

‎src/Stack/Sig/GPG.hs‎

Lines changed: 102 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,102 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
5+
{-|
6+
Module : Stack.Sig.GPG
7+
Description : GPG Functions
8+
Copyright : (c) FPComplete.com, 2015
9+
License : BSD3
10+
Maintainer : Tim Dysinger <tim@fpcomplete.com>
11+
Stability : experimental
12+
Portability : POSIX
13+
-}
14+
15+
module Stack.Sig.GPG (fullFingerprint, signPackage, verifyFile)
16+
where
17+
18+
#if __GLASGOW_HASKELL__ < 710
19+
import Control.Applicative ((<$>))
20+
#endif
21+
22+
import Control.Monad.Catch (MonadThrow, throwM)
23+
import Control.Monad.IO.Class (MonadIO, liftIO)
24+
import qualified Data.ByteString.Char8 as C
25+
import Data.Char (isSpace)
26+
import Data.List (find)
27+
import Data.Monoid ((<>))
28+
import qualified Data.Text as T
29+
import Path
30+
import Stack.Types
31+
import System.Exit (ExitCode(..))
32+
import System.Process (readProcessWithExitCode)
33+
34+
-- | Extract the full long @fingerprint@ given a short (or long)
35+
-- @fingerprint@
36+
fullFingerprint
37+
:: (Monad m, MonadIO m, MonadThrow m)
38+
=> Fingerprint -> m Fingerprint
39+
fullFingerprint (Fingerprint fp) = do
40+
(code,out,err) <-
41+
liftIO
42+
(readProcessWithExitCode "gpg" ["--fingerprint", T.unpack fp] [])
43+
if code /= ExitSuccess
44+
then throwM (GPGFingerprintException (out ++ "\n" ++ err))
45+
else maybe
46+
(throwM
47+
(GPGFingerprintException
48+
("unable to extract full fingerprint from output:\n " <>
49+
out)))
50+
return
51+
(let hasFingerprint =
52+
(==) ["Key", "fingerprint", "="] . take 3
53+
fingerprint =
54+
T.filter (not . isSpace) . T.pack . unwords . drop 3
55+
in Fingerprint . fingerprint <$>
56+
find hasFingerprint (map words (lines out)))
57+
58+
-- | Sign a file path with GPG, returning the @Signature@.
59+
signPackage
60+
:: (Monad m, MonadIO m, MonadThrow m)
61+
=> Path Abs File -> m Signature
62+
signPackage path = do
63+
(code,out,err) <-
64+
liftIO
65+
(readProcessWithExitCode
66+
"gpg"
67+
[ "--output"
68+
, "-"
69+
, "--use-agent"
70+
, "--detach-sig"
71+
, "--armor"
72+
, toFilePath path]
73+
[])
74+
if code /= ExitSuccess
75+
then throwM (GPGSignException (out ++ "\n" ++ err))
76+
else return (Signature (C.pack out))
77+
78+
-- | Verify the @Signature@ of a file path returning the
79+
-- @Fingerprint@.
80+
verifyFile
81+
:: (Monad m, MonadIO m, MonadThrow m)
82+
=> Signature -> Path Abs File -> m Fingerprint
83+
verifyFile (Signature signature) path = do
84+
let process =
85+
readProcessWithExitCode
86+
"gpg"
87+
["--verify", "-", toFilePath path]
88+
(C.unpack signature)
89+
(code,out,err) <- liftIO process
90+
if code /= ExitSuccess
91+
then throwM (GPGVerifyException (out ++ "\n" ++ err))
92+
else maybe
93+
(throwM
94+
(GPGFingerprintException
95+
("unable to extract short fingerprint from output\n: " <>
96+
out)))
97+
return
98+
(let hasFingerprint =
99+
(==) ["gpg:", "Signature", "made"] . take 3
100+
fingerprint = T.pack . last
101+
in Fingerprint . fingerprint <$>
102+
find hasFingerprint (map words (lines err)))

‎src/Stack/Sig/Sign.hs‎

Lines changed: 137 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,137 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RankNTypes #-}
4+
{-# LANGUAGE TemplateHaskell #-}
5+
6+
{-|
7+
Module : Stack.Sig.Sign
8+
Description : Signing Packages
9+
Copyright : (c) FPComplete.com, 2015
10+
License : BSD3
11+
Maintainer : Tim Dysinger <tim@fpcomplete.com>
12+
Stability : experimental
13+
Portability : POSIX
14+
-}
15+
16+
module Stack.Sig.Sign (sign, signTarBytes) where
17+
18+
import qualified Codec.Archive.Tar as Tar
19+
import qualified Codec.Compression.GZip as GZip
20+
import Control.Monad (when)
21+
import Control.Monad.Catch
22+
import Control.Monad.IO.Class
23+
import Control.Monad.Logger
24+
import Control.Monad.Trans.Control
25+
import qualified Data.ByteString.Lazy as BS
26+
import qualified Data.ByteString.Lazy as L
27+
import Data.Monoid ((<>))
28+
import qualified Data.Text as T
29+
import Data.UUID (toString)
30+
import Data.UUID.V4 (nextRandom)
31+
import Network.HTTP.Conduit
32+
(Response(..), RequestBody(..), Request(..), httpLbs, newManager,
33+
tlsManagerSettings)
34+
import Network.HTTP.Download
35+
import Network.HTTP.Types (status200, methodPut)
36+
import Path
37+
import Path.IO
38+
import Stack.Package
39+
import qualified Stack.Sig.GPG as GPG
40+
import Stack.Types
41+
import qualified System.FilePath as FP
42+
43+
-- | Sign a haskell package with the given url of the signature
44+
-- service and a path to a tarball.
45+
sign
46+
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
47+
=> Maybe (Path Abs Dir) -> String -> Path Abs File -> m ()
48+
sign Nothing _ _ = throwM SigNoProjectRootException
49+
sign (Just projectRoot) url filePath = do
50+
withStackWorkTempDir
51+
projectRoot
52+
(\tempDir ->
53+
do bytes <-
54+
liftIO
55+
(fmap
56+
GZip.decompress
57+
(BS.readFile (toFilePath filePath)))
58+
maybePath <- extractCabalFile tempDir (Tar.read bytes)
59+
case maybePath of
60+
Nothing -> throwM SigInvalidSDistTarBall
61+
Just cabalPath -> do
62+
pkg <- cabalFilePackageId (tempDir </> cabalPath)
63+
signPackage url pkg filePath)
64+
where
65+
extractCabalFile tempDir (Tar.Next entry entries) = do
66+
case Tar.entryContent entry of
67+
(Tar.NormalFile lbs _) ->
68+
case FP.splitFileName (Tar.entryPath entry) of
69+
(folder,file)
70+
| length (FP.splitDirectories folder) == 1 &&
71+
FP.takeExtension file == ".cabal" -> do
72+
cabalFile <- parseRelFile file
73+
liftIO
74+
(BS.writeFile
75+
(toFilePath (tempDir </> cabalFile))
76+
lbs)
77+
return (Just cabalFile)
78+
(_,_) -> extractCabalFile tempDir entries
79+
_ -> extractCabalFile tempDir entries
80+
extractCabalFile _ _ = return Nothing
81+
82+
-- | Sign a haskell package with the given url to the signature
83+
-- service, a package tarball path (package tarball name) and a lazy
84+
-- bytestring of bytes that represent the tarball bytestream. The
85+
-- function will write the bytes to the path in a temp dir and sign
86+
-- the tarball with GPG.
87+
signTarBytes
88+
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
89+
=> Maybe (Path Abs Dir) -> String -> Path Rel File -> L.ByteString -> m ()
90+
signTarBytes Nothing _ _ _ = throwM SigNoProjectRootException
91+
signTarBytes (Just projectRoot) url tarPath bs =
92+
withStackWorkTempDir
93+
projectRoot
94+
(\tempDir ->
95+
do let tempTarBall = tempDir </> tarPath
96+
liftIO (L.writeFile (toFilePath tempTarBall) bs)
97+
sign (Just projectRoot) url tempTarBall)
98+
99+
-- | Sign a haskell package given the url to the signature service, a
100+
-- @PackageIdentifier@ and a file path to the package on disk.
101+
signPackage
102+
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
103+
=> String -> PackageIdentifier -> Path Abs File -> m ()
104+
signPackage url pkg filePath = do
105+
$logInfo ("GPG signing " <> T.pack (toFilePath filePath))
106+
sig@(Signature signature) <- GPG.signPackage filePath
107+
let (PackageIdentifier n v) = pkg
108+
name = show n
109+
version = show v
110+
verify <- GPG.verifyFile sig filePath
111+
fingerprint <- GPG.fullFingerprint verify
112+
req <-
113+
parseUrl
114+
(url <> "/upload/signature/" <> name <> "/" <> version <> "/" <>
115+
T.unpack (fingerprintSample fingerprint))
116+
let put =
117+
req
118+
{ method = methodPut
119+
, requestBody = RequestBodyBS signature
120+
}
121+
mgr <- liftIO (newManager tlsManagerSettings)
122+
res <- liftIO (httpLbs put mgr)
123+
when
124+
(responseStatus res /= status200)
125+
(throwM (GPGSignException "unable to sign & upload package"))
126+
127+
withStackWorkTempDir
128+
:: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m)
129+
=> Path Abs Dir -> (Path Abs Dir -> m ()) -> m ()
130+
withStackWorkTempDir projectRoot f = do
131+
uuid <- liftIO nextRandom
132+
uuidPath <- parseRelDir (toString uuid)
133+
let tempDir = projectRoot </> workDirRel </> $(mkRelDir "tmp") </> uuidPath
134+
bracket
135+
(createTree tempDir)
136+
(const (removeTree tempDir))
137+
(const (f tempDir))

‎src/Stack/Types.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,3 +17,4 @@ import Stack.Types.Image as X
1717
import Stack.Types.Build as X
1818
import Stack.Types.Package as X
1919
import Stack.Types.Compiler as X
20+
import Stack.Types.Sig as X

0 commit comments

Comments
 (0)