Recognize + in sematnic tags

lib/SlackBuilder/LatestVersionCheck.hs

@@ -0,0 +1,192 @@
+{- 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(..))
+import Control.Monad ((>=>))
+
+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" >=> checkForStable
+  where
+    checkForStable tag
+        | Text.any (`elem` ['-', '+']) tag = Nothing
+        | otherwise = Just tag
+
+-- * 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\
+        \}"