diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -1,10 +1,10 @@ name: servant -version: 0.4.0 +version: 0.4.1 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in guide. + You can learn about the basics in the . . 's a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using the package. @@ -107,6 +107,8 @@ , servant , doctest , filemanip + , directory + , filepath type: exitcode-stdio-1.0 main-is: test/Doctests.hs buildable: True diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -66,29 +66,31 @@ ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<*)) +import Control.Applicative ((*>), (<*)) #endif -import Control.Arrow (left) +import Control.Arrow (left) import Control.Monad -import Data.Aeson (FromJSON, ToJSON, Value, - encode, parseJSON) -import Data.Aeson.Parser (value) -import Data.Aeson.Types (parseEither) -import Data.Attoparsec.ByteString (endOfInput, parseOnly) -import qualified Data.ByteString as BS -import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) -import qualified Data.ByteString.Lazy as B +import Data.Aeson (FromJSON, ToJSON, encode, + parseJSON) +import Data.Aeson.Parser (value) +import Data.Aeson.Types (parseEither) +import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, + skipSpace, ()) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString, fromStrict, + toStrict) +import qualified Data.ByteString.Lazy as B import Data.Monoid -import Data.String.Conversions (cs) -import qualified Data.Text as TextS -import qualified Data.Text.Encoding as TextS -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL +import Data.String.Conversions (cs) +import qualified Data.Text as TextS +import qualified Data.Text.Encoding as TextS +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable -import GHC.Exts (Constraint) -import qualified Network.HTTP.Media as M -import Network.URI (escapeURIString, isUnreserved, - unEscapeString) +import GHC.Exts (Constraint) +import qualified Network.HTTP.Media as M +import Network.URI (escapeURIString, + isUnreserved, unEscapeString) -- * Provided content types data JSON deriving Typeable @@ -291,10 +293,22 @@ -- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just -- objects and arrays. +-- +-- Will handle trailing whitespace, but not trailing junk. ie. +-- +-- >>> eitherDecodeLenient "1 " :: Either String Int +-- Right 1 +-- +-- >>> eitherDecodeLenient "1 junk" :: Either String Int +-- Left "trailing junk after valid JSON: endOfInput" eitherDecodeLenient :: FromJSON a => ByteString -> Either String a -eitherDecodeLenient input = do - v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) - parseEither parseJSON v +eitherDecodeLenient input = + parseOnly parser (cs input) >>= parseEither parseJSON + where + parser = skipSpace + *> Data.Aeson.Parser.value + <* skipSpace + <* (endOfInput "trailing junk after valid JSON") -- | `eitherDecode` instance FromJSON a => MimeUnrender JSON a where diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -72,8 +72,7 @@ -- -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) -- >>> safeLink api bad_link --- --- :64:1: +-- ... -- Could not deduce (Or -- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) -- (IsElem' @@ -138,15 +137,17 @@ -- | If either a or b produce an empty constraint, produce an empty constraint. type family Or (a :: Constraint) (b :: Constraint) :: Constraint where + -- This works because of: + -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap Or () b = () Or a () = () -- | If both a or b produce an empty constraint, produce an empty constraint. type family And (a :: Constraint) (b :: Constraint) :: Constraint where - And () () = () + And () () = () --- | You may use this type family to tell the type checker that your custom type --- may be skipped as part of a link. This is useful for things like +-- | You may use this type family to tell the type checker that your custom +-- type may be skipped as part of a link. This is useful for things like -- 'QueryParam' that are optional in a URI and do not affect them if they are -- omitted. -- @@ -162,30 +163,31 @@ -- | Closed type family, check if endpoint is within api type family IsElem endpoint api :: Constraint where - IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) - IsElem (e :> sa) (e :> sb) = IsElem sa sb - IsElem sa (Header x :> sb) = IsElem sa sb - IsElem sa (ReqBody y x :> sb) = IsElem sa sb - IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb - IsElem sa (QueryParam x y :> sb) = IsElem sa sb - IsElem sa (QueryParams x y :> sb) = IsElem sa sb - IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem sa (MatrixParam x y :> sb) = IsElem sa sb - IsElem sa (MatrixParams x y :> sb) = IsElem sa sb - IsElem sa (MatrixFlag x :> sb) = IsElem sa sb - IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' - IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' - IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' - IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' - IsElem e e = () - IsElem e a = IsElem' e a + IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) + IsElem (e :> sa) (e :> sb) = IsElem sa sb + IsElem sa (Header x :> sb) = IsElem sa sb + IsElem sa (ReqBody y x :> sb) = IsElem sa sb + IsElem (Capture z y :> sa) (Capture x y :> sb) + = IsElem sa sb + IsElem sa (QueryParam x y :> sb) = IsElem sa sb + IsElem sa (QueryParams x y :> sb) = IsElem sa sb + IsElem sa (QueryFlag x :> sb) = IsElem sa sb + IsElem sa (MatrixParam x y :> sb) = IsElem sa sb + IsElem sa (MatrixParams x y :> sb) = IsElem sa sb + IsElem sa (MatrixFlag x :> sb) = IsElem sa sb + IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' + IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' + IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' + IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' + IsElem e e = () + IsElem e a = IsElem' e a type family IsSubList a b :: Constraint where - IsSubList '[] b = () + IsSubList '[] b = () IsSubList '[x] (x ': xs) = () IsSubList '[x] (y ': ys) = IsSubList '[x] ys - IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y + IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y -- Phantom types for Param data Matrix diff --git a/test/Doctests.hs b/test/Doctests.hs --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -1,16 +1,29 @@ module Main where +import Data.List (isPrefixOf) +import System.Directory +import System.FilePath import System.FilePath.Find import Test.DocTest main :: IO () main = do files <- find always (extension ==? ".hs") "src" + cabalMacrosFile <- getCabalMacrosFile doctest $ [ "-isrc" , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" + , "-optP" ++ cabalMacrosFile , "-XOverloadedStrings" , "-XFlexibleInstances" , "-XMultiParamTypeClasses" ] ++ files +getCabalMacrosFile :: IO FilePath +getCabalMacrosFile = do + contents <- getDirectoryContents "dist" + let rest = "build" "autogen" "cabal_macros.h" + return $ case filter ("dist-sandbox-" `isPrefixOf`) contents of + [x] -> "dist" x rest + [] -> "dist" rest + xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n" + ++ show xs ++ "\nTry cabal clean"