{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Network.Linklater.Types where
import qualified Control.Exception.Safe as Ex
import qualified Data.ByteString.Lazy as LazyBytes
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Network.Wreq as Wreq
import BasePrelude
import Control.Lens hiding ((.=))
import Control.Monad.Except
import Data.Aeson
type ChannelID = Text
data Channel = Channel !ChannelID !Text deriving (Eq, Ord, Show)
newtype User = User Text deriving (Eq, Ord, Show)
data Command = Command {
_commandName :: !Text,
_commandUser :: !User,
_commandChannel :: !Channel,
_commandText :: !(Maybe Text)
} deriving (Eq, Ord, Show)
newtype Icon =
EmojiIcon Text deriving (Eq, Ord, Show)
data Format =
FormatAt !User
| FormatUser !User !Text
| FormatLink !Text !Text
| FormatString !Text
data Message =
SimpleMessage !Icon !Text !Channel !Text
| FormattedMessage !Icon !Text !Channel ![Format]
data Config = Config {
_configHookURL :: !Text
}
newtype APIToken =
APIToken Text
deriving (Show, Eq, Ord)
type Response = Wreq.Response LazyBytes.ByteString
data RequestError =
RequestError { _requestErrorException :: !(Maybe SomeException)
, _requestErrorResponse :: !(Maybe Response)
, _requestErrorDecoding :: !(Maybe String)
} deriving Show
unformat :: Format -> Text
unformat (FormatAt user@(User u)) = unformat (FormatUser user u)
unformat (FormatUser (User u) t) = "<@" <> u <> "|" <> t <> ">"
unformat (FormatLink url t) = "<" <> url <> "|" <> t <> ">"
unformat (FormatString t) = foldr (uncurry Text.replace) t (asList [("<", "<"), (">", ">"), ("&", "&")])
commandOfParams :: Map.Map Text Text -> Either String Command
commandOfParams params = do
user <- userOf <$> paramOf "user_name"
channel <- Channel <$> paramOf "channel_id" <*> paramOf "channel_name"
Command <$> (nameOf <$> paramOf "command")
<*> pure user
<*> pure channel
<*> pure (either (const Nothing) Just (paramOf "text"))
where
userOf = User . Text.filter (/= '@')
nameOf = Text.filter (/= '/')
paramOf key = case params ^. at key of
Just value -> Right value
Nothing -> Left ("paramOf: no key: " <> show key)
tryRequest :: (MonadIO m, MonadError RequestError m) => IO Response -> m Response
tryRequest io = do
either_ <- liftIO $ Ex.try io
case either_ of
Left e ->
throwError (RequestError (Just e) Nothing Nothing)
Right response -> do
let code = response ^. Wreq.responseStatus . Wreq.statusCode
if code >= 200 && code < 300 then
pure response
else
throwError (RequestError Nothing (Just response) Nothing)
promoteEither :: MonadError RequestError m => Response -> (l -> String) -> Either l r -> m r
promoteEither response l2s =
\case Left l -> throwError $ RequestError Nothing (Just response) (Just $ l2s l)
Right r -> pure r
promoteMaybe :: MonadError RequestError m => Response -> String -> Maybe r -> m r
promoteMaybe response s =
\case Nothing -> throwError $ RequestError Nothing (Just response) (Just s)
Just r -> pure r
asList :: [a] -> [a]
asList = id
instance ToJSON Channel where
toJSON (Channel cid _) = toJSON cid
instance ToJSON Message where
toJSON m = case m of
(FormattedMessage emoji username channel formats) ->
toJSON_ emoji username channel (Text.unwords (unformat <$> formats)) False
(SimpleMessage emoji username channel text) ->
toJSON_ emoji username channel text True
where
toJSON_ (EmojiIcon emoji) username channel raw toParse =
object [ "channel" .= channel
, "icon_emoji" .= (":" <> emoji <> ":")
, "parse" .= String (if toParse then "full" else "poop")
, "username" .= username
, "text" .= raw
, "unfurl_links" .= True
]