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
|
{-# LANGUAGE DeriveGeneric #-}
module Tomato.Data.Message
( InMessage (..)
, GMIUrl (..)
, OutMessage (..)
) where
import RIO
import Data.Aeson ((.:), (.=))
import Network.HTTP.Req
( Url
, Scheme (Https)
, useHttpsURI
, renderUrl
)
import qualified Data.Aeson as Ae
import qualified Data.Aeson.Types as Ae
import qualified RIO.Vector as V
import qualified Text.URI as URI
data InMessage = InMessage
{ hasAttach :: !Bool
, groupId :: !Text
, isUser :: !Bool
, text :: !Text
} deriving (Show, Generic)
instance NFData InMessage
instance Ae.FromJSON InMessage where
parseJSON = Ae.withObject "InMessage" $ \o -> InMessage
<$> (o .: "attachments" >>= Ae.withArray "attachments" (pure . not . null))
<*> o .: "group_id"
<*> ((==) ("user" :: Text) <$> o .: "sender_type")
<*> o .: "text"
newtype GMIUrl = GMIUrl
{ unGMIUrl :: Url Https
} deriving Show
instance Ae.FromJSON GMIUrl where
parseJSON = Ae.withObject "payload" $ \o -> do
p <- o .: "payload"
u <- p .: "url"
GMIUrl <$> toUrl u
where
toUrl :: Text -> Ae.Parser (Url Https)
toUrl t = maybe mzero pure $ fmap fst $ useHttpsURI =<< URI.mkURI t
data OutMessage = OutMessage
{ image :: !GMIUrl
} deriving Show
instance Ae.ToJSON OutMessage where
toJSON om = Ae.object
[ "attachments" .=
( Ae.Array $ V.singleton attach )
-- , "bot_id" .= botId
]
where
attach :: Ae.Value
attach = Ae.object
[ "type" .= ("image" :: Text)
, "url" .= url
]
url :: Text
url = renderUrl $ unGMIUrl $ image om
-- {
-- "bot_id" : "j5abcdefg",
-- "text" : "Hello world",
-- "attachments" : [
-- {
-- "type" : "image",
-- "url" : "https://i.groupme.com/somethingsomething.large"
-- }
-- ]
-- }
|
