1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
{- 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
, stableTagTransform
) 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(..))
data PackageOwner = PackageOwner
{ owner :: Text
, name :: Text
} deriving (Eq, Show)
-- | Removes the leading "v" from the version string and returns the result if
-- it looks like a version.
stableTagTransform :: Text -> Maybe Text
stableTagTransform = Text.stripPrefix "v"
-- * 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
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhVariables)
data GhQuery = GhQuery
{ query :: Text
, variables :: GhVariables
} deriving (Eq, Show)
$(deriveJSON defaultOptions ''GhQuery)
latestGitHub
:: PackageOwner
-> (Text -> Maybe Text)
-> SlackBuilderT (Maybe Text)
latestGitHub PackageOwner{..} 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\
\}"
|
