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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
module Main
( main
, getRules
, URL(..)
, Rule(..)
) where
--------------------------------------------------------------------------------
-- Dependencies
--------------------------------------------------------------------------------
import qualified Data.Maybe as Maybe
import qualified Data.Time.Clock as Clock
import qualified Data.Time.Calendar as Calendar
import qualified Data.Time.LocalTime as LocalTime
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.Aeson as Aeson
import qualified Data.Either.Combinators as Either
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import qualified Data.Text.Read as TextRead
import qualified Data.List as List
import GHC.Generics
import Data.Aeson ((.:))
import Data.Text (Text)
--------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------
newtype URL = URL { getURL :: Text } deriving (Show, Eq, Generic)
newtype IPAddress = IPAddress { getIPAddress :: Text } deriving (Show)
newtype Domain = Domain { getDomain :: Text } deriving (Show)
newtype Hour = Hour { getHour :: Int } deriving (Show, Eq, Generic)
newtype Minute = Minute { getMinute :: Int } deriving (Show, Eq, Generic)
data EtcHostsEntry = EtcHostsEntry { ip :: IPAddress
, domains :: [Domain]
} deriving (Show)
-- | Write these in terms of your system's local time (i.e. `date`).
data TimeSlot = TimeSlot { beg :: (Hour, Minute)
, end :: (Hour, Minute)
} deriving (Show, Eq, Generic)
data Allowance = Allowance { day :: Calendar.DayOfWeek
, timeslots :: [TimeSlot]
} deriving (Show, Eq, Generic)
data Rule = Rule { urls :: [URL]
, allowed :: [Allowance]
} deriving (Show, Eq, Generic)
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
instance Aeson.FromJSON TimeSlot where
parseJSON = Aeson.withText "timeslot" $ \x -> do
let [a, b] = Text.splitOn "-" x
[ah, am] = Text.splitOn ":" a
[bh, bm] = Text.splitOn ":" b
case extractTimeSlot ah am bh bm of
Left s -> fail s
Right x -> pure x
where
extractTimeSlot :: Text -> Text -> Text -> Text -> Either String TimeSlot
extractTimeSlot ah am bh bm = do
(begh, _) <- TextRead.decimal ah
(begm, _) <- TextRead.decimal am
(endh, _) <- TextRead.decimal bh
(endm, _) <- TextRead.decimal bm
pure $ TimeSlot{ beg = (Hour begh, Minute begm)
, end = (Hour endh, Minute endm)
}
instance Aeson.FromJSON Allowance where
parseJSON = Aeson.withObject "allowance" $ \x -> do
day <- x .: "day"
timeslots <- x .: "timeslots"
pure $ Allowance{day, timeslots}
instance Aeson.FromJSON URL where
parseJSON = Aeson.withText "URL" $ \x -> do
pure $ URL { getURL = x }
instance Aeson.FromJSON Rule where
parseJSON = Aeson.withObject "rule" $ \x -> do
urls <- x .: "urls"
allowed <- x .: "allowed"
pure Rule{urls, allowed}
--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------
-- | Pipe operator
(|>) :: a -> (a -> b) -> b
(|>) a f = f a
infixl 1 |>
-- | Returns True if the current time falls within any of the `timeslots`.
isWithinTimeSlot :: LocalTime.LocalTime -> [TimeSlot] -> Bool
isWithinTimeSlot date timeslots =
List.any withinTimeSlot timeslots
where
withinTimeSlot :: TimeSlot -> Bool
withinTimeSlot TimeSlot{ beg = (Hour ah, Minute am)
, end = (Hour bh, Minute bm)
} =
let LocalTime.TimeOfDay{LocalTime.todHour, LocalTime.todMin} =
LocalTime.localTimeOfDay date
in (todHour > ah) && (todMin > am) && (todHour < bh) && (todMin < bm)
-- | Returns True if `day` is the same day as today.
isToday :: LocalTime.LocalTime -> Calendar.DayOfWeek -> Bool
isToday date day = today == day
where
today = Calendar.dayOfWeek (LocalTime.localDay date)
-- | Returns True if a list of none of the `allowances` are valid.
shouldBeBlocked :: LocalTime.LocalTime -> [Allowance] -> Bool
shouldBeBlocked _ [] = True
shouldBeBlocked date allowances = do
case filter (isToday date . day) allowances of
[Allowance{timeslots}] -> not $ isWithinTimeSlot date timeslots
[] -> True
-- Error when more than one rule per day
_ -> True
-- | Maps an EtcHostsEntry to the line of text url-blocker will append to /etc/hosts.
serializeEtcHostEntry :: EtcHostsEntry -> Text
serializeEtcHostEntry EtcHostsEntry{ip, domains} =
(getIPAddress ip) <> "\t" <> (Text.unwords $ fmap getDomain domains)
-- | Create an EtcHostsEntry mapping the URLs in `rule` to 127.0.0.1 if the
-- URLs should be blocked.
maybeBlockURL :: LocalTime.LocalTime -> Rule -> Maybe EtcHostsEntry
maybeBlockURL date Rule{urls, allowed} =
if shouldBeBlocked date allowed then
Just $ EtcHostsEntry { ip = IPAddress "127.0.0.1"
, domains = fmap (Domain . getURL) urls
}
else
Nothing
-- | Read and parse the rules.json file.
-- TODO(wpcarro): Properly handle errors for file not found.
-- TODO(wpcarro): Properly handle errors for parse failures.
-- TODO(wpcarro): How can we resolve the $HOME directory when this is run as
-- root?
getRules :: IO [Rule]
getRules = do
contents <- LazyByteString.readFile "/home/wpcarro/.config/url-blocker/rules.json"
let payload = Aeson.eitherDecode contents
pure $ Either.fromRight [] payload
-- | Informational header added to /etc/hosts before the entries that
-- url-blocker adds.
urlBlockerHeader :: Text
urlBlockerHeader =
Text.unlines [ "################################################################################"
, "# Added by url-blocker."
, "#"
, "# Warning: url-blocker will remove anything that you add beneath this header."
, "################################################################################"
]
-- | Removes all entries that url-blocker may have added to /etc/hosts.
removeURLBlockerEntries :: Text -> Text
removeURLBlockerEntries etcHosts =
case Text.breakOn urlBlockerHeader etcHosts of
(etcHosts', _) -> etcHosts'
-- | Appends the newly created `entries` to `etcHosts`.
addURLBlockerEntries :: Text -> Text -> Text
addURLBlockerEntries entries etcHosts =
Text.unlines [ etcHosts
, urlBlockerHeader
, entries
]
-- | This script reads the current /etc/hosts, removes any entries that
-- url-blocker may have added in a previous run, and adds new entries to block
-- URLs according to the rules.json file.
main :: IO ()
main = do
rules <- getRules
tz <- LocalTime.getCurrentTimeZone
ct <- Clock.getCurrentTime
let date = LocalTime.utcToLocalTime tz ct
entries = rules
|> fmap (maybeBlockURL date)
|> Maybe.catMaybes
|> fmap serializeEtcHostEntry
|> Text.unlines
existingEtcHosts <- TextIO.readFile "/etc/hosts"
existingEtcHosts
|> removeURLBlockerEntries
|> addURLBlockerEntries entries
|> \x -> writeFile "/etc/hosts" (Text.unpack x)
|
