From 946764f6bd8dc8a4c9653e0b148ed96d95aabd9c Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 29 Mar 2020 20:35:34 +0100 Subject: Read and write to /etc/hosts TL;DR: - Rename website-blocker to url-blocker - Add a README.md - Reads and writes to /etc/hosts --- tools/url-blocker/.envrc | 2 + tools/url-blocker/Main.hs | 210 ++++++++++++++++++++++++++++++++++++++++ tools/url-blocker/README.md | 47 +++++++++ tools/url-blocker/Spec.hs | 38 ++++++++ tools/url-blocker/default.nix | 37 +++++++ tools/url-blocker/hosts | 1 + tools/url-blocker/rules.json | 28 ++++++ tools/url-blocker/shell.nix | 12 +++ tools/website-blocker/.envrc | 2 - tools/website-blocker/Main.hs | 165 ------------------------------- tools/website-blocker/Spec.hs | 38 -------- tools/website-blocker/hosts | 1 - tools/website-blocker/shell.nix | 12 --- 13 files changed, 375 insertions(+), 218 deletions(-) create mode 100644 tools/url-blocker/.envrc create mode 100644 tools/url-blocker/Main.hs create mode 100644 tools/url-blocker/README.md create mode 100644 tools/url-blocker/Spec.hs create mode 100644 tools/url-blocker/default.nix create mode 100644 tools/url-blocker/hosts create mode 100644 tools/url-blocker/rules.json create mode 100644 tools/url-blocker/shell.nix delete mode 100644 tools/website-blocker/.envrc delete mode 100644 tools/website-blocker/Main.hs delete mode 100644 tools/website-blocker/Spec.hs delete mode 100644 tools/website-blocker/hosts delete mode 100644 tools/website-blocker/shell.nix (limited to 'tools') diff --git a/tools/url-blocker/.envrc b/tools/url-blocker/.envrc new file mode 100644 index 000000000000..81755b513b21 --- /dev/null +++ b/tools/url-blocker/.envrc @@ -0,0 +1,2 @@ +source_up +export HOSTALIASES="$(realpath ./hosts)" diff --git a/tools/url-blocker/Main.hs b/tools/url-blocker/Main.hs new file mode 100644 index 000000000000..34197981598c --- /dev/null +++ b/tools/url-blocker/Main.hs @@ -0,0 +1,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) diff --git a/tools/url-blocker/README.md b/tools/url-blocker/README.md new file mode 100644 index 000000000000..1b7fea8c15e0 --- /dev/null +++ b/tools/url-blocker/README.md @@ -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. diff --git a/tools/url-blocker/Spec.hs b/tools/url-blocker/Spec.hs new file mode 100644 index 000000000000..b70d8619cb25 --- /dev/null +++ b/tools/url-blocker/Spec.hs @@ -0,0 +1,38 @@ +module Spec (main) where + +-------------------------------------------------------------------------------- +-- Dependencies +-------------------------------------------------------------------------------- + +import qualified Main as Main + +import Test.Hspec + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec $ do + describe "getRules" $ do + it "returns the parsed rules from rules.json" $ do + rules <- Main.getRules + rules `shouldBe` [ Main.Rule { Main.urls = [ Main.URL "facebook.com" + , Main.URL "www.facebook.com" + , Main.URL "twitter.com" + , Main.URL "www.twitter.com" + , Main.URL "youtube.com" + , Main.URL "www.youtube.com" + , Main.URL "instagram.com" + , Main.URL "www.instagram.com" + ] + , Main.allowed = [] + } + , Main.Rule { Main.urls = [ Main.URL "chat.googleplex.com" ] + , Main.allowed = [] + } + ] + + describe "Prelude.head" $ do + it "returns the first element of a list" $ do + head [23 ..] `shouldBe` (23 :: Int) diff --git a/tools/url-blocker/default.nix b/tools/url-blocker/default.nix new file mode 100644 index 000000000000..d6a098851b88 --- /dev/null +++ b/tools/url-blocker/default.nix @@ -0,0 +1,37 @@ +{ ... }: + +let + pkgs = import {}; + + 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 diff --git a/tools/url-blocker/hosts b/tools/url-blocker/hosts new file mode 100644 index 000000000000..0cf45e59584f --- /dev/null +++ b/tools/url-blocker/hosts @@ -0,0 +1 @@ +127.0.0.1 wsj.com www.wsj.com \ No newline at end of file diff --git a/tools/url-blocker/rules.json b/tools/url-blocker/rules.json new file mode 100644 index 000000000000..95e4dc9a90c1 --- /dev/null +++ b/tools/url-blocker/rules.json @@ -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" + ] + } + ] + } +] diff --git a/tools/url-blocker/shell.nix b/tools/url-blocker/shell.nix new file mode 100644 index 000000000000..40f217e3f9a7 --- /dev/null +++ b/tools/url-blocker/shell.nix @@ -0,0 +1,12 @@ +let + pkgs = import {}; +in pkgs.mkShell { + buildInputs = with pkgs; [ + (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [ + time + aeson + either + hspec + ])) + ]; +} diff --git a/tools/website-blocker/.envrc b/tools/website-blocker/.envrc deleted file mode 100644 index 81755b513b21..000000000000 --- a/tools/website-blocker/.envrc +++ /dev/null @@ -1,2 +0,0 @@ -source_up -export HOSTALIASES="$(realpath ./hosts)" diff --git a/tools/website-blocker/Main.hs b/tools/website-blocker/Main.hs deleted file mode 100644 index f1a7026714f2..000000000000 --- a/tools/website-blocker/Main.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# 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 diff --git a/tools/website-blocker/Spec.hs b/tools/website-blocker/Spec.hs deleted file mode 100644 index b70d8619cb25..000000000000 --- a/tools/website-blocker/Spec.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Spec (main) where - --------------------------------------------------------------------------------- --- Dependencies --------------------------------------------------------------------------------- - -import qualified Main as Main - -import Test.Hspec - --------------------------------------------------------------------------------- --- Tests --------------------------------------------------------------------------------- - -main :: IO () -main = hspec $ do - describe "getRules" $ do - it "returns the parsed rules from rules.json" $ do - rules <- Main.getRules - rules `shouldBe` [ Main.Rule { Main.urls = [ Main.URL "facebook.com" - , Main.URL "www.facebook.com" - , Main.URL "twitter.com" - , Main.URL "www.twitter.com" - , Main.URL "youtube.com" - , Main.URL "www.youtube.com" - , Main.URL "instagram.com" - , Main.URL "www.instagram.com" - ] - , Main.allowed = [] - } - , Main.Rule { Main.urls = [ Main.URL "chat.googleplex.com" ] - , Main.allowed = [] - } - ] - - describe "Prelude.head" $ do - it "returns the first element of a list" $ do - head [23 ..] `shouldBe` (23 :: Int) diff --git a/tools/website-blocker/hosts b/tools/website-blocker/hosts deleted file mode 100644 index 0cf45e59584f..000000000000 --- a/tools/website-blocker/hosts +++ /dev/null @@ -1 +0,0 @@ -127.0.0.1 wsj.com www.wsj.com \ No newline at end of file diff --git a/tools/website-blocker/shell.nix b/tools/website-blocker/shell.nix deleted file mode 100644 index 40f217e3f9a7..000000000000 --- a/tools/website-blocker/shell.nix +++ /dev/null @@ -1,12 +0,0 @@ -let - pkgs = import {}; -in pkgs.mkShell { - buildInputs = with pkgs; [ - (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [ - time - aeson - either - hspec - ])) - ]; -} -- cgit 1.4.1