about summary refs log tree commit diff
path: root/zoo/Main.hs
blob: 8706a7daac7e5026e58412430d791ccb0c83241b (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
{-# 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
      :<|> "mimi"
           :> Get '[JSON] Text

server :: Server Api
server = compute :<|> helloMimi
  where
    compute :: Text -> Handler UTCTime
    compute x = do
      case parseInput x of
        Nothing -> throwError err401
        Just req -> do
          res <- liftIO $ shiftTime req
          pure res
    helloMimi :: Handler Text
    helloMimi = pure "Hello, Mimi"

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