Implement isToday predicate
Use the Data.Time package to implement the isToday predicate.
This commit is contained in:
parent
561cb619a1
commit
ef5eda4015
2 changed files with 17 additions and 23 deletions
|
@ -1,16 +1,13 @@
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
module Main
|
module Main (main) where
|
||||||
( main
|
|
||||||
)where
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Dependencies
|
-- Dependencies
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
import qualified Data.Maybe as Maybe
|
import qualified Data.Maybe as Maybe
|
||||||
import Data.Time.Calendar as Calendar
|
import qualified Data.Time.Clock as Clock
|
||||||
|
import qualified Data.Time.Calendar as Calendar
|
||||||
-- I'm running this as a systemd timer that runs once per minute.
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Types
|
-- Types
|
||||||
|
@ -30,7 +27,6 @@ data EtcHostEntry = EtcHostEntry { ip :: IPAddress
|
||||||
, domains :: [Domain]
|
, domains :: [Domain]
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
|
|
||||||
data TimeRange = TimeRange { beg :: (Hour, Minute)
|
data TimeRange = TimeRange { beg :: (Hour, Minute)
|
||||||
, end :: (Hour, Minute)
|
, end :: (Hour, Minute)
|
||||||
}
|
}
|
||||||
|
@ -47,17 +43,13 @@ data Rule = Rule { urls :: [URL]
|
||||||
-- Functions
|
-- Functions
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- create the current /etc/hosts file
|
isToday :: Clock.UTCTime -> Calendar.DayOfWeek -> Bool
|
||||||
-- schedule the script to run again at the next relevant time
|
isToday date day = Calendar.dayOfWeek (Clock.utctDay date) == day
|
||||||
|
|
||||||
isToday :: Calendar.DayOfWeek -> Bool
|
isAllowed :: Clock.UTCTime -> [Allowance] -> Bool
|
||||||
isToday Monday = True
|
isAllowed _ [] = False
|
||||||
isToday _ = False
|
isAllowed date xs = do
|
||||||
|
let rules = filter (isToday date . day) xs
|
||||||
isAllowed :: [Allowance] -> Bool
|
|
||||||
isAllowed [] = False
|
|
||||||
isAllowed xs = do
|
|
||||||
let rules = filter (isToday . day) xs
|
|
||||||
case rules of
|
case rules of
|
||||||
[day] -> True
|
[day] -> True
|
||||||
[] -> False
|
[] -> False
|
||||||
|
@ -68,9 +60,9 @@ serializeEntry :: EtcHostEntry -> String
|
||||||
serializeEntry EtcHostEntry{ip, domains} =
|
serializeEntry EtcHostEntry{ip, domains} =
|
||||||
(getIPAddress ip) ++ "\t" ++ (unwords $ fmap getDomain domains)
|
(getIPAddress ip) ++ "\t" ++ (unwords $ fmap getDomain domains)
|
||||||
|
|
||||||
toEtcHostEntry :: Rule -> Maybe EtcHostEntry
|
toEtcHostEntry :: Clock.UTCTime -> Rule -> Maybe EtcHostEntry
|
||||||
toEtcHostEntry Rule{urls, allowed} =
|
toEtcHostEntry date Rule{urls, allowed} =
|
||||||
if isAllowed allowed then
|
if isAllowed date allowed then
|
||||||
Nothing
|
Nothing
|
||||||
else
|
else
|
||||||
Just $ EtcHostEntry { ip = IPAddress "127.0.0.1"
|
Just $ EtcHostEntry { ip = IPAddress "127.0.0.1"
|
||||||
|
@ -93,7 +85,7 @@ getRules = pure $
|
||||||
, allowed = []
|
, allowed = []
|
||||||
}
|
}
|
||||||
, Rule { urls = [ URL "chat.googleplex.com" ]
|
, Rule { urls = [ URL "chat.googleplex.com" ]
|
||||||
, allowed = [ Allowance { day = Tuesday
|
, allowed = [ Allowance { day = Calendar.Saturday
|
||||||
, timeslots = [ TimeRange { beg = (Hour 0, Minute 0)
|
, timeslots = [ TimeRange { beg = (Hour 0, Minute 0)
|
||||||
, end = (Hour 0, Minute 0)
|
, end = (Hour 0, Minute 0)
|
||||||
}
|
}
|
||||||
|
@ -106,5 +98,6 @@ getRules = pure $
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
rules <- getRules
|
rules <- getRules
|
||||||
let etcHosts = unlines . fmap serializeEntry . Maybe.catMaybes $ fmap toEtcHostEntry rules
|
date <- Clock.getCurrentTime
|
||||||
|
let etcHosts = unlines . fmap serializeEntry . Maybe.catMaybes $ fmap (toEtcHostEntry date) rules
|
||||||
putStrLn etcHosts
|
putStrLn etcHosts
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
let
|
let
|
||||||
pkgs = import <nixpkgs> {};
|
pkgs = import <unstable> {};
|
||||||
in pkgs.mkShell {
|
in pkgs.mkShell {
|
||||||
buildInputs = with pkgs; [
|
buildInputs = with pkgs; [
|
||||||
ghc
|
ghc
|
||||||
|
haskellPackages.time
|
||||||
];
|
];
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in a new issue