Implement isToday predicate

Use the Data.Time package to implement the isToday predicate.
This commit is contained in:
William Carroll 2020-03-29 00:00:47 +00:00
parent 561cb619a1
commit ef5eda4015
2 changed files with 17 additions and 23 deletions

View file

@ -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

View file

@ -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
]; ];
} }