pomohoro (empty) → 0.1.2.4
raw patch · 9 files changed
+341/−0 lines, 9 filesdep +basedep +configuratordep +dbussetup-changed
Dependencies added: base, configurator, dbus, directory, fdo-notify, hdaemonize, hspec, network, optparse-applicative, pomohoro, protolude, text, time
Files
- LICENSE +13/−0
- Setup.hs +2/−0
- app/Main.hs +135/−0
- pomohoro.cabal +60/−0
- src/Networking.hs +50/−0
- src/Notifications.hs +15/−0
- src/Settings.hs +25/−0
- src/Timeclock.hs +39/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) kqr 2016++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,135 @@+module Main where+import Protolude++import Options.Applicative hiding ((<>))+import System.Posix.Daemonize+import Data.Text as Text+import Data.Time+import System.Timeout++import Settings+import Timeclock+import Notifications+import Networking+++data Command+ = Start { _account :: Text, _comment :: Text }+ | Status+ | Interrupt+ | RemindMe { _minutes :: Int, _message :: Text }+ deriving Show+++args :: Parser Command+args =+ subparser (mconcat [+ command "start" (info (+ Start+ <$> textArgument+ <*> textRestArguments+ ) (progDesc (mconcat [+ "Start a new work session for the specified timeclock",+ " account (or default if none specified)"+ ]))),+ command "status" (info (+ pure Status+ ) (progDesc+ "How long has the current session been going on for?"+ )),+ command "int" (info (+ pure Interrupt+ ) (progDesc+ ("Interrupt the ongoing work session")+ )),+ command "rem" (info (+ RemindMe+ <$> argument auto (value 5)+ <*> textRestArguments + ) (progDesc (mconcat [+ "Wait for the specified number of minutes and then send",+ " a notification. Good for keeping time on breaks"+ ])))])+++textArgument :: Parser Text+textArgument =+ fmap pack (strArgument (value ""))+++textRestArguments :: Parser Text+textRestArguments =+ fmap (unwords . fmap pack) (many (strArgument mempty))+++main :: IO ()+main = do+ settings <- loadSettings+ parsed <- execParser (info (helper <*> args) (progDesc (mconcat+ [ "A small pomodoro timer based on CLI usage and FreeDesktop.org"+ , " notifications. Optionally writes pomodoro sessions to a"+ , " timeclock file for budgeting and reporting."])))+ case parsed of+ Start account comment -> startWork settings account comment+ Status -> queryStatus settings+ Interrupt -> interrupt settings+ RemindMe minutes message -> remindMe minutes message+++startWork :: Settings -> Text -> Text -> IO ()+startWork settings account comment = do+ sendUDP settings "status"+ response <- timeout 1000000 (recvUDP settings)+ case response of+ Just _ ->+ putStrLn ("Another session already active. Exiting." :: Text)+ Nothing ->+ daemonize $ do+ startTime <- getZonedTime+ appendFile (_timeclockPath settings) (clockin+ startTime+ (if Text.null account then _defaultAccount settings else account)+ comment)+ void (timeout (usecFromMinutes (_sessionLength settings))+ (handleSession settings startTime))+ stopTime <- getZonedTime+ appendFile (_timeclockPath settings) (clockout stopTime)+ notifySend "Work is over!"+ ("You have worked for " <> show (minuteDiff stopTime startTime) <> " minutes. Well done!")+++handleSession :: Settings -> ZonedTime -> IO ()+handleSession settings startTime = do+ request <- recvUDP settings+ case request of+ "interrupt" -> pure ()+ "status" -> do+ nowTime <- getZonedTime+ sendUDP settings (show (minuteDiff nowTime startTime))+ handleSession settings startTime+ _ -> handleSession settings startTime+++queryStatus :: Settings -> IO ()+queryStatus settings = do+ sendUDP settings "status"+ response <- timeout 1000000 (recvUDP settings)+ case response of+ Just mins -> + putStrLn ("Current work session: " <> mins <> "/" <> show (_sessionLength settings) <> " minute(s)")+ Nothing ->+ putStrLn ("No work session active." :: Text)+ ++interrupt :: Settings -> IO ()+interrupt settings =+ sendUDP settings "interrupt"+++remindMe :: Int -> Text -> IO ()+remindMe minutes message =+ daemonize $ do+ threadDelay (usecFromMinutes minutes)+ notifySend "Time's up!" message+ +
+ pomohoro.cabal view
@@ -0,0 +1,60 @@+name: pomohoro+version: 0.1.2.4+synopsis: Initial project template from stack+description: Please see README.md+homepage: https://github.com/kqr/pomohoro#readme+license: ISC+license-file: LICENSE+author: kqr+maintainer: k@rdw.se+copyright: (c) 2016 kqr+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Settings, Networking, Notifications, Timeclock+ build-depends: base >= 4.7 && < 5+ , protolude >= 0.1.6 && < 0.2+ , directory+ , network+ , dbus+ , fdo-notify+ , time+ , text+ , configurator+ default-language: Haskell2010+ default-extensions: OverloadedStrings, NoImplicitPrelude, LambdaCase++executable pomohoro-exe+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , protolude >= 0.1.6 && < 0.2+ , pomohoro+ , text+ , optparse-applicative+ , hdaemonize+ , time+ default-language: Haskell2010+ default-extensions: OverloadedStrings, NoImplicitPrelude, LambdaCase++test-suite pomohoro-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , pomohoro+ , protolude >= 0.1.6 && < 0.2+ , hspec+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ default-extensions: OverloadedStrings, NoImplicitPrelude, LambdaCase++source-repository head+ type: git+ location: https://github.com/kqr/pomohoro
+ src/Networking.hs view
@@ -0,0 +1,50 @@+module Networking where+import Protolude++import qualified Network.Socket as Socket hiding (send, recv)+import qualified Network.Socket.ByteString as Socket++import Settings+++data LocalSocket = LocalSocket+ { _socket :: Socket.Socket+ , _localhost :: Socket.SockAddr+ }++sendUDP :: Settings -> Text -> IO ()+sendUDP settings message =+ bracket (localSocket settings >>= connect) close (send message)++recvUDP :: Settings -> IO Text+recvUDP settings =+ bracket (localSocket settings >>= listen) close recv+ +localSocket :: Settings -> IO LocalSocket+localSocket settings = do+ socket <- Socket.socket Socket.AF_INET Socket.Datagram Socket.defaultProtocol+ Socket.setSocketOption socket Socket.ReusePort 1+ address <- Socket.inet_addr "127.0.0.1"+ return (LocalSocket socket (Socket.SockAddrInet (_udpPort settings) address))++connect :: LocalSocket -> IO LocalSocket+connect socket = do+ Socket.connect (_socket socket) (_localhost socket)+ return socket++listen :: LocalSocket -> IO LocalSocket+listen socket = do+ Socket.bind (_socket socket) (_localhost socket)+ return socket++send :: Text -> LocalSocket -> IO ()+send message socket =+ void (Socket.send (_socket socket) (encodeUtf8 message))++recv :: LocalSocket -> IO Text+recv socket = do+ fmap decodeUtf8 (Socket.recv (_socket socket) 128)++close :: LocalSocket -> IO ()+close =+ Socket.close . _socket
+ src/Notifications.hs view
@@ -0,0 +1,15 @@+module Notifications where+import Protolude++import qualified Data.Text as Text+import qualified DBus.Client as DBus+import qualified DBus.Notify as DBus+++notifySend :: Text -> Text -> IO ()+notifySend title body = do+ client <- DBus.connectSession+ void (DBus.notify client (DBus.blankNote {+ DBus.summary = Text.unpack title,+ DBus.body = Just (DBus.Text (Text.unpack body))+ }))
+ src/Settings.hs view
@@ -0,0 +1,25 @@+module Settings where+import Protolude++import Data.Configurator+import System.Directory+import qualified Network.Socket as Socket (PortNumber)+++data Settings = Settings+ { _sessionLength :: Int+ , _defaultAccount :: Text+ , _timeclockPath :: FilePath+ , _udpPort :: Socket.PortNumber+ }+++loadSettings :: IO Settings+loadSettings = do+ home <- getHomeDirectory+ config <- load [Optional (home <> "/.pomohoro.cfg")]+ Settings+ <$> lookupDefault 25 config "session-length"+ <*> lookupDefault "work" config "default-account"+ <*> lookupDefault (home <> "/.pomohoro.timeclock") config "timeclock-file"+ <*> fmap fromInteger (lookupDefault 8712 config "port")
+ src/Timeclock.hs view
@@ -0,0 +1,39 @@+module Timeclock where+import Protolude++import Data.Time+import qualified Data.Text as Text+++clockin :: ZonedTime -> Text -> Text -> Text+clockin time account comment =+ mconcat+ [ "i "+ , toTimestamp time+ , " "+ , account+ , if Text.null comment then "" else " " <> comment+ , "\n"+ ]++clockout :: ZonedTime -> Text+clockout time =+ "o " <> toTimestamp time <> "\n"+ ++toTimestamp :: ZonedTime -> Text+toTimestamp time =+ Text.pack (formatTime defaultTimeLocale "%F %T" time)+++minuteDiff :: ZonedTime -> ZonedTime -> Int+minuteDiff a b =+ let+ seconds = diffUTCTime (zonedTimeToUTC a) (zonedTimeToUTC b)+ in+ round (seconds / 60)+++usecFromMinutes :: Int -> Int+usecFromMinutes minutes =+ 60 * 1000000 * minutes
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+