diff --git a/LICENSE.markdown b/LICENSE.markdown --- a/LICENSE.markdown +++ b/LICENSE.markdown @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2022 Taylor Fausak +Copyright (c) 2023 Taylor Fausak Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/github-release.cabal b/github-release.cabal --- a/github-release.cabal +++ b/github-release.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: github-release -version: 2.0.0.2 +version: 2.0.0.3 synopsis: Upload files to GitHub releases. description: GitHub Release uploads files to GitHub releases. @@ -24,38 +24,35 @@ common library build-depends: - , base >= 4.13.0 && < 4.18 + , base >= 4.15.0 && < 4.18 , aeson >= 1.4.7 && < 1.6 || >= 2.0.0 && < 2.2 , burrito >= 1.2.0 && < 1.3 || >= 2.0.0 && < 2.1 - , bytestring >= 0.10.10 && < 0.12 + , bytestring >= 0.10.12 && < 0.12 , http-client >= 0.6.4 && < 0.8 , http-client-tls >= 0.3.5 && < 0.4 , http-types >= 0.12.3 && < 0.13 , mime-types >= 0.1.0 && < 0.2 , optparse-generic >= 1.3.1 && < 1.5 - , text >= 1.2.4 && < 1.3 || >= 2.0 && < 2.1 + , text >= 1.2.5 && < 1.3 || >= 2.0 && < 2.1 , unordered-containers >= 0.2.10 && < 0.3 default-language: Haskell2010 ghc-options: -Weverything + -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missing-deriving-strategies -Wno-missing-exported-signatures + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe - -Wno-all-missed-specialisations - if flag(pedantic) - ghc-options: -Werror - - if impl(ghc >= 8.10) - ghc-options: - -Wno-missing-safe-haskell-mode - -Wno-prepositive-qualified-module - if impl(ghc >= 9.2) ghc-options: -Wno-missing-kind-signatures + + if flag(pedantic) + ghc-options: -Werror common executable import: library diff --git a/source/executable/Main.hs b/source/executable/Main.hs --- a/source/executable/Main.hs +++ b/source/executable/Main.hs @@ -1,5 +1,6 @@ module Main - ( module GitHubRelease - ) where + ( module GitHubRelease, + ) +where import GitHubRelease (main) diff --git a/source/library/GitHubRelease.hs b/source/library/GitHubRelease.hs --- a/source/library/GitHubRelease.hs +++ b/source/library/GitHubRelease.hs @@ -1,30 +1,28 @@ -{-# OPTIONS_GHC -Wno-partial-fields #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} module GitHubRelease - ( Command(..) - , main - , runCommand - , upload - , getUploadUrl - , getTag - , authorizationHeader - , userAgentHeader - , userAgent - , versionString - , uploadFile - , uploadBody - ) where - -import Options.Generic (type ()) + ( Command (..), + main, + runCommand, + upload, + getUploadUrl, + getTag, + authorizationHeader, + userAgentHeader, + userAgent, + versionString, + uploadFile, + uploadBody, + ) +where import qualified Burrito -import Data.Aeson ((.=), object) +import Data.Aeson (object, (.=)) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL @@ -37,6 +35,7 @@ import qualified Network.HTTP.Client.TLS as TLS import qualified Network.HTTP.Types as HTTP import qualified Network.Mime as MIME +import Options.Generic (type ()) import qualified Options.Generic as Options import qualified Paths_github_release as This import qualified System.Environment as Environment @@ -44,28 +43,31 @@ import qualified Text.Printf as Printf data Command - = Upload { file :: FilePath "The path to the local file to upload." - , name :: String "The name to give the file on the release." - , owner :: Maybe String "The GitHub owner, either a user or organization." - , repo :: String "The GitHub repository name." - , tag :: String "The tag name." - , token :: Maybe 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 :: Maybe String "Your OAuth2 token." - , preRelease :: Maybe Bool "Indicates if this is a pre-release." - , draft :: Maybe Bool "Indicates if this is a draft." - } + = Upload + { file :: FilePath "The path to the local file to upload.", + name :: String "The name to give the file on the release.", + owner :: Maybe String "The GitHub owner, either a user or organization.", + repo :: String "The GitHub repository name.", + tag :: String "The tag name.", + token :: Maybe 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 :: Maybe String "Your OAuth2 token.", + preRelease :: Maybe Bool "Indicates if this is a pre-release.", + draft :: Maybe Bool "Indicates if this is a draft." + } | Delete - { name :: String "The name to give the file on the release." - , owner :: Maybe String "The GitHub owner, either a user or organization." - , repo :: String "The GitHub repository name." - , tag :: String "The tag name." - , token :: Maybe String "Your OAuth2 token." - } + { name :: String "The name to give the file on the release.", + owner :: Maybe String "The GitHub owner, either a user or organization.", + repo :: String "The GitHub repository name.", + tag :: String "The tag name.", + token :: Maybe String "Your OAuth2 token." + } | Version deriving (Generics.Generic, Show) @@ -79,8 +81,9 @@ runCommand :: Command -> IO () runCommand command = case command of Upload aFile aName anOwner aRepo aTag helpfulToken -> do - aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure - $ Options.unHelpful helpfulToken + aToken <- + maybe (Environment.getEnv "GITHUB_TOKEN") pure $ + Options.unHelpful helpfulToken upload aToken (Options.unHelpful anOwner) @@ -88,10 +91,11 @@ (Options.unHelpful aTag) (Options.unHelpful aFile) (Options.unHelpful aName) - Release aTitle anOwner aRepo aTag aDescription helpfulToken aPreRelease aDraft - -> do - aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure - $ Options.unHelpful helpfulToken + Release aTitle anOwner aRepo aTag aDescription helpfulToken aPreRelease aDraft -> + do + aToken <- + maybe (Environment.getEnv "GITHUB_TOKEN") pure $ + Options.unHelpful helpfulToken release aToken (Options.unHelpful anOwner) @@ -102,8 +106,9 @@ (Options.unHelpful aPreRelease) (Options.unHelpful aDraft) Delete aName anOwner aRepo aTag helpfulToken -> do - aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure - $ Options.unHelpful helpfulToken + aToken <- + maybe (Environment.getEnv "GITHUB_TOKEN") pure $ + Options.unHelpful helpfulToken delete (Options.unHelpful aName) (Options.unHelpful anOwner) @@ -112,8 +117,8 @@ aToken Version -> putStrLn versionString -upload - :: String -> Maybe String -> String -> String -> FilePath -> String -> IO () +upload :: + String -> Maybe String -> String -> String -> FilePath -> String -> IO () upload aToken anOwner aRepo aTag aFile aName = do manager <- Client.newManager TLS.tlsManagerSettings uploadUrl <- getUploadUrl manager aToken anOwner aRepo aTag @@ -122,37 +127,37 @@ 201 -> pure () _ -> fail "Failed to upload file to release!" -release - :: String - -> Maybe String - -> String - -> String - -> String - -> Maybe String - -> Maybe Bool - -> Maybe Bool - -> IO () +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" :: String - 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 + 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." @@ -171,42 +176,44 @@ [] -> fail "Failed to find asset on release." ghAsset : _ -> do request <- Client.parseRequest $ ghAssetUrl ghAsset - response <- Client.httpLbs - request - { Client.method = HTTP.methodDelete - , Client.requestHeaders = - [authorizationHeader aToken, userAgentHeader] - } - manager + response <- + Client.httpLbs + request + { Client.method = HTTP.methodDelete, + Client.requestHeaders = + [authorizationHeader aToken, userAgentHeader] + } + manager case HTTP.statusCode $ Client.responseStatus response of 204 -> pure () _ -> fail $ "Failed to delete asset from release! " <> show response newtype GHRelease = GHRelease { ghReleaseAssets :: [GHAsset] - } deriving (Eq, Show) + } + deriving (Eq, Show) instance Aeson.FromJSON GHRelease where parseJSON = Aeson.withObject "GHRelease" $ \obj -> GHRelease <$> obj Aeson..: "assets" data GHAsset = GHAsset - { ghAssetName :: String - , ghAssetUrl :: String + { ghAssetName :: String, + ghAssetUrl :: String } deriving (Eq, Show) instance Aeson.FromJSON GHAsset where - parseJSON = Aeson.withObject "GHAsset" - $ \obj -> GHAsset <$> obj Aeson..: "name" <*> obj Aeson..: "url" + parseJSON = Aeson.withObject "GHAsset" $ + \obj -> GHAsset <$> obj Aeson..: "name" <*> obj Aeson..: "url" -getUploadUrl - :: Client.Manager - -> String - -> Maybe String - -> String - -> String - -> IO Burrito.Template +getUploadUrl :: + Client.Manager -> + String -> + Maybe String -> + String -> + String -> + IO Burrito.Template getUploadUrl manager aToken rawOwner rawRepo aTag = do json <- do (anOwner, aRepo) <- getOwnerRepo rawOwner rawRepo @@ -235,24 +242,23 @@ pure (anOwner, drop 1 aRepo) return (anOwner, aRepo) -getTag - :: Aeson.FromJSON a - => Client.Manager - -> String - -> String - -> String - -> String - -> IO (Either String a) +getTag :: + (Aeson.FromJSON a) => + Client.Manager -> + String -> + String -> + String -> + String -> + IO (Either String a) getTag manager aToken anOwner aRepo aTag = do let format = "https://api.github.com/repos/%s/%s/releases/tags/%s" :: String - let - url :: String - url = Printf.printf format anOwner aRepo aTag + let url :: String + url = Printf.printf format anOwner aRepo aTag initialRequest <- Client.parseRequest url - let - request = initialRequest - { Client.requestHeaders = [authorizationHeader aToken, userAgentHeader] - } + let request = + initialRequest + { Client.requestHeaders = [authorizationHeader aToken, userAgentHeader] + } response <- Client.httpLbs request manager let body = Client.responseBody response return (Aeson.eitherDecode body) @@ -265,75 +271,75 @@ userAgentHeader = (HTTP.hUserAgent, BS8.pack userAgent) userAgent :: String -userAgent = Printf.printf - "%s/%s-%s" - ("tfausak" :: String) - ("github-release" :: String) - versionString +userAgent = + Printf.printf + "%s/%s-%s" + ("tfausak" :: String) + ("github-release" :: String) + versionString versionString :: String versionString = Version.showVersion This.version -uploadFile - :: Client.Manager - -> Burrito.Template - -> String - -> FilePath - -> String - -> IO (Client.Response BSL.ByteString) +uploadFile :: + Client.Manager -> + Burrito.Template -> + String -> + FilePath -> + String -> + IO (Client.Response BSL.ByteString) uploadFile manager template aToken aFile aName = do contents <- BSL.readFile aFile let body = Client.RequestBodyLBS contents uploadBody manager template aToken body aName -uploadBody - :: Client.Manager - -> Burrito.Template - -> String - -> Client.RequestBody - -> String - -> IO (Client.Response BSL.ByteString) +uploadBody :: + Client.Manager -> + Burrito.Template -> + String -> + Client.RequestBody -> + String -> + IO (Client.Response BSL.ByteString) uploadBody manager template aToken body aName = do - let - url :: String - url = Burrito.expand [("name", Burrito.stringValue aName)] template + let url :: String + url = Burrito.expand [("name", Burrito.stringValue aName)] template initialRequest <- Client.parseRequest url - let - request = initialRequest - { Client.method = BS8.pack "POST" - , Client.requestBody = body - , Client.requestHeaders = - [ authorizationHeader aToken - , (HTTP.hContentType, MIME.defaultMimeLookup (Text.pack aName)) - , userAgentHeader - ] - } + let request = + initialRequest + { Client.method = BS8.pack "POST", + Client.requestBody = body, + 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 :: + 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 - [ "tag_name" .= aTag - , "name" .= aTitle - , "body" .= Maybe.fromMaybe "" aDescription - , "prerelease" .= Maybe.fromMaybe False aPreRelease - , "draft" .= Maybe.fromMaybe False aDraft - ] - let - request = initialRequest - { Client.method = BS8.pack "POST" - , Client.requestBody = Client.RequestBodyLBS $ Aeson.encode requestObject - , Client.requestHeaders = [authorizationHeader aToken, userAgentHeader] - } + let requestObject = + object + [ "tag_name" .= aTag, + "name" .= aTitle, + "body" .= Maybe.fromMaybe "" aDescription, + "prerelease" .= Maybe.fromMaybe False aPreRelease, + "draft" .= Maybe.fromMaybe False aDraft + ] + let request = + initialRequest + { Client.method = BS8.pack "POST", + Client.requestBody = Client.RequestBodyLBS $ Aeson.encode requestObject, + Client.requestHeaders = [authorizationHeader aToken, userAgentHeader] + } Client.httpLbs request manager