Parse and serialize rules.json

TL;DR:
- Write FromJSON instances to decode rules.json file
- Prefer Text to String and use the OverloadedStrings language extension
- Read /etc/hosts and append the serialized rules.json to the end

Notes:
- I can remove some of the FromJSON instances and use GHC Generics to define
  them for me.

TODO:
- Define the systemd timer unit for this to run
- Ensure script can run with root privileges

5 files changed, 216 insertions, 110 deletions

diff --git a/tools/website-blocker/Main.hs b/tools/website-blocker/Main.hs
new file mode 100644
index 000000000000..f1a7026714f2
--- /dev/null
+++ b/tools/website-blocker/Main.hs
@@ -0,0 +1,165 @@
+{-# 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
new file mode 100644
index 000000000000..b70d8619cb25
--- /dev/null
+++ b/tools/website-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/website-blocker/main.hs b/tools/website-blocker/main.hs
deleted file mode 100644
index 6c2b24472b11..000000000000
--- a/tools/website-blocker/main.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-module Main (main) where
-
---------------------------------------------------------------------------------
--- Dependencies
---------------------------------------------------------------------------------
-
-import qualified Data.Maybe as Maybe
-import qualified Data.Time.Clock as Clock
-import qualified Data.Time.Calendar as Calendar
-
---------------------------------------------------------------------------------
--- 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
---------------------------------------------------------------------------------
-
-isToday :: Clock.UTCTime -> Calendar.DayOfWeek -> Bool
-isToday date day = Calendar.dayOfWeek (Clock.utctDay date) == day
-
-isAllowed :: Clock.UTCTime -> [Allowance] -> Bool
-isAllowed _ [] = False
-isAllowed date xs = do
-  let rules = filter (isToday date . 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 :: Clock.UTCTime -> 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
-                        }
-
--- | 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 = Calendar.Saturday
-                                 , timeslots = [ TimeRange { beg = (Hour 0, Minute 0)
-                                                           , end = (Hour 0, Minute 0)
-                                                           }
-                                               ]
-                                 }
-                     ]
-         }
-  ]
-
-main :: IO ()
-main = do
-  rules <- getRules
-  date <- Clock.getCurrentTime
-  let etcHosts = unlines . fmap serializeEntry . Maybe.catMaybes $ fmap (toEtcHostEntry date) rules
-  putStrLn etcHosts
diff --git a/tools/website-blocker/rules.json b/tools/website-blocker/rules.json
index 42094a7cdd14..95e4dc9a90c1 100644
--- a/tools/website-blocker/rules.json
+++ b/tools/website-blocker/rules.json
@@ -5,9 +5,9 @@
       "www.facebook.com",
       "twitter.com",
       "www.twitter.com",
-      "youtube.com"
-      "www.youtube.com"
-      "instagram.com"
+      "youtube.com",
+      "www.youtube.com",
+      "instagram.com",
       "www.instagram.com"
     ],
     "allowed": []
@@ -18,8 +18,10 @@
     ],
     "allowed": [
       {
-        "day": "Tuesday",
-        "timeslots": []
+        "day": "Sunday",
+        "timeslots": [
+          "18:35-18:39"
+        ]
       }
     ]
   }
diff --git a/tools/website-blocker/shell.nix b/tools/website-blocker/shell.nix
index d82e0feda466..40f217e3f9a7 100644
--- a/tools/website-blocker/shell.nix
+++ b/tools/website-blocker/shell.nix
@@ -2,7 +2,11 @@ let
   pkgs = import <unstable> {};
 in pkgs.mkShell {
   buildInputs = with pkgs; [
-    ghc
-    haskellPackages.time
+    (haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
+      time
+      aeson
+      either
+      hspec
+    ]))
   ];
 }