292 lines
9.6 KiB
Haskell
292 lines
9.6 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
|
|
, useHttpsURI
|
|
, bsResponse
|
|
, POST(..)
|
|
, ReqBodyJson(..)
|
|
)
|
|
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 Control.Monad.IO.Class (MonadIO(..))
|
|
import Data.Char (isAlpha)
|
|
|
|
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
|
|
| AsteriskMatchToken
|
|
| SymbolMatchToken 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.
|
|
-- * \\. - 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' = AsteriskMatchToken : tokens } input'
|
|
| Just (nextCharacter, leftOver) <- Text.uncons input' =
|
|
go (matchSymbolToken state nextCharacter) leftOver
|
|
| otherwise = go state{ pattern' = tokens } ""
|
|
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' = SymbolMatchToken patternCharacter : tokens } input'
|
|
| Just (nextCharacter, leftOver) <- Text.uncons input'
|
|
, patternCharacter == nextCharacter =
|
|
go (matchSymbolToken state{ pattern' = 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 ('.', remaining') -> OneOfMatchToken ('.' : 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
|
|
'*' -> AsteriskMatchToken
|
|
'(' -> 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 = packages $ responseBody packagistResponse
|
|
fullName = Text.intercalate "/" [owner, name]
|
|
|
|
pure $ HashMap.lookup fullName packagistPackages
|
|
>>= fmap (version . fst) . Vector.uncons
|
|
|
|
-- * Remote text file
|
|
|
|
data TextArguments = TextArguments
|
|
{ versionPicker :: Text -> Text
|
|
, textURL :: Text
|
|
}
|
|
|
|
latestText :: TextArguments -> SlackBuilderT (Maybe Text)
|
|
latestText TextArguments{..} = do
|
|
uri <- liftIO $ useHttpsURI <$> mkURI textURL
|
|
packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri
|
|
|
|
pure $ versionPicker . Text.Encoding.decodeUtf8 . responseBody
|
|
<$> packagistResponse
|
|
where
|
|
go uri = req GET uri NoReqBody bsResponse mempty
|
|
|
|
-- * 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)
|
|
$ 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\
|
|
\}"
|