Support GHC 9.4
This commit is contained in:
421
src/Main.hs
Normal file
421
src/Main.hs
Normal file
@ -0,0 +1,421 @@
|
||||
module Main
|
||||
( main
|
||||
) where
|
||||
|
||||
import Data.Char (isNumber)
|
||||
import Control.Applicative (Applicative(liftA2))
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Map as Map
|
||||
import Options.Applicative (execParser)
|
||||
import SlackBuilder.CommandLine
|
||||
import SlackBuilder.Config
|
||||
import SlackBuilder.Trans
|
||||
import SlackBuilder.Updater
|
||||
import qualified Toml
|
||||
import qualified Data.ByteString as ByteString
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text.IO
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), asks)
|
||||
import SlackBuilder.Download
|
||||
import SlackBuilder.Package (Package(..))
|
||||
import qualified SlackBuilder.Package as Package
|
||||
import Text.URI (URI(..), mkURI)
|
||||
import Text.URI.QQ (uri)
|
||||
import Data.Foldable (Foldable(..), for_, find)
|
||||
import qualified Text.URI as URI
|
||||
import System.FilePath ((</>), (<.>), dropExtension, takeBaseName, makeRelative, splitFileName)
|
||||
import SlackBuilder.Info
|
||||
import Text.Megaparsec (parse, errorBundlePretty)
|
||||
import GHC.Records (HasField(..))
|
||||
import System.Process
|
||||
( CmdSpec(..)
|
||||
, CreateProcess(..)
|
||||
, StdStream(..)
|
||||
, callProcess
|
||||
, withCreateProcess
|
||||
, waitForProcess
|
||||
)
|
||||
import System.Console.ANSI
|
||||
( setSGR
|
||||
, SGR(..)
|
||||
, ColorIntensity(..)
|
||||
, Color(..)
|
||||
, ConsoleLayer(..)
|
||||
)
|
||||
import System.Directory (listDirectory, doesDirectoryExist)
|
||||
import Control.Monad (filterM)
|
||||
import Data.List (isPrefixOf, isSuffixOf)
|
||||
|
||||
autoUpdatable :: [Package]
|
||||
autoUpdatable =
|
||||
[ Package
|
||||
{ latest =
|
||||
let ghArguments = GhArguments{ owner = "universal-ctags", name = "ctags", transform = Nothing}
|
||||
latest' = latestGitHub ghArguments pure
|
||||
templateTail =
|
||||
[ Package.VersionPlaceholder
|
||||
, Package.StaticPlaceholder "/ctags-"
|
||||
, Package.VersionPlaceholder
|
||||
, Package.StaticPlaceholder ".tar.gz"
|
||||
]
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://github.com/universal-ctags/ctags/archive/"
|
||||
:| templateTail
|
||||
in Package.Updater latest' $ reuploadWithTemplate template []
|
||||
, category = "development"
|
||||
, name = "universal-ctags"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let packagistArguments = PackagistArguments{ vendor = "composer", name = "composer" }
|
||||
latest' = latestPackagist packagistArguments
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://getcomposer.org/download/"
|
||||
:| [Package.VersionPlaceholder, Package.StaticPlaceholder "/composer.phar"]
|
||||
in Package.Updater latest' $ downloadWithTemplate template
|
||||
, category = "development"
|
||||
, name = "composer"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let ghArguments = GhArguments
|
||||
{ owner = "jitsi"
|
||||
, name = "jitsi-meet-electron"
|
||||
, transform = Nothing
|
||||
}
|
||||
latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://github.com/jitsi/jitsi-meet-electron/releases/download/v"
|
||||
:| Package.VersionPlaceholder
|
||||
: [Package.StaticPlaceholder "/jitsi-meet-x86_64.AppImage"]
|
||||
in Package.Updater latest' $ downloadWithTemplate template
|
||||
, category = "network"
|
||||
, name = "jitsi-meet-desktop"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let ghArguments = GhArguments
|
||||
{ owner = "php"
|
||||
, name = "php-src"
|
||||
, transform = Nothing
|
||||
}
|
||||
checkVersion x
|
||||
| not $ Text.isInfixOf "RC" x
|
||||
, Text.isPrefixOf "php-8.2." x = Text.stripPrefix "php-" x
|
||||
| otherwise = Nothing
|
||||
latest' = latestGitHub ghArguments checkVersion
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://www.php.net/distributions/php-"
|
||||
:| Package.VersionPlaceholder
|
||||
: [Package.StaticPlaceholder ".tar.xz"]
|
||||
in Package.Updater latest' $ downloadWithTemplate template
|
||||
, category = "development"
|
||||
, name = "php82"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let ghArguments = GhArguments
|
||||
{ owner = "kovidgoyal"
|
||||
, name = "kitty"
|
||||
, transform = Nothing
|
||||
}
|
||||
latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
|
||||
templateTail =
|
||||
[ Package.StaticPlaceholder "/kitty-"
|
||||
, Package.VersionPlaceholder
|
||||
, Package.StaticPlaceholder ".tar.xz"
|
||||
]
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://github.com/kovidgoyal/kitty/releases/download/v"
|
||||
:| Package.VersionPlaceholder
|
||||
: templateTail
|
||||
in Package.Updater latest' $ reuploadWithTemplate template [RawCommand "go" ["mod", "vendor"]]
|
||||
, category = "system"
|
||||
, name = "kitty"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let ghArguments = GhArguments
|
||||
{ owner = "rdiff-backup"
|
||||
, name = "rdiff-backup"
|
||||
, transform = Nothing
|
||||
}
|
||||
latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://github.com/rdiff-backup/rdiff-backup/releases/download/v"
|
||||
:| Package.VersionPlaceholder
|
||||
: Package.StaticPlaceholder "/rdiff-backup-"
|
||||
: Package.VersionPlaceholder
|
||||
: [Package.StaticPlaceholder ".tar.gz"]
|
||||
in Package.Updater latest' $ reuploadWithTemplate template []
|
||||
, category = "system"
|
||||
, name = "rdiff-backup"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let needle = "Linux—"
|
||||
textArguments = TextArguments
|
||||
{ textURL = "https://help.webex.com/en-us/article/mqkve8/Webex-App-%7C-Release-notes"
|
||||
, versionPicker = Text.takeWhile (liftA2 (||) (== '.') isNumber)
|
||||
. Text.drop (Text.length needle)
|
||||
. snd
|
||||
. Text.breakOn needle
|
||||
}
|
||||
latest' = latestText textArguments
|
||||
template = Package.DownloadTemplate $ pure
|
||||
$ Package.StaticPlaceholder
|
||||
"https://binaries.webex.com/WebexDesktop-Ubuntu-Official-Package/Webex.deb"
|
||||
in Package.Updater latest' $ downloadWithTemplate template
|
||||
, category = "network"
|
||||
, name = "webex"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let ghArguments = GhArguments
|
||||
{ owner = "librsync"
|
||||
, name = "librsync"
|
||||
, transform = Nothing
|
||||
}
|
||||
latest' = latestGitHub ghArguments $ Text.stripPrefix "v"
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://github.com/librsync/librsync/archive/v"
|
||||
:| Package.VersionPlaceholder
|
||||
: Package.StaticPlaceholder "/librsync-"
|
||||
: Package.VersionPlaceholder
|
||||
: [Package.StaticPlaceholder ".tar.gz"]
|
||||
in Package.Updater latest' $ reuploadWithTemplate template []
|
||||
, category = "libraries"
|
||||
, name = "librsync"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let textArguments = TextArguments
|
||||
{ textURL = "https://downloads.dlang.org/releases/LATEST"
|
||||
, versionPicker = Text.strip
|
||||
}
|
||||
latest' = latestText textArguments
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://downloads.dlang.org/releases/2.x/"
|
||||
:| Package.VersionPlaceholder
|
||||
: Package.StaticPlaceholder "/dmd."
|
||||
: Package.VersionPlaceholder
|
||||
: [Package.StaticPlaceholder ".linux.tar.xz"]
|
||||
in Package.Updater latest' $ downloadWithTemplate template
|
||||
, category = "development"
|
||||
, name = "dmd"
|
||||
, downloaders = mempty
|
||||
}
|
||||
, Package
|
||||
{ latest =
|
||||
let textArguments = TextArguments
|
||||
{ textURL = "https://downloads.dlang.org/releases/LATEST"
|
||||
, versionPicker = Text.strip
|
||||
}
|
||||
latest' = latestText textArguments
|
||||
template = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://codeload.github.com/dlang/tools/tar.gz/v"
|
||||
:| [Package.VersionPlaceholder]
|
||||
in Package.Updater latest' $ reuploadWithTemplate template []
|
||||
, category = "development"
|
||||
, name = "d-tools"
|
||||
, downloaders =
|
||||
let dubArguments = GhArguments{ owner = "dlang", name = "dub", transform = Nothing}
|
||||
dscannerArguments = GhArguments{ owner = "dlang-community", name = "D-Scanner", transform = Nothing }
|
||||
dcdArguments = GhArguments{ owner = "dlang-community", name = "DCD", transform = Nothing }
|
||||
latestDub = latestGitHub dubArguments pure
|
||||
latestDscanner = latestGitHub dscannerArguments pure
|
||||
latestDcd = latestGitHub dcdArguments pure
|
||||
dubTemplate = Package.DownloadTemplate
|
||||
$ Package.StaticPlaceholder "https://codeload.github.com/dlang/dub/tar.gz/v"
|
||||
:| [Package.VersionPlaceholder]
|
||||
dscannerURI = [uri|https://github.com/dlang-community/D-Scanner.git|]
|
||||
dcdURI = [uri|https://github.com/dlang-community/DCD.git|]
|
||||
in Map.fromList
|
||||
[ ("DUB", Package.Updater latestDub $ downloadWithTemplate dubTemplate)
|
||||
, ("DSCANNER", Package.Updater latestDscanner $ cloneFromGit dscannerURI "v")
|
||||
, ("DCD", Package.Updater latestDcd $ cloneFromGit dcdURI "v")
|
||||
]
|
||||
}
|
||||
]
|
||||
|
||||
up2Date :: SlackBuilderT ()
|
||||
up2Date = for_ autoUpdatable go
|
||||
where
|
||||
go package = getAndLogLatest package
|
||||
>>= mapM_ (updatePackageIfRequired package)
|
||||
>> liftIO (putStrLn "")
|
||||
getAndLogLatest Package{ latest = Package.Updater{ detectLatest }, name }
|
||||
= liftIO (putStrLn $ Text.unpack name <> ": Retreiving the latest version.")
|
||||
>> detectLatest
|
||||
|
||||
updatePackageIfRequired :: Package -> Text -> SlackBuilderT ()
|
||||
updatePackageIfRequired package@Package{..} version = do
|
||||
let packagePath = Text.unpack category </> Text.unpack name </> (Text.unpack name <.> "info")
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
infoContents <- liftIO $ ByteString.readFile $ repository' </> packagePath
|
||||
|
||||
case parse parseInfoFile packagePath infoContents of
|
||||
Right parsedInfoFile
|
||||
| version == getField @"version" parsedInfoFile ->
|
||||
liftIO $ do
|
||||
setSGR [SetColor Foreground Dull Green]
|
||||
Text.IO.putStrLn
|
||||
$ name <> " is up to date (Version " <> version <> ")."
|
||||
setSGR [Reset]
|
||||
| otherwise -> do
|
||||
liftIO $ do
|
||||
setSGR [SetColor Foreground Dull Yellow]
|
||||
Text.IO.putStrLn
|
||||
$ "A new version of "
|
||||
<> name <> " " <> getField @"version" parsedInfoFile
|
||||
<> " is available (" <> version <> ")."
|
||||
setSGR [Reset]
|
||||
updatePackage package parsedInfoFile version
|
||||
Left errorBundle -> liftIO $ putStr $ errorBundlePretty errorBundle
|
||||
|
||||
updateDownload :: Package -> Package.Updater -> SlackBuilderT (Package.Download, Text)
|
||||
updateDownload Package{..} Package.Updater{..} = do
|
||||
latestDownloadVersion <- fromJust <$> detectLatest
|
||||
result <- getVersion (Text.pack $ Text.unpack category </> Text.unpack name) latestDownloadVersion
|
||||
pure (result, latestDownloadVersion)
|
||||
|
||||
cloneFromGit :: URI -> Text -> Text -> Text -> SlackBuilderT Package.Download
|
||||
cloneFromGit repo tagPrefix packagePath version = do
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
let downloadFileName = URI.unRText
|
||||
$ NonEmpty.last $ snd $ fromJust $ URI.uriPath repo
|
||||
relativeTarball = Text.unpack packagePath
|
||||
</> (dropExtension (Text.unpack downloadFileName) <> "-" <> Text.unpack version)
|
||||
tarball = repository' </> relativeTarball
|
||||
name' = Text.pack (takeBaseName $ Text.unpack packagePath)
|
||||
checksum <- clone (URI.render repo) (Text.pack tarball) tagPrefix
|
||||
uploadCommand (Text.pack relativeTarball) ("/" <> name')
|
||||
(flip . flip Package.Download) (fromJust checksum) False
|
||||
<$> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
|
||||
|
||||
downloadWithTemplate :: Package.DownloadTemplate -> Text -> Text -> SlackBuilderT Package.Download
|
||||
downloadWithTemplate downloadTemplate packagePath version = do
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
uri' <- liftIO $ Package.renderDownloadWithVersion downloadTemplate version
|
||||
let downloadFileName = URI.unRText
|
||||
$ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
|
||||
relativeTarball = packagePath <> "/" <> downloadFileName
|
||||
tarball = repository' </> Text.unpack relativeTarball
|
||||
checksum <- fromJust <$> download uri' tarball
|
||||
pure $ Package.Download uri' checksum False
|
||||
|
||||
reuploadWithTemplate :: Package.DownloadTemplate -> [CmdSpec] -> Text -> Text -> SlackBuilderT Package.Download
|
||||
reuploadWithTemplate downloadTemplate commands packagePath version = do
|
||||
Package.Download{ download = uri', md5sum = checksum } <- downloadWithTemplate downloadTemplate packagePath version
|
||||
let downloadFileName = URI.unRText
|
||||
$ NonEmpty.last $ snd $ fromJust $ URI.uriPath uri'
|
||||
relativeTarball = packagePath <> "/" <> downloadFileName
|
||||
download' <- handleReupload relativeTarball downloadFileName
|
||||
|
||||
pure $ Package.Download download' checksum False
|
||||
where
|
||||
name' = Text.pack $ takeBaseName $ Text.unpack packagePath
|
||||
handleReupload relativeTarball downloadFileName = do
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
case commands of
|
||||
[] -> uploadTarball relativeTarball downloadFileName
|
||||
_ ->
|
||||
let tarballPath = repository' </> Text.unpack relativeTarball
|
||||
packedDirectory = takeBaseName $ dropExtension tarballPath
|
||||
in liftIO (callProcess "tar" ["xvf", tarballPath])
|
||||
>> liftIO (traverse (defaultCreateProcess packedDirectory) commands)
|
||||
>> liftIO (callProcess "tar" ["Jcvf", tarballPath, packedDirectory])
|
||||
>> uploadTarball relativeTarball downloadFileName
|
||||
uploadTarball relativeTarball downloadFileName
|
||||
= liftIO (putStrLn $ "Upload the source tarball " <> Text.unpack relativeTarball)
|
||||
>> uploadCommand relativeTarball ("/" <> name')
|
||||
>> liftIO (mkURI $ "https://download.dlackware.com/hosted-sources/" <> name' <> "/" <> downloadFileName)
|
||||
defaultCreateProcess cwd' cmdSpec
|
||||
= flip withCreateProcess (const . const . const waitForProcess)
|
||||
$ CreateProcess
|
||||
{ use_process_jobs = False
|
||||
, std_out = Inherit
|
||||
, std_in = NoStream
|
||||
, std_err = Inherit
|
||||
, new_session = False
|
||||
, env = Nothing
|
||||
, detach_console = False
|
||||
, delegate_ctlc = False
|
||||
, cwd = Just cwd'
|
||||
, create_new_console = False
|
||||
, create_group = False
|
||||
, cmdspec = cmdSpec
|
||||
, close_fds = True
|
||||
, child_user = Nothing
|
||||
, child_group = Nothing
|
||||
}
|
||||
|
||||
renderAndDownload :: Package -> Text -> SlackBuilderT Package.Download
|
||||
renderAndDownload Package{..} version = do
|
||||
let packagePath = category <> "/" <> name
|
||||
Package.Updater _ getVersion = latest
|
||||
|
||||
getVersion packagePath version
|
||||
|
||||
updatePackage :: Package -> PackageInfo -> Text -> SlackBuilderT ()
|
||||
updatePackage package@Package{..} info version = do
|
||||
let packagePath = category <> "/" <> name
|
||||
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
mainDownload <- renderAndDownload package version
|
||||
moreDownloads <- traverse (updateDownload package) downloaders
|
||||
let allDownloads = mainDownload : toList (fst <$> moreDownloads)
|
||||
let infoFilePath = repository' </> Text.unpack packagePath
|
||||
</> (Text.unpack name <.> "info")
|
||||
package' = info
|
||||
{ version = version
|
||||
, downloads = getField @"download" <$> allDownloads
|
||||
, checksums = getField @"md5sum" <$> allDownloads
|
||||
}
|
||||
liftIO $ Text.IO.writeFile infoFilePath $ generate package'
|
||||
updateSlackBuildVersion packagePath version $ snd <$> moreDownloads
|
||||
|
||||
commit packagePath version
|
||||
|
||||
findCategory :: FilePath -> IO [FilePath]
|
||||
findCategory currentDirectory = do
|
||||
contents <- liftIO $ listDirectory currentDirectory
|
||||
case find (isSuffixOf ".info") contents of
|
||||
Just _ -> pure [currentDirectory]
|
||||
Nothing -> do
|
||||
let contents' = (currentDirectory </>) <$> filter (not . isPrefixOf ".") contents
|
||||
directories <- filterM doesDirectoryExist contents'
|
||||
subCategories <- traverse findCategory directories
|
||||
pure $ concat subCategories
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
programCommand <- execParser slackBuilderParser
|
||||
settings <- Toml.decodeFile settingsCodec "config/config.toml"
|
||||
latestVersion <- flip runReaderT settings
|
||||
$ runSlackBuilderT
|
||||
$ executeCommand programCommand
|
||||
|
||||
maybe (pure ()) Text.IO.putStrLn latestVersion
|
||||
where
|
||||
executeCommand = \case
|
||||
CategoryCommand _packageName -> do
|
||||
repository' <- SlackBuilderT $ asks repository
|
||||
categories <- liftIO $ findCategory repository'
|
||||
liftIO $ print $ splitFileName . makeRelative repository' <$> categories
|
||||
pure Nothing
|
||||
CloneCommand repo tarball tagPrefix -> fmap (Text.pack . show)
|
||||
<$> clone repo tarball tagPrefix
|
||||
Up2DateCommand -> up2Date >> pure Nothing
|
||||
58
src/SlackBuilder/CommandLine.hs
Normal file
58
src/SlackBuilder/CommandLine.hs
Normal file
@ -0,0 +1,58 @@
|
||||
module SlackBuilder.CommandLine
|
||||
( GhArguments(..)
|
||||
, SlackBuilderCommand(..)
|
||||
, PackagistArguments(..)
|
||||
, TextArguments(..)
|
||||
, slackBuilderParser
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Options.Applicative
|
||||
( Parser
|
||||
, ParserInfo(..)
|
||||
, metavar
|
||||
, argument
|
||||
, str
|
||||
, info
|
||||
, fullDesc
|
||||
, subparser
|
||||
, command,
|
||||
)
|
||||
|
||||
data SlackBuilderCommand
|
||||
= CategoryCommand Text
|
||||
| CloneCommand Text Text Text
|
||||
| Up2DateCommand
|
||||
|
||||
data PackagistArguments = PackagistArguments
|
||||
{ vendor :: Text
|
||||
, name :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data GhArguments = GhArguments
|
||||
{ owner :: Text
|
||||
, name :: Text
|
||||
, transform :: Maybe Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data TextArguments = TextArguments
|
||||
{ versionPicker :: Text -> Text
|
||||
, textURL :: Text
|
||||
}
|
||||
|
||||
slackBuilderParser :: ParserInfo SlackBuilderCommand
|
||||
slackBuilderParser = info slackBuilderCommand fullDesc
|
||||
|
||||
slackBuilderCommand :: Parser SlackBuilderCommand
|
||||
slackBuilderCommand = subparser
|
||||
$ command "category" (info categoryCommand mempty)
|
||||
<> command "clone" (info cloneCommand mempty)
|
||||
<> command "up2date" (info up2DateCommand mempty)
|
||||
where
|
||||
categoryCommand = CategoryCommand
|
||||
<$> argument str (metavar "PKGNAM")
|
||||
cloneCommand = CloneCommand
|
||||
<$> argument str (metavar "REPO")
|
||||
<*> argument str (metavar "TARBALL")
|
||||
<*> argument str (metavar "TAG_PREFIX")
|
||||
up2DateCommand = pure Up2DateCommand
|
||||
158
src/SlackBuilder/Updater.hs
Normal file
158
src/SlackBuilder/Updater.hs
Normal file
@ -0,0 +1,158 @@
|
||||
module SlackBuilder.Updater
|
||||
( latestGitHub
|
||||
, latestPackagist
|
||||
, latestText
|
||||
) where
|
||||
|
||||
import SlackBuilder.Config
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson ((.:))
|
||||
import Data.Aeson.TH (defaultOptions, deriveJSON)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text.Encoding
|
||||
import Data.Vector (Vector, (!?))
|
||||
import qualified Data.Vector as Vector
|
||||
import Network.HTTP.Req
|
||||
( header
|
||||
, runReq
|
||||
, defaultHttpConfig
|
||||
, req
|
||||
, GET(..)
|
||||
, https
|
||||
, jsonResponse
|
||||
, NoReqBody(..)
|
||||
, (/:)
|
||||
, responseBody
|
||||
, useHttpsURI
|
||||
, bsResponse
|
||||
, POST(..)
|
||||
, ReqBodyJson(..)
|
||||
)
|
||||
import Text.URI (mkURI)
|
||||
import SlackBuilder.CommandLine
|
||||
import SlackBuilder.Trans
|
||||
import qualified Data.Aeson.KeyMap as KeyMap
|
||||
import GHC.Records (HasField(..))
|
||||
import Control.Monad.Trans.Reader (asks)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
|
||||
newtype PackagistPackage = PackagistPackage
|
||||
{ version :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''PackagistPackage)
|
||||
|
||||
newtype PackagistResponse = PackagistResponse
|
||||
{ packages :: HashMap Text (Vector PackagistPackage)
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''PackagistResponse)
|
||||
|
||||
newtype GhRefNode = GhRefNode
|
||||
{ name :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''GhRefNode)
|
||||
|
||||
newtype GhRef = GhRef
|
||||
{ nodes :: Vector GhRefNode
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''GhRef)
|
||||
|
||||
newtype GhRepository = GhRepository
|
||||
{ refs :: GhRef
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''GhRepository)
|
||||
|
||||
newtype GhData = GhData
|
||||
{ repository :: GhRepository
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Aeson.FromJSON GhData where
|
||||
parseJSON (Aeson.Object keyMap)
|
||||
| Just data' <- KeyMap.lookup "data" keyMap =
|
||||
GhData <$> Aeson.withObject "GhData" (.: "repository") data'
|
||||
parseJSON _ = fail "data key not found in the response"
|
||||
|
||||
data GhVariables = GhVariables
|
||||
{ name :: Text
|
||||
, owner :: Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''GhVariables)
|
||||
|
||||
data GhQuery = GhQuery
|
||||
{ query :: Text
|
||||
, variables :: GhVariables
|
||||
} deriving (Eq, Show)
|
||||
|
||||
$(deriveJSON defaultOptions ''GhQuery)
|
||||
|
||||
latestPackagist :: PackagistArguments -> SlackBuilderT (Maybe Text)
|
||||
latestPackagist PackagistArguments{..} = do
|
||||
packagistResponse <- runReq defaultHttpConfig $
|
||||
let uri = https "repo.packagist.org" /: "p2"
|
||||
/: vendor
|
||||
/: name <> ".json"
|
||||
in req GET uri NoReqBody jsonResponse mempty
|
||||
let packagistPackages = packages $ responseBody packagistResponse
|
||||
fullName = Text.intercalate "/" [vendor, name]
|
||||
|
||||
pure $ HashMap.lookup fullName packagistPackages
|
||||
>>= fmap (version . fst) . Vector.uncons
|
||||
|
||||
latestText :: TextArguments -> SlackBuilderT (Maybe Text)
|
||||
latestText TextArguments{..} = do
|
||||
uri <- liftIO $ useHttpsURI <$> mkURI textURL
|
||||
packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri
|
||||
|
||||
pure $ versionPicker . Text.Encoding.decodeUtf8 . responseBody
|
||||
<$> packagistResponse
|
||||
where
|
||||
go uri = req GET uri NoReqBody bsResponse mempty
|
||||
|
||||
latestGitHub
|
||||
:: GhArguments
|
||||
-> (Text -> Maybe Text)
|
||||
-> SlackBuilderT (Maybe Text)
|
||||
latestGitHub GhArguments{..} versionTransform = do
|
||||
ghToken' <- SlackBuilderT $ asks ghToken
|
||||
ghResponse <- runReq defaultHttpConfig $
|
||||
let uri = https "api.github.com" /: "graphql"
|
||||
query = GhQuery
|
||||
{ query = githubQuery
|
||||
, variables = GhVariables
|
||||
{ owner = owner
|
||||
, name = name
|
||||
}
|
||||
}
|
||||
authorizationHeader = header "authorization"
|
||||
$ Text.Encoding.encodeUtf8
|
||||
$ "Bearer " <> ghToken'
|
||||
in req POST uri (ReqBodyJson query) jsonResponse
|
||||
$ authorizationHeader <> header "User-Agent" "SlackBuilder"
|
||||
let ghNodes = nodes
|
||||
$ refs
|
||||
$ (getField @"repository" :: GhData -> GhRepository)
|
||||
$ responseBody ghResponse
|
||||
refs' = Vector.reverse
|
||||
$ Vector.catMaybes
|
||||
$ versionTransform . getField @"name" <$> ghNodes
|
||||
pure $ refs' !? 0
|
||||
where
|
||||
githubQuery =
|
||||
"query ($name: String!, $owner: String!) {\n\
|
||||
\ repository(name: $name, owner: $owner) {\n\
|
||||
\ refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\
|
||||
\ nodes {\n\
|
||||
\ id,\n\
|
||||
\ name\n\
|
||||
\ }\n\
|
||||
\ }\n\
|
||||
\ }\n\
|
||||
\}"
|
||||
Reference in New Issue
Block a user