Support parsing second shifts

Parse inputs like -10s into 10 second shifts back in time.

5 files changed, 125 insertions, 0 deletions

diff --git a/website/sandbox/shift-time/.ghci b/website/sandbox/shift-time/.ghci
new file mode 100644
index 0000000000..d899113e92
--- /dev/null
+++ b/website/sandbox/shift-time/.ghci
@@ -0,0 +1,3 @@
+:set prompt "> "
+:set -Wall
+:set -XOverloadedStrings
diff --git a/website/sandbox/shift-time/Main.hs b/website/sandbox/shift-time/Main.hs
new file mode 100644
index 0000000000..80663d797b
--- /dev/null
+++ b/website/sandbox/shift-time/Main.hs
@@ -0,0 +1,69 @@
+--------------------------------------------------------------------------------
+module Main where
+--------------------------------------------------------------------------------
+import RIO
+import RIO.Text
+import Prelude (putStrLn, read)
+import Text.ParserCombinators.ReadP
+
+import qualified Data.Time.Clock as Clock
+--------------------------------------------------------------------------------
+
+-- type Api = "run"
+--            :> ReqBody '[JSON] Request
+--            :> Post '[JSON] Response
+
+data ShiftTimeRequest = ShiftTimeRequest
+  { shiftSeconds :: Int
+  , shiftMinutes :: Int
+  , shiftHours :: Int
+  , shiftDays :: Int
+  , shiftWeeks :: Int
+  , shiftMonths :: Int
+  , shiftQuarters :: Int
+  , shiftYears :: Int
+  } deriving (Eq, Show)
+
+defaultShiftTimeRequest :: ShiftTimeRequest
+defaultShiftTimeRequest = ShiftTimeRequest
+  { shiftSeconds = 0
+  , shiftMinutes = 0
+  , shiftHours = 0
+  , shiftDays = 0
+  , shiftWeeks = 0
+  , shiftMonths = 0
+  , shiftQuarters = 0
+  , shiftYears = 0
+  }
+
+-- shiftTime :: Maybe Request -> IO Clock.UTCTime
+-- shiftTime = Clock.getCurrentTime
+
+data Unit = Second
+
+digit :: ReadP Char
+digit =
+  satisfy (\c -> c >= '0' && c <= '9')
+
+unit :: ReadP Unit
+unit = do
+  _ <- char 's'
+  pure Second
+
+request :: ReadP ShiftTimeRequest
+request = do
+  negative <- option Nothing $ fmap Just (satisfy (== '-'))
+  n <- read <$> many1 digit
+  _ <- unit
+  case negative of
+    Nothing -> pure $ defaultShiftTimeRequest { shiftSeconds = n }
+    Just _  -> pure $ defaultShiftTimeRequest { shiftSeconds = -1 * n }
+
+parseTime :: Text -> Maybe ShiftTimeRequest
+parseTime x =
+  case readP_to_S request (unpack x) of
+    [(res, "")] -> Just res
+    _ -> Nothing
+
+main :: IO ()
+main = putStrLn "Working!"
diff --git a/website/sandbox/shift-time/Spec.hs b/website/sandbox/shift-time/Spec.hs
new file mode 100644
index 0000000000..dcb28248b3
--- /dev/null
+++ b/website/sandbox/shift-time/Spec.hs
@@ -0,0 +1,17 @@
+--------------------------------------------------------------------------------
+module Spec where
+--------------------------------------------------------------------------------
+import RIO
+import Test.Hspec
+import Test.QuickCheck
+import Main hiding (main)
+
+import qualified RIO.Text as Text
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = hspec $ do
+  describe "Main" $ do
+    it "handles seconds" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "s"]) ==
+        (Just defaultShiftTimeRequest { shiftSeconds = x })
diff --git a/website/sandbox/shift-time/default.nix b/website/sandbox/shift-time/default.nix
new file mode 100644
index 0000000000..356c250c71
--- /dev/null
+++ b/website/sandbox/shift-time/default.nix
@@ -0,0 +1,28 @@
+let
+  briefcase = import /home/wpcarro/briefcase {};
+in briefcase.buildHaskell.program {
+  name = "shift-time";
+  srcs = builtins.path {
+    path = ./.;
+    name = "shift-time-src";
+  };
+  ghcExtensions = [
+    "OverloadedStrings"
+    "NoImplicitPrelude"
+    "RecordWildCards"
+    "TypeApplications"
+  ];
+  deps = hpkgs: with hpkgs; [
+    servant-server
+    aeson
+    wai-cors
+    warp
+    jwt
+    unordered-containers
+    base64
+    http-conduit
+    rio
+    envy
+    req
+  ];
+}
diff --git a/website/sandbox/shift-time/shell.nix b/website/sandbox/shift-time/shell.nix
new file mode 100644
index 0000000000..fb5021a6b7
--- /dev/null
+++ b/website/sandbox/shift-time/shell.nix
@@ -0,0 +1,8 @@
+let
+  briefcase = import /home/wpcarro/briefcase {};
+in briefcase.buildHaskell.shell {
+  deps = hpkgs: with hpkgs; [
+    hspec
+    rio
+  ];
+}