diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 + + diff --git a/pomohoro.cabal b/pomohoro.cabal new file mode 100644 --- /dev/null +++ b/pomohoro.cabal @@ -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 diff --git a/src/Networking.hs b/src/Networking.hs new file mode 100644 --- /dev/null +++ b/src/Networking.hs @@ -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 diff --git a/src/Notifications.hs b/src/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/Notifications.hs @@ -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)) + })) diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Settings.hs @@ -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") diff --git a/src/Timeclock.hs b/src/Timeclock.hs new file mode 100644 --- /dev/null +++ b/src/Timeclock.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +