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
fromChan :: MonadIO m => Chan b -> Producer b m ()
fromChan c = forever $ liftIO (readChan c) >>= yield
toSender :: (APIToken a, Persist a)
=> User
-> (User -> Message -> Bot a ())
-> Consumer Message (Bot a) ()
toSender u sender = forever $ do
await >>= lift . sender u
lift $ runDB $ upsertBy (StatUser $ userIdent u)
(UserStat (userIdent u) 0 1)
[UserStatMessageOut +=. 1]
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
let newStory item = modifyMVar_ chats
(return . I.insert (userChat user) item)
deleteStory = modifyMVar_ chats
(return . I.delete (userChat user))
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)
case I.lookup (userChat user) chatMap of
Just (chan, tid) ->
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)
Nothing ->
case M.lookup msg stories of
Nothing -> do
sendMessage user help
$logDebugS "Story" ("Unknown story "
<> T.pack (show msg) <> ".")
Just story -> do
chan <- liftIO newChan
let pipeline = fromChan chan
>-> (story user >>= yield)
>-> toSender user sendMessage
tid <- forkFinallyBot (runEffect pipeline)
(const deleteStory)
liftIO (newStory (chan, tid))
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) <> ".")
storyBot :: (Persist a, APIToken a, ToMessage help)
=> help -> Map Message (Story a) -> Bot a ()
storyBot help stories = do
chats <- liftIO (newMVar I.empty)
$logDebugS "Story" "Init success."
messageHandler $ storyHandler chats stories help