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
157
158
159
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
|
