diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Sergey Alirzaev + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,124 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State +import Data.List +import Data.List.Split +import Data.Maybe +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.RFC3339 +import Graphics.X11 +import Graphics.X11.XScreenSaver +import System.Console.GetOpt +import System.Directory +import System.Environment +import System.Posix.Files +import System.Process + +pollPeriod = 5000 +sleepThreshold = 1800000 + +data Options = Options + { optEdit :: Int + , optExpect :: Bool + , optDatabaseFile :: FilePath + , optList :: Bool + } deriving Show + +defaultOptions = Options + { optEdit = 0 + , optExpect = False + , optDatabaseFile = "" + , optList = False + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option ['e'] ["edit"] (OptArg ((\a o -> o { optEdit = a }) . read . fromMaybe "10") "N") "edit the last N database entries" + , Option ['x'] ["expect"] (NoArg (\o -> o { optExpect = True })) "print the expected sleepiness time" + , Option ['d'] ["database-file"] (ReqArg (\a o -> o { optDatabaseFile = a}) "FILE") "use FILE as the sleep data base" + , Option ['l'] ["list"] (NoArg (\o -> o { optList = True })) "display the database in the current timezone" + ] + +parseOpts :: [String] -> IO Options +parseOpts argv = + case getOpt Permute options argv of + (o,[],[] ) -> do + home <- getAppUserDataDirectory "posplyu" + return $ foldl (flip id) (defaultOptions { optDatabaseFile = home ++ "/database" }) o + (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) + where header = "Usage: posplyu" + +main :: IO () +main = do + setFileCreationMask $ unionFileModes groupModes otherModes + args <- getArgs + opts <- parseOpts args + when (0 < optEdit opts) $ do + db <- readDB $ optDatabaseFile opts + let (left, edit) = splitAt ((length db) - optEdit opts) db + editLocal <- mapM (mapM utcToLocalZonedTime) edit + edited <- toUser editLocal + writeDB (optDatabaseFile opts) $ left ++ map (map zonedTimeToUTC) edited + when (optList opts) $ do + db <- readDB $ optDatabaseFile opts + times <- mapM (mapM utcToLocalZonedTime) db + putStr $ formatUser times + when (optExpect opts) $ do + db <- readDB $ optDatabaseFile opts + let sleepOffset = 60 * 60 * 15 + time <- utcToLocalZonedTime $ addUTCTime sleepOffset $ last $ head $ filter (not . isNap) $ reverse db + putStrLn $ "Sleepiness expected at " ++ (show time) + when (not $ or [0 < optEdit opts, optExpect opts, optList opts]) $ do + let dirname = intercalate "/" $ init $ split (dropDelims $ whenElt (== '/')) $ optDatabaseFile opts + createDirectoryIfMissing True dirname + d <- openDisplay "" + flip evalStateT False $ forever $ pollIdle d $ optDatabaseFile opts + return () + +ser :: Show a => [[a]] -> String +ser = unlines . map ((intercalate "\t") . (map show)) +des :: Read a => String -> [[a]] +des = map ((map read) . (wordsBy (== '\t'))) . lines + +readDB :: FilePath -> IO [[UTCTime]] +readDB dbfn = do + f <- readFile dbfn + return $ des f + +writeDB :: FilePath -> [[UTCTime]] -> IO () +writeDB dbfn list = writeFile dbfn $ ser list + +formatUser :: [[ZonedTime]] -> String +formatUser = unlines . map ((intercalate "\t") . (map formatTimeRFC3339)) + +toUser :: [[ZonedTime]] -> IO [[ZonedTime]] +toUser list = do + let tmpfn = "tmp" + writeFile tmpfn $ formatUser list + system $ "\"$EDITOR\" " ++ tmpfn + fromUser <- readFile tmpfn + removeLink tmpfn + return $ map ((map (fromJust . parseTimeRFC3339)) . (wordsBy (== '\t'))) $ lines $ fromUser + +pollIdle :: Display -> FilePath -> StateT Bool IO () +pollIdle d dbfn = do + t <- liftIO $ getXIdleTime d + s1 <- get + put $ t > sleepThreshold + s2 <- get + liftIO $ when (s1 /= s2) $ (forkIO $ notify dbfn s2) >> return () + liftIO $ threadDelay $ pollPeriod * 1000 + +isNap :: [UTCTime] -> Bool +isNap [a, b] = diffUTCTime b a < 60 * 60 * 3 + +notify :: FilePath -> Bool -> IO () +notify dbfn status = do + t <- getCurrentTime + let dbline = (show t) ++ if status then "\t" else "\n" + appendFile dbfn dbline + putStr dbline 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/posplyu.cabal b/posplyu.cabal new file mode 100644 --- /dev/null +++ b/posplyu.cabal @@ -0,0 +1,39 @@ +name: posplyu +-- semver +version: 0.1.0 +synopsis: Sleep tracker for X11, using XScreenSaver extension and manual input. +description: posplyu is a sleep tracker for X11, using XScreenSaver extension and manual input, motivated by http://super-memory.com/articles/sleep.htm and designed to facilitate transitioning to the free running sleep regiment while living mostly with a GNU/Linux system handy. The tool allows you to measure and somewhat predict your sleeping cycle. For now it assumes a 24h cycle with one sleep period. +category: Tools +license: MIT +license-file: LICENSE +author: Sergey Alirzaev +maintainer: zl29ah@gmail.com +build-type: Simple +cabal-version: >= 1.10 + +Source-repository head + type: git + location: https://github.com/l29ah/posplyu.git + +Source-repository this + type: git + location: https://github.com/l29ah/posplyu.git + tag: 0.1.0 + + +executable posplyu + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >= 4.11 && < 4.13, + X11 >= 1.9 && < 1.10, + transformers >= 0.5.5.0 && < 0.6, + time >= 1.8.0.2 && < 1.9, + split >= 0.2.3.3 && < 0.3, + unix >= 2.7.2.2 && < 2.8, + process >= 1.6.3.0 && < 1.7, + timerep >= 2.0.0.2 && < 2.1, + directory >= 1.3.1.5 && < 1.4 + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -fno-warn-tabs