telegram-bot (empty) → 0.5.1.0
raw patch · 9 files changed
+486/−0 lines, 9 filesdep +basedep +containersdep +http-clientsetup-changed
Dependencies added: base, containers, http-client, http-client-tls, pipes, telegram-api, telegram-bot, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/Hello.hs +29/−0
- src/Web/Telegram/Bot.hs +51/−0
- src/Web/Telegram/Bot/Internal.hs +166/−0
- src/Web/Telegram/Bot/Story.hs +119/−0
- src/Web/Telegram/Bot/Types.hs +34/−0
- telegram-bot.cabal +53/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Hello.hs view
@@ -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..." }
+ src/Web/Telegram/Bot.hs view
@@ -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)
+ src/Web/Telegram/Bot/Internal.hs view
@@ -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
+ src/Web/Telegram/Bot/Story.hs view
@@ -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
+ src/Web/Telegram/Bot/Types.hs view
@@ -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
+ telegram-bot.cabal view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"