From 74ebec91764b57f8eb0b716fb7c1753649587986 Mon Sep 17 00:00:00 2001
From: Alex Mason <Alex.Mason@nicta.com.au>
Date: Thu, 3 Dec 2015 14:31:44 +1100
Subject: [PATCH] Reimplement time handling using a new type which carries a
 format string in its type.

---
 servant/servant.cabal            |  1 +
 servant/src/Servant/API.hs       |  2 +-
 servant/src/Servant/API/Times.hs | 83 ++++++++++++++++++++++++++------
 3 files changed, 71 insertions(+), 15 deletions(-)

diff --git a/servant/servant.cabal b/servant/servant.cabal
index 8cac1e7e..2a8f747f 100644
--- a/servant/servant.cabal
+++ b/servant/servant.cabal
@@ -59,6 +59,7 @@ library
     , string-conversions >= 0.3 && < 0.5
     , network-uri >= 2.6
     , vault >= 0.3 && <0.4
+    , time >= 1.5 && < 1.6
   hs-source-dirs: src
   default-language: Haskell2010
   other-extensions: CPP
diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs
index 635c8b1d..695471b0 100644
--- a/servant/src/Servant/API.hs
+++ b/servant/src/Servant/API.hs
@@ -87,7 +87,7 @@ import           Servant.API.ResponseHeaders (AddHeader (addHeader),
                                               HList (..), Headers (..),
                                               getHeadersHList, getResponse)
 import           Servant.API.Sub             ((:>))
-import           Servant.API.Times           (CaptureTime, QueryParamTime, QueryParamTimes)
+import           Servant.API.Times           (FTime(..), toProxy, getFormat, renderTime, parseTime)
 import           Servant.API.Vault           (Vault)
 import           Web.HttpApiData             (FromHttpApiData (..), ToHttpApiData (..))
 import           Servant.Utils.Links         (HasLink (..), IsElem, IsElem',
diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs
index a3a15b1f..64ebe14b 100644
--- a/servant/src/Servant/API/Times.hs
+++ b/servant/src/Servant/API/Times.hs
@@ -6,33 +6,88 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Servant.API.Times where
+module Servant.API.Times
+    ( FTime(..)
+    , toProxy
+    , getFormat
+    , renderTime
+    , parseTime
+    ) where
 
 import           Data.Typeable (Typeable)
-import           GHC.TypeLits  (Symbol)
+import           GHC.TypeLits  -- (Symbol)
+import           Web.HttpApiData
+import qualified Data.Time.Format as T
+import           Data.Text (pack, Text)
+import           Data.Proxy
+import           Control.Monad ((>=>))
+import           Control.Arrow (first)
 
-
--- | Capture data/time value from a path in the `format', as understood
--- by 'Data.Time.Format.
+-- | A wrapper around a time type which can be parsed/rendered to with `format',
+-- as specified in 'Data.Time.Format'.
 --
 -- Example:
 -- >>>            -- GET /events/:date
--- >>> type MyApi = "events" :> CaptureTime "date" "%Y-%m-%d" Day :> Get '[JSON] Book
-data CaptureTime (sym :: Symbol) (format :: Symbol) a
-    deriving (Typeable)
+-- >>> type MyApi = "events" :> Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[JSON] [Event]
+newtype FTime (format :: Symbol) t = FTime {getFTime :: t}
+    deriving (Typeable, Eq, Ord)
+
+instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where
+    showsPrec i t = showParen (i > 1) (\str -> renderTime t ++ str)
+
+instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where
+    readsPrec i str = res
+        where
+            res = fmap (first FTime)
+                       (readParen (i > 1)
+                                  (T.readSTime False T.defaultTimeLocale fmt)
+                                  str
+                        )
+
+            toFTimeTy :: [(FTime format t, String)] -> FTime format t
+            toFTimeTy _ = undefined
+
+            fmt = getFormat (toFTimeTy res)
 
 
-data QueryParamTime (sym :: Symbol) (format :: Symbol) a
-    deriving (Typeable)
+
+instance (KnownSymbol format, T.FormatTime t) => ToHttpApiData (FTime format t) where
+    toUrlPiece   = toUrlPiece   . renderTime
+    toHeader     = toHeader     . renderTime
+    toQueryParam = toQueryParam . renderTime
 
 
-data QueryParamTimes (sym :: Symbol) (format :: Symbol) a
-    deriving (Typeable)
+instance (KnownSymbol format, T.ParseTime t) => FromHttpApiData (FTime format t) where
+    parseUrlPiece   = parseUrlPiece   >=> parseTime
+    parseHeader     = parseHeader     >=> parseTime
+    parseQueryParam = parseQueryParam >=> parseTime
+
+
+toProxy :: FTime format t -> Proxy format
+toProxy _ = Proxy
+
+getFormat :: KnownSymbol format => FTime format t -> String
+getFormat t = symbolVal (toProxy t)
+
+renderTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String
+renderTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t
+
+parseTime :: (KnownSymbol format, T.ParseTime t) => String -> Either Text (FTime format t)
+parseTime str = res
+    where
+        res = case T.parseTimeM False T.defaultTimeLocale fmt str of
+            Nothing -> Left . pack $ "Could not parse time string \"" ++ str ++ "\" with format \"" ++ fmt ++ "\""
+            Just t -> Right (FTime t)
+
+        fmt = getFormat (toFTimeTy res)
+
+        toFTimeTy :: Either Text (FTime format t) -> FTime format a
+        toFTimeTy _ = undefined
 
 -- $setup
 -- >>> import Servant.API
 -- >>> import Data.Aeson
 -- >>> import Data.Text
 -- >>> import Data.Time.Calendar
--- >>> data Book
--- >>> instance ToJSON Book where { toJSON = undefined }
+-- >>> data Event
+-- >>> instance ToJSON Event where { toJSON = undefined }