Files
github-release/source/library/GitHubRelease.hs
2023-02-12 09:57:58 -06:00

346 lines
11 KiB
Haskell

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}
module GitHubRelease
( Command (..),
main,
runCommand,
upload,
getUploadUrl,
getTag,
authorizationHeader,
userAgentHeader,
userAgent,
versionString,
uploadFile,
uploadBody,
)
where
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 Options.Generic (type (<?>))
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