Start social-fasting app

I'd like to ensure that my /etc/hosts file blocks websites at certains times. I
use this to allow / disallow websites at various times of the day.

TODO:
- Add project README
- Add tests
- Publish
- Create a Nix derivation
- Run as a systemd timer unit
- Figure out if I can run this as a user rather than root

3 files changed, 143 insertions, 0 deletions

diff --git a/tools/website-blocker/main.hs b/tools/website-blocker/main.hs
new file mode 100644
index 000000000000..47b26a0a2734
--- /dev/null
+++ b/tools/website-blocker/main.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Main
+  ( main
+  )where
+
+--------------------------------------------------------------------------------
+-- Dependencies
+--------------------------------------------------------------------------------
+
+import qualified Data.Maybe as Maybe
+import Data.Time.Calendar as Calendar
+
+-- I'm running this as a systemd timer that runs once per minute.
+
+--------------------------------------------------------------------------------
+-- Types
+--------------------------------------------------------------------------------
+
+newtype URL = URL { getURL :: String } deriving (Show)
+
+newtype IPAddress = IPAddress { getIPAddress :: String } deriving (Show)
+
+newtype Domain = Domain { getDomain :: String } deriving (Show)
+
+newtype Hour = Hour { getHour :: Integer }
+
+newtype Minute = Minute { getMinute :: Integer }
+
+data EtcHostEntry = EtcHostEntry { ip :: IPAddress
+                                 , domains :: [Domain]
+                                 } deriving (Show)
+
+
+data TimeRange = TimeRange { beg :: (Hour, Minute)
+                           , end :: (Hour, Minute)
+                           }
+
+data Allowance = Allowance { day :: Calendar.DayOfWeek
+                           , timeslots :: [TimeRange]
+                           }
+
+data Rule = Rule { urls :: [URL]
+                 , allowed :: [Allowance]
+                 }
+
+--------------------------------------------------------------------------------
+-- Functions
+--------------------------------------------------------------------------------
+
+-- create the current /etc/hosts file
+-- schedule the script to run again at the next relevant time
+
+isToday :: Calendar.DayOfWeek -> Bool
+isToday Monday = True
+isToday _      = False
+
+isAllowed :: [Allowance] -> Bool
+isAllowed [] = False
+isAllowed xs = do
+  let rules = filter (isToday . day) xs
+  case rules of
+    [day] -> True
+    []    -> False
+    -- Error when more than one rule per day
+    _     -> False
+
+serializeEntry :: EtcHostEntry -> String
+serializeEntry EtcHostEntry{ip, domains} =
+  (getIPAddress ip) ++ "\t" ++ (unwords $ fmap getDomain domains)
+
+toEtcHostEntry :: Rule -> Maybe EtcHostEntry
+toEtcHostEntry Rule{urls, allowed} =
+  if isAllowed allowed then
+    Nothing
+  else
+    Just $ EtcHostEntry { ip = IPAddress "127.0.0.1"
+                        , domains = fmap (Domain . getURL) urls
+                        }
+
+-- | Location of the rules.json file.
+rulesFile :: FilePath
+rulesFile =
+  "~/.config/website-blocker/rules.json"
+
+-- | Reads and parses JSON from `rulesFile` and returns the result.
+getRules :: IO [Rule]
+getRules = pure $
+  [ Rule { urls = [ URL "facebook.com"
+                  , URL "twitter.com"
+                  , URL "youtube.com"
+                  , URL "instagram.com"
+                  ]
+         , allowed = []
+         }
+  , Rule { urls = [ URL "chat.googleplex.com" ]
+         , allowed = [ Allowance { day = Tuesday
+                                 , timeslots = [ TimeRange { beg = (Hour 0, Minute 0)
+                                                           , end = (Hour 0, Minute 0)
+                                                           }
+                                               ]
+                                 }
+                     ]
+         }
+  ]
+
+main :: IO ()
+main = do
+  rules <- getRules
+  let etcHosts = unlines . fmap serializeEntry . Maybe.catMaybes $ fmap toEtcHostEntry rules
+  putStrLn etcHosts
diff --git a/tools/website-blocker/rules.json b/tools/website-blocker/rules.json
new file mode 100644
index 000000000000..42094a7cdd14
--- /dev/null
+++ b/tools/website-blocker/rules.json
@@ -0,0 +1,26 @@
+[
+  {
+    "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": "Tuesday",
+        "timeslots": []
+      }
+    ]
+  }
+]
diff --git a/tools/website-blocker/shell.nix b/tools/website-blocker/shell.nix
new file mode 100644
index 000000000000..fd1889dd891f
--- /dev/null
+++ b/tools/website-blocker/shell.nix
@@ -0,0 +1,7 @@
+let
+  pkgs = import <nixpkgs> {};
+in pkgs.mkShell {
+  buildInputs = with pkgs; [
+    ghc
+  ];
+}