From 9a476d93712421f265f7f946e06f86eb2fc20920 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 10:39:59 +0000 Subject: [PATCH] Add lenses to most API types --- CHANGELOG.md | 1 + haboli.cabal | 6 +- package.yaml | 3 + src/Haboli/Euphoria/Api.hs | 241 +++++++++++++++++++++++++----------- src/Haboli/Euphoria/Lens.hs | 13 ++ 5 files changed, 191 insertions(+), 73 deletions(-) create mode 100644 src/Haboli/Euphoria/Lens.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index f6c14b0..ac9e2cf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,7 @@ ## upcoming - add `Haboli.Euphoria.Botrulez` module - add `Haboli.Euphoria.Command` module and submodules +- add `Haboli.Euphoria.Lens` and add lenses to a few types - add `Haboli.Euphoria.Listing` module - add `Haboli.Euphoria.Util` module and move `respondingToPing` there - add example bot (`Haboli.Euphoria.ExampleBot`) diff --git a/haboli.cabal b/haboli.cabal index 52f2eac..4a27c41 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ae5e8a6e8abe1ff515797a54dfa9acd185df7699102b31190d569ccfe3a693f8 +-- hash: 35dc75bb1fd8534c4476115b165d0e969a579affaa05a419abe6f7e3ab749082 name: haboli version: 0.3.1.0 @@ -37,6 +37,7 @@ library Haboli.Euphoria.Command.Megaparsec Haboli.Euphoria.Command.Simple Haboli.Euphoria.ExampleBot + Haboli.Euphoria.Lens Haboli.Euphoria.Listing Haboli.Euphoria.Util other-modules: @@ -48,8 +49,11 @@ library , base >=4.7 && <5 , containers , megaparsec + , microlens + , microlens-th , network , stm + , template-haskell , text , time , transformers diff --git a/package.yaml b/package.yaml index 29a8bf7..1185334 100644 --- a/package.yaml +++ b/package.yaml @@ -18,8 +18,11 @@ dependencies: - aeson - containers - megaparsec + - microlens + - microlens-th - network - stm + - template-haskell - text - time - transformers diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index 02664d7..fb528bf 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module attempts to map the structure of the ephoria API to types. @@ -6,41 +7,101 @@ module Haboli.Euphoria.Api ( ToJSONObject(..) -- * Basic types , AuthOption(..) - , Message(..) - , PersonalAccountView(..) - , SessionView(..) , Snowflake , UserType(..) , UserId(..) + , userTypeL + , userSnowflakeL + , SessionView(..) + , svIdL + , svNickL + , svServerIdL + , svServerEraL + , svSessionIdL + , svIsStaffL + , svIsManagerL + , svClientAddressL + , svRealClientAddressL + , Message(..) + , msgIdL + , msgParentL + , msgPreviousEditIdL + , msgTimeL + , msgSenderL + , msgContentL + , msgEncryptionKeyIdL + , msgEditedL + , msgDeletedL + , msgTruncatedL + , PersonalAccountView(..) + , pavIdL + , pavNameL + , pavEmailL -- * Asynchronous events -- ** bounce-event , BounceEvent(..) + , bounceReasonL + , bounceAuthOptionL -- ** disconnect-event , DisconnectEvent(..) + , disconnectReasonL -- ** hello-event , HelloEvent(..) + , helloAccountL + , helloSessionViewL + , helloAccountHasAccessL + , helloAccountEmailVerifiedL + , helloRoomIsPrivateL + , helloVersionL -- ** join-event , JoinEvent(..) + , joinSessionL -- ** login-event , LoginEvent(..) + , loginAccountIdL -- ** logout-event , LogoutEvent(..) -- ** network-event , NetworkEvent(..) + , networkTypeL + , networkServerIdL + , networkServerEraL -- ** nick-event , NickEvent(..) + , nickSessionIdL + , nickIdL + , nickFromL + , nickToL -- ** edit-message-event , EditMessageEvent(..) + , editMessageMessageL + , editMessageEditIdL -- ** part-event , PartEvent(..) + , partSessionL -- ** ping-event , PingEvent(..) + , pingTimeL + , pingNextL -- ** pm-initiate-event , PmInitiateEvent(..) + , pmInitiateFromL + , pmInitiateFromNickL + , pmInitiateFromRoomL + , pmInitiatePmIdL -- ** send-event , SendEvent(..) + , sendMessageL -- ** snapshot-event , SnapshotEvent(..) + , snapshotIdentityL + , snapshotSessionIdL + , snapshotVersionL + , snapshotListingL + , snapshotLogL + , snapshotNickL + , snapshotPmWithNickL + , snapshotPmWithUserIdL -- * Session commands -- ** auth , AuthCommand(..) @@ -77,6 +138,8 @@ import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX +import Haboli.Euphoria.Lens + -- | A class for all types that can be converted into an -- 'Data.Aeson.Types.Object'. Similar to 'ToJSON', but more restrictive. class ToJSONObject a where @@ -110,75 +173,6 @@ instance FromJSON AuthOption where parseJSON (String _) = fail "invalid value" parseJSON v = typeMismatch "String" v --- | A 'Message' is a node in a room’s log. It corresponds to a chat message, or --- a post, or any broadcasted event in a room that should appear in the log. See --- . -data Message = Message - { msgId :: Snowflake - , msgParent :: Maybe Snowflake - , msgPreviousEditId :: Maybe Snowflake - , msgTime :: UTCTime - , msgSender :: SessionView - , msgContent :: T.Text - , msgEncryptionKeyId :: Maybe T.Text - , msgEdited :: Maybe UTCTime - , msgDeleted :: Maybe UTCTime - , msgTruncated :: Bool - } deriving (Show) - -instance FromJSON Message where - parseJSON v = parseJSON v >>= \o -> Message - <$> o .: "id" - <*> o .:? "parent" - <*> o .:? "previous_edit_id" - <*> (posixSecondsToUTCTime <$> o .: "time") - <*> o .: "sender" - <*> o .: "content" - <*> o .:? "encryption_key_id" - <*> o .:? "edited" - <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") - <*> o .:? "truncated" .!= False - --- | A 'PersonalAccountView' contains information about an euphoria account. See --- . -data PersonalAccountView = PersonalAccountView - { pavId :: Snowflake - , pavName :: T.Text - , pavEmail :: T.Text - } deriving (Show) - -instance FromJSON PersonalAccountView where - parseJSON v = parseJSON v >>= \o -> PersonalAccountView - <$> o .: "id" - <*> o .: "name" - <*> o .: "email" - --- | A 'SessionView' describes a session and its identity. See --- . -data SessionView = SessionView - { svId :: UserId - , svNick :: T.Text - , svServerId :: T.Text - , svServerEra :: T.Text - , svSessionId :: T.Text - , svIsStaff :: Bool - , svIsManager :: Bool - , svClientAddress :: Maybe T.Text - , svRealClientAddress :: Maybe T.Text - } deriving (Show) - -instance FromJSON SessionView where - parseJSON v = parseJSON v >>= \o -> SessionView - <$> o .: "id" - <*> o .: "name" - <*> o .: "server_id" - <*> o .: "server_era" - <*> o .: "session_id" - <*> o .:? "is_staff" .!= False - <*> o .:? "is_manager" .!= False - <*> o .:? "client_address" - <*> o .:? "real_client_address" - -- | A snowflake is a 13-character string, usually used as a unique identifier -- for some type of object. It is the base-36 encoding of an unsigned, 64-bit -- integer. See . @@ -206,6 +200,8 @@ data UserId = UserId , userSnowflake :: Snowflake } deriving (Show, Eq, Ord) +makeLensesL ''UserId + instance ToJSON UserId where toJSON uid = let prefix = case userType uid of @@ -223,6 +219,81 @@ instance FromJSON UserId where ("bot", snowflake) -> pure $ UserId Bot $ T.drop 1 snowflake _ -> fail "invalid user id label" +-- | A 'SessionView' describes a session and its identity. See +-- . +data SessionView = SessionView + { svId :: UserId + , svNick :: T.Text + , svServerId :: T.Text + , svServerEra :: T.Text + , svSessionId :: T.Text + , svIsStaff :: Bool + , svIsManager :: Bool + , svClientAddress :: Maybe T.Text + , svRealClientAddress :: Maybe T.Text + } deriving (Show) + +makeLensesL ''SessionView + +instance FromJSON SessionView where + parseJSON v = parseJSON v >>= \o -> SessionView + <$> o .: "id" + <*> o .: "name" + <*> o .: "server_id" + <*> o .: "server_era" + <*> o .: "session_id" + <*> o .:? "is_staff" .!= False + <*> o .:? "is_manager" .!= False + <*> o .:? "client_address" + <*> o .:? "real_client_address" + +-- | A 'Message' is a node in a room’s log. It corresponds to a chat message, or +-- a post, or any broadcasted event in a room that should appear in the log. See +-- . +data Message = Message + { msgId :: Snowflake + , msgParent :: Maybe Snowflake + , msgPreviousEditId :: Maybe Snowflake + , msgTime :: UTCTime + , msgSender :: SessionView + , msgContent :: T.Text + , msgEncryptionKeyId :: Maybe T.Text + , msgEdited :: Maybe UTCTime + , msgDeleted :: Maybe UTCTime + , msgTruncated :: Bool + } deriving (Show) + +makeLensesL ''Message + +instance FromJSON Message where + parseJSON v = parseJSON v >>= \o -> Message + <$> o .: "id" + <*> o .:? "parent" + <*> o .:? "previous_edit_id" + <*> (posixSecondsToUTCTime <$> o .: "time") + <*> o .: "sender" + <*> o .: "content" + <*> o .:? "encryption_key_id" + <*> o .:? "edited" + <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") + <*> o .:? "truncated" .!= False + +-- | A 'PersonalAccountView' contains information about an euphoria account. See +-- . +data PersonalAccountView = PersonalAccountView + { pavId :: Snowflake + , pavName :: T.Text + , pavEmail :: T.Text + } deriving (Show) + +makeLensesL ''PersonalAccountView + +instance FromJSON PersonalAccountView where + parseJSON v = parseJSON v >>= \o -> PersonalAccountView + <$> o .: "id" + <*> o .: "name" + <*> o .: "email" + {- Asynchronous events -} {- bounce-event -} @@ -233,6 +304,8 @@ data BounceEvent = BounceEvent , bounceAuthOption :: [AuthOption] } deriving (Show) +makeLensesL ''BounceEvent + instance FromJSON BounceEvent where parseJSON = fromPacket "bounce-event" $ \o -> BounceEvent <$> o .:? "reason" @@ -245,6 +318,8 @@ newtype DisconnectEvent = DisconnectEvent { disconnectReason :: T.Text } deriving (Show) +makeLensesL ''DisconnectEvent + instance FromJSON DisconnectEvent where parseJSON = fromPacket "disconnect-evnet" $ \o -> DisconnectEvent <$> o .: "reason" @@ -261,6 +336,8 @@ data HelloEvent = HelloEvent , helloVersion :: T.Text } deriving (Show) +makeLensesL ''HelloEvent + instance FromJSON HelloEvent where parseJSON = fromPacket "hello-event" $ \o -> HelloEvent <$> o .:? "account" @@ -277,6 +354,8 @@ newtype JoinEvent = JoinEvent { joinSession :: SessionView } deriving (Show) +makeLensesL ''JoinEvent + instance FromJSON JoinEvent where parseJSON = fromPacket "join-event" $ \o -> JoinEvent <$> parseJSON (Object o) @@ -288,6 +367,8 @@ newtype LoginEvent = LoginEvent { loginAccountId :: Snowflake } deriving (Show) +makeLensesL ''LoginEvent + instance FromJSON LoginEvent where parseJSON = fromPacket "login-event" $ \o -> LoginEvent <$> o .: "acount_id" @@ -310,6 +391,8 @@ data NetworkEvent = NetworkEvent , networkServerEra :: T.Text } deriving (Show) +makeLensesL ''NetworkEvent + instance FromJSON NetworkEvent where parseJSON = fromPacket "network-event" $ \o -> NetworkEvent <$> o .: "type" @@ -326,6 +409,8 @@ data NickEvent = NickEvent , nickTo :: T.Text } deriving (Show) +makeLensesL ''NickEvent + instance FromJSON NickEvent where parseJSON = fromPacket "nick-event" $ \o -> NickEvent <$> o .: "session_id" @@ -341,6 +426,8 @@ data EditMessageEvent = EditMessageEvent , editMessageEditId :: Snowflake } deriving (Show) +makeLensesL ''EditMessageEvent + instance FromJSON EditMessageEvent where parseJSON = fromPacket "EditMessageEvent" $ \o -> EditMessageEvent <$> parseJSON (Object o) @@ -353,6 +440,8 @@ newtype PartEvent = PartEvent { partSession :: SessionView } deriving (Show) +makeLensesL ''PartEvent + instance FromJSON PartEvent where parseJSON = fromPacket "part-event" $ \o -> PartEvent <$> parseJSON (Object o) @@ -365,6 +454,8 @@ data PingEvent = PingEvent , pingNext :: UTCTime } deriving (Show) +makeLensesL ''PingEvent + instance FromJSON PingEvent where parseJSON = fromPacket "ping-event" $ \o -> PingEvent <$> (posixSecondsToUTCTime <$> o .: "time") @@ -380,6 +471,8 @@ data PmInitiateEvent = PmInitiateEvent , pmInitiatePmId :: Snowflake } deriving (Show) +makeLensesL ''PmInitiateEvent + instance FromJSON PmInitiateEvent where parseJSON = fromPacket "pm-initiate-event" $ \o -> PmInitiateEvent <$> o .: "from" @@ -394,6 +487,8 @@ newtype SendEvent = SendEvent { sendMessage :: Message } deriving (Show) +makeLensesL ''SendEvent + instance FromJSON SendEvent where parseJSON = fromPacket "send-event" $ \o -> SendEvent <$> parseJSON (Object o) @@ -412,6 +507,8 @@ data SnapshotEvent = SnapshotEvent , snapshotPmWithUserId :: Maybe UserId } deriving (Show) +makeLensesL ''SnapshotEvent + instance FromJSON SnapshotEvent where parseJSON = fromPacket "snapshot-event" $ \o -> SnapshotEvent <$> o .: "identity" diff --git a/src/Haboli/Euphoria/Lens.hs b/src/Haboli/Euphoria/Lens.hs new file mode 100644 index 0000000..7116784 --- /dev/null +++ b/src/Haboli/Euphoria/Lens.hs @@ -0,0 +1,13 @@ +module Haboli.Euphoria.Lens + ( makeLensesL + ) where + +import Language.Haskell.TH +import Lens.Micro.TH +import Lens.Micro + +rename :: Name -> [Name] -> Name -> [DefName] +rename _ _ name = [TopName $ mkName $ nameBase name ++ "L"] + +makeLensesL :: Name -> DecsQ +makeLensesL = makeLensesWith $ lensRules & lensField .~ rename