diff options
Diffstat (limited to 'tools')
| -rw-r--r-- | tools/website-blocker/Main.hs | 165 | ||||
| -rw-r--r-- | tools/website-blocker/Spec.hs | 38 | ||||
| -rw-r--r-- | tools/website-blocker/main.hs | 103 | ||||
| -rw-r--r-- | tools/website-blocker/rules.json | 12 | ||||
| -rw-r--r-- | tools/website-blocker/shell.nix | 8 |
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 + ])) ]; } |