{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Stack.Sig.Sign (sign, signPackage, signTarBytes) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import Stack.Prelude
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy as L
import Network.HTTP.Download
import Network.HTTP.StackClient (RequestBody (RequestBodyBS), setRequestMethod, setRequestBody, getResponseStatusCode, methodPut)
import Path
import Stack.Package
import Stack.Sig.GPG
import Stack.Types.PackageIdentifier
import Stack.Types.Sig
import qualified System.FilePath as FP
sign
:: HasLogFunc env
=> String -> Path Abs File -> RIO env Signature
sign url filePath =
withRunInIO $ \run ->
withSystemTempDir
"stack"
(\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)
run (signPackage url pkg filePath))
where
extractCabalFile tempDir (Tar.Next entry entries) =
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
signTarBytes
:: HasLogFunc env
=> String -> Path Rel File -> L.ByteString -> RIO env Signature
signTarBytes url tarPath bs =
withSystemTempDir
"stack"
(\tempDir ->
do let tempTarBall = tempDir </> tarPath
liftIO (L.writeFile (toFilePath tempTarBall) bs)
sign url tempTarBall)
signPackage
:: HasLogFunc env
=> String -> PackageIdentifier -> Path Abs File -> RIO env Signature
signPackage url pkg filePath = do
sig@(Signature signature) <- gpgSign filePath
let (PackageIdentifier name version) = pkg
fingerprint <- gpgVerify sig filePath
let fullUrl =
url <> "/upload/signature/" <> show name <> "/" <> show version <>
"/" <>
show fingerprint
req <- parseUrlThrow fullUrl
let put = setRequestMethod methodPut
$ setRequestBody (RequestBodyBS signature) req
res <- liftIO (httpLbs put)
when
(getResponseStatusCode res /= 200)
(throwM (GPGSignException "unable to sign & upload package"))
logInfo ("Signature uploaded to " <> fromString fullUrl)
return sig