86 lines
3.1 KiB
Haskell
86 lines
3.1 KiB
Haskell
module SlackBuilder.Download
|
|
( commit
|
|
, hostedSources
|
|
, remoteFileExists
|
|
, updateSlackBuildVersion
|
|
) where
|
|
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.IO as Text.IO
|
|
import SlackBuilder.Config
|
|
import SlackBuilder.Trans
|
|
import Control.Monad.Trans.Reader (asks)
|
|
import Control.Monad.IO.Class (MonadIO(liftIO))
|
|
import System.IO (IOMode(..), withFile)
|
|
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
|
|
repository' <- SlackBuilderT $ asks repository
|
|
let name = Text.unpack $ snd $ Text.breakOnEnd "/" packagePath
|
|
slackbuildFilename = repository'
|
|
</> Text.unpack packagePath
|
|
</> (name <.> "SlackBuild")
|
|
slackbuildContents <- liftIO $ Text.IO.readFile slackbuildFilename
|
|
let (contentsHead, contentsTail) = Text.dropWhile (/= '\n')
|
|
<$> Text.breakOn "VERSION=${VERSION:-" slackbuildContents
|
|
|
|
liftIO $ Text.IO.writeFile slackbuildFilename
|
|
$ contentsHead <> "VERSION=${VERSION:-" <> version <> "}" <> contentsTail
|
|
|
|
commit :: Text -> Text -> SlackBuilderT ()
|
|
commit packagePath version = do
|
|
branch' <- SlackBuilderT $ Text.unpack <$> asks branch
|
|
repository' <- SlackBuilderT $ asks repository
|
|
let message = Text.unpack
|
|
$ packagePath <> ": Updated for version " <> version
|
|
|
|
(checkoutExitCode, _, _) <- liftIO
|
|
$ withFile "/dev/null" WriteMode
|
|
$ testCheckout repository' branch'
|
|
|
|
unless (checkoutExitCode == ExitSuccess)
|
|
$ liftIO
|
|
$ callProcess "git" ["-C", repository', "checkout", "-b", branch', "master"]
|
|
liftIO
|
|
$ callProcess "git" ["-C", repository', "add", Text.unpack packagePath]
|
|
>> callProcess "git" ["-C", repository', "commit", "-S", "-m", message]
|
|
where
|
|
testCheckout repository' branch' nullHandle =
|
|
let createCheckoutProcess = (proc "git" ["-C", repository', "checkout", branch'])
|
|
{ std_in = NoStream
|
|
, 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
|