slackbuilder/lib/SlackBuilder/LatestVersionCheck.hs

308 lines
11 KiB
Haskell
Raw Normal View History

2023-12-23 22:15:10 +01:00
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-- | This module contains implementations to check the latest version of a
-- package hosted by a specific service.
module SlackBuilder.LatestVersionCheck
( PackageOwner(..)
, TextArguments(..)
, latestGitHub
2023-08-09 20:59:42 +02:00
, latestPackagist
, latestText
, match
) where
2023-08-09 20:59:42 +02:00
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
2023-08-09 20:59:42 +02:00
import Data.Vector (Vector, (!?))
import qualified Data.Vector as Vector
import Network.HTTP.Req
2023-08-09 20:59:42 +02:00
( header
, runReq
, defaultHttpConfig
, req
, GET(..)
, https
, jsonResponse
, NoReqBody(..)
, (/:)
, responseBody
, POST(..)
2024-09-28 15:43:18 +02:00
, ReqBodyJson(..)
, JsonResponse
)
import Text.URI (mkURI)
2023-08-15 10:33:19 +02:00
import SlackBuilder.Trans
2023-08-09 20:59:42 +02:00
import qualified Data.Aeson.KeyMap as KeyMap
import GHC.Records (HasField(..))
2023-08-21 13:38:20 +02:00
import Control.Monad.Trans.Reader (asks)
import Data.Char (isAlpha)
import SlackBuilder.Download (responseBodySource, reqGet)
import Network.HTTP.Client (BodyReader, Response(..))
2024-09-28 15:43:18 +02:00
import Conduit (decodeUtf8C, (.|), linesUnboundedC, sinkNull, runConduit)
2024-09-27 12:20:34 +02:00
import qualified Data.Conduit.List as CL
import Data.Conduit.Process (sourceProcessWithStreams, proc)
2024-09-28 15:43:18 +02:00
import Data.Maybe (listToMaybe, mapMaybe)
data PackageOwner = PackageOwner
{ owner :: Text
, name :: Text
} deriving (Eq, Show)
data MatchState = MatchState
2024-09-09 16:47:44 +02:00
{ ignoring :: !Bool
, matched :: !Text
, pattern' :: ![MatchToken]
} deriving (Eq, Show)
data MatchToken
= OpenParenMatchToken
| CloseParenMatchToken
| SymbolMatchToken Char
| AtLeastMatchToken [Char]
| OneOfMatchToken [Char]
deriving (Eq, Show)
-- | Matches a string (for example a version name or CVS tag) against a pattern.
2024-09-09 16:47:44 +02:00
-- Returns the matched part of the string or 'Nothing' if there is not match.
--
-- The pattern is just a list of characters with some special characters and
-- sequences.
--
-- * ( ) - The text in parentheses is matched but no saved in the resulting
-- string.
-- * \\d - Matches zero or more digits.
-- * \\D - Matches one or more digits.
-- * \\. - Matches zero or more digits or dots.
-- * \\\\ - Matches a back slash.
-- * * - Matches everything.
2024-09-09 16:47:44 +02:00
-- * [ ] - Match one of the characters inbetween. The characters are
-- matched verbatim.
--
-- For example the following expression matches tags like @v1.2.3@, but returns
-- only @1.2.3@.
--
-- @
-- (v)\\.
-- @
match :: Text -> Text -> Maybe Text
match fullPattern = go startState
where
startState = MatchState
{ ignoring = False
, matched = mempty
, pattern' = parsePattern fullPattern
}
go :: MatchState -> Text -> Maybe Text
-- There is no input, look at the remaining tokens.
go MatchState{ pattern' = [], matched } "" = Just matched
go state@MatchState{ pattern' = OpenParenMatchToken : tokens } input' =
go (state{ ignoring = True, pattern' = tokens }) input'
go state@MatchState{ pattern' = CloseParenMatchToken : tokens } input' =
go (state{ ignoring = False, pattern' = tokens }) input'
go state@MatchState{ pattern' = SymbolMatchToken patternCharacter : tokens } input'
| Just (nextCharacter, leftOver) <- Text.uncons input'
, patternCharacter == nextCharacter =
go (matchSymbolToken state{ pattern' = tokens } nextCharacter) leftOver
| otherwise = Nothing
go state@MatchState{ pattern' = OneOfMatchToken chars : tokens } input'
| Just (nextCharacter, leftOver) <- Text.uncons input'
, nextCharacter `elem` chars =
go (matchSymbolToken state nextCharacter) leftOver
| otherwise =
go (state{ pattern' = tokens }) input'
go state@MatchState{ pattern' = AtLeastMatchToken chars : tokens } input'
| Just (nextCharacter, leftOver) <- Text.uncons input'
, nextCharacter `elem` chars =
go (matchSymbolToken state{ pattern' = OneOfMatchToken chars : tokens } nextCharacter) leftOver
| otherwise = Nothing
-- All tokens are processed, but there is still some input left.
go MatchState{ pattern' = [] } _ = Nothing
matchSymbolToken state nextCharacter
| getField @"ignoring" state = state
| otherwise = state
{ matched = Text.snoc (getField @"matched" state) nextCharacter
}
parsePattern :: Text -> [MatchToken]
parsePattern input'
| Just (firstChar, remaining) <- Text.uncons input'
, firstChar == '\\' =
case Text.uncons remaining of
Nothing -> []
Just ('d', remaining') -> OneOfMatchToken digits
: parsePattern remaining'
Just ('D', remaining') -> AtLeastMatchToken digits
: parsePattern remaining'
Just ('.', remaining') -> AtLeastMatchToken ('.' : digits)
: parsePattern remaining'
Just ('\\', remaining') -> SymbolMatchToken '\\'
: parsePattern remaining'
Just (_, remaining') -> parsePattern remaining'
| Just (firstChar, remaining) <- Text.uncons input'
, firstChar == '['
, Just lastBracket <- Text.findIndex (== ']') remaining
= OneOfMatchToken (Text.unpack $ Text.take lastBracket remaining)
: parsePattern (Text.drop (succ lastBracket) remaining)
| Just (firstChar, remaining) <- Text.uncons input' =
let token =
case firstChar of
'*' -> OneOfMatchToken (toEnum <$> [32 .. 127])
'(' -> OpenParenMatchToken
')' -> CloseParenMatchToken
s -> SymbolMatchToken s
in token : parsePattern remaining
| otherwise = []
where
digits = toEnum <$> [fromEnum '0' .. fromEnum '9']
-- * Packagist
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 :: PackageOwner -> SlackBuilderT (Maybe Text)
latestPackagist PackageOwner{..} = do
packagistResponse <- runReq defaultHttpConfig $
let uri = https "repo.packagist.org" /: "p2"
/: owner
/: name <> ".json"
in req GET uri NoReqBody jsonResponse mempty
let packagistPackages = getField @"packages"
$ Network.HTTP.Req.responseBody (packagistResponse :: JsonResponse PackagistResponse)
fullName = Text.intercalate "/" [owner, name]
pure $ HashMap.lookup fullName packagistPackages
>>= fmap (getField @"version" . fst) . Vector.uncons
-- * Remote text file
data TextArguments = TextArguments
2024-09-27 12:20:34 +02:00
{ textURL :: Text
, versionPicker :: [String]
}
2024-09-28 15:43:18 +02:00
latestText :: TextArguments -> Text -> SlackBuilderT (Maybe Text)
latestText TextArguments{..} pattern' = do
uri' <- mkURI textURL
versions <- case versionPicker of
(command : arguments) ->
2024-09-27 12:20:34 +02:00
runReq defaultHttpConfig $ reqGet uri' $ readResponse command arguments
2024-09-28 15:43:18 +02:00
[] -> runReq defaultHttpConfig $ reqGet uri' go
pure $ listToMaybe $ mapMaybe (match pattern') versions
where
2024-09-28 15:43:18 +02:00
readResponse :: String -> [String] -> Response BodyReader -> IO [Text]
2024-09-27 12:20:34 +02:00
readResponse command arguments response = do
let createProcess' = proc command arguments
(_, stdout', _) <- sourceProcessWithStreams createProcess' (responseBodySource response) stdoutReader sinkNull
2024-09-28 15:43:18 +02:00
pure stdout'
2024-09-27 12:20:34 +02:00
stdoutReader = decodeUtf8C .| linesUnboundedC .| CL.consume
2024-09-28 15:43:18 +02:00
go response = runConduit $ responseBodySource response .| stdoutReader
-- * GitHub
2023-08-09 20:59:42 +02:00
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'
2023-08-21 13:38:20 +02:00
parseJSON _ = fail "data key not found in the response"
2023-08-09 20:59:42 +02:00
data GhVariables = GhVariables
{ name :: Text
, owner :: Text
, prefix :: Maybe Text
2023-08-09 20:59:42 +02:00
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhVariables)
data GhQuery = GhQuery
{ query :: Text
, variables :: GhVariables
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhQuery)
2023-08-15 10:33:19 +02:00
latestGitHub
:: PackageOwner
-> Text
2023-08-15 10:33:19 +02:00
-> SlackBuilderT (Maybe Text)
latestGitHub PackageOwner{..} pattern' = do
2023-08-15 10:33:19 +02:00
ghToken' <- SlackBuilderT $ asks ghToken
2023-08-09 20:59:42 +02:00
ghResponse <- runReq defaultHttpConfig $
let uri = https "api.github.com" /: "graphql"
prefix = Text.takeWhile isAlpha
$ Text.filter (liftA2 (&&) (/= ')') (/= '(')) pattern'
2023-08-09 20:59:42 +02:00
query = GhQuery
{ query = githubQuery
, variables = GhVariables
{ owner = owner
, name = name
, prefix = if Text.null prefix then Nothing else Just $ prefix <> "*"
2023-08-09 20:59:42 +02:00
}
}
authorizationHeader = header "authorization"
$ Text.Encoding.encodeUtf8
2023-08-15 10:33:19 +02:00
$ "Bearer " <> ghToken'
2023-08-09 20:59:42 +02:00
in req POST uri (ReqBodyJson query) jsonResponse
$ authorizationHeader <> header "User-Agent" "SlackBuilder"
2023-08-15 10:33:19 +02:00
let ghNodes = nodes
$ refs
$ (getField @"repository" :: GhData -> GhRepository)
$ Network.HTTP.Req.responseBody ghResponse
refs' = Vector.catMaybes
$ match pattern' . getField @"name" <$> ghNodes
2023-08-09 20:59:42 +02:00
pure $ refs' !? 0
where
githubQuery =
"query ($name: String!, $owner: String!, $prefix: String) {\n\
2023-08-09 20:59:42 +02:00
\ repository(name: $name, owner: $owner) {\n\
\ refs(first: 10, query: $prefix, refPrefix: \"refs/tags/\", orderBy: {\n\
\ field: TAG_COMMIT_DATE, direction: DESC\n\
\ }) {\n\
2023-08-09 20:59:42 +02:00
\ nodes {\n\
\ id,\n\
\ name\n\
\ }\n\
\ }\n\
\ }\n\
\}"