145 lines
4.4 KiB
Haskell
145 lines
4.4 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 (POST), ReqBodyJson (ReqBodyJson)
|
|
)
|
|
import Text.URI (mkURI)
|
|
import SlackBuilder.CommandLine
|
|
import qualified Data.Aeson.KeyMap as KeyMap
|
|
import GHC.Records (HasField(..))
|
|
|
|
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 v = 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 -> IO (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 -> IO (Maybe Text)
|
|
latestText (TextArguments textArguments) = do
|
|
uri <- 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 :: Settings -> GhArguments -> (Text -> Maybe Text) -> IO (Maybe Text)
|
|
latestGitHub Settings{..} GhArguments{..} versionTransform = do
|
|
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 $ repository $ 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\
|
|
\}"
|