tpb 0.1.1.1 → 0.4.0.0

raw patch · 7 files changed

+471/−29 lines, 7 filesdep +asyncdep +containersdep +servant-serverdep ~aesondep ~pushbullet-typesdep ~servant

Dependencies added: async, containers, servant-server, wai, warp

Dependency ranges changed: aeson, pushbullet-types, servant, servant-client, servant-pushbullet-client

Files

• ChangeLog.md +21/−0
• src/pb-notify/Main.hs +346/−14
• src/tpb/Command.hs +20/−0
• src/tpb/Main.hs +41/−1
• src/tpb/ResponseFormat/HumanTable.hs +5/−2
• src/tpb/ResponseFormat/JSV.hs +9/−2
• tpb.cabal +29/−10

@@ -1,5 +1,26 @@ # Revision history for tpb +## 0.4.0.0  -- 2017-08-01++* Bump dependency on servant-pushbullet-client and pushbullet-types to 0.4.+  This version includes important fixes for parsing pushes sent by channels and+  link pushes without bodies.+* pb-notify: Improve formatting of notification text for link pushes.++## 0.3.0.0  -- 2017-07-29++* implement clipboard integration in pb-notify via a built-in HTTP server.+* add script pbclip for interacting with the pushbullet clipboard via+  pb-notify.+* tpb: add `devices create` and `devices remove` commands+* tpb: support pushbullet-types 0.3+* bump dependency on servant-pushbullet-client to 0.3++## 0.2.0.0  -- 2017-04-30++* Partially fix connectivity bugs in pb-notify.+* Mirror pushes in pb-notify.+ ## 0.1.1.1  -- 2017-02-20  * add `app_name` libnotify hint in pb-notify, so applications processing

@@ -1,49 +1,381 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}  module Main where +import Network.Pushbullet.Api+import Network.Pushbullet.Client+import Network.Pushbullet.Misc import Network.Pushbullet.Types +import Control.Concurrent ( threadDelay )+import Control.Concurrent.Async+import Control.Concurrent.Chan+import Control.Concurrent.MVar import Control.Monad ( forever, forM_ )+import Control.Monad.IO.Class import Data.Aeson ( eitherDecode' )+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LBS+import Data.IORef+import Data.List ( sortBy )+import qualified Data.Map.Strict as M+import Data.Maybe ( listToMaybe ) import Data.Monoid ( (<>) )+import Data.Ord ( comparing ) import qualified Data.Text as T import Data.Time.Format ( defaultTimeLocale, formatTime ) import Data.Time.LocalTime ( getTimeZone, utcToLocalTime ) import qualified Libnotify as Noti+import Network.HTTP.Client ( newManager )+import Network.HTTP.Client.TLS ( tlsManagerSettings )+import Network.Wai ( Application )+import Network.Wai.Handler.Warp ( run ) import qualified Network.WebSockets as WS+import Servant+import Servant.Client+import System.IO ( hPutStrLn, stderr ) import System.Environment ( getEnv )+import System.Exit ( exitFailure )+import System.Timeout ( timeout )+import Text.Read ( readMaybe ) import Wuss ( runSecureClient )  appName :: String appName = "pb-notify" +timeoutDelay :: Int+timeoutDelay = 5000000 -- five seconds++-- | A map from text (identifiers in the PushBullet API) to libnotify+-- notification.+newtype NotifyMap+  = NotifyMap+    { unNotifyMap :: M.Map T.Text Noti.Notification }++newtype NotifyMapVar+  = NotifyMapVar+    { unNotifyMapVar :: MVar NotifyMap }++data ClipDataVar+  = ClipDataVar+    { clipDataLock :: MVar Bool+      -- ^ The lock is used to guard access to the IORef and to indicate+      -- whether the IORef contains meaningful data+    , clipData :: IORef T.Text+    }++newClipDataVar :: IO ClipDataVar+newClipDataVar = do+  v <- newMVar False+  r <- newIORef ""+  pure ClipDataVar { clipDataLock = v, clipData = r }++-- | Reads the clip data; if it's empty then Nothing is returned.+readClipVar :: ClipDataVar -> IO (Maybe T.Text)+readClipVar (ClipDataVar lock r) = withMVar lock $ \case+  True -> Just <$> readIORef r+  False -> pure Nothing++newtype HttpChan+  = HttpChan+    { unHttpChan :: Chan HttpReq }++-- | The types of things we can ask the HTTP client thread to do.+data HttpReq+  -- | Send the given text to the stream.+  = SendClip T.Text+  -- | Check for new pushes and convert to notifications.+  | CheckPushes++newHttpChan :: IO HttpChan+newHttpChan = HttpChan <$> newChan++checkPushes :: HttpChan -> IO ()+checkPushes (HttpChan c) = writeChan c CheckPushes++sendClip :: HttpChan -> T.Text -> IO ()+sendClip (HttpChan c) t = writeChan c (SendClip t)++getHttpChan :: HttpChan -> IO HttpReq+getHttpChan (HttpChan c) = readChan c++withNotifyMap :: NotifyMapVar -> (NotifyMap -> IO (NotifyMap, a)) -> IO a+withNotifyMap (NotifyMapVar v) m = do modifyMVar v m++type PbNotifyApi =+  "clip" :> (+    Get '[PlainText] T.Text+  :<|>+    ReqBody '[PlainText] T.Text :> PostAccepted '[PlainText] NoContent+  )++pbNotifyApi :: Proxy PbNotifyApi+pbNotifyApi = Proxy++addNoti+  :: Noti.Mod Noti.Notification+  -> T.Text+  -> NotifyMap+  -> IO NotifyMap+addNoti n t (NotifyMap m)= do+  noti <- Noti.display n+  pure $ NotifyMap (M.insert t noti m)++deleteNoti :: T.Text -> NotifyMap -> IO NotifyMap+deleteNoti t (NotifyMap m) = do+  case M.lookup t m of+    Nothing -> pure (NotifyMap m)+    Just n -> do+      Noti.close n+      pure $ NotifyMap (M.delete t m)++webapp :: ClipDataVar -> HttpChan -> Application+webapp clipvar httpChan = serve pbNotifyApi (server clipvar httpChan)++server :: ClipDataVar -> HttpChan -> Server PbNotifyApi+server (ClipDataVar lock var) httpChan = getClip :<|> postClip where+  getClip :: Handler T.Text+  getClip = do+    liftIO (takeMVar lock) >>= \case+      False -> do+        liftIO (putMVar lock False)+        throwError err404 { errBody = "no clipboard data" }+      True -> do+        t <- liftIO (readIORef var)+        liftIO (putMVar lock True)+        pure t++  postClip :: T.Text -> Handler NoContent+  postClip t = do+    liftIO $ modifyMVar_ lock $ \b -> do+      -- writeIORef var t+      sendClip httpChan t+      -- pure True+      pure b+    pure NoContent++streamUrl :: String+streamUrl = "stream.pushbullet.com"++apiUrl :: String+apiUrl = "api.pushbullet.com"++die :: String -> IO a+die s = hPutStrLn stderr s *> exitFailure+ main :: IO () main = do   token <- getEnv "PUSHBULLET_KEY"-  runSecureClient "stream.pushbullet.com" 443 ("/websocket/" <> token) ws+  deviceIdS <- getEnv "PBNOTIFY_DEVICE"+  listenPort <- do+    p <- getEnv "PBNOTIFY_PORT"+    maybe (die "PBNOTIFY_PORT must be an integer") pure $ readMaybe p -ws :: WS.ClientApp ()-ws connection = forever $ do-  raw <- WS.receiveData connection+  let key = PushbulletKey (T.pack token)++  -- strategy for making clipboard ephemerals+  makeClipEphemeral <- do+    uid <- _userId <$> getUser key+    let did = DeviceId (T.pack deviceIdS)++    pure $ \x -> PushEphemeral (Just allEphemeralTargets) Clipboard+      { _ephClipBody = x+      , _ephClipSourceUser = uid+      , _ephClipSourceDevice = did+      }++  httpChan <- newHttpChan+  clipvar <- newClipDataVar++  notiVar <- NotifyMapVar <$> newMVar (NotifyMap M.empty)++  -- run the asynchronous http thread+  -- This thread gets poked over the chan whenever a Tickle event is received+  -- over the websocket. This causes the list of pushes to get updated, and+  -- transformed into notifications.+  -- HTTP requests sent by this thread are retried indefinitely until they+  -- succeed.+  _ <- async (http notiVar httpChan makeClipEphemeral key)++  -- run the http server thread+  -- This thread runs a dead simple API to access the pushbullet clipboard+  -- POST requests to /clip will set the internal variable holding the PB+  -- clipboard and send the clipboard ephemeral over the websocket so other+  -- devices will have their clipboards set.+  -- GET requests will retrieve the value of the internal variable holding the+  -- PB clipboard. If no clipboard data has been received yet via an ephemeral+  -- on the websocket, this produces a 404.+  -- Note that the local clipboard is unaffected by these actions!+  _ <- async (run listenPort (webapp clipvar httpChan))++  let wsclient = runSecureClient streamUrl 443 ("/websocket/" <> token)++  forever $ do+    a <- async $ do+      wsclient (ws httpChan clipvar)++    waitCatch a >>= \case+      Left err -> print err+      Right () -> pure ()++    threadDelay timeoutDelay+    putStrLn "restarting websocket connection..."++getUser :: PushbulletKey -> IO User+getUser key = do+  let auth = pushbulletAuth key++  manager <- newManager tlsManagerSettings+  let url = BaseUrl Https "api.pushbullet.com" 443 ""+  let env = ClientEnv manager url+  let runClient = {- debug -} retryingDelay timeoutDelay . flip runClientM env++  runClient (getMe auth)++http+  :: NotifyMapVar+  -> HttpChan+  -> (T.Text -> Ephemeral)+  -> PushbulletKey+  -> IO ()+http notiVar httpChan mke key = do+  let auth = pushbulletAuth key++  manager <- newManager tlsManagerSettings+  let url = BaseUrl Https "api.pushbullet.com" 443 ""+  let env = ClientEnv manager url+  let runClient = {- debug -} retryingDelay timeoutDelay . flip runClientM env++  -- create a variable holding the last push time we've processed.+  -- Initially, we set it to contain the time of the most recent push, if one+  -- exists; else, we set it to UTC zero.+  lastPushTimeVar <- do+    -- get the most recent push, just for its timestamp+    (Page (ExistingPushes pushes) _) <-+      runClient (getPushes auth Nothing (Just True) (Just 1) Nothing)+    newIORef (maybe minPushbulletTime pushModified (listToMaybe pushes))++  forever $ do+    -- block until a new request+    r <- getHttpChan httpChan++    case r of+      SendClip t -> runClient (createEphemeral auth (mke t)) *> pure ()++      CheckPushes -> do+        lastPushTime <- readIORef lastPushTimeVar+        let f = fmap (fmap unExistingPushes)+        getPushes' <- pure $ \time active n ->+          f . runClient . getPushes auth time active n+        let getPushes'' = getPushes' (Just lastPushTime) (Just True) Nothing+        start <- getPushes'' Nothing+        let next = getPushes'' . Just+        pushes <- sortBy (comparing pushModified)+          <$> getPaginatedLimit All start next++        withNotifyMap notiVar $ \notiMap -> do+          v <- newIORef notiMap++          forM_ pushes $ \Push{..} -> do+            let (PushId pid) = pushId+            writeIORef lastPushTimeVar pushModified++            m <- readIORef v+            let note = preparePushNotification pushData+            let g = if pushActive then addNoti note else deleteNoti+            writeIORef v =<< g pid m++          (,) <$> readIORef v <*> pure ()++preparePushNotification :: PushData 'Existing -> Noti.Mod Noti.Notification+preparePushNotification pushData = mconcat $ case pushData of+  NotePush{..} ->+    [ Noti.summary ("Note: " ++ maybe "[untitled]" T.unpack pushTitle)+    , Noti.body (T.unpack pushBody)+    , Noti.appName appName+    ]+  LinkPush{..} ->+    [ Noti.summary ("Link: " ++ maybe "[untitled]" T.unpack pushTitle)+    , Noti.body $ T.unpack $ formatLinkPush pushUrl pushLinkBody+    , Noti.appName appName+    ]+  FilePush{..} ->+    [ Noti.summary ("File: " ++ T.unpack pushFileName)+    , Noti.body (T.unpack (unUrl pushFileUrl))+    , Noti.appName appName+    ]+  where+    formatLinkPush (Url url) mbody = case mbody of+      Nothing -> url+      Just body -> body <> "\n" <> url++ws+  :: HttpChan+  -- ^ The channel used to wake up the HTTP thread to check for new pushes+  -> ClipDataVar+  -- ^ The variable to store our clipboard buffer in+  -> WS.ClientApp ()+ws httpChan clipvar connection = recv where+  recv :: IO ()+  recv = do+    -- this timeout is set to 35s. Pushbullet is supposed to send us a+    -- heartbeat every 30s.+    rawm <- timeout 35000000 (WS.receiveData connection)+    case rawm of+      Nothing -> putStrLn "websocket receive timed out"+      Just raw -> handle httpChan clipvar raw *> recv++handle :: HttpChan -> ClipDataVar -> C8.ByteString -> IO ()+handle httpChan (ClipDataVar lock clip) raw = do   let message = eitherDecode' (LBS.fromStrict raw)   case message of-    Left _ -> pure ()-    Right x -> case x of-      SmsChanged{..} ->-        forM_ _ephNotifications $ \Notification{..} -> do-          t <- niceTime _notifTime-          Noti.display_ $ mconcat-            [ Noti.summary (T.unpack $ "SMS from " <> _notifTitle)-            , Noti.body (T.unpack (_notifBody <> "\n") <> t)-            , Noti.appName appName-            ]+    Right x -> case x :: Ephemeral of+      Tickle t -> case t of+        PushType -> checkPushes httpChan+        OtherType t' -> putStrLn $ "got other tickle: " ++ T.unpack t'+      PushEphemeral _ p -> case p of+        SmsChanged{..} ->+          forM_ _ephNotifications $ \Notification{..} -> do+            t <- niceTime _notifTime+            Noti.display_ $ mconcat+              [ Noti.summary (T.unpack $ "SMS from " <> _notifTitle)+              , Noti.body (T.unpack (_notifBody <> "\n") <> t)+              , Noti.appName appName+              ]+        Clipboard{..} ->+          modifyMVar_ lock $ const $ do+            writeIORef clip _ephClipBody+            pure True+        _ -> pure ()       _ -> pure ()+    Left _ -> pure ()  niceTime :: PushbulletTime -> IO String niceTime (PushbulletTime t) =   formatTime defaultTimeLocale "%a %d %b %Y @ %H:%M:%S"     <$> (utcToLocalTime <$> getTimeZone t <*> pure t) +-- | Retries an IO action that can fail with Either indefinitely.+retrying :: IO (Either e a) -> IO a+retrying m = either (const (retrying m)) pure =<< m++-- | Retries an IO action that can fail with Either by delaying a given number+-- of microseconds before retrying, indefinitely.+retryingDelay :: Show e => Int -> IO (Either e a) -> IO a+retryingDelay n m = either loop pure =<< m where+  loop e = do+    putStrLn $ "retrying... " ++ show e+    threadDelay n+    retryingDelay n m++debug :: Show e => IO (Either e a) -> IO a+debug m = do+  a <- m+  case a of+    Left err -> print err *> exitFailure+    Right x -> pure x

@@ -15,14 +15,28 @@ 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++  -- | Create a new device.+  MakeDevice :: Device 'New -> (Device 'Existing -> a) -> CommandF a++  -- | Remove an existing device.+  RemoveDevice :: DeviceId -> a -> CommandF a++  -- | Get the current user info.   Me :: (User -> a) -> CommandF a++  -- | Raise an exception.   ThrowCommandError :: T.Text -> CommandF a+   deriving Functor  -- | The Command monad.@@ -31,6 +45,9 @@ listSms :: DeviceId -> SmsThreadId -> Command [SmsMessage] listSms d t = liftF (ListSms d t id) +removeDevice :: DeviceId -> Command ()+removeDevice d = liftF (RemoveDevice d ())+ listThreads :: DeviceId -> Command [SmsThread] listThreads d = liftF (ListThreads d id) @@ -39,6 +56,9 @@  listDevices :: Count -> Command [Device 'Existing] listDevices c = liftF (ListDevices c id)++makeDevice :: Device 'New -> Command (Device 'Existing)+makeDevice d = liftF (MakeDevice d id)  me :: Command User me = liftF (Me id)

@@ -18,10 +18,12 @@  import Control.Monad.Except import Control.Monad.Free ( iterM )+import Data.Bool ( bool ) import Data.ByteString ( readFile ) import qualified Data.ByteString as BS import Data.List.NonEmpty ( toList ) import qualified Data.List.NonEmpty as N+import Data.Maybe ( fromMaybe ) import Data.Monoid ( (<>) ) import qualified Data.Text as T import Data.Text.Encoding ( decodeUtf8 )@@ -124,6 +126,40 @@             )             <*> optional (option (Limit <$> auto) (long "limit"))         )+        <>+        command "create" (+          fullDescInfo $+            pure (\name sms manuf model icon -> do+              let sms' = maybe NoSms (bool NoSms HasSms) sms+              pure $ inject <$> makeDevice Device+                { _deviceId = ()+                , _deviceActive = ()+                , _deviceCreated = ()+                , _deviceModified = ()+                , _deviceIcon = fromMaybe deviceIconSystem icon+                , _deviceNickname = Just name+                , _deviceGeneratedNickname = ()+                , _deviceManufacturer = manuf+                , _deviceModel = model+                , _deviceAppVersion = Nothing+                , _deviceFingerprint = ()+                , _deviceKeyFingerprint = ()+                , _deviceHasSms = sms'+                , _devicePushToken = Nothing+                }+            )+            <*> option (Nickname <$> raw) (long "name")+            <*> optional (switch (long "has-sms"))+            <*> optional (option (Manufacturer <$> raw) (long "manufacturer"))+            <*> optional (option (Model <$> raw) (long "model"))+            <*> optional (option (DeviceIcon <$> raw) (long "icon"))+        )+        <>+        command "delete" (+          fullDescInfo $+            pure (\did -> pure $ inject <$> removeDevice did)+            <*> option (DeviceId <$> raw) (long "by-id")+        )       )     )   )@@ -169,7 +205,7 @@         =<< lift (getSmsThreads auth (ThreadsOf d))      SendSms u d n m k ->-      lift (createEphemeral auth (Sms u d n m)) *> k+      lift (createEphemeral auth (PushEphemeral Nothing (Sms u d n m))) *> k      ListDevices count k -> do       let f = fmap (fmap unExistingDevices)@@ -177,6 +213,10 @@       start <- getDevices' Nothing Nothing       let next = getDevices' Nothing . Just       k =<< getPaginatedLimit count start next++    MakeDevice d k -> k =<< lift (createDevice auth d)++    RemoveDevice did k -> lift (deleteDevice auth did) *> k      Me k -> k =<< lift (getMe auth) 

@@ -29,10 +29,10 @@  formatHumanTable   :: Product-    '[[SmsMessage], [SmsThread], (), [Device 'Existing]]+    '[[SmsMessage], [SmsThread], (), [Device 'Existing], Device 'Existing]     (IO HumanTable) formatHumanTable-  = smsMessage -| smsThreads -| ok -| devices -| Inexhaustive where+  = smsMessage -| smsThreads -| ok -| devices -| device1 -| Inexhaustive where      chronologicalBy l = sortBy (comparing l) @@ -89,6 +89,9 @@      devices :: [Device 'Existing] -> IO HumanTable     devices = error "nice devices listing is not implemented"++    device1 :: Device 'Existing -> IO HumanTable+    device1 = error "nice device listing is not implemented"      niceTime (PushbulletTime t) =       formatTime defaultTimeLocale "%a %d %b %Y @ %H:%M:%S"

@@ -34,9 +34,16 @@   toJSON (JsvCell cell) = toJSON cell  formatJsv-  :: Product '[[SmsMessage], [SmsThread], (), [Device 'Existing]] JSV+  :: Product+    '[[SmsMessage], [SmsThread], (), [Device 'Existing], Device 'Existing]+    JSV formatJsv-  = JSV . map pure <$> (sms -| threads -| ok -| devices -| Inexhaustive) where+  = JSV+  . map pure+  <$> (sms -| threads -| ok -| devices -| device -| Inexhaustive) where+    device :: Device 'Existing -> [JsvCell]+    device = pure . JsvCell . Formatted+     sms :: [SmsMessage] -> [JsvCell]     sms = map (JsvCell . Formatted) 

@@ -2,12 +2,20 @@ -- see http://haskell.org/cabal/users-guide/  name:                tpb-version:             0.1.1.1+version:             0.4.0.0 synopsis:            Applications for interacting with the Pushbullet API description:   This package provides two programs, tpb and pb-notify, for interacting with   the Pushbullet API. The former is primarily used for sending SMS whereas the   latter is used for showing desktop notifications when SMS are received.+  tpb additionally supports a number of additional management commands for+  creating and deleting resources inside PushBullet.+  pb-notify is responsible for integration with PushBullet's Universal+  Copy/Paste feature. It maintains an internal buffer that is kept in sync with+  PushBullet's clipboard. This buffer can be accessed via pb-notify's built-in+  HTTP server. A POST request to the /clip endpoint of the server will in turn+  send the necessary request to PushBullet to set the clipboard of all+  connected devices. license:             GPL-3 license-file:        LICENSE author:              Jacob Thomas Errington@@ -24,8 +32,8 @@  source-repository this   type: git-  location: https://github.com/tsani/tpb/releases/tag/v0.1.1.1-  tag: v0.1.1.1+  location: https://github.com/tsani/tpb/releases/tag/v0.4.0.0+  tag: v0.4.0.0  executable tpb   hs-source-dirs: src/tpb@@ -50,7 +58,10 @@   ghc-options:     -Wall   build-depends:-    aeson >=1.0 && <1.1,+    pushbullet-types >=0.4 && <0.5,+    servant-pushbullet-client >=0.4 && <0.5,++    aeson >=1.0 && <1.2,     ansi-wl-pprint >=0.6 && <0.7,     base >=4.9 && <4.10,     boxes >=0.1 && <0.2,@@ -63,12 +74,10 @@     microlens >=0.4 && <0.5,     mtl >=2.2 && <2.3,     optparse-applicative >=0.13 && <0.14,-    pushbullet-types >=0.1 && <0.2,     text >=1.2 && <1.3,     time >=1.6 && <1.7,-    servant >=0.9 && <0.10,-    servant-client >=0.9 && <0.10,-    servant-pushbullet-client >=0.1 && <0.2+    servant >=0.9 && <0.12,+    servant-client >=0.9 && <0.12  executable pb-notify   hs-source-dirs: src/pb-notify@@ -77,12 +86,22 @@   ghc-options:     -Wall   build-depends:-    aeson >=1.0 && <1.1,+    pushbullet-types >=0.4 && <0.5,+    servant-pushbullet-client >=0.4 && <0.5,++    aeson >=1.0 && <1.2,+    async >=2.1 && <2.2,     base >=4.9 && <4.10,     bytestring >=0.10 && <0.11,+    containers >=0.5 && <0.6,+    http-client >=0.5 && <0.6,+    http-client-tls >=0.3 && <0.4,     libnotify >=0.2 && <0.3,-    pushbullet-types >=0.1 && <0.2,+    servant-client >=0.9 && <0.12,+    servant-server >=0.9 && <0.12,     text >=1.2 && <1.3,     time >=1.6 && <1.7,     websockets >=0.10 && <0.11,+    wai >=3.2 && <3.3,+    warp >=3.2 && <3.3,     wuss >=1.1 && <1.2