@@ -0,0 +1,207 @@
1+module Data.Time.Extra
2+ ( Minutes(..)
3+ , _Minutes
4+ , duration
5+ , durationLocal
6+ , minutesToNDF
7+ , UTCDate(..)
8+ , _UTCDate
9+ , UTCTime'(..)
10+ , _UTCTime'
11+ , mskTimeZone
12+ , toAPITimeMSK
13+ , apiDate
14+ , module Data.Time.LocalTime.Short
15+ , TimeFrame
16+ , mkTimeFrame
17+ , tfFrom
18+ , tfTo
19+ , tfType
20+ , TimeFrameType(..)
21+ , Hours(..)
22+ , _Hours
23+ , DateRange(..)
24+ , mkDateRange
25+ , drFromDate
26+ , drToDate
27+ , module Data.Time.Utils
28+ ) where
29+
30+import Control.DeepSeq
31+import Control.Lens
32+import Control.Monad
33+import Control.Monad.Fail
34+import Data.Aeson
35+import Data.Binary
36+import Data.Function (on)
37+import qualified Data.Text as T
38+import Data.Time
39+import Data.Time.LocalTime.Short
40+import Data.Time.Utils
41+import GHC.Generics (Generic)
42+import Test.QuickCheck
43+import Test.QuickCheck.Arbitrary.Generic
44+
45+
46+newtype Minutes
47+ = Minutes { unMinutes :: Int
48+ } deriving (Show, Eq, Ord, Arbitrary, Generic, FromJSON, ToJSON)
49+
50+instance NFData Minutes
51+
52+makePrisms ''Minutes
53+
54+newtype Hours
55+ = Hours { unHours :: Int
56+ } deriving (Show, Eq, Ord, Arbitrary, Generic, FromJSON, ToJSON)
57+
58+instance NFData Hours
59+
60+makePrisms ''Hours
61+
62+duration :: ShortZonedTime -> ShortZonedTime -> Minutes
63+duration t1 t2 = Minutes (timeDiff `div` 60)
64+ where
65+ calcDiff = diffUTCTime `on` zonedTimeToUTC . unShortZonedTime
66+ timeDiff = round (calcDiff t1 t2)
67+
68+durationLocal :: LocalTime -> LocalTime -> Minutes
69+durationLocal t1 t2 = Minutes (timeDiff `div` 60)
70+ where
71+ calcDiff = diffUTCTime `on` localTimeToUTC utc
72+ timeDiff = round (calcDiff t1 t2)
73+
74+minutesToNDF :: Minutes -> NominalDiffTime
75+minutesToNDF (Minutes mins) = 60 * realToFrac mins
76+
77+-- UTCTime with lexically correct show instance.
78+-- Motivation: using ppShow.
79+newtype UTCTime' = UTCTime' { unUTCTime' :: UTCTime }
80+ deriving (Eq, Ord, Generic, Binary, NFData)
81+
82+makePrisms ''UTCTime'
83+
84+instance Show UTCTime' where
85+ showsPrec n
86+ = showsPrec n
87+ . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
88+ . unUTCTime'
89+
90+instance Arbitrary UTCTime' where
91+ arbitrary = UTCTime' <$> do
92+ UTCTime
93+ <$> (ModifiedJulianDay <$> choose (55000, 58000))
94+ <*> arbitrary
95+
96+-- TODO: do not store the time, only the date
97+newtype UTCDate
98+ = UTCDate
99+ { utcTime :: UTCTime
100+ } deriving (Eq, Ord)
101+
102+makePrisms ''UTCDate
103+
104+instance NFData UTCDate where
105+ rnf (UTCDate d) = d `seq` () -- NOTE: not very good
106+
107+instance Binary UTCDate where
108+ put (UTCDate t) = put d
109+ where
110+ UTCTime (ModifiedJulianDay d) _ = t
111+ get = do
112+ d <- get
113+ return $ UTCDate (UTCTime (ModifiedJulianDay d) 0)
114+
115+instance Show UTCDate where
116+-- I hope no code was depending on this instance!
117+-- show = formatTime defaultTimeLocale "%d-%B-%y" . utcTime
118+ showsPrec n
119+ = showsPrec n
120+ . formatTime defaultTimeLocale "%d-%B-%y"
121+ . utcTime
122+
123+instance ToJSON UTCDate where
124+ toJSON (UTCDate t) = String $ T.pack iso8601
125+ where iso8601 = formatTime defaultTimeLocale (iso8601DateFormat Nothing) t
126+
127+instance FromJSON UTCDate where
128+ parseJSON (String s) = return $ UTCDate date
129+ where
130+ date = parseTimeOrError True defaultTimeLocale format string
131+ format = iso8601DateFormat Nothing
132+ string = T.unpack s
133+ parseJSON _ = mzero
134+
135+instance Arbitrary UTCDate where
136+ arbitrary = do
137+ dayNum <- choose (55000, 58000)
138+ return(UTCDate $ UTCTime (ModifiedJulianDay dayNum) (secondsToDiffTime 0))
139+
140+toApiDate :: UTCDate -> T.Text
141+toApiDate (UTCDate t) = T.pack iso8601
142+ where
143+ iso8601 = formatTime defaultTimeLocale (iso8601DateFormat Nothing) t
144+
145+fromApiDate :: (MonadFail m) => T.Text -> m UTCDate
146+fromApiDate t = UTCDate <$> parseTimeM
147+ True
148+ defaultTimeLocale
149+ (iso8601DateFormat Nothing)
150+ (T.unpack t)
151+
152+apiDate :: Prism' T.Text UTCDate
153+apiDate = prism' toApiDate fromApiDate
154+
155+mskTimeZone :: TimeZone
156+mskTimeZone = TimeZone (3 * 60) False "MSK"
157+
158+toAPITimeMSK :: UTCTime -> ShortZonedTime
159+toAPITimeMSK = shortZonedTime . utcToZonedTime mskTimeZone
160+
161+data TimeFrameType
162+ = TimeOfArrival
163+ | TimeOfDeparture
164+ deriving (Eq, Show, Generic)
165+
166+instance Binary TimeFrameType
167+
168+instance Arbitrary TimeFrameType where
169+ arbitrary = genericArbitrary
170+ shrink = genericShrink
171+
172+data TimeFrame = TimeFrame
173+ { _tfFrom :: !TimeOfDay
174+ , _tfTo :: !TimeOfDay
175+ , _tfType :: !TimeFrameType
176+ }
177+ deriving (Eq, Show, Generic)
178+
179+makeLenses ''TimeFrame
180+
181+instance Binary TimeFrame
182+
183+instance Arbitrary TimeFrame where
184+ arbitrary = genericArbitrary
185+ shrink = genericShrink
186+
187+mkTimeFrame :: TimeOfDay -> TimeOfDay -> TimeFrameType -> Maybe TimeFrame
188+mkTimeFrame fromTof toTof tft = if toTof >= fromTof
189+ then Just $ TimeFrame fromTof toTof tft
190+ else Nothing
191+
192+data DateRange = DateRange
193+ { _drFromDate :: Day
194+ , _drToDate :: Day
195+ } deriving (Eq, Show, Read, Generic)
196+
197+makeLenses ''DateRange
198+
199+mkDateRange :: Day -> Day -> DateRange
200+mkDateRange a b | b < a = DateRange b a
201+mkDateRange a b = DateRange a b
202+
203+instance Arbitrary DateRange where
204+ arbitrary = mkDateRange <$> arbitrary <*> arbitrary
205+ shrink = genericShrink
206+
207+instance Binary DateRange