From 36f45861ded111c2cbe69cb28e068583a4b9030f Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Mon, 26 Jun 2023 16:50:14 +0200
Subject: [PATCH] Add instances for UTCTime

---
 CHANGELOG.md                        |  2 ++
 graphql-spice.cabal                 |  2 ++
 src/Language/GraphQL/Class.hs       | 47 +++++++++++++++++++++++++++++
 tests/Language/GraphQL/ClassSpec.hs | 20 ++++++++++++
 4 files changed, 71 insertions(+)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 8c2ee0d..fb189ba 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -10,6 +10,8 @@ and this project adheres to
 ### Added
 - `ToGraphQL` and `FromGraphQL` instances for `Word` types, `Float`, `Double`,
   and `Scientific`.
+- `ToGraphQL` and `FromGraphQL` instances for `Day`, `DiffTime`,
+  `NominalDiffTime`, and `UTCTime`.
 - `Resolver`: Export `ServerException`.
 - `Resolver.defaultResolver`: Throw `FieldNotResolvedException` if the requested
   field is not in the parent object.
diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index eb8a16e..2ca4923 100644
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@@ -42,6 +42,7 @@ library
       megaparsec >= 9.0 && < 10,
       scientific ^>= 0.3.7,
       text >= 1.2 && < 3,
+      time >= 1.11.1,
       transformers ^>= 0.5.6,
       vector ^>= 0.12.3,
       unordered-containers ^>= 0.2.16
@@ -67,5 +68,6 @@ test-suite graphql-test
     hspec >= 2.9.1 && < 3,
     scientific,
     text,
+    time,
     unordered-containers
   default-language: Haskell2010
diff --git a/src/Language/GraphQL/Class.hs b/src/Language/GraphQL/Class.hs
index cce1bae..49bae57 100644
--- a/src/Language/GraphQL/Class.hs
+++ b/src/Language/GraphQL/Class.hs
@@ -20,6 +20,17 @@ import Data.Vector (Vector)
 import qualified Data.Vector as Vector
 import qualified Language.GraphQL.Type as Type
 import Data.Scientific (Scientific, toRealFloat)
+import qualified Data.Text as Text
+import Data.Time
+    ( Day
+    , DiffTime
+    , NominalDiffTime
+    , UTCTime(..)
+    , showGregorian
+    , secondsToNominalDiffTime
+    , secondsToDiffTime
+    )
+import Data.Time.Format.ISO8601 (formatParseM, iso8601Format, iso8601Show)
 
 fromGraphQLToIntegral :: Integral a => Type.Value -> Maybe a
 fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value
@@ -108,6 +119,22 @@ instance ToGraphQL Scientific
   where
     toGraphQL = Type.Float . toRealFloat
 
+instance ToGraphQL Day
+  where
+    toGraphQL = Type.String . Text.pack . showGregorian
+
+instance ToGraphQL DiffTime
+  where
+    toGraphQL = Type.Int . truncate . (realToFrac :: DiffTime -> Double)
+
+instance ToGraphQL NominalDiffTime
+  where
+    toGraphQL = Type.Int . truncate . (realToFrac :: NominalDiffTime -> Double)
+
+instance ToGraphQL UTCTime
+  where
+    toGraphQL = Type.String . Text.pack . iso8601Show
+
 -- | Instances of this typeclass can be used to convert GraphQL internal
 -- representation to user-defined type.
 class FromGraphQL a
@@ -194,3 +221,23 @@ instance FromGraphQL Scientific
   where
     fromGraphQL (Type.Float value) = Just $ realToFrac value
     fromGraphQL _ = Nothing
+
+instance FromGraphQL Day
+  where
+    fromGraphQL (Type.String value') = formatParseM iso8601Format $ Text.unpack value'
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL DiffTime
+  where
+    fromGraphQL (Type.Int value') = Just $ secondsToDiffTime $ fromIntegral value'
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL NominalDiffTime
+  where
+    fromGraphQL (Type.Int value') = Just $ secondsToNominalDiffTime $ fromIntegral value'
+    fromGraphQL _ = Nothing
+
+instance FromGraphQL UTCTime
+  where
+    fromGraphQL (Type.String value') = formatParseM iso8601Format $ Text.unpack value'
+    fromGraphQL _ = Nothing
diff --git a/tests/Language/GraphQL/ClassSpec.hs b/tests/Language/GraphQL/ClassSpec.hs
index 087abd0..a5ed41f 100644
--- a/tests/Language/GraphQL/ClassSpec.hs
+++ b/tests/Language/GraphQL/ClassSpec.hs
@@ -8,6 +8,8 @@ module Language.GraphQL.ClassSpec
     ) where
 
 import Data.Text (Text)
+import Data.Time (UTCTime(..))
+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
 import qualified Language.GraphQL.Type as Type
 import Language.GraphQL.Class (FromGraphQL(..), ToGraphQL(..))
 import Test.Hspec (Spec, describe, it, shouldBe)
@@ -30,6 +32,15 @@ spec = do
         it "converts singleton lists" $
             toGraphQL [True] `shouldBe` Type.List [Type.Boolean True]
 
+        it "converts UTCTime" $
+            let given = UTCTime
+                    { utctDay = fromOrdinalDate 2023 5
+                    , utctDayTime = 90
+                    }
+                actual = toGraphQL given
+                expected = Type.String "2023-01-05T00:01:30Z"
+             in actual `shouldBe` expected
+
     describe "FromGraphQL" $ do
         it "converts integers" $
             fromGraphQL (Type.Int 5) `shouldBe` Just (5 :: Int)
@@ -45,3 +56,12 @@ spec = do
 
         it "converts singleton lists" $
             fromGraphQL (Type.List [Type.Boolean True]) `shouldBe` Just [True]
+
+        it "converts UTCTime" $
+            let given = Type.String "2023-01-05T00:01:30Z"
+                expected = Just $ UTCTime
+                    { utctDay = fromOrdinalDate 2023 5
+                    , utctDayTime = 90
+                    }
+                actual = fromGraphQL given
+             in actual `shouldBe` expected