Move text URL check to the Haskell binary

This commit is contained in:
Eugen Wissner 2023-08-06 14:25:19 +02:00
parent 028f64d25a
commit 69ba04a731
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
5 changed files with 126 additions and 45 deletions

View File

@ -2,45 +2,18 @@ module Main
( main
) where
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.IO as Text.IO
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Network.HTTP.Req
( runReq
, defaultHttpConfig
, req
, GET(..)
, https
, jsonResponse
, NoReqBody(..)
, (/:)
, responseBody
)
import Data.Maybe (fromMaybe)
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)
import Options.Applicative (execParser)
import SlackBuilder.CommandLine
import SlackBuilder.Updater
main :: IO ()
main = do
packagistResponse <- runReq defaultHttpConfig $
let uri = https "repo.packagist.org" /: "p2" /: "composer" /: "composer.json"
in req GET uri NoReqBody jsonResponse mempty
let packagistPackages = packages $ responseBody packagistResponse
programCommand <- execParser slackBuilderParser
latestVersion <- case programCommand of
PackagistCommand packagistArguments ->
latestPackagist packagistArguments
TextCommand textArguments -> latestText textArguments
Text.IO.putStrLn $ fromMaybe ""
$ HashMap.lookup "composer/composer" packagistPackages
>>= fmap (version . fst) . Vector.uncons
Text.IO.putStrLn $ fromMaybe "" latestVersion

View File

@ -0,0 +1,46 @@
module SlackBuilder.CommandLine
( SlackBuilderCommand(..)
, PackagistArguments(..)
, TextArguments(..)
, slackBuilderParser
) where
import Data.Text (Text)
import Options.Applicative
( Parser
, ParserInfo(..)
, metavar
, argument
, str
, info
, fullDesc
, subparser
, command
)
data SlackBuilderCommand
= PackagistCommand PackagistArguments
| TextCommand TextArguments
data PackagistArguments = PackagistArguments
{ vendor :: Text
, name :: Text
} deriving (Eq, Show)
newtype TextArguments = TextArguments Text
packagistArguments :: Parser PackagistArguments
packagistArguments = PackagistArguments
<$> argument str (metavar "VENDOR")
<*> argument str (metavar"NAME")
textArguments :: Parser TextArguments
textArguments = TextArguments <$> argument str (metavar "URL")
slackBuilderParser :: ParserInfo SlackBuilderCommand
slackBuilderParser = info slackBuilderCommand fullDesc
slackBuilderCommand :: Parser SlackBuilderCommand
slackBuilderCommand = subparser
$ command "packagist" (info (PackagistCommand <$> packagistArguments) mempty)
<> command "text" (info (TextCommand <$> textArguments) mempty)

View File

@ -0,0 +1,61 @@
module SlackBuilder.Updater
( latestPackagist
, latestText
) where
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
( runReq
, defaultHttpConfig
, req
, GET(..)
, https
, jsonResponse
, NoReqBody(..)
, (/:)
, responseBody, useHttpsURI, bsResponse
)
import Text.URI (mkURI)
import SlackBuilder.CommandLine
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)
latestPackagist :: PackagistArguments -> IO (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 -> IO (Maybe Text)
latestText (TextArguments textArguments) = do
uri <- useHttpsURI <$> mkURI textArguments
packagistResponse <- traverse (runReq defaultHttpConfig) $ go . fst <$> uri
pure $ Text.strip . Text.Encoding.decodeASCII . responseBody
<$> packagistResponse
where
go uri = req GET uri NoReqBody bsResponse mempty

View File

@ -77,7 +77,7 @@ module SlackBuilder
end
def latest
`./bin/slackbuilder #{@vendor} #{@name}`.strip
`./bin/slackbuilder packagist #{@vendor} #{@name}`.strip
end
end
@ -86,14 +86,11 @@ module SlackBuilder
def initialize(latest_url)
super()
@latest_url = URI latest_url
@latest_url = latest_url
end
def latest
response = Net::HTTP.get @latest_url, {
'content-type' => 'text/plain'
}
response.strip
`./bin/slackbuilder text #{@latest_url}`.strip
end
end

View File

@ -23,15 +23,19 @@ extra-source-files: CHANGELOG.md
executable slackbuilder
main-is: Main.hs
-- Modules included in this executable, other than Main.
-- other-modules:
other-modules:
SlackBuilder.CommandLine
SlackBuilder.Updater
default-extensions:
OverloadedStrings
RecordWildCards
TemplateHaskell
build-depends:
aeson ^>= 2.2.0,
base ^>= 4.16.4.0,
bytestring ^>= 0.11.0,
modern-uri ^>= 0.3.6,
optparse-applicative ^>= 0.18.1,
req ^>=3.13,
text ^>= 2.0,
unordered-containers ^>= 0.2.19,