bot.hs

{-# LANGUAGE TypeApplications #-}

module Main where

import Control.Concurrent.Async (forConcurrently)
import Control.Lens hiding ((.=))
import Control.Monad (void)
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), decode, withObject, (.:), (.=))
import Data.Function (on)
import Data.Generics.Labels ()
import Data.List (groupBy)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Traversable (for)
import GHC.Generics (Generic)
import qualified Network.Wreq as Wreq

-- Domain types

newtype TelegramResponse a = TelegramResponse a

newtype UpdateID = UpdateID Integer
  deriving newtype (Eq, Ord, Show, Num, FromJSON, ToJSON)

data Update = NewMessage {id :: UpdateID, message :: Message}
  deriving stock (Show, Generic)

newtype MessageID = MessageID Integer
  deriving newtype (Eq, Ord, Show, Num, FromJSON, ToJSON)

data Message = TextMessage {id :: MessageID, author :: User, chat :: Chat, text :: Text}
  deriving stock (Show, Generic)

newtype UserID = UserID Integer
  deriving newtype (Eq, Ord, Show, Num, FromJSON, ToJSON)

data User = User {id :: UserID, name :: Text}
  deriving stock (Show, Generic)

newtype ChatID = ChatID Integer
  deriving newtype (Eq, Ord, Show, Num, FromJSON, ToJSON)

data ChatType = Private | Group | Supergroup | Channel
  deriving stock (Eq, Show, Generic)

data Chat = Chat {id :: ChatID, type_ :: ChatType}
  deriving stock (Eq, Show, Generic)

-- Aeson instances

instance FromJSON a => FromJSON (TelegramResponse a) where
  parseJSON = withObject "TelegramResponse" \v -> do
    Bool True <- v .: "ok"
    TelegramResponse <$> v .: "result"

instance FromJSON Update where
  parseJSON = withObject "NewMessage" \v -> do
    id <- v .: "update_id"
    message <- v .: "message"
    pure NewMessage {id, message}

instance FromJSON Message where
  parseJSON = withObject "TextMessage" \v -> do
    id <- v .: "message_id"
    author <- v .: "from"
    chat <- v .: "chat"
    text <- v .: "text"
    pure TextMessage {id, author, chat, text}

instance FromJSON User where
  parseJSON = withObject "User" \v -> do
    id <- v .: "id"
    name <- v .: "first_name"
    pure User {id, name}

instance FromJSON Chat where
  parseJSON = withObject "Chat" \v -> do
    id <- v .: "id"
    type_ <- v .: "type"
    pure Chat {id, type_}

instance FromJSON ChatType where
  parseJSON "private" = pure Private
  parseJSON "group" = pure Group
  parseJSON "supergroup" = pure Supergroup
  parseJSON "channel" = pure Channel
  parseJSON _ = fail "can't parse chat type"

-- Utils

groupsOf :: Eq b => Getting b a b -> [a] -> [[a]]
groupsOf getter = groupBy ((==) `on` (^. getter))

-- Telegram API

type Bot = (?token :: Text)

request :: (Bot, FromJSON r) => Text -> [(Text, Value)] -> IO r
request method arguments = do
  let options = Wreq.defaults & Wreq.params .~ query arguments
  response <- Wreq.getWith options (Text.unpack ("https://api.telegram.org/bot" <> ?token <> "/" <> method))
  case decode (response ^. Wreq.responseBody) of
    Just (TelegramResponse result) -> pure result
    Nothing -> error "unknown telegram response"
  where
    query =
      each . _2 %~ \case
        String s -> s
        Number x -> Text.pack (show (floor x))
        Bool True -> "true"
        Bool False -> "false"
        _ -> ""

getUpdates :: Bot => UpdateID -> IO [Update]
getUpdates offset = request "getUpdates" ["offset" .= offset]

sendMessage :: Bot => ChatID -> Text -> IO Message
sendMessage chat message = request "sendMessage" ["chat_id" .= chat, "text" .= message]

handleUpdate :: Bot => (Update -> IO a) -> IO ()
handleUpdate action = loop 0
  where
    loop offset = do
      updates <- getUpdates offset
      forConcurrently (groupsOf (#message . #chat) updates) \group -> do
        for group \update -> do
          action update
      loop (maximumOf (each . #id . to (+ 1)) updates ^. non offset)

-- Bot

main :: IO ()
main = do
  let ?token = "_"
  handleUpdate \case
    NewMessage {message = TextMessage {chat, text}} -> void do
      sendMessage (chat ^. #id) text