diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,17 @@ +# Revision history for pushbullet-types + +## 0.1.0.0 -- 2017-02-20 + +Define the following core types: + +* `Push` -- messages used internally in Pushbullet. +* `Ephemeral` -- messages sent directly into the live event stream. These have + a multitude of uses, e.g. sending SMS via a phone or seeing whether + notifications have occurred on a device. +* `Device` -- representation of a device. +* `User` -- representation of a user. +* `Permanant` -- this is an undocumented type in the Pushbullet API. Notably, + SMS threads and messages are permanents. + +Some of these types come in two flavors: `New` and `Existing`. This is +signalled by a type index coming from a datakind. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Jacob Errington + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pushbullet-types.cabal b/pushbullet-types.cabal new file mode 100644 --- /dev/null +++ b/pushbullet-types.cabal @@ -0,0 +1,64 @@ +-- Initial pushbullet-types.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: pushbullet-types +version: 0.1.0.0 +synopsis: Datatypes used by the Pushbullet APIs +-- description: +license: MIT +license-file: LICENSE +author: Jacob Thomas Errington +maintainer: hackage@mail.jerrington.me +copyright: Jacob Thomas Errington 2017 +category: Web +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/tsani/pushbullet-types + +source-repository this + type: git + location: https://github.com/tsani/pushbullet-types/releases/tag/v0.1.0.0 + tag: v0.1.0.0 + +library + default-language: Haskell2010 + hs-source-dirs: src + default-extensions: + DataKinds, + DeriveFunctor, + FlexibleInstances, + GADTs, + GeneralizedNewtypeDeriving, + PolyKinds, + RecordWildCards, + StandaloneDeriving, + TypeApplications, + TypeFamilies + exposed-modules: + Network.Pushbullet.Types, + Network.Pushbullet.Internal.Reflection + other-modules: + Network.Pushbullet.Types.Device, + Network.Pushbullet.Types.Ephemeral, + Network.Pushbullet.Types.Misc, + Network.Pushbullet.Types.Pagination, + Network.Pushbullet.Types.Permanent, + Network.Pushbullet.Types.Push, + Network.Pushbullet.Types.SMS, + Network.Pushbullet.Types.Status, + Network.Pushbullet.Types.Time, + Network.Pushbullet.Types.User + build-depends: + aeson >=0.11 && <1.1, + base >=4.9 && <4.10, + http-api-data >=0.3 && <0.4, + microlens >=0.4 && <0.5, + microlens-th >=0.4 && <0.5, + scientific >=0.3 && <0.4, + text >=1.0 && <1.3, + time >=1.6 && <1.7, + unordered-containers >=0.2 && <0.3 diff --git a/src/Network/Pushbullet/Internal/Reflection.hs b/src/Network/Pushbullet/Internal/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Internal/Reflection.hs @@ -0,0 +1,17 @@ +module Network.Pushbullet.Internal.Reflection +( Demote' +, Demote +, Reflected +, Reflect(..) +, KProxy(..) +) where + +import Data.Proxy + +type family Demote' (p :: KProxy k) :: k -> * + +type Demote (a :: k) = Demote' ('KProxy :: KProxy k) +type Reflected a = Demote a a + +class Reflect a where + reflect :: proxy a -> Reflected a diff --git a/src/Network/Pushbullet/Types.hs b/src/Network/Pushbullet/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types.hs @@ -0,0 +1,117 @@ +module Network.Pushbullet.Types +( -- * Pagination + Paginated(..) +, Cursor + -- * Pushes +, Push(..) +, PushData(..) +, PushTarget(..) +, simpleNewPush +, ExistingPushes(..) + -- * Ephemerals +, Ephemeral(..) +, Notification(..) + -- * Devices +, Device(..) +, DeviceId(..) +, Nickname(..) +, DeviceIcon(..) +, HasSms(..) +, ExistingDevices(..) +, newDevice + -- * Users +, User(..) +, UserId(..) + -- * Permanents +, Permanent(..) +, PermanentK(..) + -- ** SMS +, SmsThreads(..) +, SmsThread(..) +, SmsThreadId(..) +, SmsThreadRecipient(..) +, SmsMessages(..) +, SmsMessage(..) +, SmsId(..) +, SmsDirection(..) +, SmsMessageType(..) + -- * Misc + -- + -- ** Data +, EmailAddress(..) +, ChannelTag(..) +, ClientId(..) +, MimeType(..) +, Url(..) +, Guid(..) +, TrivialObject(..) +, Status(..) +, PushbulletTime(..) +, PhoneNumber(..) +, Name(..) + + -- ** Type-level stuff +, EqT + + -- * Lenses + -- ** Device +, deviceId +, deviceActive +, deviceCreated +, deviceModified +, deviceIcon +, deviceNickname +, deviceGeneratedNickname +, deviceManufacturer +, deviceModel +, deviceAppVersion +, deviceFingerprint +, deviceKeyFingerprint +, deviceHasSms +, devicePushToken + -- ** User +, userCreated +, userEmail +, userEmailNormalized +, userId +, userImageUrl +, userMaxUploadSize +, userModified +, userName + -- ** SMS +, smsDirection +, smsTime +, smsBody +, smsId +, smsSent +, smsType +, recipientName +, recipientAddress +, recipientNumber +, threadId +, threadRecipients +, threadLatest + -- ** Ephemerals +, ephSmsSourceUser +, ephSmsTargetDevice +, ephSmsConversation +, ephSmsMessage + -- ** Clipboard +, ephClipBody +, ephClipSourceUser +, ephClipSourceDevice + -- ** Pagination +, pageData +, pageCursor +) where + +import Network.Pushbullet.Types.Device +import Network.Pushbullet.Types.Ephemeral +import Network.Pushbullet.Types.Misc +import Network.Pushbullet.Types.Pagination +import Network.Pushbullet.Types.Permanent +import Network.Pushbullet.Types.Push +import Network.Pushbullet.Types.SMS +import Network.Pushbullet.Types.Status +import Network.Pushbullet.Types.Time +import Network.Pushbullet.Types.User diff --git a/src/Network/Pushbullet/Types/Device.hs b/src/Network/Pushbullet/Types/Device.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Device.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Pushbullet.Types.Device where + +import Network.Pushbullet.Types.Status +import Network.Pushbullet.Types.Time + +import Data.Aeson +import Data.Text ( Text ) +import Lens.Micro.TH +import Web.HttpApiData ( ToHttpApiData(..) ) + +newtype DeviceId = DeviceId Text + deriving (Eq, FromJSON, Show, ToJSON, ToHttpApiData) + +newtype DeviceIcon = DeviceIcon Text + deriving (Eq, ToJSON, Show, FromJSON) + +newtype Nickname = Nickname Text + deriving (Eq, ToJSON, Show, FromJSON) + +newtype PushToken = PushToken Text + deriving (Eq, ToJSON, Show, FromJSON) + +newtype Manufacturer = Manufacturer Text + deriving (Eq, ToJSON, Show, FromJSON) + +newtype Fingerprint = Fingerprint Text + deriving (Eq, ToJSON, Show, FromJSON) + +newtype Model = Model Text + deriving (Eq, ToJSON, Show, FromJSON) + +newtype AppVersion = AppVersion Int + deriving (Eq, ToJSON, Show, FromJSON) + +newtype KeyFingerprint = KeyFingerprint Text + deriving (Eq, ToJSON, Show, FromJSON) + +-- | Whether the device has SMS capabilities. +data HasSms = NoSms | HasSms + deriving (Eq, Ord, Show) + +-- | A device attached to a Pushbullet account. +data Device (s :: Status) + = Device + { _deviceId :: !(EqT 'Existing s DeviceId) + , _deviceActive :: !(EqT 'Existing s Bool) + , _deviceCreated :: !(EqT 'Existing s PushbulletTime) + , _deviceModified :: !(EqT 'Existing s PushbulletTime) + , _deviceIcon :: !DeviceIcon + , _deviceNickname :: !(Maybe Nickname) + , _deviceGeneratedNickname :: !(EqT 'Existing s Bool) + , _deviceManufacturer :: !(Maybe Manufacturer) + , _deviceModel :: !(Maybe Model) + , _deviceAppVersion :: !(Maybe AppVersion) + , _deviceFingerprint :: !(EqT 'Existing s (Maybe Fingerprint)) + , _deviceKeyFingerprint :: !(EqT 'Existing s (Maybe KeyFingerprint)) + , _deviceHasSms :: !HasSms + , _devicePushToken :: !(Maybe PushToken) + } + +makeLenses ''Device + +-- | Smart constructor for a new device that fills in the ignored fields. +newDevice + :: HasSms + -> DeviceIcon + -> Nickname + -> Maybe Manufacturer + -> Maybe Model + -> Maybe AppVersion + -> Device 'New +newDevice sms icon nick man m ver = Device + { _deviceId = () + , _deviceActive = () + , _deviceCreated = () + , _deviceModified = () + , _deviceIcon = icon + , _deviceNickname = Just nick + , _deviceGeneratedNickname = () + , _deviceManufacturer = man + , _deviceModel = m + , _deviceAppVersion = ver + , _deviceFingerprint = () + , _deviceKeyFingerprint = () + , _deviceHasSms = sms + , _devicePushToken = Nothing + } + +-- | A newtype wrapper for a list of existing devices. We need this to get a +-- nonstandard 'FromJSON' instance for the list, because Pushbullet gives us +-- the list wrapped in a trivial object with one key. +newtype ExistingDevices + = ExistingDevices + { unExistingDevices :: [Device 'Existing] + } + deriving (Eq, Show) + +instance ToJSON HasSms where + toJSON NoSms = Bool False + toJSON HasSms = Bool True + +instance FromJSON HasSms where + parseJSON (Bool True) = pure HasSms + parseJSON (Bool False) = pure NoSms + parseJSON _ = fail "cannot parse SMS ability from non-boolean" + +deriving instance Eq (Device 'New) +deriving instance Eq (Device 'Existing) +deriving instance Show (Device 'New) +deriving instance Show (Device 'Existing) + +instance ToJSON (Device 'Existing) where + toJSON Device{..} = object + [ "iden" .= _deviceId + , "active" .= _deviceActive + , "created" .= _deviceCreated + , "modified" .= _deviceModified + , "icon" .= _deviceIcon + , "nickname" .= _deviceNickname + , "generated_nickname" .= _deviceGeneratedNickname + , "manufacturer" .= _deviceManufacturer + , "model" .= _deviceModel + , "app_version" .= _deviceAppVersion + , "fingerprint" .= _deviceFingerprint + , "key_fingerprint" .= _deviceKeyFingerprint + , "has_sms" .= _deviceHasSms + , "push_token" .= _devicePushToken + ] + +instance FromJSON (Device 'Existing) where + parseJSON (Object o) = pure Device + <*> o .: "iden" + <*> o .: "active" + <*> o .: "created" + <*> o .: "modified" + <*> o .: "icon" + <*> o .:? "nickname" + <*> o .:? "generated_nickname" .!= False + <*> o .:? "manufacturer" + <*> o .:? "model" + <*> o .:? "app_version" + <*> o .:? "fingerprint" + <*> o .:? "key_fingerprint" + <*> o .:? "has_sms" .!= NoSms + <*> o .:? "push_token" + parseJSON _ = fail "cannot parse existing device from non-object" + +instance ToJSON (Device 'New) where + toJSON Device{..} = object + [ "nickname" .= _deviceNickname + , "model" .= _deviceModel + , "manufacturer" .= _deviceManufacturer + , "push_token" .= _devicePushToken + , "app_version" .= _deviceAppVersion + , "icon" .= _deviceIcon + , "has_sms" .= _deviceHasSms + ] + +instance FromJSON ExistingDevices where + parseJSON (Object o) = ExistingDevices <$> o .: "devices" + parseJSON _ = fail "cannot parse devices object from non-object" + +instance ToJSON ExistingDevices where + toJSON (ExistingDevices ds) = object [ "devices" .= ds ] diff --git a/src/Network/Pushbullet/Types/Ephemeral.hs b/src/Network/Pushbullet/Types/Ephemeral.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Ephemeral.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Pushbullet.Types.Ephemeral where + +import Network.Pushbullet.Types.Device +import Network.Pushbullet.Types.Misc +import Network.Pushbullet.Types.SMS +import Network.Pushbullet.Types.Time +import Network.Pushbullet.Types.User + +import Control.Monad ( guard ) +import Data.Aeson +import Data.Monoid ( (<>) ) +import Data.Text ( Text ) +import Lens.Micro +import Lens.Micro.TH + +data Notification + = Notification + { _notifThread :: !SmsThreadId + , _notifTime :: !PushbulletTime + , _notifTitle :: !Text + , _notifBody :: !Text + } + deriving (Eq, Show) + +makeLenses ''Notification + +data Ephemeral + = Sms + { _ephSmsSourceUser :: !UserId + , _ephSmsTargetDevice :: !DeviceId + , _ephSmsConversation :: !PhoneNumber + , _ephSmsMessage :: !Text + } + | Clipboard + { _ephClipBody :: !Text + , _ephClipSourceUser :: !UserId + , _ephClipSourceDevice :: !DeviceId + } + | SmsChanged + { _ephSourceDevice :: !DeviceId + , _ephNotifications :: ![Notification] + } + deriving (Eq, Show) + +makeLenses ''Ephemeral + +instance ToJSON Ephemeral where + toJSON o = case o of + Sms{..} -> object + [ "type" .= id @Text "push" + , "push" .= object + [ "type" .= id @Text "messaging_extension_reply" + , "package_name" .= id @Text "com.pushbullet.android" + , "source_user_iden" .= _ephSmsSourceUser + , "target_device_iden" .= _ephSmsTargetDevice + , "conversation_iden" .= _ephSmsConversation + , "message" .= _ephSmsMessage + ] + ] + Clipboard{..} -> object + [ "type" .= id @Text "push" + , "push" .= object + [ "type" .= id @Text "clip" + , "body" .= _ephClipBody + , "source_user_iden" .= _ephClipSourceUser + , "source_device_iden" .= _ephClipSourceDevice + ] + ] + SmsChanged{..} -> object + [ "type" .= id @Text "push" + , "push" .= object + [ "type" .= id @Text "sms_changed" + , "source_device_iden" .= _ephSourceDevice + , "notifications" .= _ephNotifications + ] + ] + +instance FromJSON Ephemeral where + parseJSON (Object o) = do + t <- o .: "type" + guard (t == id @Text "push") + p <- o .: "push" + case p of + Object p' -> do + t' <- p' .: "type" + case t' of + "messaging_extension_reply" -> pure Sms + <*> p' .: "source_user_iden" + <*> p' .: "target_device_iden" + <*> p' .: "conversation_iden" + <*> p' .: "message" + "clip" -> pure Clipboard + <*> p' .: "body" + <*> p' .: "source_user_iden" + <*> p' .: "source_device_iden" + "sms_changed" -> pure SmsChanged + <*> p' .: "source_device_iden" + <*> p' .: "notifications" + _ -> fail $ "unknown push type " <> t' + _ -> fail "cannot parse push from non-object" + +instance ToJSON Notification where + toJSON n = object + [ "thread_id" .= (n^.notifThread) + , "timestamp" .= (n^.notifTime) + , "title" .= (n^.notifTitle) + , "body" .= (n^.notifBody) + ] + +instance FromJSON Notification where + parseJSON (Object o) = pure Notification + <*> o .: "thread_id" + <*> o .: "timestamp" + <*> o .: "title" + <*> o .: "body" + parseJSON _ = fail "cannot parse notification from non-object" diff --git a/src/Network/Pushbullet/Types/Misc.hs b/src/Network/Pushbullet/Types/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Misc.hs @@ -0,0 +1,46 @@ +module Network.Pushbullet.Types.Misc where + +import Data.Aeson +import qualified Data.HashMap.Lazy as H +import Data.Text ( Text ) + +newtype EmailAddress = EmailAddress Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype ChannelTag = ChannelTag Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype ChannelId = ChannelId Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype ClientId = ClientId Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype MimeType = MimeType Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype Url = Url Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype Guid = Guid Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype PhoneNumber = PhoneNumber Text + deriving (Eq, FromJSON, Show, ToJSON) + +newtype TrivialObject = TrivialObject () + deriving (Eq, Ord, Monoid, Show) + +newtype Name = Name + { unName :: Text + } + deriving (Eq, FromJSON, Show, ToJSON) + +instance ToJSON TrivialObject where + toJSON _ = object [] + +instance FromJSON TrivialObject where + parseJSON (Object o) + | H.null o = pure mempty + | otherwise = fail "trivial object has no keys" + parseJSON _ = fail "cannot parse non-object to trivial object" diff --git a/src/Network/Pushbullet/Types/Pagination.hs b/src/Network/Pushbullet/Types/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Pagination.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Pushbullet.Types.Pagination where + +import Data.Aeson +import Data.Text ( Text ) +import Lens.Micro.TH +import Web.HttpApiData ( ToHttpApiData(..) ) + +-- | Cursors are opaque. +newtype Cursor = Cursor Text + deriving (Eq, FromJSON, Show, ToJSON, ToHttpApiData) + +-- | A single page of data, possibly with a cursor attached to it. +-- The cursor may be used in routes that return paginated data to produce the +-- next page of data. +data Paginated a + = Page + { _pageData :: !a + , _pageCursor :: !(Maybe Cursor) + } + deriving (Eq, Functor, Show) + +makeLenses ''Paginated + +instance FromJSON a => FromJSON (Paginated a) where + parseJSON j@(Object o) = Page <$> parseJSON j <*> o .:? "cursor" + parseJSON _ = fail "cannot parse paginated data from non-object" diff --git a/src/Network/Pushbullet/Types/Permanent.hs b/src/Network/Pushbullet/Types/Permanent.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Permanent.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Pushbullet.Types.Permanent where + +import Network.Pushbullet.Types.Device +import Network.Pushbullet.Types.SMS + +import Data.Monoid ( (<>) ) +import Web.HttpApiData ( ToHttpApiData(..) ) + +data PermanentK + = ThreadList + | MessageList + +data Permanent (p :: PermanentK) where + ThreadsOf :: !DeviceId -> Permanent 'ThreadList + MessagesIn :: !DeviceId -> !SmsThreadId -> Permanent 'MessageList + +instance ToHttpApiData (Permanent 'ThreadList) where + toUrlPiece p = case p of + ThreadsOf (DeviceId d) -> d <> "_threads" + +instance ToHttpApiData (Permanent 'MessageList) where + toUrlPiece p = case p of + MessagesIn (DeviceId d) (SmsThreadId t) -> d <> "_thread_" <> t diff --git a/src/Network/Pushbullet/Types/Push.hs b/src/Network/Pushbullet/Types/Push.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Push.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Pushbullet.Types.Push +( Push(..) +, PushId(..) +, PushDirection(..) +, PushTarget(..) +, PushData(..) +, PushOrigin(..) +, ExistingPushes(..) +, simpleNewPush +) where + +import Network.Pushbullet.Types.Device +import Network.Pushbullet.Types.Misc +import Network.Pushbullet.Types.Status +import Network.Pushbullet.Types.Time +import Network.Pushbullet.Types.User + +import Control.Applicative ( (<|>) ) +import Data.Aeson +import Data.Text ( Text ) + +-- | A push. We reuse the same datatype for representing new pushes and +-- existing pushes. The 'EqT' type family is used to enable fields selectively +-- according to whether we're making a new push or representing an existing +-- one. +data Push (s :: Status) + = Push + { pushData :: !(PushData s) + , pushSourceDevice :: !(Maybe DeviceId) + , pushTarget :: !(PushTarget s) + , pushGuid :: !(Maybe Guid) + , pushId :: !(EqT 'Existing s PushId) + , pushActive :: !(EqT 'Existing s Bool) + , pushCreated :: !(EqT 'Existing s PushbulletTime) + , pushModified :: !(EqT 'Existing s PushbulletTime) + , pushDismissed :: !(EqT 'Existing s Bool) + , pushDirection :: !(EqT 'Existing s PushDirection) + , pushSender :: !(EqT 'Existing s UserId) + , pushSenderEmail :: !(EqT 'Existing s EmailAddress) + , pushSenderEmailNormalized :: !(EqT 'Existing s EmailAddress) + , pushSenderName :: !(EqT 'Existing s Name) + , pushReceiver :: !(EqT 'Existing s UserId) + , pushReceiverEmail :: !(EqT 'Existing s EmailAddress) + , pushReceiverEmailNormalized :: !(EqT 'Existing s EmailAddress) + , pushOrigin :: !(EqT 'Existing s (Maybe PushOrigin)) + } + +-- | Unique identifier for a push. +newtype PushId = PushId Text + deriving (Eq, FromJSON, Show, ToJSON) + +-- | The direction of a push. +data PushDirection + = SelfPush + | OutgoingPush + | IncomingPush + deriving (Eq, Ord, Show) + +-- | The target of a push. +data PushTarget (s :: Status) where + ToAll :: PushTarget 'New + ToDevice :: !DeviceId -> PushTarget 'New + ToEmail :: !EmailAddress -> PushTarget 'New + ToChannel :: !ChannelTag -> PushTarget 'New + ToClient :: !ClientId -> PushTarget 'New + SentBroadcast :: PushTarget 'Existing + SentToDevice :: !DeviceId -> PushTarget 'Existing + +-- | The actual contents of a push. +data PushData (s :: Status) + = NotePush + { pushTitle :: !Text + , pushBody :: !Text + } + | LinkPush + { pushTitle :: !Text + , pushBody :: !Text + , pushUrl :: !Url + } + | FilePush + { pushBody :: !Text + , pushFileName :: !Text + , pushFileType :: !MimeType + , pushFileUrl :: !Url + , pushFileTitle :: !(EqT 'Existing s Text) + , pushImageUrl :: !(EqT 'Existing s (Maybe Url)) + , pushImageWidth :: !(EqT 'Existing s (Maybe Int)) + , pushImageHeight :: !(EqT 'Existing s (Maybe Int)) + } + +-- | The origin of a push. +data PushOrigin + = FromClient !ClientId + | FromChannel !ChannelId + deriving (Eq, Show) + +-- | A newtype wrapper for a list of existing pushes. We need this to get a +-- nonstandard 'FromJSON' instance for the list, because Pushbullet gives us +-- the list wrapped in a trivial object with one key. +newtype ExistingPushes = ExistingPushes [Push 'Existing] + deriving (Eq, Show) + +-- | Constructs a new @Push@ with the source device and guid set to @Nothing@. +simpleNewPush :: PushTarget 'New -> PushData 'New -> Push 'New +simpleNewPush t d = Push + { pushData = d + , pushSourceDevice = Nothing + , pushTarget = t + , pushGuid = Nothing + , pushId = () + , pushActive = () + , pushCreated = () + , pushModified = () + , pushDismissed = () + , pushDirection = () + , pushSender = () + , pushSenderEmail = () + , pushSenderEmailNormalized = () + , pushSenderName = () + , pushReceiver = () + , pushReceiverEmail = () + , pushReceiverEmailNormalized = () + , pushOrigin = () + } + +instance ToJSON PushDirection where + toJSON SelfPush = String "self" + toJSON OutgoingPush = String "outgoing" + toJSON IncomingPush = String "incoming" + +instance FromJSON PushDirection where + parseJSON (String s) = case s of + "self" -> pure SelfPush + "outgoing" -> pure OutgoingPush + "incoming" -> pure IncomingPush + _ -> fail "invalid direction string" + parseJSON _ = fail "cannot parse push direction from non-string" + +deriving instance Eq (PushTarget s) +deriving instance Show (PushTarget s) + +deriving instance Eq (PushData 'New) +deriving instance Eq (PushData 'Existing) +deriving instance Show (PushData 'New) +deriving instance Show (PushData 'Existing) + +deriving instance Eq (Push 'New) +deriving instance Eq (Push 'Existing) +deriving instance Show (Push 'New) +deriving instance Show (Push 'Existing) + +instance FromJSON (Push 'Existing) where + parseJSON (Object o) = do + pushType <- o .: "type" + d <- case id @Text pushType of + "note" -> pure NotePush + <*> o .: "title" + <*> o .: "body" + "file" -> pure FilePush + <*> o .: "body" + <*> o .: "file_name" + <*> o .: "file_type" + <*> o .: "file_url" + <*> o .: "file_title" + <*> o .:? "image_url" + <*> o .:? "image_width" + <*> o .:? "image_height" + "link" -> pure LinkPush + <*> o .: "title" + <*> o .: "body" + <*> o .: "url" + _ -> fail "unrecognized push type" + client <- o .:? "client_iden" + channel <- o .:? "channel_iden" + let origin = (FromClient <$> client) <|> (FromChannel <$> channel) + + pure Push + <*> pure d + <*> o .:? "source_device_iden" + <*> (maybe SentBroadcast SentToDevice <$> o .:? "target_device_iden") + <*> o .:? "guid" + <*> o .: "iden" + <*> o .: "active" + <*> o .: "created" + <*> o .: "modified" + <*> o .: "dismissed" + <*> o .: "direction" + <*> o .: "sender_iden" + <*> o .: "sender_email" + <*> o .: "sender_email_normalized" + <*> o .: "sender_name" + <*> o .: "receiver_iden" + <*> o .: "receiver_email" + <*> o .: "receiver_email_normalized" + <*> pure origin + parseJSON _ = fail "cannot parse push from non-object" + +instance FromJSON ExistingPushes where + parseJSON (Object o) = ExistingPushes <$> o .: "pushes" + parseJSON _ = fail "cannot parse existing pushes from non-object" + +instance ToJSON (Push 'New) where + toJSON Push{..} = object (concat pieces) where + pieces = + [ [ "source_device_iden" .= pushSourceDevice + , "guid" .= pushGuid + ] + , target + , thePushData + ] + + target = case pushTarget of + ToAll -> [] + ToDevice d -> [ "device_iden" .= d ] + ToEmail email -> [ "email" .= email ] + ToChannel tag -> [ "channel_tag" .= tag ] + ToClient client -> [ "client_iden" .= client ] + + thePushData = case pushData of + NotePush{..} -> + [ "type" .= id @Text "note" + , "title" .= pushTitle + , "body" .= pushBody + ] + LinkPush{..} -> + [ "type" .= id @Text "link" + , "title" .= pushTitle + , "body" .= pushBody + , "url" .= pushUrl + ] + FilePush{..} -> + [ "type" .= id @Text "file" + , "body" .= pushBody + , "file_name" .= pushFileName + , "file_type" .= pushFileType + , "file_url" .= pushFileUrl + ] diff --git a/src/Network/Pushbullet/Types/SMS.hs b/src/Network/Pushbullet/Types/SMS.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/SMS.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Pushbullet.Types.SMS where + +import Data.Aeson +import Data.Text ( Text ) +import Data.List.NonEmpty ( NonEmpty ) +import Lens.Micro.TH + +import Network.Pushbullet.Types.Misc +import Network.Pushbullet.Types.Time + +data SmsDirection + = IncomingSms + | OutgoingSms + deriving (Eq, Show) + +newtype SmsId = SmsId Text + deriving (Eq, FromJSON, Show, ToJSON) + +data SmsMessageType + = SMS + | MMS + deriving (Eq, Show) + +data SmsMessage + = SmsMessage + { _smsDirection :: !SmsDirection + , _smsTime :: !PushbulletTime + , _smsBody :: !Text + , _smsId :: !SmsId + , _smsSent :: !(Maybe Bool) + , _smsType :: !SmsMessageType + } + deriving (Eq, Show) + +makeLenses ''SmsMessage + +newtype SmsMessages + = SmsMessages + { unSmsMessages :: [SmsMessage] + } + deriving (Eq, Show) + +data SmsThreadRecipient + = SmsThreadRecipient + { _recipientName :: !Name + , _recipientAddress :: !PhoneNumber + , _recipientNumber :: !PhoneNumber + } + deriving (Eq, Show) + +makeLenses ''SmsThreadRecipient + +newtype SmsThreadId = SmsThreadId Text + deriving (Eq, FromJSON, Show, ToJSON) + +data SmsThread + = SmsThread + { _threadId :: SmsThreadId + , _threadRecipients :: NonEmpty SmsThreadRecipient + , _threadLatest :: SmsMessage + } + deriving (Eq, Show) + +makeLenses ''SmsThread + +newtype SmsThreads + = SmsThreads + { unSmsThreads :: [SmsThread] + } + deriving (Eq, Show) + +instance FromJSON SmsDirection where + parseJSON (String s) = case s of + "incoming" -> pure IncomingSms + "outgoing" -> pure OutgoingSms + _ -> fail "invalid SMS direction string" + parseJSON _ = fail "cannot parse SMS direction from non-string" + +instance FromJSON SmsMessageType where + parseJSON (String s) + | "sms" <- s = pure SMS + | "mms" <- s = pure MMS + | otherwise = fail "invalid SMS type" + parseJSON _ = fail "cannot parse SMS type from non-string" + +instance FromJSON SmsMessage where + parseJSON (Object o) = pure SmsMessage + <*> o .: "direction" + <*> o .: "timestamp" + <*> o .: "body" + <*> o .: "id" + <*> o .:? "sent" + <*> o .: "type" + parseJSON _ = fail "cannot parse sms message from non-object" + +instance FromJSON SmsMessages where + parseJSON (Object o) = SmsMessages <$> o .: "thread" + parseJSON _ = fail "cannot parse sms messages from non-object" + +instance FromJSON SmsThreads where + parseJSON (Object o) = SmsThreads <$> o .: "threads" + parseJSON _ = fail "cannot parse sms threads from non-object" + +instance FromJSON SmsThreadRecipient where + parseJSON (Object o) = pure SmsThreadRecipient + <*> o .: "name" + <*> o .: "address" + <*> o .: "number" + parseJSON _ = fail "cannot parse sms thread recipient from non-object" + +instance FromJSON SmsThread where + parseJSON (Object o) = pure SmsThread + <*> o .: "id" + <*> o .: "recipients" + <*> o .: "latest" + parseJSON _ = fail "cannot parse sms thread from non-object" diff --git a/src/Network/Pushbullet/Types/Status.hs b/src/Network/Pushbullet/Types/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Status.hs @@ -0,0 +1,30 @@ +module Network.Pushbullet.Types.Status +( Status(..) +, EqT +) where + +import Network.Pushbullet.Internal.Reflection + +data Status + = New + | Existing + +data Status' :: Status -> * where + New' :: Status' 'New + Existing' :: Status' 'Existing + +type instance Demote' ('KProxy :: KProxy Status) = Status' + +instance Reflect 'New where + reflect _ = New' + +instance Reflect 'Existing where + reflect _ = Existing' + +-- | If the first two types are the same, return the third; else, return unit. +-- +-- This type family is used to disable certain fields according to the 'Status' +-- datakind. +type family EqT (s :: k) (s' :: k) (a :: *) :: * where + EqT s s a = a + EqT _ _ _ = () diff --git a/src/Network/Pushbullet/Types/Time.hs b/src/Network/Pushbullet/Types/Time.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/Time.hs @@ -0,0 +1,26 @@ +module Network.Pushbullet.Types.Time where + +import Data.Aeson +import Data.String ( fromString ) +import Data.Scientific ( toRealFloat ) +import Data.Time.Clock ( NominalDiffTime, UTCTime ) +import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds, posixSecondsToUTCTime ) +import Web.HttpApiData ( ToHttpApiData(..) ) + +newtype PushbulletTime = PushbulletTime UTCTime + deriving (Eq, Ord, Show) + +instance ToHttpApiData PushbulletTime where + toUrlPiece (PushbulletTime utc) = fromString (show d) where + d = fromRational r :: Double + r = toRational $ utcTimeToPOSIXSeconds utc + +instance FromJSON PushbulletTime where + parseJSON (Number n) = pure (PushbulletTime (posixSecondsToUTCTime p)) where + p = fromRational (toRational d) :: NominalDiffTime + d = toRealFloat n :: Double + parseJSON _ = fail "cannot parse pushbullet time from non-number" + +instance ToJSON PushbulletTime where + toJSON (PushbulletTime utcTime) + = Number $ fromRational (toRational $ utcTimeToPOSIXSeconds utcTime) diff --git a/src/Network/Pushbullet/Types/User.hs b/src/Network/Pushbullet/Types/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pushbullet/Types/User.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Pushbullet.Types.User where + +import Network.Pushbullet.Types.Misc +import Network.Pushbullet.Types.Time + +import Data.Aeson +import Data.Text ( Text ) +import Lens.Micro.TH + +newtype UserId = UserId Text + deriving (Eq, FromJSON, Show, ToJSON) + +data User + = User + { _userCreated :: PushbulletTime + , _userEmail :: EmailAddress + , _userEmailNormalized :: EmailAddress + , _userId :: UserId + , _userImageUrl :: Url + , _userMaxUploadSize :: Double + , _userModified :: PushbulletTime + , _userName :: Name + } + deriving (Eq, Show) + +makeLenses ''User + +instance FromJSON User where + parseJSON (Object o) = pure User + <*> o .: "created" + <*> o .: "email" + <*> o .: "email_normalized" + <*> o .: "iden" + <*> o .: "image_url" + <*> o .: "max_upload_size" + <*> o .: "modified" + <*> o .: "name" + parseJSON _ = fail "cannot parse user from non-object"