eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source 
# Conflicts:
#	servant-server/servant-server.cabal
#	servant-server/test/Servant/ServerSpec.hs
#	servant/servant.cabal
#	servant/src/Servant/API.hs
This commit is contained in:
Alex Mason 2016-09-02 16:32:51 +10:00
commit e15737dd2f
5 changed files with 195 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
servant-server/servant-server.cabal
View file

@ -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

61
servant-server/test/Servant/ServerSpec.hs
View file

@ -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 {{{

6
servant/servant.cabal
View file

@ -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

3
servant/src/Servant/API.hs
View file

@ -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,

122
servant/src/Servant/API/Times.hs Normal file
View file

@ -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 }