diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Author name here (c) 2018 +Copyright Alexandre Moreno (c) 2018 All rights reserved. diff --git a/examples/Echo.hs b/examples/Echo.hs --- a/examples/Echo.hs +++ b/examples/Echo.hs @@ -10,7 +10,9 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Data.String (fromString) -import Line.Bot.Client as B +import Line.Bot.Client (Line, replyMessage, + runLine) +import Line.Bot.Types as B import Line.Bot.Webhook as W import Network.Wai.Handler.Warp (run) import Network.Wai.Middleware.RequestLogger (logStdout) @@ -27,14 +29,14 @@ replyMessage replyToken [B.Text text Nothing] echo _ = return NoContent -handleEvents :: Events -> WebM NoContent -handleEvents Events { events } = do +handleEvents :: [Event] -> WebM NoContent +handleEvents events = do token <- ask - _ <- liftIO $ mapM_ (runLine token . echo) events + _ <- liftIO $ mapM_ (flip runLine token . echo) events return NoContent echoServer :: ServerT API WebM -echoServer = handleEvents +echoServer = handleEvents . events app :: ChannelToken -> ChannelSecret -> Application app token secret = serveWithContext api context server diff --git a/line-bot-sdk.cabal b/line-bot-sdk.cabal --- a/line-bot-sdk.cabal +++ b/line-bot-sdk.cabal @@ -1,5 +1,5 @@ name: line-bot-sdk -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Haskell SDK for LINE Messaging API homepage: https://github.com/moleike/line-bot-sdk#readme bug-reports: https://github.com/moleike/line-bot-sdk/issues @@ -28,11 +28,11 @@ library hs-source-dirs: src exposed-modules: Line.Bot.Webhook + , Line.Bot.Webhook.Events , Line.Bot.Client + , Line.Bot.Types other-modules: Line.Bot.Endpoints - , Line.Bot.Types - , Line.Bot.Webhook.Types build-depends: base >= 4.7 && < 5 , aeson >= 1.4.2 && < 1.5 diff --git a/src/Line/Bot/Client.hs b/src/Line/Bot/Client.hs --- a/src/Line/Bot/Client.hs +++ b/src/Line/Bot/Client.hs @@ -7,20 +7,32 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Line.Bot.Client +-- Copyright : (c) Alexandre Moreno, 2019 +-- License : BSD3 +-- Maintainer : alexmorenocano@gmail.com +-- Stability : experimental module Line.Bot.Client - ( module Line.Bot.Types + ( Line , runLine - , Line - , ChannelToken(..) + , runLineWith + -- ** Profile , getProfile + -- ** Group , getGroupMemberProfile , leaveGroup + -- ** Room , getRoomMemberProfile , leaveRoom + -- ** Message , replyMessage , pushMessage , multicastMessage + , getContent + -- ** Account Link + , issueLinkToken ) where @@ -49,29 +61,31 @@ host :: BaseUrl host = BaseUrl Https "api.line.me" 443 "" -newtype ChannelToken = ChannelToken Text - deriving (Eq) - -instance IsString ChannelToken where - fromString s = ChannelToken (fromString s) - -instance ToHttpApiData ChannelToken where - toQueryParam (ChannelToken t) = "Bearer " <> t - +-- | @Line@ is the monad in which bot requests run. Contains the +-- OAuth access token for a channel type Line = ReaderT ChannelToken ClientM type Auth = AuthenticatedRequest (AuthProtect ChannelAuth) type instance AuthClientData (AuthProtect ChannelAuth) = ChannelToken -runLine' :: ClientM a -> IO (Either ServantError a) -runLine' comp = do +defaultClient:: ClientM a -> IO (Either ServantError a) +defaultClient comp = do manager <- newManager tlsManagerSettings runClientM comp (mkClientEnv manager host) -runLine :: ChannelToken -> Line a -> IO (Either ServantError a) -runLine token comp = runLine' $ runReaderT comp token +-- | Runs a @Line@ computation with the given channel access token +runLine :: Line a -> ChannelToken -> IO (Either ServantError a) +runLine = runLineWith defaultClient +-- | Runs the monad with a different client evironment +runLineWith + :: (ClientM a -> IO (Either ServantError a)) + -> Line a + -> ChannelToken + -> IO (Either ServantError a) +runLineWith f comp token = f $ runReaderT comp token + mkAuth :: ChannelToken -> Auth mkAuth token = mkAuthenticatedRequest token addAuthHeader where @@ -96,6 +110,8 @@ getContent' :: Auth -> String -> ClientM ByteString +issueLinkToken' :: Auth -> Id User -> ClientM LinkToken + getProfile' :<|> getGroupMemberProfile' :<|> leaveGroup' @@ -104,7 +120,8 @@ :<|> replyMessage' :<|> pushMessage' :<|> multicastMessage' - :<|> getContent' = client (Proxy :: Proxy Endpoints) + :<|> getContent' + :<|> issueLinkToken' = client (Proxy :: Proxy Endpoints) getProfile :: Id User -> Line Profile getProfile a = ask >>= \token -> lift $ getProfile' (mkAuth token) a @@ -135,3 +152,10 @@ multicastMessage a ms = ask >>= \token -> lift $ multicastMessage' (mkAuth token) body where body = MulticastMessageBody a ms + +getContent :: String -> Line ByteString +getContent a = ask >>= \token -> lift $ getContent' (mkAuth token) a + +issueLinkToken :: Id User -> Line LinkToken +issueLinkToken a = ask >>= \token -> lift $ issueLinkToken' (mkAuth token) a + diff --git a/src/Line/Bot/Endpoints.hs b/src/Line/Bot/Endpoints.hs --- a/src/Line/Bot/Endpoints.hs +++ b/src/Line/Bot/Endpoints.hs @@ -7,6 +7,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Line.Bot.Endpoints +-- Copyright : (c) Alexandre Moreno, 2019 +-- License : BSD3 +-- Maintainer : alexmorenocano@gmail.com +-- Stability : experimental module Line.Bot.Endpoints where @@ -72,6 +78,12 @@ :> "content" :> Get '[OctetStream] ByteString +type IssueLinkToken = AuthProtect ChannelAuth + :> "user" + :> Capture "userId" (Id User) + :> "linkToken" + :> Get '[JSON] LinkToken + type Endpoints = "v2" :> "bot" :> ( GetProfile :<|> GetGroupMemberProfile @@ -82,4 +94,5 @@ :<|> PushMessage :<|> MulticastMessage :<|> GetContent + :<|> IssueLinkToken ) diff --git a/src/Line/Bot/Types.hs b/src/Line/Bot/Types.hs --- a/src/Line/Bot/Types.hs +++ b/src/Line/Bot/Types.hs @@ -11,13 +11,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} +-- | +-- Module : Line.Bot.Types +-- Copyright : (c) Alexandre Moreno, 2019 +-- License : BSD3 +-- Maintainer : alexmorenocano@gmail.com +-- Stability : experimental module Line.Bot.Types - ( ChatType(..) + ( ChannelToken(..) + , ChannelSecret(..) + , ChatType(..) , Id(..) , URL(..) , Message(..) , ReplyToken(..) + , LinkToken(..) , ReplyMessageBody(ReplyMessageBody) , PushMessageBody(PushMessageBody) , MulticastMessageBody(MulticastMessageBody) @@ -30,17 +39,34 @@ import Data.Aeson import Data.Aeson.Types -import Data.Char (toLower) -import Data.List as L (stripPrefix) -import Data.Maybe (fromJust) +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower) +import Data.List as L (stripPrefix) +import Data.Maybe (fromJust) import Data.String -import Data.Text as T hiding (drop, toLower) -import GHC.Generics hiding (to) +import Data.Text as T hiding (drop, toLower) +import GHC.Generics hiding (to) import Servant.API import Text.Show +newtype ChannelToken = ChannelToken Text + deriving (Eq) + +instance IsString ChannelToken where + fromString s = ChannelToken (fromString s) + +instance ToHttpApiData ChannelToken where + toQueryParam (ChannelToken t) = "Bearer " <> t + +newtype ChannelSecret = ChannelSecret + { unChannelSecret :: B.ByteString } + +instance IsString ChannelSecret where + fromString s = ChannelSecret (B.pack s) + data ChatType = User | Group | Room +-- | ID of a chat user, group or room data Id :: ChatType -> * where UserId :: Text -> Id User GroupId :: Text -> Id Group @@ -129,6 +155,11 @@ instance ToJSON ReplyToken instance FromJSON ReplyToken + +data LinkToken = LinkToken { linkToken :: Text } + deriving (Eq, Show, Generic) + +instance FromJSON LinkToken data ReplyMessageBody = ReplyMessageBody { replyToken :: ReplyToken diff --git a/src/Line/Bot/Webhook.hs b/src/Line/Bot/Webhook.hs --- a/src/Line/Bot/Webhook.hs +++ b/src/Line/Bot/Webhook.hs @@ -12,14 +12,19 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - +-- | +-- Module : Line.Bot.Webhook +-- Copyright : (c) Alexandre Moreno, 2019 +-- License : BSD3 +-- Maintainer : alexmorenocano@gmail.com +-- Stability : experimental module Line.Bot.Webhook - ( module Line.Bot.Webhook.Types - , Webhook + ( Webhook , LineReqBody + , module Events ) - where +where import Control.Monad.IO.Class (liftIO) import qualified Crypto.Hash.SHA256 as SHA256 @@ -32,7 +37,8 @@ import Data.Proxy import Data.String.Conversions (cs) import Data.Typeable (Typeable) -import Line.Bot.Webhook.Types +import Line.Bot.Types (ChannelSecret (..)) +import Line.Bot.Webhook.Events as Events import Network.HTTP.Types (HeaderName, hContentType) import Network.Wai (Request, lazyRequestBody, requestHeaders) diff --git a/src/Line/Bot/Webhook/Events.hs b/src/Line/Bot/Webhook/Events.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Webhook/Events.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +-- | +-- Module : Line.Bot.Webhook.Events +-- Copyright : (c) Alexandre Moreno, 2019 +-- License : BSD3 +-- Maintainer : alexmorenocano@gmail.com +-- Stability : experimental + +module Line.Bot.Webhook.Events + ( Events(..) + , Event(..) + , Message(..) + , EpochMilli(..) + , Source(..) + , Members(..) + , Postback(..) + , Beacon(..) + , BeaconEvent(..) + , Things(..) + , ThingsEvent(..) + , AccountLink(..) + , AccountLinkResult(..) + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Char +import Data.Foldable +import Data.List as L (stripPrefix) +import Data.Maybe +import Data.Scientific +import Data.String +import Data.Text as T hiding (drop, stripPrefix, toLower) +import Data.Time (LocalTime, UTCTime) +import Data.Time.Calendar (Day) +import Data.Time.Clock.POSIX +import Data.Time.Format +import Data.Time.LocalTime +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Line.Bot.Types hiding (Message, Text) + + +data Events = Events + { destination :: Id User + , events :: [Event] + } + deriving (Eq, Show, Generic) + +instance FromJSON Events + +data Event = + EventMessage { replyToken :: ReplyToken + , message :: Message + , source :: Source + , timestamp :: EpochMilli + } + | EventFollow { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + } + | EventUnfollow { source :: Source + , timestamp :: EpochMilli + } + | EventJoin { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + } + | EventLeave { source :: Source + , timestamp :: EpochMilli + } + | EventMemberJoined { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , joined :: Members + } + | EventMemberLeft { source :: Source + , timestamp :: EpochMilli + , left :: Members + } + | EventPostback { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , postback :: Postback + } + | EventBeacon { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , beacon :: Beacon + } + | EventAccountLink { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , link :: AccountLink + } + | EventThings { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , things :: Things + } + deriving (Eq, Show, Generic) + +instance FromJSON Event where + parseJSON = genericParseJSON $ + defaultOptions { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 5 + } + +data Message = + Text { messageId :: Text + , text :: Text + } + | Image { messageId :: Text + , contentProvider :: ContentProvider + } + | Video { messageId :: Text + , duration :: Int + , contentProvider :: ContentProvider + } + | Audio { messageId :: Text + , duration :: Int + , contentProvider :: ContentProvider + } + | File { messageId :: Text + , fileSize :: Int + , fileName :: Text + } + | Location { messageId :: Text + , title :: Text + , address :: Text + , latitude :: Double + , longitude :: Double + } + | Sticker { messageId :: Text + , packageId :: Text + , stickerId :: Text + } + deriving (Eq, Show, Generic) + +messageJSONOptions :: Options +messageJSONOptions = defaultOptions + { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = fmap toLower + , fieldLabelModifier = \orig -> + case L.stripPrefix "message" orig of + Just s -> fmap toLower s + Nothing -> orig + , omitNothingFields = True + } + +instance FromJSON Message where + parseJSON = genericParseJSON messageJSONOptions + + +data ContentProvider = ContentProvider + { originalContentUrl :: Maybe URL + , previewImageUrl :: Maybe URL + } + deriving (Eq, Show, Generic) + +instance FromJSON ContentProvider + +newtype EpochMilli = EpochMilli { + fromEpochMilli :: UTCTime + -- ^ Acquire the underlying value. +} deriving (Eq, Ord, Read, Show, FormatTime) + +instance FromJSON EpochMilli where + parseJSON = withScientific "EpochMilli" $ \t -> + pure $ millis t + where + millis = EpochMilli + . posixSecondsToUTCTime + . fromRational + . toRational + . (/ 1000) + + +data Source = + SourceUser (Id User) + | SourceGroup (Id Group) (Maybe (Id User)) + | SourceRoom (Id Room) (Maybe (Id User)) + deriving (Eq, Show) + +instance FromJSON Source where + parseJSON = withObject "Source" $ \o -> do + messageType <- o .: "type" + case messageType of + "user" -> SourceUser <$> o .: "userId" + "group" -> SourceGroup <$> o .: "groupId" <*> o .:? "userId" + "room" -> SourceRoom <$> o .: "roomId" <*> o .:? "userId" + _ -> fail ("unknown source: " ++ messageType) + + +data Members = Members { members :: [Source] } + deriving (Eq, Show, Generic) + +instance FromJSON Members + +data PostbackDateTime = + PostbackDay Day + | PostbackLocalTime LocalTime + | PostbackTimeOfDay TimeOfDay + deriving (Eq, Show) + +instance FromJSON PostbackDateTime where + parseJSON = withObject "PostbackDateTime" $ \o -> do + dateTime <- asum + [ PostbackDay <$> o .: "date" + , PostbackLocalTime <$> o .: "datetime" + , PostbackTimeOfDay <$> o .: "time" + ] + return dateTime + +data Postback = Postback Text PostbackDateTime + deriving (Eq, Show) + +instance FromJSON Postback where + parseJSON = withObject "Postback" $ \o -> do + postbackData <- o .: "data" + params <- o .: "params" + return $ Postback postbackData params + +data BeaconEvent = Enter | Leave | Banner + deriving (Show, Read, Eq, Ord, Generic) + +instance FromJSON BeaconEvent where + parseJSON = genericParseJSON $ + defaultOptions { constructorTagModifier = fmap toLower + , allNullaryToStringTag = True + } + +data Beacon = Beacon + { hwid :: Text + , eventType :: BeaconEvent + , dm :: Maybe Text + } + deriving (Eq, Show, Generic) + +instance FromJSON Beacon where + parseJSON = withObject "Beacon" $ \o -> do + hwid <- o .: "hwid" + eventType <- o .: "type" + dm <- o .:? "dm" + return $ Beacon{..} + +data AccountLinkResult = Ok | Failed + deriving (Eq, Show, Generic) + +instance FromJSON AccountLinkResult where + parseJSON = genericParseJSON $ + defaultOptions { constructorTagModifier = fmap toLower + , allNullaryToStringTag = True + } + +data AccountLink = AccountLink + { nonce :: Text + , result :: AccountLinkResult + } + deriving (Eq, Show, Generic) + +instance FromJSON AccountLink + +data ThingsEvent = Link | Unlink + deriving (Show, Read, Eq, Ord, Generic) + +instance FromJSON ThingsEvent where + parseJSON = genericParseJSON $ + defaultOptions { constructorTagModifier = fmap toLower + , allNullaryToStringTag = True + } + +data Things = Things + { deviceId :: Text + , eventType :: ThingsEvent + } + deriving (Eq, Show, Generic) + +instance FromJSON Things where + parseJSON = withObject "Things" $ \o -> do + deviceId <- o .: "deviceId" + eventType <- o .: "type" + return $ Things{..} diff --git a/src/Line/Bot/Webhook/Types.hs b/src/Line/Bot/Webhook/Types.hs deleted file mode 100644 --- a/src/Line/Bot/Webhook/Types.hs +++ /dev/null @@ -1,301 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Line.Bot.Webhook.Types - ( ChannelSecret(..) - , Events(..) - , Event(..) - , Message(..) - , EpochMilli(..) - , Source(..) - , Members(..) - , Postback(..) - , Beacon(..) - , BeaconEvent(..) - , Things(..) - , ThingsEvent(..) - , AccountLink(..) - , AccountLinkResult(..) - ) -where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Char8 as B -import Data.Char -import Data.Foldable -import Data.List as L (stripPrefix) -import Data.Maybe -import Data.Scientific -import Data.String -import Data.Text as T hiding (drop, stripPrefix, toLower) -import Data.Time (LocalTime, UTCTime) -import Data.Time.Calendar (Day) -import Data.Time.Clock.POSIX -import Data.Time.Format -import Data.Time.LocalTime -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Line.Bot.Types hiding (Message, Text) - - -newtype ChannelSecret = ChannelSecret - { unChannelSecret :: B.ByteString } - -instance IsString ChannelSecret where - fromString s = ChannelSecret (B.pack s) - -data Events = Events - { destination :: Id User - , events :: [Event] - } - deriving (Eq, Show, Generic) - -instance FromJSON Events - -data Event = - EventMessage { replyToken :: ReplyToken - , message :: Message - , source :: Source - , timestamp :: EpochMilli - } - | EventFollow { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - } - | EventUnfollow { source :: Source - , timestamp :: EpochMilli - } - | EventJoin { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - } - | EventLeave { source :: Source - , timestamp :: EpochMilli - } - | EventMemberJoined { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - , joined :: Members - } - | EventMemberLeft { source :: Source - , timestamp :: EpochMilli - , left :: Members - } - | EventPostback { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - , postback :: Postback - } - | EventBeacon { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - , beacon :: Beacon - } - | EventAccountLink { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - , link :: AccountLink - } - | EventThings { replyToken :: ReplyToken - , source :: Source - , timestamp :: EpochMilli - , things :: Things - } - deriving (Eq, Show, Generic) - -instance FromJSON Event where - parseJSON = genericParseJSON $ - defaultOptions { sumEncoding = TaggedObject - { tagFieldName = "type" - , contentsFieldName = undefined - } - , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 5 - } - -data Message = - Text { messageId :: Text - , text :: Text - } - | Image { messageId :: Text - , contentProvider :: ContentProvider - } - | Video { messageId :: Text - , duration :: Int - , contentProvider :: ContentProvider - } - | Audio { messageId :: Text - , duration :: Int - , contentProvider :: ContentProvider - } - | File { messageId :: Text - , fileSize :: Int - , fileName :: Text - } - | Location { messageId :: Text - , title :: Text - , address :: Text - , latitude :: Double - , longitude :: Double - } - | Sticker { messageId :: Text - , packageId :: Text - , stickerId :: Text - } - deriving (Eq, Show, Generic) - -messageJSONOptions :: Options -messageJSONOptions = defaultOptions - { sumEncoding = TaggedObject - { tagFieldName = "type" - , contentsFieldName = undefined - } - , constructorTagModifier = fmap toLower - , fieldLabelModifier = \orig -> - case L.stripPrefix "message" orig of - Just s -> fmap toLower s - Nothing -> orig - , omitNothingFields = True - } - -instance FromJSON Message where - parseJSON = genericParseJSON messageJSONOptions - - -data ContentProvider = ContentProvider - { originalContentUrl :: Maybe URL - , previewImageUrl :: Maybe URL - } - deriving (Eq, Show, Generic) - -instance FromJSON ContentProvider - -newtype EpochMilli = EpochMilli { - fromEpochMilli :: UTCTime - -- ^ Acquire the underlying value. -} deriving (Eq, Ord, Read, Show, FormatTime) - -instance FromJSON EpochMilli where - parseJSON = withScientific "EpochMilli" $ \t -> - pure $ millis t - where - millis = EpochMilli - . posixSecondsToUTCTime - . fromRational - . toRational - . (/ 1000) - - -data Source = - SourceUser (Id User) - | SourceGroup (Id Group) (Maybe (Id User)) - | SourceRoom (Id Room) (Maybe (Id User)) - deriving (Eq, Show) - -instance FromJSON Source where - parseJSON = withObject "Source" $ \o -> do - messageType <- o .: "type" - case messageType of - "user" -> SourceUser <$> o .: "userId" - "group" -> SourceGroup <$> o .: "groupId" <*> o .:? "userId" - "room" -> SourceRoom <$> o .: "roomId" <*> o .:? "userId" - _ -> fail ("unknown source: " ++ messageType) - - -data Members = Members { members :: [Source] } - deriving (Eq, Show, Generic) - -instance FromJSON Members - -data PostbackDateTime = - PostbackDay Day - | PostbackLocalTime LocalTime - | PostbackTimeOfDay TimeOfDay - deriving (Eq, Show) - -instance FromJSON PostbackDateTime where - parseJSON = withObject "PostbackDateTime" $ \o -> do - dateTime <- asum - [ PostbackDay <$> o .: "date" - , PostbackLocalTime <$> o .: "datetime" - , PostbackTimeOfDay <$> o .: "time" - ] - return dateTime - -data Postback = Postback Text PostbackDateTime - deriving (Eq, Show) - -instance FromJSON Postback where - parseJSON = withObject "Postback" $ \o -> do - postbackData <- o .: "data" - params <- o .: "params" - return $ Postback postbackData params - -data BeaconEvent = Enter | Leave | Banner - deriving (Show, Read, Eq, Ord, Generic) - -instance FromJSON BeaconEvent where - parseJSON = genericParseJSON $ - defaultOptions { constructorTagModifier = fmap toLower - , allNullaryToStringTag = True - } - -data Beacon = Beacon - { hwid :: Text - , eventType :: BeaconEvent - , dm :: Maybe Text - } - deriving (Eq, Show, Generic) - -instance FromJSON Beacon where - parseJSON = withObject "Beacon" $ \o -> do - hwid <- o .: "hwid" - eventType <- o .: "type" - dm <- o .:? "dm" - return $ Beacon{..} - -data AccountLinkResult = Ok | Failed - deriving (Eq, Show, Generic) - -instance FromJSON AccountLinkResult where - parseJSON = genericParseJSON $ - defaultOptions { constructorTagModifier = fmap toLower - , allNullaryToStringTag = True - } - -data AccountLink = AccountLink - { nonce :: Text - , result :: AccountLinkResult - } - deriving (Eq, Show, Generic) - -instance FromJSON AccountLink - -data ThingsEvent = Link | Unlink - deriving (Show, Read, Eq, Ord, Generic) - -instance FromJSON ThingsEvent where - parseJSON = genericParseJSON $ - defaultOptions { constructorTagModifier = fmap toLower - , allNullaryToStringTag = True - } - -data Things = Things - { deviceId :: Text - , eventType :: ThingsEvent - } - deriving (Eq, Show, Generic) - -instance FromJSON Things where - parseJSON = withObject "Things" $ \o -> do - deviceId <- o .: "deviceId" - eventType <- o .: "type" - return $ Things{..}