schenario

Main-resume.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE MonadComprehensions #-}
{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}

import Control.Concurrent.Async (async)
import Control.Concurrent.STM
import Control.Exception (SomeException, finally, try)
import Control.Lens (set, view)
import Control.Monad (guard)
import Control.Monad.Free (Free (..), foldFree, liftF)
import Data.Aeson (FromJSON, KeyValue ((.=)), Value, decode, encode, object)
import Data.Foldable (for_)
import Data.Function (fix)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.String (fromString)
import Data.Traversable (for)
import Deriving.Aeson (CustomJSON (CustomJSON), SumUntaggedValue)
import GHC.Generics (Generic)
import GHC.Records.Compat (HasField (..))
import Network.Wreq qualified as Wreq
import Text.Read (readMaybe)
import Prelude hiding (id)

-- Telegram bot api

instance HasField "body" (Wreq.Response a) a where
  hasField value = (\x -> set Wreq.responseBody x value, view Wreq.responseBody value)

data TelegramResponse a = TelegramResponse {ok :: Bool, result :: a}
  deriving stock (Show, Generic)
  deriving anyclass (FromJSON)

type ChatId = Integer

data Update
  = NewMessage {update_id :: Integer, message :: Message}
  | UnknownUpdate {update_id :: Integer}
  deriving stock (Show, Generic)
  deriving (FromJSON) via (CustomJSON '[SumUntaggedValue] Update)

data Message = Message {message_id :: Integer, text :: String, chat :: Chat}
  deriving stock (Show, Read, Generic)
  deriving anyclass (FromJSON)

data Chat = Chat {id :: ChatId}
  deriving stock (Eq, Show, Read, Generic)
  deriving anyclass (FromJSON)

type WithToken = (?token :: String)

request :: (WithToken, FromJSON r) => String -> Value -> IO r
request method body = do
  print ("send", method, encode body)
  response <- Wreq.post ("https://api.telegram.org/bot" <> ?token <> "/" <> method) body
  case decode response.body of
    Just TelegramResponse {ok = True, result} -> pure result
    _ -> error "unknown telegram response"

sendMessage :: WithToken => ChatId -> String -> IO Message
sendMessage chatId msg = request "sendMessage" do
  object [fromString "chat_id" .= chatId, fromString "text" .= msg]

handleUpdate :: WithToken => (Update -> IO a) -> IO ()
handleUpdate action = loop 0
  where
    loop offset = do
      updates <- request "getUpdates" (object [fromString "offset" .= offset])
      case updates of
        [] -> loop offset
        updates -> do
          for_ updates action
          loop (maximum [u.update_id | u <- updates] + 1)

-- Scenario

type Scenarios = TVar (Map ChatId (TQueue Message, TVar [Message]))

resume :: [Message] -> Free BotF () -> Free BotF ()
resume history bot = go (reverse history) bot
  where
    go _ bot@Pure {} = bot
    go [] (Free (Eval _ next)) = go [] next
    go [] bot = bot
    go msgs (Free (Eval _ next)) = go msgs next
    go (msg : msgs) (Free (Expect pred)) =
      case pred msg of
        Nothing -> error "impossible"
        Just next -> go msgs next

spawn :: WithToken => Scenarios -> ChatId -> [Message] -> Free BotF () -> IO (TQueue Message)
spawn scenarios chatId history' bot = do
  (mailbox, history) <- atomically do
    mailbox <- newTQueue
    history <- newTVar history'
    modifyTVar scenarios (Map.insert chatId (mailbox, history))
    pure (mailbox, history)
  async do
    foldFree (alg mailbox history) bot
    atomically do modifyTVar scenarios (Map.delete chatId)
  pure mailbox
  where
    alg :: TQueue Message -> TVar [Message] -> BotF a -> IO a
    alg mailbox history = \case
      Expect pred -> do
        mnext <- atomically do
          msg <- readTQueue mailbox
          case pred msg of
            Nothing -> pure Nothing
            Just next -> do
              modifyTVar' history (msg :)
              pure (Just next)
        case mnext of
          Nothing -> alg mailbox history (Expect pred)
          Just next -> pure next
      Eval (SendText chatId msg) next -> do
        sendMessage chatId msg
        pure next

getSaved :: IO (Map ChatId [Message])
getSaved = do
  result <- try do
    save <- readFile "save"
    case readMaybe save of
      Just value -> pure value
      Nothing -> error "invalid save"
  case result of
    Left (e :: SomeException) -> pure Map.empty
    Right save -> pure save

main :: IO ()
main =
  do
    let ?token = "TOKEN"
    scenarios <- newTVarIO Map.empty
    saved <- getSaved
    for_ (Map.toList saved) \(chatId, history) ->
      spawn scenarios chatId history (resume history example)
    putStrLn ("resumed: " <> show (Map.keys saved))
    do
      handleUpdate \update -> do
        print update
        case update of
          UnknownUpdate {} -> pure ()
          NewMessage {message} -> do
            scenarios' <- readTVarIO scenarios
            scenario <- case message.chat.id `Map.lookup` scenarios' of
              Nothing -> spawn scenarios message.chat.id [] example
              Just (scenario, _) -> pure scenario
            atomically do writeTQueue scenario message
      `finally` do
        scenarios' <- readTVarIO scenarios
        dump <-
          Map.fromList <$> for (Map.toList scenarios') \(chatId, (_, history)) -> do
            history <- readTVarIO history
            pure (chatId, history)
        writeFile "save" (show dump)
        putStrLn ("saved: " <> show (Map.keys scenarios'))

data Command
  = SendText Integer String

data BotF next
  = Eval Command next
  | Expect (Message -> Maybe next)
  deriving stock (Functor)

expect :: (Message -> Maybe a) -> Free BotF a
expect pred = liftF (Expect pred)

eval :: Command -> Free BotF ()
eval command = liftF (Eval command ())

example :: Free BotF ()
example = do
  chat <- expect \msg -> do guard (msg.text == "init"); pure msg.chat
  eval (SendText chat.id "Now send numbers or result to get sum of entered numbers")
  let loop sum = do
        msg <- expect \msg -> pure msg.text
        case (msg, readMaybe msg) of
          ("result", _) -> eval (SendText chat.id ("Result is " ++ show sum))
          (_, Just value) -> do
            eval (SendText chat.id (show value ++ " added"))
            loop (sum + value)
          _ -> do
            eval (SendText chat.id "Invalid input, enter number or `result`")
            loop sum
  loop 0

Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MonadComprehensions #-}
{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}

import Control.Concurrent.Async (async)
import Control.Concurrent.STM (TQueue, TVar, atomically, modifyTVar, newTQueue, newTVarIO, readTQueue, readTVarIO, writeTQueue)
import Control.Lens (set, view)
import Control.Monad.Free (Free, foldFree, liftF)
import Data.Aeson (FromJSON, KeyValue ((.=)), Value, decode, encode, object)
import Data.Foldable (for_)
import Data.Function (fix)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.String (fromString)
import Deriving.Aeson (CustomJSON (CustomJSON), SumUntaggedValue)
import GHC.Generics (Generic)
import GHC.Records.Compat (HasField (..))
import Network.Wreq qualified as Wreq
import Prelude hiding (id)

-- Telegram bot api

instance HasField "body" (Wreq.Response a) a where
  hasField value = (\x -> set Wreq.responseBody x value, view Wreq.responseBody value)

data TelegramResponse a = TelegramResponse {ok :: Bool, result :: a}
  deriving stock (Show, Generic)
  deriving anyclass (FromJSON)

type ChatId = Integer

data Update
  = NewMessage {update_id :: Integer, message :: Message}
  | UnknownUpdate {update_id :: Integer}
  deriving stock (Show, Generic)
  deriving (FromJSON) via (CustomJSON '[SumUntaggedValue] Update)

data Message = Message {message_id :: Integer, text :: String, chat :: Chat}
  deriving stock (Show, Generic)
  deriving anyclass (FromJSON)

data Chat = Chat {id :: ChatId}
  deriving stock (Eq, Show, Generic)
  deriving anyclass (FromJSON)

type WithToken = (?token :: String)

request :: (WithToken, FromJSON r) => String -> Value -> IO r
request method body = do
  print ("send", method, encode body)
  response <- Wreq.post ("https://api.telegram.org/bot" <> ?token <> "/" <> method) body
  case decode response.body of
    Just TelegramResponse {ok = True, result} -> pure result
    _ -> error "unknown telegram response"

sendMessage :: WithToken => ChatId -> String -> IO Message
sendMessage chatId msg = request "sendMessage" do
  object [fromString "chat_id" .= chatId, fromString "text" .= msg]

handleUpdate :: WithToken => (Update -> IO a) -> IO ()
handleUpdate action = loop 0
  where
    loop offset = do
      updates <- request "getUpdates" (object [fromString "offset" .= offset])
      case updates of
        [] -> loop offset
        updates -> do
          for_ updates action
          loop (maximum [u.update_id | u <- updates] + 1)

-- Scenario

spawn :: WithToken => TVar (Map Integer (TQueue Message)) -> ChatId -> Free BotF () -> IO (TQueue Message)
spawn scenarios chatId bot = do
  mailbox <- atomically do
    mailbox <- newTQueue
    modifyTVar scenarios (Map.insert chatId mailbox)
    pure mailbox
  async do
    foldFree (alg mailbox) bot
    atomically do modifyTVar scenarios (Map.delete chatId)
  pure mailbox
  where
    alg :: TQueue Message -> BotF a -> IO a
    alg mailbox = \case
      Expect pred -> do
        msg <- atomically do readTQueue mailbox
        case pred msg of
          Nothing -> alg mailbox (Expect pred)
          Just next -> pure next
      Eval (SendText chatId msg) next -> do
        sendMessage chatId msg
        pure next

main :: IO ()
main = do
  let ?token = "PLACE YOUR TOKEN HERE"
  scenarios <- newTVarIO Map.empty
  handleUpdate \update -> do
    print update
    case update of
      UnknownUpdate {} -> pure ()
      NewMessage {message} -> do
        scenarios' <- readTVarIO scenarios
        scenario <- case message.chat.id `Map.lookup` scenarios' of
          Nothing -> spawn scenarios message.chat.id example
          Just scenario -> pure scenario
        atomically do writeTQueue scenario message

data Command
  = SendText Integer String

data BotF next
  = Eval Command next
  | Expect (Message -> Maybe next)
  deriving stock (Functor)

expect :: (Message -> Maybe a) -> Free BotF a
expect pred = liftF (Expect pred)

eval :: Command -> Free BotF ()
eval command = liftF (Eval command ())

example :: Free BotF ()
example = do
  chat <- expect \msg -> [msg.chat | msg.text == "hi"]
  eval (SendText chat.id "Hello, what's your name?")
  name <- expect \msg -> pure msg.text
  eval (SendText chat.id ("Hello " <> name))

package.yaml

name: hspg

dependencies:
  - base == 4.14.3.0

  - free
  - stm
  - async
  - containers

  - lens 
  - wreq
  - aeson
  - deriving-aeson

  - record-dot-preprocessor
  - record-hasfield

executables:
  hspg-exe:
    main: Main.hs