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

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c09813172c79820bcf526bb10cf4208
git-subtree-split: 24f5a642af3aa1627bbff977f0a101907a02c69f
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

1 files changed, 160 insertions, 0 deletions

diff --git a/users/wpcarro/zoo/Main.hs b/users/wpcarro/zoo/Main.hs
new file mode 100644
index 000000000000..407d29e61e3a
--- /dev/null
+++ b/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