tvl-depot/users/wpcarro/zoo/Main.hs
sterni 11f9306b9a chore(3p/sources): Bump channels & overlays
Use nixos-unstable-small which fixes CVE-2018-25032
(out of bounds write while compressing).

* //users/grfn/xanthous:

  - Supporting random-fu 0.3 requires considerable changes and patching
    random-extras (https://github.com/aristidb/random-extras/pull/5).

    For now we downgrade random-fu and its dependency rvar to 0.2.*,
    forcing us to build xanthous with GHC 8.10.7, due to random-fu 0.2.*
    not supporting that version.

    Nix expressions for the downgraded packages are checked in to avoid
    the potential need to compile Haskell at pipeline eval time.

  - generic-arbitrary exposes a GenericArbitrary newtype now.
    This means we no longer have to implement it in xanthous
    downstream and patch generic-arbitrary to expose the
    GArbitrary type class.

  - Minor adjustments for lens 5.0:

    Xanthous.Game.Memo: clear needs to use ASetter' instead of Lens'

    Xanthous.Data.EntityMap: TraversableWithIndex no longer has an
    itraversed function.

  - Xanthous.Orphans: adjust for aeson's KeyMap, use KM.size explicitly
    instead of relying on MonoTraversable's length

* //nix/buildLisp: the CCL issue has resurfaced, disabling the
  implementation once again.

* //3p/arion: remove, as depot uses the nixpkgs package of it anyways.

* //users/wpcarro: accomodate GHC 9.0.1's stricter parsing of operators.

* //users/tazjin: disable rustfmt as it stopped respecting settings

* //3p/overlays: upgrade home-manager until fix for serivce generation
  has landed upstream

* //users/grfn/system: remove rr override, as the pinned commit is part
  of the 5.5.0 release shipped by nixpkgs.

Change-Id: If229e7317ba48498f85170b57ee9053f6997ff8a
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5428
Tested-by: BuildkiteCI
Autosubmit: sterni <sternenseemann@systemli.org>
Reviewed-by: grfn <grfn@gws.fyi>
Reviewed-by: tazjin <tazjin@tvl.su>
Reviewed-by: wpcarro <wpcarro@gmail.com>
2022-04-11 19:37:01 +00:00

160 lines
4.4 KiB
Haskell

{-# 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