diff --git a/executable/Main.hs b/executable/Main.hs deleted file mode 100644 --- a/executable/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Main (module GitHubRelease) where - -import GitHubRelease (main) diff --git a/github-release.cabal b/github-release.cabal --- a/github-release.cabal +++ b/github-release.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: github-release -version: 0.2.0 +version: 1.0.0 synopsis: Upload files to GitHub releases. description: GitHub Release is a command-line utility for uploading files to GitHub releases. category: Utility @@ -27,20 +27,20 @@ library hs-source-dirs: - library + source/library ghc-options: -Wall build-depends: - aeson >=0.9.0.1 && <1.1 - , base >=4.8.2.0 && <4.10 - , bytestring >=0.10.6.0 && <0.11 + aeson >=0.9 && <1.1 + , base >=4.8.2 && <4.10 + , bytestring >=0.10.6 && <0.11 , http-client >=0.4.30 && <0.6 , http-client-tls >=0.2.4 && <0.4 , http-types >=0.9 && <0.10 - , mime-types >=0.1.0.7 && <0.2 - , optparse-generic >=1.1.0 && <1.2 - , text >=1.2.2.1 && <1.3 - , unordered-containers >=0.2.5.1 && <0.3 - , uri-templater >=0.2.0.0 && <0.3 + , mime-types >=0.1 && <0.2 + , optparse-generic >=1.1 && <1.2 + , text >=1.2.2 && <1.3 + , unordered-containers >=0.2.5 && <0.3 + , uri-templater >=0.2 && <0.3 exposed-modules: GitHubRelease other-modules: @@ -50,7 +50,7 @@ executable github-release main-is: Main.hs hs-source-dirs: - executable + source/executable ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base diff --git a/library/GitHubRelease.hs b/library/GitHubRelease.hs deleted file mode 100644 --- a/library/GitHubRelease.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module GitHubRelease where - -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 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 - -data Command - = Upload - { file :: FilePath Options. - "The path to the local file to upload." - , name :: String Options. - "The name to give the file on the release." - , owner :: String Options. - "The GitHub owner, either a user or organization." - , repo :: String Options. - "The GitHub repository name." - , tag :: String Options. - "The tag name." - , token :: String Options. - "Your OAuth2 token." - } - | Version - deriving (Generics.Generic, Show) - -instance Options.ParseRecord Command - -main :: IO () -main = do - command <- Options.getRecord (Text.pack "Upload a file to a GitHub release.") - runCommand command - -runCommand :: Command -> IO () -runCommand command = case command of - Upload aFile aName anOwner aRepo aTag aToken -> upload - (Options.unHelpful aToken) - (Options.unHelpful anOwner) - (Options.unHelpful aRepo) - (Options.unHelpful aTag) - (Options.unHelpful aFile) - (Options.unHelpful aName) - Version -> putStrLn versionString - -upload :: String -> 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 - response <- uploadFile manager uploadUrl aToken aFile aName - case HTTP.statusCode (Client.responseStatus response) of - 201 -> pure () - _ -> do - IO.hPrint IO.stderr response - BSL.hPutStr IO.stderr (Client.responseBody response) - fail "Failed to upload file to release!" - -getUploadUrl :: Client.Manager -> String -> String -> String -> String -> IO Template.UriTemplate -getUploadUrl manager aToken anOwner aRepo aTag = do - (Right json) <- getTag manager aToken anOwner aRepo aTag - let (Just (Aeson.String text)) = HashMap.lookup (Text.pack "upload_url") json - let uploadUrl = Text.unpack text - let (Right template) = Template.parseTemplate uploadUrl - pure template - -getTag :: Client.Manager -> String -> String -> String -> String -> IO (Either String Aeson.Object) -getTag manager aToken anOwner aRepo aTag = do - let format = "https://api.github.com/repos/%s/%s/releases/tags/%s" - let url = Printf.printf format anOwner aRepo aTag - initialRequest <- Client.parseUrlThrow url - let request = initialRequest - { Client.requestHeaders = - [ authorizationHeader aToken - , userAgentHeader - ] - } - response <- Client.httpLbs request manager - let body = Client.responseBody response - let json = Aeson.eitherDecode body - return json - -authorizationHeader :: String -> HTTP.Header -authorizationHeader aToken = - ( HTTP.hAuthorization - , BS8.pack (Printf.printf "token %s" aToken) - ) - -userAgentHeader :: HTTP.Header -userAgentHeader = - ( HTTP.hUserAgent - , BS8.pack userAgent - ) - -userAgent :: String -userAgent = Printf.printf "%s/%s-%s" "tfausak" "github-release" versionString - -versionString :: String -versionString = Version.showVersion This.version - -uploadFile :: Client.Manager -> Template.UriTemplate -> 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 -> Template.UriTemplate -> String -> Client.RequestBody -> String -> IO (Client.Response BSL.ByteString) -uploadBody manager template aToken body aName = do - let url = Template.render template - [ ("name", Template.WrappedValue (Template.Single aName)) - ] - initialRequest <- Client.parseUrlThrow url - 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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -11,7 +11,7 @@ - -rtsopts - -with-rtsopts=-N main: Main.hs - source-dirs: executable + source-dirs: source/executable extra-source-files: - CHANGELOG.markdown - package.yaml @@ -21,22 +21,22 @@ github: tfausak/github-release library: dependencies: - - aeson >=0.9.0.1 && <1.1 - - base >=4.8.2.0 && <4.10 - - bytestring >=0.10.6.0 && <0.11 + - aeson >=0.9 && <1.1 + - base >=4.8.2 && <4.10 + - bytestring >=0.10.6 && <0.11 - http-client >=0.4.30 && <0.6 - http-client-tls >=0.2.4 && <0.4 - http-types >=0.9 && <0.10 - - mime-types >=0.1.0.7 && <0.2 - - optparse-generic >=1.1.0 && <1.2 - - text >=1.2.2.1 && <1.3 - - unordered-containers >=0.2.5.1 && <0.3 - - uri-templater >=0.2.0.0 && <0.3 + - mime-types >=0.1 && <0.2 + - optparse-generic >=1.1 && <1.2 + - text >=1.2.2 && <1.3 + - unordered-containers >=0.2.5 && <0.3 + - uri-templater >=0.2 && <0.3 other-modules: Paths_github_release - source-dirs: library + source-dirs: source/library license: MIT license-file: LICENSE.markdown maintainer: Taylor Fausak name: github-release synopsis: Upload files to GitHub releases. -version: '0.2.0' +version: '1.0.0' diff --git a/source/executable/Main.hs b/source/executable/Main.hs new file mode 100644 --- /dev/null +++ b/source/executable/Main.hs @@ -0,0 +1,5 @@ +module Main + ( module GitHubRelease + ) where + +import GitHubRelease (main) diff --git a/source/library/GitHubRelease.hs b/source/library/GitHubRelease.hs new file mode 100644 --- /dev/null +++ b/source/library/GitHubRelease.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module GitHubRelease where + +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 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 + +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 :: String "The GitHub owner, either a user or organization." + , repo :: String "The GitHub repository name." + , tag :: String "The tag name." + , token :: String "Your OAuth2 token."} + | Version + deriving (Generics.Generic, Show) + +instance Options.ParseRecord Command + +main :: IO () +main = do + command <- Options.getRecord (Text.pack "Upload a file to a GitHub release.") + runCommand command + +runCommand :: Command -> IO () +runCommand command = + case command of + Upload aFile aName anOwner aRepo aTag aToken -> + upload + (Options.unHelpful aToken) + (Options.unHelpful anOwner) + (Options.unHelpful aRepo) + (Options.unHelpful aTag) + (Options.unHelpful aFile) + (Options.unHelpful aName) + Version -> putStrLn versionString + +upload :: String -> 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 + response <- uploadFile manager uploadUrl aToken aFile aName + case HTTP.statusCode (Client.responseStatus response) of + 201 -> pure () + _ -> do + IO.hPrint IO.stderr response + BSL.hPutStr IO.stderr (Client.responseBody response) + fail "Failed to upload file to release!" + +getUploadUrl + :: Client.Manager + -> String + -> String + -> String + -> String + -> IO Template.UriTemplate +getUploadUrl manager aToken anOwner aRepo aTag = do + (Right json) <- getTag manager aToken anOwner aRepo aTag + let (Just (Aeson.String text)) = HashMap.lookup (Text.pack "upload_url") json + let uploadUrl = Text.unpack text + let (Right template) = Template.parseTemplate uploadUrl + pure template + +getTag + :: Client.Manager + -> String + -> String + -> String + -> String + -> IO (Either String Aeson.Object) +getTag manager aToken anOwner aRepo aTag = do + let format = "https://api.github.com/repos/%s/%s/releases/tags/%s" + let url = Printf.printf format anOwner aRepo aTag + initialRequest <- Client.parseUrlThrow url + let request = + initialRequest + {Client.requestHeaders = [authorizationHeader aToken, userAgentHeader]} + response <- Client.httpLbs request manager + let body = Client.responseBody response + let json = Aeson.eitherDecode body + return json + +authorizationHeader :: String -> HTTP.Header +authorizationHeader aToken = + (HTTP.hAuthorization, BS8.pack (Printf.printf "token %s" aToken)) + +userAgentHeader :: HTTP.Header +userAgentHeader = (HTTP.hUserAgent, BS8.pack userAgent) + +userAgent :: String +userAgent = Printf.printf "%s/%s-%s" "tfausak" "github-release" versionString + +versionString :: String +versionString = Version.showVersion This.version + +uploadFile + :: Client.Manager + -> Template.UriTemplate + -> 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 + -> Template.UriTemplate + -> String + -> Client.RequestBody + -> String + -> IO (Client.Response BSL.ByteString) +uploadBody manager template aToken body aName = do + let url = + Template.render + template + [("name", Template.WrappedValue (Template.Single aName))] + initialRequest <- Client.parseUrlThrow url + 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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,1 @@ -extra-deps: -- uri-templater-0.2.1.0 -resolver: nightly-2016-12-08 +resolver: nightly-2016-12-30