subtree(users/wpcarro): docking briefcase at '24f5a642'

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c
git-subtree-split: 24f5a642af
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

users/wpcarro/zoo/.envrc

@@ -0,0 +1,2 @@
+source_up
+use_nix

users/wpcarro/zoo/.ghci

@@ -0,0 +1,5 @@
+:set prompt "> "
+:set -Wall
+:set -XOverloadedStrings
+:set -XRecordWildCards
+:set -XTypeApplications

users/wpcarro/zoo/Main.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+--------------------------------------------------------------------------------
+module Main where
+--------------------------------------------------------------------------------
+import RIO hiding (Handler)
+import RIO.Text
+import RIO.Time
+import Servant
+import Data.Time.Clock.POSIX
+import Prelude (read)
+import Text.ParserCombinators.ReadP
+
+import qualified Network.Wai.Handler.Warp as Warp
+--------------------------------------------------------------------------------
+
+type Api = "run"
+           :> QueryParam' '[Required] "offset" Text
+           :> Get '[JSON] UTCTime
+      :<|> "hello"
+           :> QueryParam "name" Text
+           :> Get '[JSON] Text
+
+server :: Server Api
+server = compute :<|> hello
+  where
+    compute :: Text -> Handler UTCTime
+    compute x = do
+      case parseInput x of
+        Nothing -> throwError err401
+        Just req -> do
+          res <- liftIO $ shiftTime req
+          pure res
+    hello :: Maybe Text -> Handler Text
+    hello mName =
+      case mName of
+        Nothing -> pure "Hello, world!"
+        Just name -> pure $ RIO.Text.concat ["Hello, ", name]
+
+data ShiftTimeRequest = ShiftTimeRequest
+  { shiftSeconds :: Int
+  , shiftMinutes :: Int
+  , shiftHours :: Int
+  , shiftDays :: Int
+  , shiftWeeks :: Int
+  , shiftMonths :: Int
+  , shiftQuarters :: Int
+  , shiftYears :: Int
+  } deriving (Eq, Show)
+
+instance Semigroup ShiftTimeRequest where
+  (ShiftTimeRequest as am ah ad aw amonths aq ay) <> (ShiftTimeRequest bs bm bh bd bw bmonths bq by) =
+    ShiftTimeRequest
+    { shiftSeconds = as + bs
+    , shiftMinutes = am + bm
+    , shiftHours = ah + bh
+    , shiftDays = ad + bd
+    , shiftWeeks = aw + bw
+    , shiftMonths = amonths + bmonths
+    , shiftQuarters = aq + bq
+    , shiftYears = ay + by
+    }
+
+instance Monoid ShiftTimeRequest where
+  mempty = defaultShiftTimeRequest
+
+defaultShiftTimeRequest :: ShiftTimeRequest
+defaultShiftTimeRequest = ShiftTimeRequest
+  { shiftSeconds = 0
+  , shiftMinutes = 0
+  , shiftHours = 0
+  , shiftDays = 0
+  , shiftWeeks = 0
+  , shiftMonths = 0
+  , shiftQuarters = 0
+  , shiftYears = 0
+  }
+
+-- This basically broken because it doesn't account for:
+-- Exhales... time stuff
+--   - Leap seconds, leap days, leap years...
+--   - Months like February having 28 days and others having 31
+--   - other things that I'm probably not considering
+toSeconds :: ShiftTimeRequest -> NominalDiffTime
+toSeconds ShiftTimeRequest{..} = do
+  let minutes = 60
+      hours = minutes * 60
+      days = hours * 24
+      weeks = days * 7
+      months = weeks * 4
+      quarters = months * 3
+      years = days * 365
+  fromIntegral $ shiftSeconds +
+    shiftMinutes * minutes +
+    shiftHours * hours +
+    shiftDays * days +
+    shiftWeeks * weeks +
+    shiftMonths * months +
+    shiftQuarters * quarters +
+    shiftYears * years
+
+shiftTime :: ShiftTimeRequest -> IO UTCTime
+shiftTime req = do
+  t <- getPOSIXTime
+  let t' = t + toSeconds req
+  pure $ posixSecondsToUTCTime t'
+
+data Unit = Second
+          | Minute
+          | Hour
+          | Day
+          | Week
+          | Month
+          | Quarter
+          | Year
+  deriving (Eq, Show)
+
+digit :: ReadP Char
+digit =
+  satisfy (\c -> c >= '0' && c <= '9')
+
+unit :: ReadP Unit
+unit = do
+  c <- get
+  case c of
+    's' -> pure Second
+    'm' -> pure Minute
+    'h' -> pure Hour
+    'd' -> pure Day
+    'w' -> pure Week
+    'M' -> pure Month
+    'q' -> pure Quarter
+    'y' -> pure Year
+    _ -> fail $ "We don't support this unit: " ++ show c
+
+request :: ReadP ShiftTimeRequest
+request = do
+  negative <- option Nothing $ fmap Just (satisfy (== '-'))
+  n <- read <$> many1 digit
+  u <- unit
+  let amt = if isJust negative then -1 * n else n
+  case u of
+    Second  -> pure $ defaultShiftTimeRequest { shiftSeconds = amt }
+    Minute  -> pure $ defaultShiftTimeRequest { shiftMinutes = amt }
+    Hour    -> pure $ defaultShiftTimeRequest { shiftHours = amt }
+    Day     -> pure $ defaultShiftTimeRequest { shiftDays = amt }
+    Week    -> pure $ defaultShiftTimeRequest { shiftWeeks = amt }
+    Month   -> pure $ defaultShiftTimeRequest { shiftMonths = amt }
+    Quarter -> pure $ defaultShiftTimeRequest { shiftQuarters = amt }
+    Year    -> pure $ defaultShiftTimeRequest { shiftYears = amt }
+
+parseInput :: Text -> Maybe ShiftTimeRequest
+parseInput x =
+  case readP_to_S (manyTill request eof) (unpack x) of
+    [(xs, "")] -> Just $ mconcat xs
+    _ -> Nothing
+
+main :: IO ()
+main = Warp.run 8000 $ serve (Proxy @ Api) server

users/wpcarro/zoo/Spec.hs

@@ -0,0 +1,54 @@
+--------------------------------------------------------------------------------
+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 })
+
+    it "handles minutes" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "m"]) ==
+        (Just defaultShiftTimeRequest { shiftMinutes = x })
+
+    it "handles hours" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "h"]) ==
+        (Just defaultShiftTimeRequest { shiftHours = x })
+
+    it "handles days" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "d"]) ==
+        (Just defaultShiftTimeRequest { shiftDays = x })
+
+    it "handles weeks" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "w"]) ==
+        (Just defaultShiftTimeRequest { shiftWeeks = x })
+
+    it "handles months" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "M"]) ==
+        (Just defaultShiftTimeRequest { shiftMonths = x })
+
+    it "handles quarters" $ do
+      property $ \x -> parseTime (Text.concat [x & show & Text.pack, "q"]) ==
+        (Just defaultShiftTimeRequest { shiftQuarters = x })
+
+    it "handles multiple shifts" $ do
+      parseTime "1s-20m5h0d-4w100M-3y2q" ==
+        (Just $ ShiftTimeRequest
+          { shiftSeconds = 1
+          , shiftMinutes = -20
+          , shiftHours = 5
+          , shiftDays = 0
+          , shiftWeeks = -4
+          , shiftMonths = 100
+          , shiftQuarters = 2
+          , shiftYears = -3
+          })

users/wpcarro/zoo/default.nix

@@ -0,0 +1,21 @@
+{ briefcase, ... }:
+
+briefcase.buildHaskell.program {
+  name = "zoo";
+  srcs = builtins.path {
+    path = ./.;
+    name = "zoo-src";
+  };
+  ghcExtensions = [
+    "OverloadedStrings"
+    "NoImplicitPrelude"
+    "RecordWildCards"
+    "TypeApplications"
+  ];
+  deps = hpkgs: with hpkgs; [
+    servant-server
+    aeson
+    warp
+    rio
+  ];
+}

users/wpcarro/zoo/shell.nix

@@ -0,0 +1,10 @@
+let
+  briefcase = import <briefcase> {};
+in briefcase.buildHaskell.shell {
+  deps = hpkgs: with hpkgs; [
+    servant-server
+    aeson
+    warp
+    rio
+  ];
+}