Merge branch 'servant-dates' into servant-dates-new

# Conflicts:
#	servant-server/servant-server.cabal
#	servant-server/test/Servant/ServerSpec.hs
#	servant/servant.cabal
#	servant/src/Servant/API.hs

servant-server/servant-server.cabal

@@ -70,6 +70,11 @@ library
       , wai-app-static     >= 3.1  && < 3.2
       , warp               >= 3.0  && < 3.3
       , word8              >= 0.1  && < 0.2
+  if impl(ghc < 7.10)
+    build-depends: old-locale >= 1.0 && < 1.1
+                   , time >= 1.4 && < 1.5
+  else
+    build-depends: time >= 1.5 && < 1.6
 
   hs-source-dirs: src
   default-language: Haskell2010
@@ -136,6 +141,7 @@ test-suite spec
     , wai
     , wai-extra
     , warp
+    , time
 
 test-suite doctests
  build-depends: base

servant-server/test/Servant/ServerSpec.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
@@ -46,7 +45,8 @@ import           Servant.API                ((:<|>) (..), (:>), AuthProtect,
                                              Post, Put,
                                              QueryFlag, QueryParam, QueryParams,
                                              Raw, RemoteHost, ReqBody,
-                                             StdMethod (..), Verb, addHeader)
+                                             StdMethod (..), Verb, addHeader,
+                                             FTime(..))
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Server             (Server, Handler, err401, err403,
                                              err404, serve, serveWithContext,
@@ -65,7 +65,11 @@ import           Servant.Server.Experimental.Auth
                                              mkAuthHandler)
 import           Servant.Server.Internal.Context
                                             (NamedContext(..))
-
+import           Data.Time.Calendar         (Day, fromGregorian)
+import           Data.Time.LocalTime        (LocalTime(..), hoursToTimeZone,
+                                             localTimeToUTC, makeTimeOfDayValid)
+import           Data.Time.Clock            (UTCTime)
+import           Data.ByteString.Lazy       (ByteString)
 -- * comprehensive api test
 
 -- This declaration simply checks that all instances are in place.
@@ -80,6 +84,7 @@ spec :: Spec
 spec = do
   verbSpec
   captureSpec
+  captureTimeSpec
   queryParamSpec
   reqBodySpec
   headerSpec
@@ -217,6 +222,7 @@ captureSpec = do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
 
 -- }}}
+
 ------------------------------------------------------------------------------
 -- * captureAllSpec {{{
 ------------------------------------------------------------------------------
@@ -268,6 +274,55 @@ captureAllSpec = do
       it "consumes everything from pathInfo" $ do
         get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
 
+-- }}}
+------------------------------------------------------------------------------
+-- * timeCaptureSpec {{{
+------------------------------------------------------------------------------
+
+type TimeFormatWSpace = "%Y-%m-%d %H:%M:%S%Z"
+
+type CaptureTimeApi = (Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[PlainText] String)
+                      :<|>
+                      ("datetime" :> Capture "datetime" (FTime TimeFormatWSpace UTCTime) :> Get '[PlainText] String)
+captureTimeApi :: Proxy CaptureTimeApi
+captureTimeApi = Proxy
+captureDateServer :: FTime "%Y-%m-%d" Day -> Handler String
+captureDateServer = return . show
+captureDateTimeServer :: FTime TimeFormatWSpace UTCTime -> Handler String
+captureDateTimeServer = return . show
+
+
+
+captureTimeSpec :: Spec
+captureTimeSpec = do
+  describe "Servant.API.Times(CaptureTime)" $ do
+    with (return (serve captureTimeApi (captureDateServer :<|> captureDateTimeServer))) $ do
+
+      it "can capture parts of the 'pathInfo' (date only)" $ do
+        response <- get "/2015-12-02"
+        liftIO $ simpleBody response `shouldBe` (fromString . show $ fromGregorian 2015 12 2 :: ByteString)
+
+      it "can capture parts of the 'pathInfo' (date and time with a space)" $ do
+        let day       =  fromGregorian 2015 12 2
+            Just time =  makeTimeOfDayValid 12 34 56
+            tz        =  hoursToTimeZone 10
+            utcT      =  localTimeToUTC tz (LocalTime day time)
+            ftime     :: FTime TimeFormatWSpace UTCTime
+            ftime     =  FTime utcT
+        response <- get "/datetime/2015-12-02%2012:34:56+1000"
+        liftIO $ simpleBody response `shouldBe` (fromString . show $ ftime)
+
+
+      it "returns 404 if the decoding fails" $ do
+        get "/notAnInt" `shouldRespondWith` 404
+
+    with (return (serve
+        (Proxy :: Proxy (Capture "datetime" (FTime TimeFormatWSpace UTCTime) :> Raw))
+        (\ (FTime _day) request_ respond ->
+            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+      it "strips the captured path snippet from pathInfo" $ do
+        get "/2015-12-02%2012:34:56+1000/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * queryParamSpec {{{

servant/servant.cabal

@@ -43,6 +43,7 @@ library
     Servant.API.ReqBody
     Servant.API.ResponseHeaders
     Servant.API.Sub
+    Servant.API.Times
     Servant.API.Vault
     Servant.API.Verbs
     Servant.API.WithNamedContext
@@ -65,6 +66,11 @@ library
     , string-conversions    >= 0.3  && < 0.5
     , network-uri           >= 2.6  && < 2.7
     , vault                 >= 0.3  && < 0.4
+  if impl(ghc < 7.10)
+    build-depends: old-locale >= 1.0 && < 1.1
+                   , time >= 1.4 && < 1.5
+  else
+    build-depends: time >= 1.5 && < 1.6
   hs-source-dirs: src
   default-language: Haskell2010
   other-extensions: CPP

servant/src/Servant/API.hs

@@ -25,6 +25,8 @@ module Servant.API (
   -- | Access the location for arbitrary data to be shared by applications and middleware
   module Servant.API.WithNamedContext,
   -- | Access context entries in combinators in servant-server
+  module Servant.API.Times,
+  -- | Capturing dates and times in URLs and params with specified formats.
 
   -- * Actual endpoints, distinguished by HTTP method
   module Servant.API.Verbs,
@@ -81,6 +83,7 @@ import           Servant.API.ResponseHeaders (AddHeader (addHeader),
                                               HList (..), Headers (..),
                                               getHeadersHList, getResponse)
 import           Servant.API.Sub             ((:>))
+import           Servant.API.Times           (FTime(..), getFormat, renderFTime, parseFTime)
 import           Servant.API.Vault           (Vault)
 import           Servant.API.Verbs           (PostCreated, Delete, DeleteAccepted,
                                               DeleteNoContent,

servant/src/Servant/API/Times.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Servant.API.Times
+    ( FTime(..)
+    , toFormatProxy
+    , getFormat
+    , renderFTime
+    , parseFTime
+    , ISO8601Date
+    , ISO8601DateTime
+    , ISO8601DateTimeZ
+    ) where
+
+import           Data.Typeable    (Typeable)
+import           GHC.TypeLits     (Symbol,KnownSymbol,symbolVal)
+import           Web.HttpApiData
+import qualified Data.Time.Format as T
+#if !MIN_VERSION_time(1,5,0)
+import qualified System.Locale    as T
+#endif
+import           Data.Text        (pack, Text)
+import           Data.Proxy
+import           Control.Monad    ((>=>))
+import           Control.Arrow    (first)
+
+
+type ISO8601Date      = "%Y-%m-%d"
+type ISO8601DateTime  = "%Y-%m-%dT%H:%M:%S"
+type ISO8601DateTimeZ = "%Y-%m-%dT%H:%M:%S%z"
+
+-- | An `FTime` is a wrapper around a time type which can be
+-- parsed/rendered with `format', as specified in "Data.Time.Format".
+--
+-- Example:
+--
+-- >>>            -- GET /events/:date
+-- >>> type MyApi = "events" :> Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[JSON] [Event]
+--
+-- __Note:__ Time Zones parsed in the @%z@ format (@±HHMM@) need to ensure that the @+@ symbol is
+-- url encoded (@%2B@) in requests, as the @+@ symbol is interpreted as a space in query params.
+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) (renderFTime t ++)
+
+instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where
+  readsPrec i str = res where
+    fmt = symbolVal (Proxy :: Proxy format)
+    res = fmap (first FTime)
+               (readParen (i > 1)
+                          (rtime T.defaultTimeLocale fmt)
+                          str)
+
+
+instance (KnownSymbol format, T.FormatTime t) => ToHttpApiData (FTime format t) where
+  toUrlPiece   = toUrlPiece   . renderFTime
+  toHeader     = toHeader     . renderFTime
+  toQueryParam = toQueryParam . renderFTime
+
+
+instance (KnownSymbol format, T.ParseTime t) => FromHttpApiData (FTime format t) where
+  parseUrlPiece   = parseUrlPiece   >=> parseFTime
+  parseHeader     = parseHeader     >=> parseFTime
+  parseQueryParam = parseQueryParam >=> parseFTime
+
+
+toFormatProxy :: FTime format t -> Proxy format
+toFormatProxy _ = Proxy
+
+-- | Returns the sttring representation of the type level @format@ string
+--
+-- >>> getFormat (undefined :: FTime ISO8601Date UTCTime)
+-- "%Y-%m-%d"
+getFormat :: KnownSymbol format => FTime format t -> String
+getFormat t = symbolVal (toFormatProxy t)
+
+-- | Renders an @FTime format t@ using the format `format'.
+--
+-- >>> renderFTime (FTime (fromGregorian 2016 9 2) :: FTime ISO8601Date Day)
+-- "2016-09-02"
+renderFTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String
+renderFTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t
+
+parseFTime :: (KnownSymbol format, T.ParseTime t) => String -> Either Text (FTime format t)
+parseFTime str = res where
+  res = case ptime T.defaultTimeLocale fmt str of
+      Nothing -> Left . pack $ "Could not parse time string \""
+                             ++ str ++ "\" with format \"" ++ fmt ++ "\""
+      Just t -> Right (FTime t)
+
+  fmt = symbolVal (toFTimeTy res)
+
+  toFTimeTy :: Either Text (FTime format t) -> Proxy format
+  toFTimeTy _ = Proxy
+
+
+ptime :: T.ParseTime t => T.TimeLocale -> String -> String -> Maybe t
+rtime :: T.ParseTime t => T.TimeLocale -> String -> ReadS t
+#if !MIN_VERSION_time(1,5,0)
+ptime = T.parseTime
+rtime = T.readsTime
+#else
+ptime = T.parseTimeM False
+rtime = T.readSTime False
+#endif
+
+-- $setup
+-- >>> import Servant.API
+-- >>> import Data.Aeson
+-- >>> import Data.Text
+-- >>> import Data.Time.Calendar
+-- >>> import Data.Time.Clock (UTCTime)
+-- >>> data Event
+-- >>> instance ToJSON Event where { toJSON = undefined }