8 files changed, 375 insertions, 0 deletions
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 <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
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 <unstable> {};
+in pkgs.mkShell {
+  buildInputs = with pkgs; [
+    (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
+      time
+      aeson
+      either
+      hspec
+    ]))
+  ];
+}