slackbuilder/app/SlackBuilder/Updater.hs

159 lines
4.6 KiB
Haskell
Raw Normal View History

module SlackBuilder.Updater
2023-08-09 20:59:42 +02:00
( latestGitHub
, latestPackagist
, latestText
) 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
, useHttpsURI
, bsResponse
, POST(..)
, ReqBodyJson(..)
)
import Text.URI (mkURI)
import SlackBuilder.CommandLine
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)
2023-08-15 10:33:19 +02:00
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)
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
} 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
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
2023-08-15 10:33:19 +02:00
latestText :: TextArguments -> SlackBuilderT (Maybe Text)
latestText (TextArguments textArguments) = do
2023-08-15 10:33:19 +02:00
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
2023-08-09 20:59:42 +02:00
2023-08-15 10:33:19 +02:00
latestGitHub
:: GhArguments
-> (Text -> Maybe Text)
-> SlackBuilderT (Maybe Text)
latestGitHub GhArguments{..} versionTransform = do
ghToken' <- SlackBuilderT $ asks ghToken
2023-08-09 20:59:42 +02:00
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
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)
$ responseBody ghResponse
2023-08-09 20:59:42 +02:00
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\
\}"