diff options
Diffstat (limited to 'app/SlackBuilder')
| -rw-r--r-- | app/SlackBuilder/CommandLine.hs | 58 | ||||
| -rw-r--r-- | app/SlackBuilder/Updater.hs | 158 |
2 files changed, 0 insertions, 216 deletions
diff --git a/app/SlackBuilder/CommandLine.hs b/app/SlackBuilder/CommandLine.hs deleted file mode 100644 index 7cfe747..0000000 --- a/app/SlackBuilder/CommandLine.hs +++ /dev/null @@ -1,58 +0,0 @@ -module SlackBuilder.CommandLine - ( GhArguments(..) - , SlackBuilderCommand(..) - , PackagistArguments(..) - , TextArguments(..) - , slackBuilderParser - ) where - -import Data.Text (Text) -import Options.Applicative - ( Parser - , ParserInfo(..) - , metavar - , argument - , str - , info - , fullDesc - , subparser - , command, - ) - -data SlackBuilderCommand - = CategoryCommand Text - | CloneCommand Text Text Text - | Up2DateCommand - -data PackagistArguments = PackagistArguments - { vendor :: Text - , name :: Text - } deriving (Eq, Show) - -data GhArguments = GhArguments - { owner :: Text - , name :: Text - , transform :: Maybe Text - } deriving (Eq, Show) - -data TextArguments = TextArguments - { versionPicker :: Text -> Text - , textURL :: Text - } - -slackBuilderParser :: ParserInfo SlackBuilderCommand -slackBuilderParser = info slackBuilderCommand fullDesc - -slackBuilderCommand :: Parser SlackBuilderCommand -slackBuilderCommand = subparser - $ command "category" (info categoryCommand mempty) - <> command "clone" (info cloneCommand mempty) - <> command "up2date" (info up2DateCommand mempty) - where - categoryCommand = CategoryCommand - <$> argument str (metavar "PKGNAM") - cloneCommand = CloneCommand - <$> argument str (metavar "REPO") - <*> argument str (metavar "TARBALL") - <*> argument str (metavar "TAG_PREFIX") - up2DateCommand = pure Up2DateCommand diff --git a/app/SlackBuilder/Updater.hs b/app/SlackBuilder/Updater.hs deleted file mode 100644 index 1ebf7fe..0000000 --- a/app/SlackBuilder/Updater.hs +++ /dev/null @@ -1,158 +0,0 @@ -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{..} = 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 - -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\ - \}" |