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
|
{-# 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 EtcHostEntry = EtcHostEntry { 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
--------------------------------------------------------------------------------
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)
isToday :: LocalTime.LocalTime -> Calendar.DayOfWeek -> Bool
isToday date day = Calendar.dayOfWeek (LocalTime.localDay date) == day
isAllowed :: LocalTime.LocalTime -> [Allowance] -> Bool
isAllowed _ [] = False
isAllowed date allowances = do
case filter (isToday date . day) allowances of
[Allowance{timeslots}] ->
isWithinTimeSlot date timeslots
[] -> False
-- Error when more than one rule per day
_ -> False
serializeEntry :: EtcHostEntry -> Text
serializeEntry EtcHostEntry{ip, domains} =
(getIPAddress ip) <> "\t" <> (Text.unwords $ fmap getDomain domains)
toEtcHostEntry :: LocalTime.LocalTime -> Rule -> Maybe EtcHostEntry
toEtcHostEntry date Rule{urls, allowed} =
if isAllowed date allowed then
Nothing
else
Just $ EtcHostEntry { ip = IPAddress "127.0.0.1"
, domains = fmap (Domain . getURL) urls
}
getRules :: IO [Rule]
getRules = do
contents <- LazyByteString.readFile "rules.json"
let payload = Aeson.eitherDecode contents
pure $ Either.fromRight [] payload
header :: Text
header =
Text.unlines [ "################################################################################"
, "# Added by url-blocker"
, "################################################################################"
]
main :: IO ()
main = do
rules <- getRules
tz <- LocalTime.getCurrentTimeZone
ct <- Clock.getCurrentTime
let date = LocalTime.utcToLocalTime tz ct
etcHosts = Text.unlines . fmap serializeEntry . Maybe.catMaybes $ fmap (toEtcHostEntry date) rules
existingEtcHosts <- TextIO.readFile "/etc/hosts"
TextIO.putStrLn $ existingEtcHosts <> "\n" <> header <> "\n" <> etcHosts
|
