diff --git a/github-release.cabal b/github-release.cabal --- a/github-release.cabal +++ b/github-release.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 6c10f0a19692a85cbc12e772a291d66576e1848c8286945cb0d5bd86884dc3e4 +-- hash: ae19757f3c07e1d84f2fbfed8fa95201cf2ab78d3c4349fd95dfc0670e52fb62 name: github-release -version: 1.1.6 +version: 1.2.0 synopsis: Upload files to GitHub releases. description: GitHub Release uploads files to GitHub releases. category: Utility diff --git a/library/GitHubRelease.hs b/library/GitHubRelease.hs --- a/library/GitHubRelease.hs +++ b/library/GitHubRelease.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module GitHubRelease ( Command(..) @@ -18,25 +19,28 @@ , uploadBody ) where -import Options.Generic (type ()) +import Options.Generic (type ()) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BSL -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as Text -import qualified Data.Version as Version -import qualified GHC.Generics as Generics -import qualified Network.HTTP.Client as Client -import qualified Network.HTTP.Client.TLS as TLS -import qualified Network.HTTP.Types as HTTP -import qualified Network.Mime as MIME -import qualified Network.URI.Template as Template +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (maybe) +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import qualified Data.Version as Version +import qualified GHC.Generics as Generics +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Client.TLS as TLS +import qualified Network.HTTP.Types as HTTP +import qualified Network.Mime as MIME +import qualified Network.URI.Template as Template import qualified Network.URI.Template.Types as Template -import qualified Options.Generic as Options -import qualified Paths_github_release as This -import qualified System.IO as IO -import qualified Text.Printf as Printf +import qualified Options.Generic as Options +import qualified Paths_github_release as This +import qualified System.IO as IO +import qualified Text.Printf as Printf data Command = Upload { file :: FilePath "The path to the local file to upload." @@ -45,6 +49,15 @@ , repo :: String "The GitHub repository name." , tag :: String "The tag name." , token :: String "Your OAuth2 token."} + | Release { title :: String "The name of the release" + , owner :: Maybe String "The GitHub owner, either a user or organization." + , repo :: String "The GitHub repository name." + , tag :: String "The tag name." + , description :: Maybe String "Release description." + , token :: String "Your OAuth2 token." + , preRelease :: Maybe Bool "Indicates if this is a pre-release." + , draft :: Maybe Bool "Indicates if this is a draft." + } | Version deriving (Generics.Generic, Show) @@ -66,6 +79,16 @@ (Options.unHelpful aTag) (Options.unHelpful aFile) (Options.unHelpful aName) + Release aTitle anOwner aRepo aTag aDescription aToken aPreRelease aDraft -> + release + (Options.unHelpful aToken) + (Options.unHelpful anOwner) + (Options.unHelpful aRepo) + (Options.unHelpful aTag) + (Options.unHelpful aTitle) + (Options.unHelpful aDescription) + (Options.unHelpful aPreRelease) + (Options.unHelpful aDraft) Version -> putStrLn versionString upload :: String -> Maybe String -> String -> String -> FilePath -> String -> IO () @@ -75,8 +98,23 @@ response <- uploadFile manager uploadUrl aToken aFile aName case HTTP.statusCode (Client.responseStatus response) of 201 -> pure () - _ -> fail "Failed to upload file to release!" + _ -> fail "Failed to upload file to release!" +release :: String -> Maybe String -> String -> String -> String -> Maybe String -> Maybe Bool -> Maybe Bool -> IO () +release aToken anOwner aRepo aTag aTitle aDescription aPreRelease aDraft = do + manager <- Client.newManager TLS.tlsManagerSettings + (owner', repo') <- getOwnerRepo anOwner aRepo + let format = "https://api.github.com/repos/%s/%s/releases" + let + url :: String + url = Printf.printf format owner' repo' + response <- mkRelease manager url aToken aTag aTitle aDescription aPreRelease aDraft + let body = Aeson.eitherDecode $ Client.responseBody response :: Either String Aeson.Object + case HTTP.statusCode (Client.responseStatus response) of + 201 -> pure () + 422 -> IO.hPutStrLn IO.stderr "Release aready exists. Ignoring." + _ -> fail $ "Failed to create release! Reason: " <> (show body) + getUploadUrl :: Client.Manager -> String @@ -89,16 +127,29 @@ result <- getTag manager aToken anOwner aRepo aTag case result of Left problem -> fail ("Failed to get tag JSON: " ++ show problem) - Right json -> pure json + Right json -> pure json text <- case HashMap.lookup (Text.pack "upload_url") json of Just (Aeson.String text) -> pure text _ -> fail ("Failed to get upload URL: " ++ show json) let uploadUrl = Text.unpack text template <- case Template.parseTemplate uploadUrl of - Left problem -> fail ("Failed to parse URL template: " ++ show problem) + Left problem -> fail ("Failed to parse URL template: " ++ show problem) Right template -> pure template pure template +getOwnerRepo :: Maybe String -> String -> IO ((String, String)) +getOwnerRepo rawOwner rawRepo = do + (anOwner, aRepo) <- case break (== '/') rawRepo of + (aRepo, "") -> case rawOwner of + Nothing -> fail "Missing required option --owner." + Just anOwner -> pure (anOwner, aRepo) + (anOwner, aRepo) -> do + case rawOwner of + Nothing -> pure () + Just _ -> IO.hPutStrLn IO.stderr "Ignoring --owner option." + pure (anOwner, drop 1 aRepo) + return (anOwner, aRepo) + getTag :: Client.Manager -> String @@ -107,15 +158,7 @@ -> String -> IO (Either String Aeson.Object) getTag manager aToken rawOwner rawRepo aTag = do - (anOwner, aRepo) <- case break (== '/') rawRepo of - (aRepo, "") -> case rawOwner of - Nothing -> fail "Missing required option --owner." - Just anOwner -> pure (anOwner, aRepo) - (anOwner, aRepo) -> do - case rawOwner of - Nothing -> pure () - Just _ -> IO.hPutStrLn IO.stderr "Ignoring --owner option." - pure (anOwner, drop 1 aRepo) + (anOwner, aRepo) <- getOwnerRepo rawOwner rawRepo let format = "https://api.github.com/repos/%s/%s/releases/tags/%s" let url :: String @@ -174,6 +217,36 @@ , Client.requestHeaders = [ authorizationHeader aToken , (HTTP.hContentType, MIME.defaultMimeLookup (Text.pack aName)) + , userAgentHeader + ] + } + Client.httpLbs request manager + +mkRelease + :: Client.Manager + -> String + -> String + -> String + -> String + -> Maybe String + -> Maybe Bool + -> Maybe Bool + -> IO (Client.Response BSL.ByteString) +mkRelease manager url aToken aTag aTitle aDescription aPreRelease aDraft = do + initialRequest <- Client.parseRequest url + let requestObject = object + [ Text.pack "tag_name" .= aTag + , Text.pack "name" .= aTitle + , Text.pack "body" .= maybe "" id aDescription + , Text.pack "prerelease" .= maybe False id aPreRelease + , Text.pack "draft" .= maybe False id aDraft + ] + let request = + initialRequest + { Client.method = BS8.pack "POST" + , Client.requestBody = Client.RequestBodyLBS $ Aeson.encode requestObject + , Client.requestHeaders = + [ authorizationHeader aToken , userAgentHeader ] }