diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,1 @@ +# 0.1.0 diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2017 Juan Pedro Villa Isaza + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,35 @@ +# Haskell bindings for the Slack web API + +## Example + +``` +> import qualified Web.Slack as Slack +``` + +``` +> import qualified Web.Slack.Api as Api +``` + +``` +> manager <- Slack.mkManager +``` + +``` +> :set -XRecordWildCards +> Slack.Cli{..} = Slack.mkCli +apiTest :: ... +authTest :: ... +channelsCreate :: ... +chatPostMessage :: ... +``` + +``` +> Slack.run manager (apiTest Api.mkTestReq) +Right ... +``` + +``` +> :set -XOverloadedStrings +> Slack.run manager (apiTest Api.mkTestReq { testReqFoo = Just "bar" }) +Right ... +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/slack-web.cabal b/slack-web.cabal new file mode 100644 --- /dev/null +++ b/slack-web.cabal @@ -0,0 +1,58 @@ +name: slack-web +version: 0.1.0 + +build-type: Simple +cabal-version: >= 1.21 + +license: MIT +license-file: LICENSE.md + +copyright: 2017 Juan Pedro Villa Isaza +author: Juan Pedro Villa Isaza +maintainer: Juan Pedro Villa Isaza + +homepage: https://github.com/jpvillaisaza/slack-web +bug-reports: https://github.com/jpvillaisaza/slack-web/issues + +synopsis: Bindings for the Slack web API +description: Haskell bindings for the Slack web API. + +category: Web + +tested-with: GHC == 8.0.2 + +extra-source-files: + CHANGELOG.md + README.md + + +library + hs-source-dirs: + src + exposed-modules: + Web.Slack + Web.Slack.Api + Web.Slack.Auth + Web.Slack.Channel + Web.Slack.Chat + Web.Slack.Util + build-depends: + aeson >= 1.1 && < 1.2 + , base >= 4.9 && < 4.10 + , generics-sop >= 0.2 && < 0.3 + , http-api-data >= 0.3 && < 0.4 + , http-client >= 0.5 && < 0.6 + , http-client-tls >= 0.3 && < 0.4 + , servant >= 0.10 && < 0.11 + , servant-client >= 0.10 && < 0.11 + , text >= 1.2 && < 1.3 + , transformers + default-language: + Haskell2010 + ghc-options: + -Wall + + +source-repository head + type: git + location: https://github.com/jpvillaisaza/slack-web diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.Slack + ( Cli(..) + , mkCli + , run + , mkManager + ) + where + +-- base +import Data.Proxy (Proxy(..)) +import GHC.Generics (Generic) + +-- generics-sop +import qualified Generics.SOP (Generic) + +-- http-client +import Network.HTTP.Client (Manager, newManager) + +-- http-client-tls +import Network.HTTP.Client.TLS (tlsManagerSettings) + +-- servant +import Servant.API + +-- servant-client +import Servant.Client +import Servant.Client.Generic + +-- slack-web +import qualified Web.Slack.Api as Api +import qualified Web.Slack.Auth as Auth +import qualified Web.Slack.Channel as Channel +import qualified Web.Slack.Chat as Chat + +-- transformers +import Control.Monad.IO.Class + + +-- | +-- +-- + +type Api = + "api.test" + :> ReqBody '[FormUrlEncoded] Api.TestReq + :> Post '[JSON] Api.TestRsp + :<|> + "auth.test" + :> ReqBody '[FormUrlEncoded] Auth.TestReq + :> Post '[JSON] Auth.TestRsp + :<|> + "channels.create" + :> ReqBody '[FormUrlEncoded] Channel.CreateReq + :> Post '[JSON] Channel.CreateRsp + :<|> + "chat.postMessage" + :> ReqBody '[FormUrlEncoded] Chat.PostMsgReq + :> Post '[JSON] Chat.PostMsgRsp + + +-- | +-- +-- + +data Cli = + Cli + { -- | + -- + -- Check API calling code. + -- + -- + + apiTest + :: Api.TestReq + -> ClientM Api.TestRsp + + -- | + -- + -- Check authentication and identity. + -- + -- + + , authTest + :: Auth.TestReq + -> ClientM Auth.TestRsp + + -- | + -- + -- Create a channel. + -- + -- + + , channelsCreate + :: Channel.CreateReq + -> ClientM Channel.CreateRsp + + -- | + -- + -- Send a message to a channel. + -- + -- + + , chatPostMessage + :: Chat.PostMsgReq + -> ClientM Chat.PostMsgRsp + + } + deriving (Generic) + + +-- | +-- +-- + +instance Generics.SOP.Generic Cli + + +-- | +-- +-- + +instance (Client Api ~ cli) => ClientLike cli Cli + + +-- | +-- +-- + +mkCli :: Cli +mkCli = + mkClient (client (Proxy :: Proxy Api)) + + +-- | +-- +-- + +run + :: MonadIO m + => Manager + -> ClientM a + -> m (Either ServantError a) +run manager = + let + baseUrl = + BaseUrl Https "slack.com" 443 "/api" + + in + liftIO . flip runClientM (ClientEnv manager baseUrl) + + +-- | +-- +-- + +mkManager :: IO Manager +mkManager = + newManager tlsManagerSettings diff --git a/src/Web/Slack/Api.hs b/src/Web/Slack/Api.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Api.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Api +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + + +module Web.Slack.Api + ( TestReq(..) + , mkTestReq + , TestRsp(..) + ) + where + +-- aeson +import Data.Aeson.TH + +-- base +import GHC.Generics (Generic) + +-- http-api-data +import Web.FormUrlEncoded + +-- slack-web +import Web.Slack.Util + +-- text +import Data.Text (Text) + + +-- | +-- +-- + +data TestReq = + TestReq + { testReqError :: Maybe Text + , testReqFoo :: Maybe Text + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "testReq") ''TestReq) + + +-- | +-- +-- + +instance ToForm TestReq where + toForm = + genericToForm (formOpts "testReq") + + +-- | +-- +-- + +mkTestReq :: TestReq +mkTestReq = + TestReq + { testReqError = Nothing + , testReqFoo = Nothing + } + + +-- | +-- +-- + +data TestRsp = + TestRsp + { testRspOk :: Bool + , testRspArgs :: Maybe TestReq + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "testRsp") ''TestRsp) diff --git a/src/Web/Slack/Auth.hs b/src/Web/Slack/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Auth.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Auth +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + + +module Web.Slack.Auth + where + +-- aeson +import Data.Aeson.TH + +-- base +import GHC.Generics (Generic) + +-- http-api-data +import Web.FormUrlEncoded + +-- slack-web +import Web.Slack.Util + +-- text +import Data.Text (Text) + + +-- | +-- +-- + +newtype TestReq = + TestReq + { testReqToken :: Text + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "testReq") ''TestReq) + + +-- | +-- +-- + +instance ToForm TestReq where + toForm = + genericToForm (formOpts "testReq") + + +-- | +-- +-- + +mkTestReq + :: Text + -> TestReq +mkTestReq = + TestReq + + +-- | +-- +-- + +data TestRsp = + TestRsp + { testRspOk :: Bool + , testRspUrl :: Text + , testRspTeam :: Text + , testRspUser :: Text + , testRspTeamId :: Text + , testRspUserId :: Text + , testRspEnterpriseId :: Maybe Text + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "testRsp") ''TestRsp) diff --git a/src/Web/Slack/Channel.hs b/src/Web/Slack/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Channel.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Channel +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.Slack.Channel + ( Channel(..) + , Purpose(..) + , Topic(..) + , CreateReq(..) + , mkCreateReq + , CreateRsp(..) + ) + where + +-- aeson +import Data.Aeson.TH + +-- base +import GHC.Generics (Generic) + +-- http-api-data +import Web.FormUrlEncoded + +-- slack-web +import Web.Slack.Util + +-- text +import Data.Text (Text) + + +-- | +-- +-- + +data Channel = + Channel + { channelId :: Text + , channelName :: Text + , channelCreated :: Integer + , channelCreator :: Text + , channelIsArchived :: Bool + , channelIsMember :: Bool + , channelIsGeneral :: Bool + , channelLastRead :: Text + , channelLatest :: Maybe Text + , channelUnreadCount :: Integer + , channelUnreadCountDisplay :: Integer + , channelMembers :: [Text] + , channelTopic :: Topic + , channelPurpose :: Purpose + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +data Purpose = + Purpose + { purposeValue :: Text + , purposeCreator :: Text + , purposeLastSet :: Integer + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +data Topic = + Topic + { topicValue :: Text + , topicCreator :: Text + , topicLastSet :: Integer + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "channel") ''Channel) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "purpose") ''Purpose) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "topic") ''Topic) + + +-- | +-- +-- + +data CreateReq = + CreateReq + { createReqToken :: Text + , createReqName :: Text + , createReqValidate :: Maybe Bool + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "createReq") ''CreateReq) + + +-- | +-- +-- + +instance ToForm CreateReq where + toForm = + genericToForm (formOpts "createReq") + + +-- | +-- +-- + +mkCreateReq + :: Text + -> Text + -> CreateReq +mkCreateReq token name = + CreateReq + { createReqToken = token + , createReqName = name + , createReqValidate = Nothing + } + + +-- | +-- +-- + +data CreateRsp = + CreateRsp + { createRspOk :: Bool + , createRspChannel :: Channel + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- +$(deriveJSON (jsonOpts "createRsp") ''CreateRsp) diff --git a/src/Web/Slack/Chat.hs b/src/Web/Slack/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Chat.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Chat +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.Slack.Chat + ( PostMsg(..) + , PostMsgReq(..) + , mkPostMsgReq + , PostMsgRsp(..) + ) + where + +-- aeson +import Data.Aeson.TH + +-- base +import GHC.Generics (Generic) + +-- http-api-data +import Web.FormUrlEncoded + +-- slack-web +import Web.Slack.Util + +-- text +import Data.Text (Text) + + +data PostMsg = + PostMsg + { postMsgText :: Text + , postMsgParse :: Maybe Text + , postMsgLinkNames :: Maybe Bool + , postMsgAttachments :: Maybe Text + , postMsgUnfurlLinks :: Maybe Bool + , postMsgUnfurlMedia :: Maybe Bool + , postMsgUsername :: Maybe Text + , postMsgAsUser :: Maybe Bool + , postMsgIconUrl :: Maybe Text + , postMsgIconEmoji :: Maybe Text + , postMsgThreadTs :: Maybe Text + , postMsgReplyBroadcast :: Maybe Bool + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "postMsg") ''PostMsg) + + +-- | +-- +-- + +data PostMsgReq = + PostMsgReq + { postMsgReqToken :: Text + , postMsgReqChannel :: Text + , postMsgReqText :: Text + , postMsgReqParse :: Maybe Text + , postMsgReqLinkNames :: Maybe Bool + , postMsgReqAttachments :: Maybe Text + , postMsgReqUnfurlLinks :: Maybe Bool + , postMsgReqUnfurlMedia :: Maybe Bool + , postMsgReqUsername :: Maybe Text + , postMsgReqAsUser :: Maybe Bool + , postMsgReqIconUrl :: Maybe Text + , postMsgReqIconEmoji :: Maybe Text + , postMsgReqThreadTs :: Maybe Text + , postMsgReqReplyBroadcast :: Maybe Bool + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "postMsgReq") ''PostMsgReq) + + +-- | +-- +-- + +instance ToForm PostMsgReq where + toForm = + genericToForm (formOpts "postMsgReq") + + +-- | +-- +-- + +mkPostMsgReq + :: Text + -> Text + -> Text + -> PostMsgReq +mkPostMsgReq token channel text = + PostMsgReq + { postMsgReqToken = token + , postMsgReqChannel = channel + , postMsgReqText = text + , postMsgReqParse = Nothing + , postMsgReqLinkNames = Nothing + , postMsgReqAttachments = Nothing + , postMsgReqUnfurlLinks = Nothing + , postMsgReqUnfurlMedia = Nothing + , postMsgReqUsername = Nothing + , postMsgReqAsUser = Nothing + , postMsgReqIconUrl = Nothing + , postMsgReqIconEmoji = Nothing + , postMsgReqThreadTs = Nothing + , postMsgReqReplyBroadcast = Nothing + } + + +-- | +-- +-- + +data PostMsgRsp = + PostMsgRsp + { postMsgRspOk :: Bool + , postMsgRspTs :: String + , postMsgRspMessage :: PostMsg + } + deriving (Eq, Generic, Show) + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "postMsgRsp") ''PostMsgRsp) diff --git a/src/Web/Slack/Util.hs b/src/Web/Slack/Util.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Util.hs @@ -0,0 +1,84 @@ +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Util +-- Description: +-- +-- +-- +---------------------------------------------------------------------- + +module Web.Slack.Util + ( formOpts + , jsonOpts + ) + where + +-- aeson +import Data.Aeson.TH + +-- base +import Data.Char + +-- http-api-data +import Web.FormUrlEncoded (FormOptions(FormOptions)) + +-- text +import Data.Text (Text) +import qualified Data.Text as Text + + +-- | +-- +-- + +formOpts + :: Text + -> FormOptions +formOpts prefix = + FormOptions (modifyLabel prefix) + + +-- | +-- +-- + +jsonOpts + :: Text + -> Options +jsonOpts prefix = + defaultOptions + { fieldLabelModifier = modifyLabel prefix + } + + +-- | +-- +-- + +modifyLabel + :: Text + -> String + -> String +modifyLabel prefix = + fmap toLower + . addUnderscores + . drop (Text.length prefix) + + +-- | +-- +-- + +addUnderscores + :: String + -> String +addUnderscores = + let + go res [] = res + go [] (x:xs) = go [toLower x] xs + go res (x:xs) + | isUpper x = go (toLower x : '_' : res) xs + | otherwise = go (x : res) xs + + in + reverse . go []