linklater-1.0.0.0: Network/Linklater.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module: Network.Linklater
-- Copyright: (c) The Linklaterteers
--
-- License: BSD-style
-- Stability: experimental
-- Portability: GHC
--
-- Features:
--
-- * Uses @Text@ everywhere so you can send your slash commands crazy Unicode characters all day long.
-- * Lovely documentation.
-- * Battle-tested.
--
-- Here's a @/jpgto@ bot! If you run this program and then tell Slack
-- about your server (incoming hook and custom slash command) and then
-- type @/jpgto diplomatico@ in one of your channels, you'll get the
-- image from @http://diplomatico.jpg.to@. How, you say? /Screen scraping/.
--
-- @
-- urlParser :: Parser B.ByteString
-- urlParser = p
--   where
--     p = garbage *> url
--     garbage = string "src=\"" <|> (P.take 1 *> garbage)
--     url = takeTill (== _quotedbl)
--
-- urlFor :: Text -> IO Text
-- urlFor search = do
--   r <- get (T.unpack $ F.format "http://{}.jpg.to/" [search])
--   (return . handle . parse urlParser . strictly) (r ^. responseBody)
--   where
--     strictly = B.concat . L.toChunks
--     handle (Fail i ctxs s) = error (show (i, ctxs, s))
--     handle (Partial f) = handle (f "")
--     handle (Done _ r) = toText r
--
-- jpgto :: Maybe Command -> Application
-- jpgto (Just (Command (User user) channel text)) req respond = do
--   url <- urlFor (maybe "spolsky" id text)
--   say (Message channel (response url) (EmojiIcon "gift")) config
--   (respond . responseLBS status200 headers) ""
--   where
--     response url = F.format "@{} {}" (user, url)
--     config = Config token "trello.slack.com"
--     headers = [("Content-Type", "text/plain")]
--
-- main :: IO ()
-- main = do
--   let port = 80
--   putStrLn (F.format "+ Listening on port {}" [port])
--   run port (slash jpgto)
--    return ()
-- @
--
-- For the full example (since this one is missing a ton of imports),
-- see the @examples/@ directory on GitHub.
--
-- https://github.com/hlian/linklater

module Network.Linklater
       (
         say,
         slash,
         Channel(..),
         User(..),
         Message(..),
         Config(..),
         Command(..),
         Icon(..),
       ) where

import Control.Applicative ((<$>))
import Data.Aeson
import Data.ByteString.Lazy as BSL
import qualified Data.Map as M
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL
import qualified Network.Wai as W
import Network.Wreq hiding (params)

-- | Where slash commands can come from, and where messages can go.
data Channel =
   -- | A public or private group.
    GroupChannel Text
  -- | A private conversation with your best friend (or lover?).
  | IMChannel Text
  deriving (Eq, Ord, Show)

-- | A username: no at-signs, just text!
newtype User = User Text deriving (Eq, Ord, Show)

-- | Incoming HTTP requests to the slash function get parsed into one
-- of these babies.
data Command = Command {
  -- | Who ran your slash command.
  _commandUser :: User,
  -- | Where the person ran your slash command.
  _commandChannel :: Channel,
  -- | Text for the slash command, if any.
  _commandText :: Maybe Text
  } deriving (Eq, Ord, Show)

-- | For example, @":stars2:"@. Future versions should support actual
-- images, I GUESS.
newtype Icon = EmojiIcon Text deriving (Eq, Ord, Show)

-- | Here's how you talk.
data Message = Message {
  -- | You need a channel. It can be a group channel or a private IM.
  -- Alert: if it's a private IM, it'll look like it came from
  -- slackbot (as of writing).
  _messageChannel :: Channel,
  -- | What you want to say. This will be parsed in full (parse=full).
  -- In the future I'll support other forms of parsing, hopefully.
  -- Poke me with a pull request if I forget.
  _messageText :: Text,
  -- | The icon you want your message to appear as.
  _messageIcon :: Icon
  } deriving (Eq, Ord, Show)

instance ToJSON Message where
  toJSON (Message channel text (EmojiIcon emoji)) =
    object [ "channel" .= stringOfChannel channel
           , "icon_emoji" .= TL.concat [":", emoji, ":"]
           , "parse" .= String "full"
           , "username" .= String "jpgtobot"
           , "text" .= text
           ]
    where
      stringOfChannel (GroupChannel c) = TL.concat ["#", c]
      stringOfChannel (IMChannel m) = TL.concat ["@", m]

-- | Like a curiosity about the world, you'll need one of these to say something.
data Config = Config {
  -- | This is the incoming web hook token that Slack gave you. It's usually a long alphanumberic string of garbage.
  _configIncomingHookToken :: Text,
  -- | This is where your Slack account is hosted. For example, 'trello.slack.com'.
  _configHostname :: Text
  }

-- | The 'say' function posts a Message, with a capital M, to Slack.
-- It'll, ahem, need your token first though.
say :: Message -> Config -> IO (Response ByteString)
say message config =
  post (TL.unpack url) (encode message)
  where
    -- TODO: use a URL builder
    url = TL.concat ["https://", _configHostname config, "/services/hooks/incoming-webhook?token=", _configIncomingHookToken config]

-- | A bot server! As if by magic. This acts like a WAI middleware in
-- that you let us wrap around your application.
slash :: (Maybe Command -> W.Application) -> W.Application
slash f req respond = f command req respond
  where
    command = do
      user <- userOf <$> wishFor "user_name"
      channel <- wishFor "channel_name" >>= channelOf user
      let text = wishFor "text"
      return (Command user channel text)
    wishFor key = case M.lookup (key :: Text) params of
      Just (Just "") -> Nothing
      Just (Just value) -> Just value
      _ -> Nothing
    userOf = User . TL.filter (/= '@')
    channelOf (User u) "directmessage" = Just (IMChannel u)
    channelOf _ "privategroup" = Nothing
    channelOf _ c = Just (GroupChannel c)
    params = M.fromList [(toText k, toText <$> v) | (k, v) <- W.queryString req]
    toText = TLE.decodeUtf8 . BSL.fromChunks . return