Read and write to /etc/hosts

TL;DR:
- Rename website-blocker to url-blocker
- Add a README.md
- Reads and writes to /etc/hosts
This commit is contained in:
William Carroll 2020-03-29 20:35:34 +01:00
parent 75595b0126
commit 946764f6bd
8 changed files with 182 additions and 25 deletions

View file

@ -43,9 +43,9 @@ 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)
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)
@ -103,6 +103,12 @@ instance Aeson.FromJSON Rule where
-- 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
@ -115,51 +121,90 @@ isWithinTimeSlot date timeslots =
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 = Calendar.dayOfWeek (LocalTime.localDay date) == day
isToday date day = today == day
where
today = Calendar.dayOfWeek (LocalTime.localDay date)
isAllowed :: LocalTime.LocalTime -> [Allowance] -> Bool
isAllowed _ [] = False
isAllowed date allowances = do
-- | 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}] ->
isWithinTimeSlot date timeslots
[] -> False
[Allowance{timeslots}] -> not $ isWithinTimeSlot date timeslots
[] -> True
-- Error when more than one rule per day
_ -> False
_ -> True
serializeEntry :: EtcHostEntry -> Text
serializeEntry EtcHostEntry{ip, domains} =
-- | 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)
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"
-- | 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 "rules.json"
contents <- LazyByteString.readFile "/home/wpcarro/.config/url-blocker/rules.json"
let payload = Aeson.eitherDecode contents
pure $ Either.fromRight [] payload
header :: Text
header =
-- | Informational header added to /etc/hosts before the entries that
-- url-blocker adds.
urlBlockerHeader :: Text
urlBlockerHeader =
Text.unlines [ "################################################################################"
, "# Added by url-blocker"
, "# 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
etcHosts = Text.unlines . fmap serializeEntry . Maybe.catMaybes $ fmap (toEtcHostEntry date) rules
entries = rules
|> fmap (maybeBlockURL date)
|> Maybe.catMaybes
|> fmap serializeEtcHostEntry
|> Text.unlines
existingEtcHosts <- TextIO.readFile "/etc/hosts"
TextIO.putStrLn $ existingEtcHosts <> "\n" <> header <> "\n" <> etcHosts
existingEtcHosts
|> removeURLBlockerEntries
|> addURLBlockerEntries entries
|> \x -> writeFile "/etc/hosts" (Text.unpack x)

View file

@ -0,0 +1,47 @@
# url-blocker
`url-blocker` blocks the URLs that you want to block when you want it to block
them.
Let's say that you don't want to visit Twitter during the work week. Create the
file `~/.config/url-blocker/rules.json` with the following contents and
`url-blocker` will take care of the rest.
```json
# ~/.config/url-blocker/rules.json
[
{
"urls": [
"twitter.com",
"www.twitter.com",
],
"allowed": [
{
"day": "Saturday",
"timeslots": [
"00:00-11:59"
]
},
{
"day": "Sunday",
"timeslots": [
"00:00-11:59"
]
}
]
}
]
```
## Installation
```shell
$ nix-env -iA 'briefcase.tools.url-blocker'
```
## How does it work?
`systemd` is intended to run `url-blocker` once every minute. `url-blocker` will
read `/etc/hosts` and map the URLs defined in `rules.json` to `127.0.0.1` when
you want them blocked. Because `systemd` run once every minute, `/etc/hosts`
should be current to the minute as well.

View file

@ -0,0 +1,37 @@
{ ... }:
let
pkgs = import <unstable> {};
ghc = pkgs.haskellPackages.ghcWithPackages (hpkgs: [
hpkgs.time
hpkgs.aeson
hpkgs.either
]);
# This is the systemd service unit
service = pkgs.stdenv.mkDerivation {
name = "url-blocker";
src = ./.;
buildInputs = with pkgs; [
];
buildPhase = ''
${ghc}/bin/ghc Main.hs
'';
installPhase = ''
mv ./Main $out
'';
};
# This is the systemd timer unit.
# Run once every minute.
# Give root privilege.
systemdUnit = {
systemd = {
timers.simple-timer = {
wantedBy = [ "timers.target" ];
partOf = [];
};
};
};
in null

View file

@ -0,0 +1,28 @@
[
{
"urls": [
"facebook.com",
"www.facebook.com",
"twitter.com",
"www.twitter.com",
"youtube.com",
"www.youtube.com",
"instagram.com",
"www.instagram.com"
],
"allowed": []
},
{
"urls": [
"chat.googleplex.com"
],
"allowed": [
{
"day": "Sunday",
"timeslots": [
"18:35-18:39"
]
}
]
}
]