blob: a4e15eff7cf9fa92fcdcbf9bedd3379c92d49fe0 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.Char
import Data.Text (Text)
import Data.List (intercalate)
import Data.Time
import Data.Time.Clock.POSIX
import qualified Data.Text as Text
import Text.Read (readMaybe)
import Control.Monad.Writer
import Telegram.Bot.API
import Telegram.Bot.Simple
import Telegram.Bot.Simple.UpdateParser (updateMessageText)
data Event = Event { eventTime :: Integer, eventChatId :: ChatId, eventMsgId :: MessageId }
data Action
= TextMsg { textMsgText :: Text, textMsgChatId :: ChatId , textMsgId :: MessageId }
| AddEvent Event
| FireEvents Integer
type Model = [Event]
main :: IO ()
main = do
content <- readFile "tgtoken"
let token = Token $ Text.pack $ strip content
run token
currentTimestamp :: IO Integer
currentTimestamp = fmap (floor . utcTimeToPOSIXSeconds) getCurrentTime
botApp :: BotApp Model Action
botApp = BotApp
{ botInitialModel = []
, botAction = updateToAction
, botHandler = handleAction
, botJobs = [
BotJob
{ botJobSchedule = "* * * * *" -- every minute
, botJobTask = eventHandler
}]
}
eventHandler :: Model -> Eff Action Model
eventHandler model = Eff $ do
let acts = do
ts <- liftIO $ currentTimestamp
return $ Just $ FireEvents ts
tell [acts]
return model
updateToAction :: Update -> Model -> Maybe Action
updateToAction update _ = do
text <- updateMessageText update
cid <- fmap chatId $ fmap messageChat $ updateMessage update
mid <- fmap messageMessageId $ updateMessage update
return $ TextMsg text cid mid
replyTextEff :: Model -> ChatId -> MessageId -> Text -> Eff Action Model
replyTextEff model cid mid msg = Eff $ do
let acts = do
replyToMessage cid mid msg
return Nothing
tell [acts]
return model
handleAction :: Action -> Model -> Eff Action Model
handleAction action model = case action of
TextMsg tmsg cid mid -> case (words $ Text.unpack tmsg) of
(command:args) ->
case (takeWhile (/='@') command) of
"/timer" -> handleTimerCmd model cid mid args
_ -> return model
[] -> return model
AddEvent e -> return (e:model)
FireEvents ts -> fireEvents model ts
replyToMessage:: ChatId -> MessageId -> Text -> BotM ()
replyToMessage cid mid t = replyTo (SomeChatId cid) $ ReplyMessage
t Nothing Nothing Nothing Nothing Nothing Nothing (Just mid) Nothing Nothing
fireEvents :: Model -> Integer -> Eff Action Model
fireEvents model ts = Eff $ do
let acts = do
let sendEvent e = do
replyToMessage (eventChatId e) (eventMsgId e) "时间到了哦"
mapM_ sendEvent $ filter (\e -> (eventTime e) <= ts) model
return Nothing
tell [acts]
return $ filter (\e -> (eventTime e) > ts) model
handleTimerCmd :: Model -> ChatId -> MessageId -> [String] -> Eff Action Model
handleTimerCmd model chatId mid args =
let minutes :: Maybe Integer = readMaybe $ intercalate " " args in
case minutes of
Nothing -> replyTextEff model chatId mid "格式：/timer <分钟数>"
Just num ->
Eff $ do
let validNumAction = do
replyToMessage chatId mid $ Text.pack $ "已设置" ++ (show num) ++ "分钟提醒"
curTime <- liftIO $ currentTimestamp
return $ Just $ AddEvent $ Event (curTime + (toInteger num) * 60) chatId mid
let invalidNumAction = do
replyToMessage chatId mid $ Text.pack $ "只能设置一天内的提醒"
return Nothing
let queueFullAction = do
replyToMessage chatId mid $ Text.pack $ "提醒队列已满"
return Nothing
if num > 1440 then tell [invalidNumAction]
else
if (length model) > 4096 then tell [queueFullAction]
else tell [validNumAction]
return model
run :: Token -> IO ()
run token = do
env <- defaultTelegramClientEnv token
startBot_ botApp env
strip :: String -> String
strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
|
