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
{-# LANGUAGE CPP #-}
module Composite.Aeson.Formats.DateTime
( DateTimeFormat(..), regularDateTimeFormat
, dateTimeJsonFormat
, iso8601DateJsonFormat, iso8601DateTimeJsonFormat, iso8601TimeJsonFormat
) where
import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
import Composite.Aeson.DateTimeFormatUtils (fixupTzIn, fixupTzOut, fixupMs)
import Composite.Aeson.Formats.Provided (stringJsonFormat)
import Control.Monad.Error.Class (throwError)
import qualified Data.Aeson.BetterErrors as ABE
import Data.Either (partitionEithers)
import Data.Monoid ((<>))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NEL
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (FormatTime, ParseTime, TimeLocale, defaultTimeLocale, formatTime, parseTimeM)
import Data.Time.LocalTime (TimeOfDay)
-- |Structure carrying the date/time format string along with an example for error messaging and functions which optionally permute the input or output
-- before using the format.
data DateTimeFormat = DateTimeFormat
{ dateTimeFormat :: String
, dateTimeFormatExample :: String
, dateTimeFormatPreParse :: String -> String
, dateTimeFormatPostFormat :: String -> String
}
-- |Construct a 'DateTimeFormat' with no pre- or post- processing.
regularDateTimeFormat :: String -> String -> DateTimeFormat
regularDateTimeFormat format example = DateTimeFormat format example id id
-- |'JsonFormat' for any type which 'ParseTime' and 'FormatTime' are defined for which maps to JSON via the first format given and maps from JSON via
-- any format given.
dateTimeJsonFormat :: (ParseTime t, FormatTime t) => TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat locale formats@(outFormat :| otherInFormats) = JsonFormat (JsonProfunctor dayOut dayIn)
where
formatsList = NEL.toList formats
JsonFormat (JsonProfunctor stringOut stringIn) = stringJsonFormat
dayOut = stringOut . dateTimeFormatPostFormat outFormat . formatTime locale (dateTimeFormat outFormat)
dayIn = do
s <- stringIn
let attempt format = successOrFail Left Right $ parseTimeM True locale (dateTimeFormat format) (dateTimeFormatPreParse format s)
attempts = map attempt formatsList
case partitionEithers attempts of
(_, a : _) ->
pure a
(es, _) | null otherInFormats ->
toss $ "expected date/time string formatted as " <> dateTimeFormatExample outFormat <> ", but: " <> intercalate ", " es
(es, _) ->
toss $ "expected date/time string formatted as one of "
<> intercalate ", " (map dateTimeFormatExample formatsList)
<> ", but: " <> intercalate ", " es
toss = throwError . ABE.BadSchema [] . ABE.FromAeson
-- |ISO8601 extended date format (@yyyy-mm-dd@).
iso8601DateJsonFormat :: JsonFormat e Day
iso8601DateJsonFormat =
dateTimeJsonFormat defaultTimeLocale (fmt :| [])
where
fmt = regularDateTimeFormat "%F" "yyyy-mm-dd"
-- |ISO8601 extended date/time format (@yyyy-mm-ddThh:mm:ss.sssZ@ or @yyyy-mm-ttThh:mm:ssZ@)
iso8601DateTimeJsonFormat :: JsonFormat e UTCTime
iso8601DateTimeJsonFormat =
dateTimeJsonFormat defaultTimeLocale (withMs :| [withoutMs])
where
withMs = DateTimeFormat "%FT%T%Q%z" "yyyy-mm-ddThh:mm:ss.sssZ" fixupTzIn (fixupTzOut . fixupMs)
withoutMs = DateTimeFormat "%FT%T%z" "yyyy-mm-ddThh:mm:ssZ" fixupTzIn fixupTzOut
-- |ISO8601 extended time format (@hh:mm:ss.sss@ or @hh:mm:ss@)
iso8601TimeJsonFormat :: JsonFormat e TimeOfDay
iso8601TimeJsonFormat =
dateTimeJsonFormat defaultTimeLocale (withMs :| [withoutMs])
where
withMs = DateTimeFormat "%T%Q%z" "hh:mm:ss.sss" id fixupMs
withoutMs = DateTimeFormat "%T%Q" "hh:mm:ss" id id
-- |Monad for capturing uses of 'fail', because @Data.Time.Format@ has a poorly factored interface.
data SuccessOrFail a = Fail String | Success a
instance Functor SuccessOrFail where
fmap f (Success a) = Success (f a)
fmap _ (Fail f) = Fail f
instance Applicative SuccessOrFail where
pure = Success
Success f <*> Success a = Success (f a)
Success _ <*> Fail f = Fail f
Fail f <*> _ = Fail f
instance Monad SuccessOrFail where
return = Success
Success a >>= k = k a
Fail f >>= _ = Fail f
#if MIN_VERSION_base(4,13,0)
instance MonadFail SuccessOrFail where
#endif
fail = Fail
-- |Evaluate some action of type @Monad m => m a@ and apply either the first or second function based on whether the computation completed or used @fail@.
#if MIN_VERSION_base(4,13,0)
successOrFail :: (String -> b) -> (a -> b) -> (forall m. MonadFail m => m a) -> b
#else
successOrFail :: (String -> b) -> (a -> b) -> (forall m. Monad m => m a) -> b
#endif
successOrFail _ f (Success a) = f a
successOrFail f _ (Fail s) = f s