slackbuilder/lib/SlackBuilder/LatestVersionCheck.hs

{- 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 no 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.
--
-- 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 input =
    case Text.foldl' go (Just startState) input of
        Just state@MatchState{ pattern' = [] } -> Just $ getField @"matched" state
        Just state@MatchState{ pattern' = [CloseParenMatchToken] } ->
            Just $ getField @"matched" state
        Just state@MatchState{ pattern' = [AsteriskMatchToken] } ->
            Just $ getField @"matched" state
        Just state@MatchState{ pattern' = [OneOfMatchToken _] } ->
            Just $ getField @"matched" state
        _ -> Nothing
  where
    digits = toEnum <$> [fromEnum '0' .. fromEnum '9']
    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' =
            let token =
                    case firstChar of
                        '*' -> AsteriskMatchToken
                        '(' -> OpenParenMatchToken
                        ')' -> CloseParenMatchToken
                        s -> SymbolMatchToken s
             in token : parsePattern remaining
        | otherwise = []
    startState = MatchState
        { ignoring = False
        , matched = mempty
        , pattern' = parsePattern fullPattern
        }
    go :: Maybe MatchState -> Char -> Maybe MatchState
    go (Just state@MatchState{ pattern' = token : remaining }) nextCharacter =
        case token of
            OpenParenMatchToken -> go (Just state{ ignoring = True, pattern' = remaining }) nextCharacter
            CloseParenMatchToken -> go (Just state{ ignoring = False, pattern' = remaining }) nextCharacter
            AsteriskMatchToken -> Just $ matchSymbolToken state nextCharacter
            SymbolMatchToken patternCharacter
                | patternCharacter == nextCharacter -> Just
                    $ matchSymbolToken state{ pattern' = remaining } nextCharacter
                | otherwise -> Nothing
            OneOfMatchToken chars
                | nextCharacter `elem` chars ->
                    Just $ matchSymbolToken state nextCharacter
                | otherwise ->
                    go (Just state{ pattern' = remaining }) nextCharacter
    go _ _ = Nothing
    matchSymbolToken state nextCharacter
        | getField @"ignoring" state = state
        | otherwise = state
            { matched = Text.snoc (getField @"matched" state) nextCharacter
            }

-- * 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\
        \}"