Implement remote file check as Haskell command

This commit is contained in:
Eugen Wissner 2023-08-17 22:07:09 +02:00
parent 6b15ccd0f5
commit fd649b66f5
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
7 changed files with 43 additions and 8 deletions

View File

@ -34,6 +34,8 @@ main = do
updateSlackBuildVersion packagePath version >> pure Nothing
CommitCommand packagePath version ->
commit packagePath version >> pure Nothing
ExistsCommand urlPath -> pure . Text.pack . show
<$> remoteFileExists urlPath
chooseTransformFunction (Just "php") = phpTransform
chooseTransformFunction (Just "rdiff-backup") = Text.stripPrefix "v"
chooseTransformFunction _ = stripPrefix "v"

View File

@ -25,6 +25,7 @@ data SlackBuilderCommand
| GhCommand GhArguments
| SlackBuildCommand Text Text
| CommitCommand Text Text
| ExistsCommand Text
deriving (Eq, Show)
data PackagistArguments = PackagistArguments
@ -65,6 +66,7 @@ slackBuilderCommand = subparser
<> command "github" (info (GhCommand <$> ghArguments) mempty)
<> command "slackbuild" (info slackBuildCommand mempty)
<> command "commit" (info commitCommand mempty)
<> command "exists" (info existsCommand mempty)
where
slackBuildCommand = SlackBuildCommand
<$> argument str (metavar "PATH")
@ -72,3 +74,4 @@ slackBuilderCommand = subparser
commitCommand = CommitCommand
<$> argument str (metavar "PATH")
<*> argument str (metavar "VERSION")
existsCommand = ExistsCommand <$> argument str (metavar "PATH")

View File

@ -11,6 +11,7 @@ data Settings = Settings
{ ghToken :: !Text
, repository :: !FilePath
, branch :: Text
, downloadURL :: Text
} deriving (Eq, Show)
settingsCodec :: Toml.TomlCodec Settings
@ -18,3 +19,4 @@ settingsCodec = Settings
<$> Toml.text "gh_token" .= ghToken
<*> Toml.string "repository" .= repository
<*> Toml.text "branch" .= branch
<*> Toml.text "download_url" .= downloadURL

View File

@ -1,5 +1,7 @@
module SlackBuilder.Download
( commit
, hostedSources
, remoteFileExists
, updateSlackBuildVersion
) where
@ -15,6 +17,19 @@ import System.FilePath ((</>), (<.>))
import System.Process (CreateProcess(..), StdStream(..), proc, readCreateProcessWithExitCode, callProcess)
import System.Exit (ExitCode(..))
import Control.Monad (unless)
import Text.URI (URI(..), mkURI)
import Network.HTTP.Req
( useHttpsURI
, HEAD(..)
, NoReqBody(..)
, req
, runReq
, defaultHttpConfig
, ignoreResponse
, responseStatusCode, HttpConfig (..)
)
import Data.Maybe (fromMaybe)
import Data.Functor ((<&>))
updateSlackBuildVersion :: Text -> Text -> SlackBuilderT ()
updateSlackBuildVersion packagePath version = do
@ -54,3 +69,17 @@ commit packagePath version = do
, std_err = UseHandle nullHandle
}
in readCreateProcessWithExitCode createCheckoutProcess ""
hostedSources :: Text -> SlackBuilderT URI
hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
>>= liftIO . mkURI . (<> absoluteURL)
remoteFileExists :: Text -> SlackBuilderT Bool
remoteFileExists url = hostedSources url
>>= traverse (runReq httpConfig . go . fst) . useHttpsURI
<&> maybe False ((== 200) . responseStatusCode)
where
httpConfig = defaultHttpConfig
{ httpConfigCheckResponse = const $ const $ const Nothing
}
go uri = req HEAD uri NoReqBody ignoreResponse mempty

View File

@ -25,7 +25,11 @@ import Network.HTTP.Req
, jsonResponse
, NoReqBody(..)
, (/:)
, responseBody, useHttpsURI, bsResponse, POST (POST), ReqBodyJson (ReqBodyJson)
, responseBody
, useHttpsURI
, bsResponse
, POST(..)
, ReqBodyJson(..)
)
import Text.URI (mkURI)
import SlackBuilder.CommandLine

View File

@ -1,3 +1,4 @@
gh_token = ""
repository = "./slackbuilds"
branch = "user/nick/updates"
download_url = "https://example.com/some/path"

View File

@ -48,13 +48,7 @@ module SlackBuilder
end
def self.remote_file_exists?(url)
uri = URI hosted_sources(url)
request = Net::HTTP.new uri.host, uri.port
request.use_ssl = true
response = request.request_head uri.path
response.code.to_i == 200
`./bin/slackbuilder exists #{url}`.strip == 'True'
end
def self.download_and_deploy(uri, tarball)