slackbuilder/app/SlackBuilder/Updater.hs
2023-09-25 10:18:00 +02:00

159 lines
4.6 KiB
Haskell

module SlackBuilder.Updater
( latestGitHub
, latestPackagist
, latestText
) 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.CommandLine
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(..))
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)
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
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhVariables)
data GhQuery = GhQuery
{ query :: Text
, variables :: GhVariables
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhQuery)
latestPackagist :: PackagistArguments -> SlackBuilderT (Maybe Text)
latestPackagist PackagistArguments{..} = do
packagistResponse <- runReq defaultHttpConfig $
let uri = https "repo.packagist.org" /: "p2"
/: vendor
/: name <> ".json"
in req GET uri NoReqBody jsonResponse mempty
let packagistPackages = packages $ responseBody packagistResponse
fullName = Text.intercalate "/" [vendor, name]
pure $ HashMap.lookup fullName packagistPackages
>>= fmap (version . fst) . Vector.uncons
latestText :: TextArguments -> SlackBuilderT (Maybe Text)
latestText (TextArguments textArguments) = do
uri <- liftIO $ useHttpsURI <$> mkURI textArguments
packagistResponse <- traverse (runReq defaultHttpConfig . go . fst) uri
pure $ Text.strip . Text.Encoding.decodeASCII . responseBody
<$> packagistResponse
where
go uri = req GET uri NoReqBody bsResponse mempty
latestGitHub
:: GhArguments
-> (Text -> Maybe Text)
-> SlackBuilderT (Maybe Text)
latestGitHub GhArguments{..} versionTransform = do
ghToken' <- SlackBuilderT $ asks ghToken
ghResponse <- runReq defaultHttpConfig $
let uri = https "api.github.com" /: "graphql"
query = GhQuery
{ query = githubQuery
, variables = GhVariables
{ owner = owner
, name = name
}
}
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.reverse
$ Vector.catMaybes
$ versionTransform . getField @"name" <$> ghNodes
pure $ refs' !? 0
where
githubQuery =
"query ($name: String!, $owner: String!) {\n\
\ repository(name: $name, owner: $owner) {\n\
\ refs(last: 10, refPrefix: \"refs/tags/\", orderBy: { field: TAG_COMMIT_DATE, direction: ASC }) {\n\
\ nodes {\n\
\ id,\n\
\ name\n\
\ }\n\
\ }\n\
\ }\n\
\}"