diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index d055df2f..a5be18e2 100644 --- a/servant-server/servant-server.cabal +++ b/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 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2337c258..8bd049e8 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 {{{ diff --git a/servant/servant.cabal b/servant/servant.cabal index 3c89171f..1f1cb007 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index cbb0db09..bf0e102f 100644 --- a/servant/src/Servant/API.hs +++ b/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, diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs new file mode 100644 index 00000000..431414a9 --- /dev/null +++ b/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 }