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/Main.hs

@@ -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
+data EtcHostsEntry = EtcHostsEntry { ip :: IPAddress
-                                 , domains :: [Domain]
+                                   , domains :: [Domain]
-                                 } deriving (Show)
+                                   } 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
+-- | Returns True if a list of none of the `allowances` are valid.
-isAllowed _ [] = False
+shouldBeBlocked :: LocalTime.LocalTime -> [Allowance] -> Bool
-isAllowed date allowances = do
+shouldBeBlocked _ [] = True
+shouldBeBlocked date allowances = do
   case filter (isToday date . day) allowances of
-    [Allowance{timeslots}] ->
+    [Allowance{timeslots}] -> not $ isWithinTimeSlot date timeslots
-      isWithinTimeSlot date timeslots
+    [] -> True
-    [] -> False
     -- Error when more than one rule per day
-    _  -> False
+    _  -> True
 
-serializeEntry :: EtcHostEntry -> Text
+-- | Maps an EtcHostsEntry to the line of text url-blocker will append to /etc/hosts.
-serializeEntry EtcHostEntry{ip, domains} =
+serializeEtcHostEntry :: EtcHostsEntry -> Text
+serializeEtcHostEntry EtcHostsEntry{ip, domains} =
   (getIPAddress ip) <> "\t" <> (Text.unwords $ fmap getDomain domains)
 
-toEtcHostEntry :: LocalTime.LocalTime -> Rule -> Maybe EtcHostEntry
+-- | Create an EtcHostsEntry mapping the URLs in `rule` to 127.0.0.1 if the
-toEtcHostEntry date Rule{urls, allowed} =
+-- URLs should be blocked.
-  if isAllowed date allowed then
+maybeBlockURL :: LocalTime.LocalTime -> Rule -> Maybe EtcHostsEntry
-    Nothing
+maybeBlockURL date Rule{urls, allowed} =
-  else
+  if shouldBeBlocked date allowed then
-    Just $ EtcHostEntry { ip = IPAddress "127.0.0.1"
+    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
+-- | Informational header added to /etc/hosts before the entries that
-header =
+-- 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)

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.

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

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"
+        ]
+      }
+    ]
+  }
+]