1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
{-# LANGUAGE NamedFieldPuns #-}
module Main
( main
)where
--------------------------------------------------------------------------------
-- Dependencies
--------------------------------------------------------------------------------
import qualified Data.Maybe as Maybe
import Data.Time.Calendar as Calendar
-- I'm running this as a systemd timer that runs once per minute.
--------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------
newtype URL = URL { getURL :: String } deriving (Show)
newtype IPAddress = IPAddress { getIPAddress :: String } deriving (Show)
newtype Domain = Domain { getDomain :: String } deriving (Show)
newtype Hour = Hour { getHour :: Integer }
newtype Minute = Minute { getMinute :: Integer }
data EtcHostEntry = EtcHostEntry { ip :: IPAddress
, domains :: [Domain]
} deriving (Show)
data TimeRange = TimeRange { beg :: (Hour, Minute)
, end :: (Hour, Minute)
}
data Allowance = Allowance { day :: Calendar.DayOfWeek
, timeslots :: [TimeRange]
}
data Rule = Rule { urls :: [URL]
, allowed :: [Allowance]
}
--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------
-- create the current /etc/hosts file
-- schedule the script to run again at the next relevant time
isToday :: Calendar.DayOfWeek -> Bool
isToday Monday = True
isToday _ = False
isAllowed :: [Allowance] -> Bool
isAllowed [] = False
isAllowed xs = do
let rules = filter (isToday . day) xs
case rules of
[day] -> True
[] -> False
-- Error when more than one rule per day
_ -> False
serializeEntry :: EtcHostEntry -> String
serializeEntry EtcHostEntry{ip, domains} =
(getIPAddress ip) ++ "\t" ++ (unwords $ fmap getDomain domains)
toEtcHostEntry :: Rule -> Maybe EtcHostEntry
toEtcHostEntry Rule{urls, allowed} =
if isAllowed allowed then
Nothing
else
Just $ EtcHostEntry { ip = IPAddress "127.0.0.1"
, domains = fmap (Domain . getURL) urls
}
-- | Location of the rules.json file.
rulesFile :: FilePath
rulesFile =
"~/.config/website-blocker/rules.json"
-- | Reads and parses JSON from `rulesFile` and returns the result.
getRules :: IO [Rule]
getRules = pure $
[ Rule { urls = [ URL "facebook.com"
, URL "twitter.com"
, URL "youtube.com"
, URL "instagram.com"
]
, allowed = []
}
, Rule { urls = [ URL "chat.googleplex.com" ]
, allowed = [ Allowance { day = Tuesday
, timeslots = [ TimeRange { beg = (Hour 0, Minute 0)
, end = (Hour 0, Minute 0)
}
]
}
]
}
]
main :: IO ()
main = do
rules <- getRules
let etcHosts = unlines . fmap serializeEntry . Maybe.catMaybes $ fmap toEtcHostEntry rules
putStrLn etcHosts
|
