habit (empty) → 0.2.1.2
raw patch · 15 files changed
+934/−0 lines, 15 filesdep +basedep +containersdep +cryptonitesetup-changed
Dependencies added: base, containers, cryptonite, habit, http-client, http-client-tls, monad-control, monad-logger, persistent, persistent-mysql, persistent-postgresql, persistent-sqlite, persistent-template, pipes, resourcet, telegram-api, text, transformers, transformers-base
Files
- LICENSE +30/−0
- README.md +56/−0
- Setup.hs +2/−0
- examples/Hello.hs +35/−0
- habit.cabal +68/−0
- src/Web/Bot.hs +58/−0
- src/Web/Bot/Log.hs +23/−0
- src/Web/Bot/Message.hs +38/−0
- src/Web/Bot/Metrics.hs +38/−0
- src/Web/Bot/Persist.hs +71/−0
- src/Web/Bot/Platform.hs +121/−0
- src/Web/Bot/Platform/Telegram.hs +133/−0
- src/Web/Bot/Story.hs +101/−0
- src/Web/Bot/Story/Internal.hs +129/−0
- src/Web/Bot/User.hs +31/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexander Krupenkin (c) 2016-2017++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.
+ README.md view
@@ -0,0 +1,56 @@+## Haskell Bot it :: Message bot framework++[](https://travis-ci.org/airalab/habit)+[](https://ci.appveyor.com/project/akru/habit)+[](http://hackage.haskell.org/package/habit)+++++### Install++ $ git clone https://github.com/airalab/habit && cd habit+ $ stack setup+ $ stack ghci++### Run your story++The `Story` is an abstraction about sparsed data getted from user+though dialogue.++```haskell+helloStory :: Story a+helloStory _ = hello <$> question "How your name?"+ <*> question "How your surname?"+ <*> question "How old are you?"+```++As you see the story handler `hello` is apply though the questions+to user responses.++```haskell+type Name = Text+type Surname = Text+type Age = Int++hello :: Monad m => Name -> Surname -> Age -> m BotMessage+hello name surname age = do+ return . toMessage $ "Hello, " <> name <> " " <> surname <> "!\n"+ <> "You lost " <> (pack $ show age) <> " years =)"+```++To run the `Story` simple pass it to `storyBot` as value of mapping between+command an story. `APIToken` type class defines token for given platform,+e.g. Telegram platform.++```haskell+instance APIToken Telegram where+ apiToken = "bot..."++main :: IO ()+main = runBot myBot+ where myBot :: Bot Telegram ()+ myBot = storyBot helpMsg [("/hello", helloStory)]+```++Full example [text](examples/Hello.hs).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Hello.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedLists #-}+module Main where++import Data.Text (Text, pack)+import Data.Monoid ((<>))+import Web.Bot++type Name = Text+type Surname = Text+type Age = Int++hello :: Name -> Surname -> Age -> Message+hello name surname age =+ toMessage $ "Hello, " <> name <> " " <> surname <> "!\n"+ <> "You lost " <> (pack $ show age) <> " years =)"++helloStory :: Story a+helloStory _ = hello <$> question "How your name?"+ <*> question "How your surname?"+ <*> question "How old are you?"++helpMsg :: Text+helpMsg = "Hello, I'm hello bot!"++instance APIToken Telegram where+ apiToken = return "bot308165623:AAGeMyzyedc787LZSpzlhwTCWQcO5CAZpAo"++instance Persist Telegram where+ persist = return $ Sqlite "storage.db"++main :: IO ()+main = runBot myStory+ where+ myStory :: Bot Telegram ()+ myStory = storyBot helpMsg [("/hello", helloStory)]
+ habit.cabal view
@@ -0,0 +1,68 @@+name: habit+version: 0.2.1.2+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Alexander Krupenkin+maintainer: mail@akru.me+homepage: https://github.com/airalab/habit#readme+synopsis: Haskell message bot framework+description:+ Framework for building text message bots for popular platforms+category: Web+author: Alexander Krupenkin+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/airalab/habit++library+ exposed-modules:+ Web.Bot+ Web.Bot.Log+ Web.Bot.User+ Web.Bot.Story+ Web.Bot.Message+ Web.Bot.Metrics+ Web.Bot.Persist+ Web.Bot.Platform+ Web.Bot.Platform.Telegram+ build-depends:+ base ==4.9.*,+ persistent-postgresql ==2.6.*,+ persistent-template >=2.5.1.6 && <2.6,+ persistent-sqlite ==2.6.*,+ persistent-mysql ==2.6.*,+ persistent ==2.6.*,+ transformers-base >=0.4.4 && <0.5,+ http-client-tls >=0.2.4.1 && <0.3,+ monad-control >=1.0.1.0 && <1.1,+ transformers >=0.5.2.0 && <0.6,+ monad-logger >=0.3.20.1 && <0.4,+ telegram-api >=0.5.0.1 && <0.6,+ http-client >=0.4.31.2 && <0.5,+ containers >=0.5.7.1 && <0.6,+ cryptonite ==0.19.*,+ resourcet >=1.1.8.1 && <1.2,+ pipes >=4.1.9 && <4.2,+ text >=1.2.2.1 && <1.3+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ hs-source-dirs: src+ other-modules:+ Web.Bot.Story.Internal++executable hello-bot+ main-is: Hello.hs+ build-depends:+ base >=4.7 && <5,+ habit >=0.2.1.2 && <0.3,+ text >=1.2.2.1 && <1.3+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ hs-source-dirs: examples+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+
+ src/Web/Bot.hs view
@@ -0,0 +1,58 @@+-- |+-- Module : Web.Bot+-- Copyright : Alexander Krupenkin 2016+-- License : BSD3+--+-- Maintainer : email@something.com+-- Stability : experimental+-- Portability : portable+--+-- Text message bot framework for creating story like:+--+-- @+-- helloStory :: BotConfig a => Story a+-- helloStory _ = hello <$> question "How your name?"+-- <*> question "How your surname?"+-- <*> question "How old are you?"+-- @+--+module Web.Bot (+ -- ** Story & message types+ ToMessage(..)+ , Answer(..)+ , Message+ , StoryT+ , Story+ , User+ -- ** Story makers+ , question+ , replica+ , select+ -- ** Bot monad & configuration classes+ , Bot+ , Platform(..)+ , APIToken(..)+ -- ** Bot platforms+ , Telegram+ -- ** Bot storage+ , Persist(..)+ , Connection(..)+ , ConnectInfo(..)+ -- ** Bot runners+ , storyBot+ , forkBot+ , runBot+ -- ** Re-exports+ , yield+ , await+ , lift+ ) where++import Pipes (yield, await, lift)+import Web.Bot.Story.Internal+import Web.Bot.Platform.Telegram+import Web.Bot.Platform+import Web.Bot.Persist+import Web.Bot.Message+import Web.Bot.Story+import Web.Bot.User
+ src/Web/Bot/Log.hs view
@@ -0,0 +1,23 @@+-- |+-- Module : Web.Bot.Log+-- Copyright : Alexander Krupenkin 2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Logging utils.+--+module Web.Bot.Log (+ logDebug+ , logInfo+ , logWarn+ , logError+ , logDebugS+ , logInfoS+ , logWarnS+ , logErrorS+) where++import Control.Monad.Logger
+ src/Web/Bot/Message.hs view
@@ -0,0 +1,38 @@+-- |+-- Module : Web.Bot.Message+-- Copyright : Alexander Krupenkin 2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Common used message type.+--+module Web.Bot.Message where++import Data.String (IsString(..))+import Data.Text (Text)++-- | Generalized message type+data Message+ = MsgTyping+ -- ^ When is typing+ | MsgText Text+ -- ^ Simple text+ | MsgKeyboard Text [[Text]]+ -- ^ Interactive keyboard+ deriving (Eq, Ord, Show)++instance IsString Message where+ fromString = MsgText . fromString++-- | Convert any data to message+class ToMessage a where+ toMessage :: a -> Message++instance ToMessage Message where+ toMessage = id++instance ToMessage Text where+ toMessage = MsgText
+ src/Web/Bot/Metrics.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}+-- |+-- Module : Web.Bot.Metrics+-- Copyright : Alexander Krupenkin 2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Bot metrics utils.+--+module Web.Bot.Metrics where++import Database.Persist.TH+import Database.Persist+import Data.Text (Text)+import Web.Bot.User++share [mkPersist sqlSettings, mkMigrate "migrateMetrics"] [persistLowerCase|+UserStat+ ident Text Unique+ messageOut Int+ messageIn Int+ StatUser ident+ deriving Show++StoryStat+ name Text Unique+ calls Int+ StatStory name+ deriving Show+|]
+ src/Web/Bot/Persist.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module : Web.Bot.Persist+-- Copyright : Alexander Krupenkin 2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Bot storage utils.+--+module Web.Bot.Persist (+ Persist(..)+ , Connection(..)+ , ConnectInfo(..)+ , runDB+ , module Database.Persist+ ) where++import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Resource (ResourceT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Logger (NoLoggingT)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Data.Text (Text)++import Database.Persist.Postgresql (withPostgresqlConn,+ ConnectionString)+import Database.Persist.Sqlite (withSqliteConn)+import Database.Persist.MySQL (withMySQLConn,+ ConnectInfo(..))+import Database.Persist.Sql (SqlBackend,+ runSqlPersistM, runMigration)+import Database.Persist++import Web.Bot.Platform+import Web.Bot.Log++-- Models+import Web.Bot.Metrics+import Web.Bot.User++-- | Database connection information+data Connection = Postgresql ConnectionString+ | Sqlite Text+ | MySQL ConnectInfo+ deriving (Eq, Show)++-- | Connection info provider+class Platform a => Persist a where+ persist :: Bot a Connection++-- | Run some staff with database connection+runDB :: Persist a+ => ReaderT SqlBackend (NoLoggingT (ResourceT IO)) b+ -> Bot a b+runDB ma = do+ db <- persist+ $logDebugS "Persist" (T.append "Connection: " $ T.pack (show db))++ let runConnection = case db of+ Postgresql conn -> withPostgresqlConn conn+ Sqlite conn -> withSqliteConn conn+ MySQL conn -> withMySQLConn conn++ runConnection $ \backend ->+ liftIO $ flip runSqlPersistM backend $+ runMigration (migrateMetrics >> migrateUser) >> ma
+ src/Web/Bot/Platform.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Web.Bot.Platform+-- Copyright : Alexander Krupenkin 2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Bot platform type class.+--+module Web.Bot.Platform (+ Bot+ , Platform(..)+ , APIToken(..)+ , getManager+ , forkFinallyBot+ , forkBot+ , runBot+ ) where++import Control.Monad.Logger (MonadLogger(..), LoggingT, runStderrLoggingT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Concurrent (forkIO, forkFinally, ThreadId)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Control.Exception (throwIO, SomeException)+import Network.HTTP.Client (newManager, Manager)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Base (MonadBase(..))+import qualified Data.Text as T+import Data.Monoid ((<>))+import Data.Text (Text)++import Web.Bot.Message (Message, ToMessage)+import Web.Bot.User (User)+import Web.Bot.Log++-- | Message bot monad+newtype Bot a b = Bot { unBot :: ReaderT Manager (LoggingT IO) b }+ deriving (Functor, Applicative, Monad, MonadIO)++instance MonadLogger (Bot a) where+ monadLoggerLog a b c d = Bot (monadLoggerLog a b c d)++instance MonadBase IO (Bot a) where+ liftBase = liftIO++instance MonadBaseControl IO (Bot a) where+ type StM (Bot a) b = b+ liftBaseWith f = Bot $ liftBaseWith $ \r -> f (r . unBot)+ restoreM = return++-- | Message bot platform.+-- Different platforms provide message bot API,+-- e.g. Telegram, Viber, Facebook Messenger etc.+-- This is generalized interface to it.+class Platform a where+ -- | Try connection to platform API+ trySelf :: APIToken a => Bot a ()++ -- | Send message to user by platform API+ sendMessage :: (ToMessage msg, APIToken a) => User -> msg -> Bot a ()++ -- | Get user updates by platform API+ messageHandler :: APIToken a+ => (User -> Message -> Bot a b)+ -- ^ Incoming message handler+ -> Bot a c+ -- ^ Blocking event processing++ -- | Short description of platform+ platformName :: a -> Text++-- | Bot authentification in platform+-- Instance of it should be writen by user+class Platform a => APIToken a where+ apiToken :: Bot a Text+ -- ^ Platform API token++-- | TCP-connection manager getter+getManager :: Bot a Manager+{-# INLINE getManager #-}+getManager = Bot ask++-- | Run bot monad+runBot :: (APIToken a, MonadIO m)+ => Bot a b -> m b+runBot bot = liftIO $ do+ -- Init connection manager+ manager <- newManager tlsManagerSettings+ -- Run bot monad+ runStderrLoggingT (runReaderT mBot manager)+ where Bot mBot = trySelf >> bot++-- | Fork bot thread+forkBot :: APIToken a+ => Bot a () -> Bot a ThreadId+forkBot (Bot bot) = do+ t <- Bot (ask >>= forkReader)+ $logDebugS "Bot" ("Forked " <> T.pack (show t))+ return t+ where forkReader = liftIO . forkIO+ . runStderrLoggingT . runReaderT bot++-- | Fork bot thread with finalizer+forkFinallyBot :: APIToken a+ => Bot a b+ -> (Either SomeException b -> IO ())+ -> Bot a ThreadId+forkFinallyBot (Bot bot) f = do+ t <- Bot (ask >>= forkFinallyReader)+ $logDebugS "Bot" ("Forked finally " <> T.pack (show t))+ return t+ where forkFinallyReader = liftIO . flip forkFinally f+ . runStderrLoggingT . runReaderT bot
+ src/Web/Bot/Platform/Telegram.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module : Web.Bot.Platform.Telegram+-- Copyright : Alexander Krupenkin 2016-2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Telegram bot API support.+--+module Web.Bot.Platform.Telegram (Telegram) where++import Crypto.Hash (hash, Digest, Keccak_256)+import qualified Web.Telegram.API.Bot as API+import Control.Monad.IO.Class (liftIO)+import Data.Text.Encoding (encodeUtf8)+import Control.Exception (throwIO)+import qualified Data.Text as T+import Data.Monoid ((<>))+import Data.Text (Text)++import Web.Bot.Platform+import Web.Bot.Message+import Web.Bot.User+import Web.Bot.Log++-- | Telegram Bot API 2.0 platform+data Telegram++instance Platform Telegram where+ trySelf = _trySelf+ sendMessage = _sendMessage+ messageHandler = _messageHandler+ platformName = const "Telegram Bot API 2.0"++_trySelf :: APIToken a => Bot a ()+_trySelf = do+ token <- apiToken+ manager <- getManager+ self <- liftIO (API.getMe (API.Token token) manager)+ name <- fmap platformName returnPlatform+ $logInfoS "Telegram" ("Platform: " <> name)+ case self of+ Left e -> do $logErrorS "Telegram" ("Init failure: " <> T.pack (show e))+ liftIO (throwIO e)+ Right (API.Response u) ->+ $logInfoS "Telegram" ("Init success, bot name: " <> API.user_first_name u)+ where returnPlatform :: Bot a a+ returnPlatform = return undefined++-- | Updates pull timeout in seconds+-- So it should be large number, but less TCP timeout+pullTimeout :: Num a => a+pullTimeout = 10++-- | Infinity loop for getting updates from API+_messageHandler :: APIToken a+ => (User -> Message -> Bot a b)+ -> Bot a c+_messageHandler handler = go 0+ where updates o t = API.getUpdates t (Just o) Nothing . Just+ go offset = do+ manager <- getManager+ token <- apiToken+ -- Take updates+ upd <- liftIO (updates offset (API.Token token) pullTimeout manager)+ -- Check for errors+ case API.result <$> upd of+ Left e -> do $logDebugS "Telegram"+ ("Pull updates failure: " <> T.pack (show e))+ go offset+ Right [] -> go offset+ Right xs -> do+ -- Run handler for any update+ mapM_ (withUpdate handler) xs+ -- Step for the new offset+ go (maximum (API.update_id <$> xs) + 1)++sha3 :: Text -> Text+sha3 x = T.pack (show digest)+ where digest :: Digest Keccak_256+ digest = hash (encodeUtf8 x)++withUpdate :: APIToken a+ => (User -> Message -> Bot a b)+ -> API.Update+ -> Bot a ()+withUpdate f update = case go of+ Just (user, msg) -> f user msg >> return ()+ Nothing -> return ()+ where+ go = (,) <$> mkUser <*> mkMessage+ formatUserName u = API.user_first_name u <>+ case API.user_last_name u of+ Just last_name -> " " <> last_name+ Nothing -> ""+ formatUserHash u = sha3 ("telegram-" <> T.pack (show $ API.user_id u))+ mkUser = User <$> (fmap (API.chat_id . API.chat) $ API.message update)+ <*> (fmap formatUserName (API.message update >>= API.from))+ <*> (fmap formatUserHash (API.message update >>= API.from))+ mkMessage = MsgText <$> (API.message update >>= API.text)++_sendMessage :: (ToMessage msg, APIToken a) => User -> msg -> Bot a ()+_sendMessage user msg = do+ manager <- getManager+ token <- apiToken+ res <- liftIO (send (API.Token token) manager $ toMessage msg)+ case res of+ Right _ -> return ()+ Left e -> do $logErrorS "Telegram" ("Failure send to " <> userName user+ <> " with " <> T.pack (show e))+ _sendMessage user msg+ where cid = T.pack $ show $ userChat user++ send tok mgr MsgTyping =+ let r = API.sendChatActionRequest cid API.Typing+ in API.sendChatAction tok r mgr >>= return . fmap (const ())++ send tok mgr (MsgText t) =+ let r = (API.sendMessageRequest cid t)+ { API.message_reply_markup = Just API.replyKeyboardHide+ , API.message_parse_mode = Just API.Markdown }+ in API.sendMessage tok r mgr >>= return . fmap (const ())++ send tok mgr (MsgKeyboard txt btnTexts) =+ let btns = fmap API.keyboardButton <$> btnTexts+ keyboard = API.replyKeyboardMarkup btns+ r = (API.sendMessageRequest cid txt)+ { API.message_reply_markup = Just keyboard+ , API.message_parse_mode = Just API.Markdown }+ in API.sendMessage tok r mgr >>= return . fmap (const ())
+ src/Web/Bot/Story.hs view
@@ -0,0 +1,101 @@+-- |+-- Module : Web.Bot.Story+-- Copyright : Alexander Krupenkin 2016+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Story is a dialog like abstraction for processing sparsed+-- by messages data from user.+--+-- @+-- hello :: Monad m => Text -> Text -> Int -> m BotMessage+-- hello name surname age = toMessage $+-- "Hello, " <> name <> " " <> surname <> "!\n"+-- <> "You lost " <> (T.pack $ show age) <> " years =)"+--+-- helloStory :: BotConfig a => Story a+-- helloStory _ = hello <$> question "How your name?"+-- <*> question "How your surname?"+-- <*> question "How old are you?"+-- @+--+module Web.Bot.Story where++import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Data.Text.Read (signed, decimal, double)+import Control.Monad.IO.Class (MonadIO)+import Pipes (Pipe, await, yield)+import qualified Data.Text as T+import Data.Text (Text)++import Web.Bot.Message (Message(..), ToMessage(..))+import Web.Bot.Platform (Bot)+import Web.Bot.User (User)++-- | Story is a pipe from user message to bot message+-- and result is a final bot message.+type Story a = User -> StoryT (Bot a) Message++-- | Story transformer is based on 'Pipe'+-- with fixed 'Message' in/out.+type StoryT = Pipe Message Message++-- | User message reply parser.+class Answer a where+ parse :: MonadIO m => Message -> ExceptT Text m a++instance Answer Text where+ parse (MsgText x) = return x+ parse _ = throwE "Please send text message."++instance Answer Double where+ parse x = do+ t <- parse x+ case signed double t of+ Left e -> throwE (T.pack e)+ Right (v, "") -> return v+ Right _ -> 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 (T.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 . MsgKeyboard q++-- | Bot text question.+question :: (MonadIO m, Answer a) => Text -> StoryT m a+{-# INLINE question #-}+question = replica++-- | Generalized story maker.+-- The replica send message to user, when answer isn't parsed+-- the error be sended and wait for correct answer.+replica :: (ToMessage a, MonadIO m, Answer b) => a -> StoryT m b+replica msg = do+ yield (toMessage msg)+ res <- runExceptT . parse =<< await+ yield MsgTyping+ case res of+ Left e -> replica e+ Right a -> return a
+ src/Web/Bot/Story/Internal.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module : Web.Bot.Story.Internal+-- Copyright : Alexander Krupenkin 2016-2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Story bot implementation.+--+module Web.Bot.Story.Internal (storyBot) where++import Control.Concurrent (killThread, ThreadId)+import Data.IntMap.Strict as I+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Monad (forever)+import qualified Data.Text as T+import Data.Map.Strict as M+import Data.Monoid ((<>))+import Data.Text (Text)+import Pipes++import Web.Bot.Platform+import Web.Bot.Metrics+import Web.Bot.Persist+import Web.Bot.Message+import Web.Bot.Story+import Web.Bot.User+import Web.Bot.Log++-- | 'Producer' from 'Chan' creator+fromChan :: MonadIO m => Chan b -> Producer b m ()+fromChan c = forever $ liftIO (readChan c) >>= yield++-- | Incoming messages will be sended+toSender :: (APIToken a, Persist a)+ => User+ -> (User -> Message -> Bot a ())+ -> Consumer Message (Bot a) ()+toSender u sender = forever $ do+ await >>= lift . sender u+ -- Metrics+ lift $ runDB $ upsertBy (StatUser $ userIdent u)+ (UserStat (userIdent u) 0 1)+ [UserStatMessageOut +=. 1]+++-- | Chat ID based message splitter+storyHandler :: (Persist a, APIToken a, ToMessage help)+ => MVar (IntMap (Chan Message, ThreadId))+ -> Map Message (Story a)+ -> help+ -> User -> Message -> Bot a ()+storyHandler chats stories help user msg = do+ -- Get a chat id+ let newStory item = modifyMVar_ chats+ (return . I.insert (userChat user) item)+ deleteStory = modifyMVar_ chats+ (return . I.delete (userChat user))+ -- Metrics+ runDB $ do+ upsertBy (StatUser $ userIdent user)+ (UserStat (userIdent user) 0 1)+ [UserStatMessageIn +=. 1]+ upsertBy (UserIdentity $ userIdent user)+ user+ [ UserName =. userName user+ , UserChat =. userChat user ]++ chatMap <- liftIO (readMVar chats)+ -- Lookup chat id in the map+ case I.lookup (userChat user) chatMap of+ -- Chat exist => story is run now+ Just (chan, tid) ->+ -- Want to cancel it?+ case msg of+ "/cancel" -> do+ $logDebugS "Story" ("Cancel request, story "+ <> T.pack (show tid) <> " killed.")+ liftIO (killThread tid)+ sendMessage user help++ _ -> liftIO (writeChan chan msg)++ -- Is no runned stories+ Nothing ->+ case M.lookup msg stories of+ -- Unknown story, try to help+ Nothing -> do+ sendMessage user help+ $logDebugS "Story" ("Unknown story "+ <> T.pack (show msg) <> ".")++ -- Story exist+ Just story -> do+ -- Create chan+ chan <- liftIO newChan+ -- Story pipeline+ let pipeline = fromChan chan+ >-> (story user >>= yield)+ >-> toSender user sendMessage+ -- Run story in separate thread+ tid <- forkFinallyBot (runEffect pipeline)+ (const deleteStory)+ -- Update userMap+ liftIO (newStory (chan, tid))++ -- Log and update metrics+ let sname = T.pack (show msg)+ runDB $ upsertBy (StatStory sname)+ (StoryStat sname 1)+ [StoryStatCalls +=. 1]+ $logDebugS "Story" ("Story " <> sname+ <> " spawned at "+ <> T.pack (show tid) <> ".")+++-- | User story handler+storyBot :: (Persist a, APIToken a, ToMessage help)+ => help -> Map Message (Story a) -> Bot a ()+storyBot help stories = do+ -- Create map from user chat to it story+ chats <- liftIO (newMVar I.empty)+ -- Run update loop+ $logDebugS "Story" "Init success."+ messageHandler $ storyHandler chats stories help
+ src/Web/Bot/User.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}+-- |+-- Module : Web.Bot.User+-- Copyright : Alexander Krupenkin 2017+-- License : BSD3+--+-- Maintainer : mail@akru.me+-- Stability : experimental+-- Portability : portable+--+-- Common used user model.+--+module Web.Bot.User where++import Database.Persist.TH+import Database.Persist+import Data.Text (Text)++share [mkPersist sqlSettings, mkMigrate "migrateUser"] [persistLowerCase|+User+ chat Int+ name Text+ ident Text Unique+ UserIdentity ident+ deriving Show+|]