github-release 1.3.10 → 2.0.0.0
raw patch · 8 files changed
+442/−332 lines, 8 filesdep ~basedep ~burritoPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, burrito
API changes (from Hackage documentation)
Files
- CHANGELOG.markdown +4/−0
- LICENSE.markdown +1/−1
- README.markdown +54/−0
- github-release.cabal +39/−12
- source/executable/Main.hs +5/−0
- source/library/GitHubRelease.hs +339/−0
- src/exe/Main.hs +0/−5
- src/lib/GitHubRelease.hs +0/−314
+ CHANGELOG.markdown view
@@ -0,0 +1,4 @@+# Change log++GitHub Release follows the [Package Versioning Policy](https://pvp.haskell.org).+You can find release notes [on GitHub](https://github.com/tfausak/github-release/releases).
LICENSE.markdown view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2021 Taylor Fausak+Copyright (c) 2022 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
+ README.markdown view
@@ -0,0 +1,54 @@+# [GitHub Release][]++[](https://github.com/tfausak/github-release/actions/new)+[](https://hackage.haskell.org/package/github-release)+[](https://www.stackage.org/package/github-release)++GitHub Release is a command-line utility for uploading files to GitHub+releases.++Once you've got it, run it like so:++``` sh+github-release upload \+ --token '...' \+ --owner 'someone' \+ --repo 'something' \+ --tag 'v1.2.3' \+ --file 'path/to/example.tgz' \+ --name 'example-1.2.3.tgz'+```++You can generate a token on the [personal access tokens][] page of your+personal settings. The `file` option is the path to the local file you want to+upload. The `name` option is what the file should be called on the GitHub+release.++GitHub Release is written in Haskell. If you want to build it yourself or use+it in your project, you'll want to get [Stack][]. Once you've done that, you+can install and use it from the command line.++``` sh+stack --resolver nightly install github-release+stack exec -- github-release upload # as above ...+```++Or you can use it from Haskell.++``` hs+import qualified GitHubRelease+GitHubRelease.upload+ "..." -- token+ "someone" -- owner+ "something" -- repo+ "1.2.3" -- tag+ "path/to/example.tgz" -- file+ "example-1.2.3.tgz" -- name+```++Inspired by <https://github.com/aktau/github-release>.++[GitHub Release]: https://github.com/tfausak/github-release+[the latest release]: https://github.com/tfausak/github-release/releases/latest+[personal access tokens]: https://github.com/settings/tokens+[Stack]: http://docs.haskellstack.org/en/stable/README/
github-release.cabal view
@@ -1,13 +1,14 @@-cabal-version: 2.0+cabal-version: 2.2 name: github-release-version: 1.3.10+version: 2.0.0.0 synopsis: Upload files to GitHub releases. description: GitHub Release uploads files to GitHub releases. build-type: Simple category: Utility+extra-source-files: CHANGELOG.markdown README.markdown license-file: LICENSE.markdown license: MIT maintainer: Taylor Fausak@@ -16,12 +17,16 @@ location: https://github.com/tfausak/github-release type: git -library- autogen-modules: Paths_github_release+flag pedantic+ default: False+ description: Enables @-Werror@, which turns warnings into errors.+ manual: True++common library build-depends:- base >= 4.13.0 && < 4.16+ , base >= 4.13.0 && < 4.17 , aeson >= 1.4.7 && < 1.6 || >= 2.0.0 && < 2.1- , burrito >= 1.2.0 && < 1.3+ , burrito >= 1.2.0 && < 1.3 || >= 2.0.0 && < 2.1 , bytestring >= 0.10.10 && < 0.12 , http-client >= 0.6.4 && < 0.8 , http-client-tls >= 0.3.5 && < 0.4@@ -31,7 +36,6 @@ , text >= 1.2.4 && < 1.3 , unordered-containers >= 0.2.10 && < 0.3 default-language: Haskell2010- exposed-modules: GitHubRelease ghc-options: -Weverything -Wno-implicit-prelude@@ -39,16 +43,39 @@ -Wno-missing-exported-signatures -Wno-safe -Wno-unsafe- hs-source-dirs: src/lib- other-modules: Paths_github_release+ -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++common executable+ import: library++ build-depends: github-release+ ghc-options:+ -rtsopts+ -threaded+ -Wno-unused-packages++library+ import: library++ autogen-modules: Paths_github_release+ exposed-modules: GitHubRelease+ hs-source-dirs: source/library+ other-modules: Paths_github_release+ executable github-release- build-depends: base, github-release- default-language: Haskell2010- hs-source-dirs: src/exe+ import: executable++ hs-source-dirs: source/executable main-is: Main.hs
+ source/executable/Main.hs view
@@ -0,0 +1,5 @@+module Main+ ( module GitHubRelease+ ) where++import GitHubRelease (main)
+ source/library/GitHubRelease.hs view
@@ -0,0 +1,339 @@+{-# OPTIONS_GHC -Wno-partial-fields #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module GitHubRelease+ ( Command(..)+ , main+ , runCommand+ , upload+ , getUploadUrl+ , getTag+ , authorizationHeader+ , userAgentHeader+ , userAgent+ , versionString+ , uploadFile+ , uploadBody+ ) where++import Options.Generic (type (<?>))++import qualified Burrito+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 qualified Data.Maybe as Maybe+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 Options.Generic as Options+import qualified Paths_github_release as This+import qualified System.Environment as Environment+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 :: 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."+ }+ | 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 helpfulToken -> do+ aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure+ $ Options.unHelpful helpfulToken+ upload+ aToken+ (Options.unHelpful anOwner)+ (Options.unHelpful aRepo)+ (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+ aToken+ (Options.unHelpful anOwner)+ (Options.unHelpful aRepo)+ (Options.unHelpful aTag)+ (Options.unHelpful aTitle)+ (Options.unHelpful aDescription)+ (Options.unHelpful aPreRelease)+ (Options.unHelpful aDraft)+ Delete aName anOwner aRepo aTag helpfulToken -> do+ aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure+ $ Options.unHelpful helpfulToken+ delete+ (Options.unHelpful aName)+ (Options.unHelpful anOwner)+ (Options.unHelpful aRepo)+ (Options.unHelpful aTag)+ aToken+ Version -> putStrLn versionString++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+ response <- uploadFile manager uploadUrl aToken aFile aName+ case HTTP.statusCode (Client.responseStatus response) of+ 201 -> pure ()+ _ -> 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" :: 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+ 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++delete :: String -> Maybe String -> String -> String -> String -> IO ()+delete aName rawOwner rawRepo aTag aToken = do+ manager <- Client.newManager TLS.tlsManagerSettings+ (anOwner, aRepo) <- getOwnerRepo rawOwner rawRepo+ ghRelease <- do+ result <- getTag manager aToken anOwner aRepo aTag+ case result of+ Left problem -> fail $ "Failed to get tag JSON: " <> show problem+ Right json -> pure json+ case filter ((== aName) . ghAssetName) $ ghReleaseAssets ghRelease of+ [] -> 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+ 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)++instance Aeson.FromJSON GHRelease where+ parseJSON =+ Aeson.withObject "GHRelease" $ \obj -> GHRelease <$> obj Aeson..: "assets"++data GHAsset = GHAsset+ { ghAssetName :: String+ , ghAssetUrl :: String+ }+ deriving (Eq, Show)++instance Aeson.FromJSON GHAsset where+ parseJSON = Aeson.withObject "GHAsset"+ $ \obj -> GHAsset <$> obj Aeson..: "name" <*> obj Aeson..: "url"++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+ result <- getTag manager aToken anOwner aRepo aTag+ case result of+ Left problem -> fail ("Failed to get tag JSON: " <> show problem)+ 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+ case Burrito.parse uploadUrl of+ Nothing -> fail ("Failed to parse URL template: " <> show uploadUrl)+ Just 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+ :: 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+ initialRequest <- Client.parseRequest url+ let+ request = initialRequest+ { Client.requestHeaders = [authorizationHeader aToken, userAgentHeader]+ }+ response <- Client.httpLbs request manager+ let body = Client.responseBody response+ return (Aeson.eitherDecode body)++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" :: 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 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 manager template aToken body aName = do+ 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+ ]+ }+ 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+ [ "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
− src/exe/Main.hs
@@ -1,5 +0,0 @@-module Main- ( module GitHubRelease- ) where--import GitHubRelease (main)
− src/lib/GitHubRelease.hs
@@ -1,314 +0,0 @@-{-# OPTIONS_GHC -Wno-partial-fields #-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module GitHubRelease- ( Command(..)- , main- , runCommand- , upload- , getUploadUrl- , getTag- , authorizationHeader- , userAgentHeader- , userAgent- , versionString- , uploadFile- , uploadBody- ) where--import Options.Generic (type (<?>))--import qualified Burrito-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 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 Options.Generic as Options-import qualified Paths_github_release as This-import qualified System.Environment as Environment-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 :: 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."- }- | 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 helpfulToken -> do- aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure- $ Options.unHelpful helpfulToken- upload- aToken- (Options.unHelpful anOwner)- (Options.unHelpful aRepo)- (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- aToken- (Options.unHelpful anOwner)- (Options.unHelpful aRepo)- (Options.unHelpful aTag)- (Options.unHelpful aTitle)- (Options.unHelpful aDescription)- (Options.unHelpful aPreRelease)- (Options.unHelpful aDraft)- Delete aName anOwner aRepo aTag helpfulToken -> do- aToken <- maybe (Environment.getEnv "GITHUB_TOKEN") pure- $ Options.unHelpful helpfulToken- delete- (Options.unHelpful aName)- (Options.unHelpful anOwner)- (Options.unHelpful aRepo)- (Options.unHelpful aTag)- aToken- Version -> putStrLn versionString--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- response <- uploadFile manager uploadUrl aToken aFile aName- case HTTP.statusCode (Client.responseStatus response) of- 201 -> pure ()- _ -> 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" :: 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- 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)--delete :: String -> Maybe String -> String -> String -> String -> IO ()-delete aName rawOwner rawRepo aTag aToken = do- manager <- Client.newManager TLS.tlsManagerSettings- (anOwner, aRepo) <- getOwnerRepo rawOwner rawRepo- ghRelease <- do- result <- getTag manager aToken anOwner aRepo aTag- case result of- Left problem -> fail $ "Failed to get tag JSON: " ++ show problem- Right json -> pure json- case filter ((== aName) . ghAssetName) $ ghReleaseAssets ghRelease of- [] -> 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- 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)--instance Aeson.FromJSON GHRelease where- parseJSON = Aeson.withObject "GHRelease" $ \ obj -> GHRelease- <$> obj Aeson..: "assets"--data GHAsset = GHAsset- { ghAssetName :: String- , ghAssetUrl :: String- } deriving (Eq, Show)--instance Aeson.FromJSON GHAsset where- parseJSON = Aeson.withObject "GHAsset" $ \ obj -> GHAsset- <$> obj Aeson..: "name"- <*> obj Aeson..: "url"--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- result <- getTag manager aToken anOwner aRepo aTag- case result of- Left problem -> fail ("Failed to get tag JSON: " ++ show problem)- 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 Burrito.parse uploadUrl of- Nothing -> fail ("Failed to parse URL template: " ++ show uploadUrl)- Just 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- :: 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- initialRequest <- Client.parseRequest url- let request =- initialRequest- {Client.requestHeaders = [authorizationHeader aToken, userAgentHeader]}- response <- Client.httpLbs request manager- let body = Client.responseBody response- return (Aeson.eitherDecode body)--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" :: 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 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 manager template aToken body aName = do- 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- ]- }- 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- [ "tag_name" .= aTag- , "name" .= aTitle- , "body" .= maybe "" id aDescription- , "prerelease" .= maybe False id aPreRelease- , "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- ]- }- Client.httpLbs request manager