packages feed

tpb 0.1.0.0 → 0.1.1.1

raw patch · 11 files changed

+491/−8 lines, 11 files

Files

ChangeLog.md view
@@ -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
src/pb-notify/Main.hs view
@@ -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
+ src/tpb/Command.hs view
@@ -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
+ src/tpb/Count.hs view
+ src/tpb/Format.hs view
@@ -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 }
+ src/tpb/Request.hs view
@@ -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
+ src/tpb/ResponseFormat.hs view
@@ -0,0 +1,7 @@+module ResponseFormat+( module ResponseFormat.HumanTable+, module ResponseFormat.JSV+) where++import ResponseFormat.HumanTable+import ResponseFormat.JSV
+ src/tpb/ResponseFormat/HumanTable.hs view
@@ -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
+ src/tpb/ResponseFormat/JSV.hs view
@@ -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)+    ]
+ src/tpb/Sum.hs view
@@ -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
tpb.cabal view
@@ -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: