diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Revision history for tpb +## 0.1.1.1 -- 2017-02-20 + +* add `app_name` libnotify hint in pb-notify, so applications processing + notifications sent by pb-notify can do special logic. + +## 0.1.1.0 -- 2017-02-20 + +* remove unused module. +* declare all modules in `other-modules` so cabal includes them in source + distributions. + ## 0.1.0.0 -- 2017-02-20 This version releases the `tpb` and `pb-notify` programs as well as some diff --git a/src/pb-notify/Main.hs b/src/pb-notify/Main.hs --- a/src/pb-notify/Main.hs +++ b/src/pb-notify/Main.hs @@ -17,6 +17,9 @@ import System.Environment ( getEnv ) import Wuss ( runSecureClient ) +appName :: String +appName = "pb-notify" + main :: IO () main = do token <- getEnv "PUSHBULLET_KEY" @@ -32,11 +35,11 @@ SmsChanged{..} -> forM_ _ephNotifications $ \Notification{..} -> do t <- niceTime _notifTime - Noti.display_ $ - Noti.summary (T.unpack $ "SMS from " <> _notifTitle) <> - Noti.body ( - T.unpack (_notifBody <> "\n") <> t - ) + Noti.display_ $ mconcat + [ Noti.summary (T.unpack $ "SMS from " <> _notifTitle) + , Noti.body (T.unpack (_notifBody <> "\n") <> t) + , Noti.appName appName + ] _ -> pure () niceTime :: PushbulletTime -> IO String diff --git a/src/tpb/Command.hs b/src/tpb/Command.hs new file mode 100644 --- /dev/null +++ b/src/tpb/Command.hs @@ -0,0 +1,47 @@ +{-| + - This module describes a free monad for some high-level operations on the + - Pushbullet API. + -} + +module Command where + +import Network.Pushbullet.Types +import Network.Pushbullet.Misc ( Count ) + +import Control.Monad.Free +import qualified Data.Text as T + +-- | The base functor for the 'Command' free monad. +data CommandF a where + -- | List the SMS messages in a thread on a device. + ListSms :: DeviceId -> SmsThreadId -> ([SmsMessage] -> a) -> CommandF a + -- | List the SMS threads on a device. + ListThreads :: DeviceId -> ([SmsThread] -> a) -> CommandF a + -- | Send an SMS with a device to a phone. + SendSms :: UserId -> DeviceId -> PhoneNumber -> T.Text -> a -> CommandF a + -- | List the devices. + ListDevices :: Count -> ([Device 'Existing] -> a) -> CommandF a + Me :: (User -> a) -> CommandF a + ThrowCommandError :: T.Text -> CommandF a + deriving Functor + +-- | The Command monad. +type Command = Free CommandF + +listSms :: DeviceId -> SmsThreadId -> Command [SmsMessage] +listSms d t = liftF (ListSms d t id) + +listThreads :: DeviceId -> Command [SmsThread] +listThreads d = liftF (ListThreads d id) + +sendSms :: UserId -> DeviceId -> PhoneNumber -> T.Text -> Command () +sendSms u d p t = liftF (SendSms u d p t ()) + +listDevices :: Count -> Command [Device 'Existing] +listDevices c = liftF (ListDevices c id) + +me :: Command User +me = liftF (Me id) + +commandError :: T.Text -> Command a +commandError = Free . ThrowCommandError diff --git a/src/tpb/Count.hs b/src/tpb/Count.hs new file mode 100644 --- /dev/null +++ b/src/tpb/Count.hs diff --git a/src/tpb/Format.hs b/src/tpb/Format.hs new file mode 100644 --- /dev/null +++ b/src/tpb/Format.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Format where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import Data.Text.Encoding ( encodeUtf8 ) +import qualified Text.PrettyPrint.ANSI.Leijen as P + +-- | The class of output formats that can be rendered. +class RenderableFormat a where + renderFormat :: a -> LBS.ByteString + + -- | If the format can be rendered in a special way directly to some output, + -- then this method can be used. It is implemented by default by simply + -- writing the format rendered as a bytestring. + printFormat :: a -> IO () + printFormat = LBS.putStr . renderFormat + +instance RenderableFormat LBS.ByteString where + renderFormat = id + +instance RenderableFormat BS.ByteString where + renderFormat = LBS.fromStrict + +instance RenderableFormat P.Doc where + renderFormat + = LBS.fromStrict + . encodeUtf8 + . T.pack + . ($ "") + . P.displayS + . P.renderPretty 0.75 80 + +instance RenderableFormat T.Text where + renderFormat = LBS.fromStrict . encodeUtf8 + +-- | Existential that wraps up a renderable format applied to some type +-- constructor. +data ExistsRenderableFormat f where + ExistsRenderableFormat + :: RenderableFormat fmt + => f fmt + -> ExistsRenderableFormat f + +-- | A monad for formatting text. This is just a kleisli arrow! +newtype FormatM i m o = FormatM { unFormatM :: i -> m o } diff --git a/src/tpb/Request.hs b/src/tpb/Request.hs new file mode 100644 --- /dev/null +++ b/src/tpb/Request.hs @@ -0,0 +1,31 @@ +module Request where + +import Command +import Format +import Sum + +import Network.Pushbullet.Types + +import qualified Data.Text as T + +-- | A request is a program for computing the given response combined with a +-- pushbullet api key that can be used to actually execute the program. The +-- command must compute a result in an open sum type that can be handled by a +-- 'Product' to convert that result into a renderable format, possibly using +-- monadic effects. +data Request m key where + Request + :: Product ts (ExistsRenderableFormat m) + -> key + -> m (Command (Sum' ts)) + -> Request m key + +deriving instance Functor (Request m) +deriving instance Foldable (Request m) +deriving instance Traversable (Request m) + +data RequestInfo dev count + = ListSmsReq dev SmsThreadId + | ListThreadsReq dev + | SendSmsReq dev PhoneNumber T.Text + | ListDevicesReq count diff --git a/src/tpb/ResponseFormat.hs b/src/tpb/ResponseFormat.hs new file mode 100644 --- /dev/null +++ b/src/tpb/ResponseFormat.hs @@ -0,0 +1,7 @@ +module ResponseFormat +( module ResponseFormat.HumanTable +, module ResponseFormat.JSV +) where + +import ResponseFormat.HumanTable +import ResponseFormat.JSV diff --git a/src/tpb/ResponseFormat/HumanTable.hs b/src/tpb/ResponseFormat/HumanTable.hs new file mode 100644 --- /dev/null +++ b/src/tpb/ResponseFormat/HumanTable.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module ResponseFormat.HumanTable where + +import Format +import Sum + +import Network.Pushbullet.Types + +import Data.Function ( on ) +import Data.List ( sortBy ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as N +import Data.Ord ( comparing ) +import qualified Data.Text as T +import Data.Time.Clock ( diffUTCTime, NominalDiffTime ) +import Data.Time.Format ( defaultTimeLocale, formatTime ) +import Data.Time.LocalTime ( getTimeZone, utcToLocalTime ) +import Lens.Micro +import qualified Text.PrettyPrint.ANSI.Leijen as P + +newtype HumanTable = HumanTable P.Doc + deriving RenderableFormat + +formatHumanTable + :: Product + '[[SmsMessage], [SmsThread], (), [Device 'Existing]] + (IO HumanTable) +formatHumanTable + = smsMessage -| smsThreads -| ok -| devices -| Inexhaustive where + + chronologicalBy l = sortBy (comparing l) + + smsMessage :: [SmsMessage] -> IO HumanTable + smsMessage + (chronologicalBy (^.smsTime) -> groupSms tenMins -> groups) = + HumanTable . P.vcat <$> (mapM phi groups) where + phi :: SmsGroup -> IO P.Doc + phi (SmsGroup msgs) = do + let msg = N.head msgs + let dir = msg^.smsDirection + t <- niceTime (msg^.smsTime) + pure $ + P.vsep ( + P.hang 2 + . (arrow dir P.<+>) + . P.fillSep + . map P.text . words . T.unpack + . (^.smsBody) + <$> N.toList msgs + ) + P.<$> "+" P.<+> P.text t P.<$> "" + + tenMins :: NominalDiffTime + tenMins = 60 * 10 -- ten minutes + + smsThreads :: [SmsThread] -> IO HumanTable + smsThreads + = fmap (HumanTable . P.vsep) -- join all the lines + . mapM phi -- convert the thread to a line of text + . chronologicalBy (^.threadLatest.smsTime) + -- order by latest message in thread + where + phi :: SmsThread -> IO P.Doc + phi t = do + -- let SmsThreadId i = threadId + -- let SmsMessage{..} = threadLatest + let unpackName = P.text . T.unpack . unName + let name = unpackName . (^.recipientName) + let recipientNames = map name . N.toList $ t^.threadRecipients + let rs = P.hcat (P.punctuate ", " recipientNames) + let niceBody = P.fillSep . map P.text . words . T.unpack + let msg = t^.threadLatest + let body = niceBody $ msg^.smsBody + time <- niceTime (msg^.smsTime) + pure $ + dirName (msg^.smsDirection) P.<+> rs P. + "on" P.<+> P.text time P.<$> + P.indent 2 body P.<$> + "" + + ok :: () -> IO HumanTable + ok _ = pure . HumanTable $ "" + + devices :: [Device 'Existing] -> IO HumanTable + devices = error "nice devices listing is not implemented" + + niceTime (PushbulletTime t) = + formatTime defaultTimeLocale "%a %d %b %Y @ %H:%M:%S" + <$> (utcToLocalTime <$> getTimeZone t <*> pure t) + + arrow dir = case dir of + OutgoingSms -> ">" + IncomingSms -> "<" + + dirName dir = case dir of + OutgoingSms -> "to" + IncomingSms -> "from" + +-- | An SMS group is a bunch of messages from a given person ordered +-- chronologically such that the timestamps of adjacent messages differ by no +-- more than a fixed amount. +newtype SmsGroup + = SmsGroup + { groupMessages :: NonEmpty SmsMessage + } + +smsGroupDir :: SmsGroup -> SmsDirection +smsGroupDir = (^.smsDirection) . N.head . groupMessages + +-- | Given a list of SMS ordered chronologically and a maximum time difference, +-- group the messages. +groupSms :: NominalDiffTime -> [SmsMessage] -> [SmsGroup] +groupSms d + = concat -- so we have to flatten the groups of groups to get just groups + . fmap (N.toList . fmap SmsGroup . timeframe) + -- within each group, group by time (no more than 10 minutes apart) + -- this gives s *group of groups* + . samedir -- group by direction + where + timeframe :: NonEmpty SmsMessage -> NonEmpty (NonEmpty SmsMessage) + timeframe = N.groupBy1 checkTime + + samedir :: [SmsMessage] -> [NonEmpty SmsMessage] + samedir = N.groupBy ((==) `on` (^.smsDirection)) + + checkTime + (SmsMessage{_smsTime=PushbulletTime u1}) + (SmsMessage{_smsTime=PushbulletTime u2}) = diffUTCTime u2 u1 < d diff --git a/src/tpb/ResponseFormat/JSV.hs b/src/tpb/ResponseFormat/JSV.hs new file mode 100644 --- /dev/null +++ b/src/tpb/ResponseFormat/JSV.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module ResponseFormat.JSV +( formatJsv +) where + +import Format +import Sum + +import Network.Pushbullet.Types + +import Data.Aeson ( ToJSON(..), encode, (.=), object, Value(Number) ) +import qualified Data.ByteString.Lazy as LBS +import Data.Monoid ( (<>) ) +import Lens.Micro +import qualified Data.Text as T +import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) + +newtype JSV = JSV [[JsvCell]] + +instance RenderableFormat JSV where + renderFormat (JSV rows) + = LBS.concat ((<> "\n") . LBS.intercalate "," . fmap encode <$> rows) + +data JsvCell where + JsvCell :: ToJSON a => !a -> JsvCell + +instance ToJSON JsvCell where + toJSON (JsvCell cell) = toJSON cell + +formatJsv + :: Product '[[SmsMessage], [SmsThread], (), [Device 'Existing]] JSV +formatJsv + = JSV . map pure <$> (sms -| threads -| ok -| devices -| Inexhaustive) where + sms :: [SmsMessage] -> [JsvCell] + sms = map (JsvCell . Formatted) + + threads :: [SmsThread] -> [JsvCell] + threads = map (JsvCell . Formatted) + + devices :: [Device 'Existing] -> [JsvCell] + devices = map (JsvCell . Formatted) + + ok :: () -> [JsvCell] + ok _ = pure $ JsvCell @T.Text "ok" + +-- | A simple newtype wrapper so that we can special ToJSON instances for the +-- output. +newtype Formatted a = Formatted a + +instance ToJSON (Formatted PushbulletTime) where + toJSON (Formatted (PushbulletTime t)) = Number d where + d = fromRational (toRational $ utcTimeToPOSIXSeconds t) + +instance ToJSON (Formatted SmsMessage) where + toJSON (Formatted msg) = object + [ "direction" .= id @T.Text ( + case msg^.smsDirection of + IncomingSms -> "incoming" + OutgoingSms -> "outgoing" + ) + , "time" .= Formatted (msg^.smsTime) + , "body" .= (msg^.smsBody) + , "smsId" .= (msg^.smsId) + , "smsType" .= id @T.Text ( + case msg^.smsType of + SMS -> "sms" + MMS -> "mms" + ) + ] + +instance ToJSON (Formatted SmsThread) where + toJSON (Formatted t) = object + [ "id" .= (t^.threadId) + , "recipients" .= (Formatted <$> t^.threadRecipients) + , "latest" .= Formatted (t^.threadLatest) + ] + +instance ToJSON (Formatted SmsThreadRecipient) where + toJSON (Formatted r) = object + [ "name" .= (r^.recipientName) + , "number" .= (r^.recipientNumber) + ] + +instance ToJSON (Formatted (Device 'Existing)) where + toJSON (Formatted d) = object + [ "id" .= (d^.deviceId) + , "active" .= (d^.deviceActive) + , "name" .= (d^.deviceNickname) + , "hasSms" .= (d^.deviceHasSms) + , "manufacturer" .= (d^.deviceManufacturer) + , "model" .= (d^.deviceModel) + ] diff --git a/src/tpb/Sum.hs b/src/tpb/Sum.hs new file mode 100644 --- /dev/null +++ b/src/tpb/Sum.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Sum where + +import Data.Kind +import Data.Proxy +import GHC.Exts ( Constraint ) +import GHC.TypeLits + +type family Demote' (p :: KProxy k) :: k -> Type + +type Demote (a :: k) = Demote' ('KProxy :: KProxy k) + +class Reflect (a :: k) where + reflect :: proxy a -> Demote' ('KProxy :: KProxy k) a + +data SumStatus + = EmptySum + | NonEmptySum + +data Sum :: SumStatus -> [Type] -> Type where + Case :: x -> Sum 'NonEmptySum (x ': xs) + Skip :: Sum 'NonEmptySum xs -> Sum 'NonEmptySum (x ': xs) + +type Sum' = Sum 'NonEmptySum + +data Product :: [Type] -> Type -> Type where + Inexhaustive :: Product '[] a + Match :: (a -> b) -> Product as b -> Product (a ': as) b + +deriving instance Functor (Product ts) + +(-|) :: (a -> b) -> Product as b -> Product (a ': as) b +(-|) = Match +infixr 6 -| + +data Elem :: k -> [k] -> Type where + Here :: Elem a (a ': as) + There :: Elem a as -> Elem a (a' ': as) + +class Inject (t :: Type) (ts :: [Type]) where + inject :: t -> Sum 'NonEmptySum ts + +instance + TypeError ( + 'Text "cannot inject " ':<>: + 'ShowType t ':<>: + 'Text " into empty list." + ) + => Inject t '[] where + inject = error "inject is impossible" + +instance {-# OVERLAPPABLE #-} Inject s ts => Inject s (t ': ts) where + inject t = Skip (inject t) + +instance {-# OVERLAPPING #-} Inject t (t ': ts) where + inject t = Case t + +-- | We can inject into open sums if we can prove that the value we want to +-- inject is in the sum. +inject' :: t -> Elem t ts -> Sum 'NonEmptySum ts +inject' x Here = Case x +inject' x (There e) = Skip (inject' x e) + +-- | Pattern matching. +-- +-- Given an element in a disjoint union of types and a handler for each of +-- those types to convert it to some output type, lookup the corresponding +-- handler in the union and run it. +match' :: Product ts t -> Sum 'NonEmptySum ts -> t +match' (Match _ p) (Skip s) = match' p s +match' (Match f _) (Case x) = f x +-- actually these cases are exhaustive. + +type family ElemC (x :: k) (xs :: [k]) :: Constraint where + ElemC x '[] + = TypeError ( + 'Text "Type " ':<>: + 'ShowType x ':<>: + 'Text " was not found in the list" + ) + ElemC x (x ': xs) = () + ElemC x (y ': xs) = ElemC x xs diff --git a/tpb.cabal b/tpb.cabal --- a/tpb.cabal +++ b/tpb.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: tpb -version: 0.1.0.0 +version: 0.1.1.1 synopsis: Applications for interacting with the Pushbullet API description: This package provides two programs, tpb and pb-notify, for interacting with @@ -24,8 +24,8 @@ source-repository this type: git - location: https://github.com/tsani/tpb/releases/tag/v0.1.0.0 - tag: v0.1.0.0 + location: https://github.com/tsani/tpb/releases/tag/v0.1.1.1 + tag: v0.1.1.1 executable tpb hs-source-dirs: src/tpb @@ -38,6 +38,15 @@ GeneralizedNewtypeDeriving StandaloneDeriving main-is: Main.hs + other-modules: + Command, + Count, + Format, + Request, + ResponseFormat, + ResponseFormat.HumanTable, + ResponseFormat.JSV, + Sum ghc-options: -Wall build-depends: