slackbuilder/lib/SlackBuilder/LatestVersionCheck.hs

308 lines
11 KiB
Haskell

{- 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
, latestPackagist
, latestText
, match
) 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
, POST(..)
, ReqBodyJson(..)
, JsonResponse
)
import Text.URI (mkURI)
import SlackBuilder.Trans
import qualified Data.Aeson.KeyMap as KeyMap
import GHC.Records (HasField(..))
import Control.Monad.Trans.Reader (asks)
import Data.Char (isAlpha)
import SlackBuilder.Download (responseBodySource, reqGet)
import Network.HTTP.Client (BodyReader, Response(..))
import Conduit (decodeUtf8C, (.|), linesUnboundedC, sinkNull, runConduit)
import qualified Data.Conduit.List as CL
import Data.Conduit.Process (sourceProcessWithStreams, proc)
import Data.Maybe (listToMaybe, mapMaybe)
data PackageOwner = PackageOwner
{ owner :: Text
, name :: Text
} deriving (Eq, Show)
data MatchState = MatchState
{ 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.
-- 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.
-- * [ ] - 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
{ textURL :: Text
, versionPicker :: [String]
}
latestText :: TextArguments -> Text -> SlackBuilderT (Maybe Text)
latestText TextArguments{..} pattern' = do
uri' <- mkURI textURL
versions <- case versionPicker of
(command : arguments) ->
runReq defaultHttpConfig $ reqGet uri' $ readResponse command arguments
[] -> runReq defaultHttpConfig $ reqGet uri' go
pure $ listToMaybe $ mapMaybe (match pattern') versions
where
readResponse :: String -> [String] -> Response BodyReader -> IO [Text]
readResponse command arguments response = do
let createProcess' = proc command arguments
(_, stdout', _) <- sourceProcessWithStreams createProcess' (responseBodySource response) stdoutReader sinkNull
pure stdout'
stdoutReader = decodeUtf8C .| linesUnboundedC .| CL.consume
go response = runConduit $ responseBodySource response .| stdoutReader
-- * GitHub
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
, prefix :: Maybe Text
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhVariables)
data GhQuery = GhQuery
{ query :: Text
, variables :: GhVariables
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhQuery)
latestGitHub
:: PackageOwner
-> Text
-> SlackBuilderT (Maybe Text)
latestGitHub PackageOwner{..} pattern' = do
ghToken' <- SlackBuilderT $ asks ghToken
ghResponse <- runReq defaultHttpConfig $
let uri = https "api.github.com" /: "graphql"
prefix = Text.takeWhile isAlpha
$ Text.filter (liftA2 (&&) (/= ')') (/= '(')) pattern'
query = GhQuery
{ query = githubQuery
, variables = GhVariables
{ owner = owner
, name = name
, prefix = if Text.null prefix then Nothing else Just $ prefix <> "*"
}
}
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)
$ Network.HTTP.Req.responseBody ghResponse
refs' = Vector.catMaybes
$ match pattern' . getField @"name" <$> ghNodes
pure $ refs' !? 0
where
githubQuery =
"query ($name: String!, $owner: String!, $prefix: String) {\n\
\ repository(name: $name, owner: $owner) {\n\
\ refs(first: 10, query: $prefix, refPrefix: \"refs/tags/\", orderBy: {\n\
\ field: TAG_COMMIT_DATE, direction: DESC\n\
\ }) {\n\
\ nodes {\n\
\ id,\n\
\ name\n\
\ }\n\
\ }\n\
\ }\n\
\}"