diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexander Krupenkin (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Krupenkin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Hello.hs b/examples/Hello.hs new file mode 100644 --- /dev/null +++ b/examples/Hello.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedLists #-} +module Main where + +import Data.Text (Text, pack) +import Data.Monoid ((<>)) +import Web.Telegram.Bot + +type Name = Text +type Surname = Text +type Age = Int + +hello :: Name -> Surname -> Age -> BotMessage +hello name surname age = + toMessage $ "Hello, " <> name <> " " <> surname <> "!\n" + <> "You lost " <> (pack $ show age) <> " years =)" + +helloStory :: Story +helloStory _ = hello <$> question "How your name?" + <*> question "How your surname?" + <*> question "How old are you?" + +helpMessage :: Text +helpMessage = "Hello, I'm hello bot!" + +main :: IO () +main = runBot config $ do + storyBot helpMessage [("/hello", helloStory)] + where config = defaultConfig + { token = Token "bot..." } diff --git a/src/Web/Telegram/Bot.hs b/src/Web/Telegram/Bot.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/Bot.hs @@ -0,0 +1,51 @@ +-- | +-- Module : Web.Telegram.Bot +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : email@something.com +-- Stability : experimental +-- Portability : portable +-- +-- Telegram Bot API microframework for creating story like +-- command handlers: +-- +-- @ +-- helloStory :: Story +-- helloStory _ = hello <$> question "How your name?" +-- <*> question "How your surname?" +-- <*> question "How old are you?" +-- @ +-- +module Web.Telegram.Bot ( + -- * Exported types + -- ** API types + module Web.Telegram.API.Bot.Data + -- ** Story types + , ToBotMessage(..) + , BotMessage(..) + , Answer(..) + , Config(..) + , Token(..) + , StoryT + , Story + -- ** Story makers + , select + , replica + , question + -- ** Bot runners + , sendMessageBot + , defaultConfig + , storyBot + , forkBot + , runBot + -- ** Re-exports + , lift + ) where + +import Web.Telegram.API.Bot.Data +import Web.Telegram.Bot.Internal +import Web.Telegram.Bot.Types +import Web.Telegram.Bot.Story +import Web.Telegram.API.Bot +import Pipes (lift) diff --git a/src/Web/Telegram/Bot/Internal.hs b/src/Web/Telegram/Bot/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/Bot/Internal.hs @@ -0,0 +1,166 @@ +-- | +-- Module : Web.Telegram.Bot.Handler +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Telegram Bot runners. +-- +module Web.Telegram.Bot.Internal (runBot, storyBot, sendMessageBot, forkBot) where + +import Control.Monad.Trans.Reader (runReaderT, ask) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Client (newManager, Manager) +import Control.Concurrent (forkIO, ThreadId) +import Control.Exception (throwIO, finally) +import Data.IntMap.Strict as I +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Monad (forever) +import Web.Telegram.Bot.Story +import Web.Telegram.Bot.Types +import Data.Text (Text, pack) +import Data.Map.Strict as M +import Web.Telegram.API.Bot +import Pipes + +-- | Try connection with Telegram Bot API +trySelf :: Token -> Manager -> IO () +trySelf tok mgr = do + me <- getMe tok mgr + case me of + Left e -> throwIO e + Right (Response u) -> + putStrLn $ "Hello! I'm " ++ show (user_first_name u) + +-- | Infinity loop for getting updates from API +updateLoop :: (Update -> Bot ()) + -- ^ Update handler + -> Bot () +updateLoop handler = go 0 + where updates o t = getUpdates t (Just o) Nothing . Just + go offset = do + (manager, config) <- ask + -- Take updates + upd <- liftIO $ + updates offset (token config) (timeout config) manager + -- Check for errors + case result <$> upd of + Left e -> liftIO (throwIO e) + Right [] -> go offset + Right xs -> do + -- Run handler for any update + mapM_ handler xs + -- Step for the new offset + go (maximum (update_id <$> xs) + 1) + +-- | 'Producer' from 'Chan' creator +fromChan :: MonadIO m => Chan a -> Producer a m () +fromChan c = forever $ liftIO (readChan c) >>= yield + +-- | Incoming messages will be sended +toSender :: MonadIO m => (BotMessage -> m ()) -> Consumer BotMessage m () +toSender sender = forever $ await >>= lift . sender + +-- | Chat ID based message splitter +storyHandler :: MVar (IntMap (Chan Message)) + -> Map Text Story + -> BotMessage + -> Update + -> Bot () +storyHandler chats stories help = go + where go (Update { message = Just msg }) = do + -- Get a chat id + let cid = chat_id (chat msg) + newStory chan = modifyMVar_ chats (return . I.insert cid chan) + deleteStory = modifyMVar_ chats (return . I.delete cid) + + chatMap <- liftIO (readMVar chats) + -- Lookup chat id in the map + case I.lookup cid chatMap of + -- Chat exist => story is run now + Just chan -> do + -- Want to cancel it? + case text msg of + Just "/cancel" -> do + liftIO deleteStory + sendMessageBot (chat msg) help + + _ -> liftIO (writeChan chan msg) + + -- Is no runned stories + Nothing -> + case text msg >>= flip M.lookup stories of + -- Unknown story, try to help + Nothing -> sendMessageBot (chat msg) help + + -- Story exist + Just story -> do + -- Create chan and update chanMap + chan <- liftIO newChan + liftIO (newStory chan) + + -- Story pipeline + let pipeline = fromChan chan + >-> (story (chat msg) >>= yield) + >-> toSender (sendMessageBot (chat msg)) + + -- Story effect + (manager, config) <- ask + let runStory = runReaderT (runEffect pipeline) + (manager, config) + + -- Run story in separate thread + _ <- liftIO $ forkIO $ do + runStory `finally` deleteStory + return () + go _ = return () + +sendMessageBot :: Chat -> BotMessage -> Bot () +sendMessageBot c msg = do + (manager, config) <- ask + liftIO $ send (textChatId c) (token config) manager msg + where textChatId = pack . show . chat_id + + send cid tok mgr BotTyping = + let r = sendChatActionRequest cid Typing + in sendChatAction tok r mgr >> return () + + send cid tok mgr (BotText t) = + let r = (sendMessageRequest cid t) + { message_reply_markup = Just replyKeyboardHide + , message_parse_mode = Just Markdown } + in sendMessage tok r mgr >> return () + + send cid tok mgr (BotKeyboard txt btnTexts) = + let btns = fmap keyboardButton <$> btnTexts + keyboard = replyKeyboardMarkup btns + r = (sendMessageRequest cid txt) + { message_reply_markup = Just keyboard + , message_parse_mode = Just Markdown } + in sendMessage tok r mgr >> return () + +-- | User story handler +storyBot :: ToBotMessage help => help -> Map Text Story -> Bot () +storyBot help stories = do + -- Create map from user to it story + chats <- liftIO (newMVar I.empty) + -- Run update loop + updateLoop (storyHandler chats stories $ toMessage help) + +-- | Run bot monad +runBot :: Config -> Bot a -> IO a +runBot config bot = do + -- Init connection manager + manager <- newManager tlsManagerSettings + -- Check connection + trySelf (token config) manager + -- Run bot + runReaderT bot (manager, config) + +-- Fork bot thread +forkBot :: Bot () -> Bot ThreadId +forkBot bot = ask >>= liftIO . forkIO . runReaderT bot diff --git a/src/Web/Telegram/Bot/Story.hs b/src/Web/Telegram/Bot/Story.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/Bot/Story.hs @@ -0,0 +1,119 @@ +-- | +-- Module : Web.Telegram.Bot.Story +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Story is a dialog like abstraction for processing data from +-- user sparsed by messages. +-- +-- @ +-- hello :: Monad m => Text -> Text -> Int -> m BotMessage +-- hello name surname age = toMessage $ +-- "Hello, " <> name <> " " <> surname <> "!\n" +-- <> "You lost " <> (pack $ show age) <> " years =)" +-- +-- helloStory :: Story +-- helloStory _ = hello <$> question "How your name?" +-- <*> question "How your surname?" +-- <*> question "How old are you?" +-- @ +-- +module Web.Telegram.Bot.Story where + +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Web.Telegram.API.Bot (Message, Chat, text) +import Data.Text.Read (signed, decimal, double) +import Control.Monad.IO.Class (MonadIO) +import Pipes (Pipe, await, yield, lift) +import Web.Telegram.Bot.Types (Bot) +import qualified Data.Text as T +import Data.Text (Text, pack) + +-- | Story is a pipe from user message to bot message +-- and result is a final message bot. +type Story = Chat -> StoryT Bot BotMessage +type StoryT = Pipe Message BotMessage + +-- | Bot message data. +data BotMessage + = BotTyping + | BotText Text + | BotKeyboard Text [[Text]] + deriving Show + +-- | Bot message typeclass for conversion. +class ToBotMessage a where + toMessage :: a -> BotMessage + +-- | Idenity instance +instance ToBotMessage BotMessage where + toMessage = id + +-- | Simple text question send text message from bot +instance ToBotMessage Text where + toMessage = BotText + +-- | The value can be passed to story handler function. +class Answer a where + parse :: MonadIO m => Message -> ExceptT Text m a + +-- | Simple text answer, pass any text message +instance Answer Text where + parse x = + case text x of + Just t -> return t + Nothing -> throwE "Please send text message." + +instance Answer Double where + parse x = do + t <- parse x + case signed double t of + Left e -> throwE (pack e) + Right (v, x) -> if T.null x + then return v + else throwE "Please use only 0-9 and '.' chars." + +instance Answer Integer where + parse x = do + t <- parse x + case signed decimal t of + Left e -> throwE (pack e) + Right (v, x) -> if T.null x + then return v + else throwE "Please use only 0-9 chars." + +instance Answer Int where + parse x = do + v <- parse x + return (fromIntegral (v :: Integer)) + +instance Answer Word where + parse x = do + v <- parse x + return (fromIntegral (v :: Integer)) + +-- | Reply keyboard selection +select :: (MonadIO m, Answer a) => Text -> [[Text]] -> StoryT m a +{-# INLINE select #-} +select q = replica . BotKeyboard q + +-- | Bot text question. +question :: (MonadIO m, Answer a) => Text -> StoryT m a +{-# INLINE question #-} +question = replica + +-- | Generalized story maker. +-- The replica send to user, when answer isn't parsed +-- the error send to user and waiting for correct answer. +replica :: (ToBotMessage a, MonadIO m, Answer b) => a -> StoryT m b +replica msg = do + yield (toMessage msg) + res <- lift . runExceptT . parse =<< await + yield BotTyping + case res of + Left e -> replica e + Right a -> return a diff --git a/src/Web/Telegram/Bot/Types.hs b/src/Web/Telegram/Bot/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/Bot/Types.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleInstances #-} +-- | +-- Module : Web.Telegram.Bot.Types +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : portable +-- +-- Bot types and helper instances. +-- +module Web.Telegram.Bot.Types where + +import Control.Monad.Trans.Reader (ReaderT) +import Web.Telegram.API.Bot (Token(..)) +import Network.HTTP.Client (Manager) + +type Timeout = Int + +data Config = Config + { timeout :: Timeout + -- ^ Polling timeout in seconds + , token :: Token + -- ^ Telegram Bot API private token + } deriving Show + +-- | Default bot config +defaultConfig :: Config +defaultConfig = Config 10 (Token "") + +-- | Telegram bot monad +type BotT = ReaderT (Manager, Config) +type Bot = BotT IO diff --git a/telegram-bot.cabal b/telegram-bot.cabal new file mode 100644 --- /dev/null +++ b/telegram-bot.cabal @@ -0,0 +1,53 @@ +name: telegram-bot +version: 0.5.1.0 +synopsis: Telegram Bot microframework for Haskell +description: Please see README.md +homepage: https://github.com/akru/telegram-bot#readme +license: BSD3 +license-file: LICENSE +author: Alexander Krupenkin +maintainer: mail@akru.me +copyright: Alexander Krupenkin +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable hello-bot + hs-source-dirs: examples + main-is: Hello.hs + build-depends: base >= 4.7 && < 5 + , telegram-bot + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings + +library + hs-source-dirs: src + exposed-modules: Web.Telegram.Bot + , Web.Telegram.Bot.Story + , Web.Telegram.Bot.Types + other-modules: Web.Telegram.Bot.Internal + build-depends: base >= 4.7 && < 4.10 + , http-client-tls + , transformers + , telegram-api + , http-client + , containers + , pipes + , text + default-language: Haskell2010 + default-extensions: OverloadedStrings + +test-suite telegram-bot-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , telegram-bot + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/akru/telegram-bot diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"