diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Changelog +## 0.33 + +* Added a `Rest.Types.Error.ToResponseCode` constraint to `jsonE`, `xmlE`, and `xmlJsonE`. +* Changed `domainReason` to have a `ToResponseCode` constraint instead of an explicit argument. +* Added `Rest.ShowUrl` re-exporting `ShowUrl` from `rest-types`. +* `application/*` and `application/octet-stream` accept headers now match file outputs. + #### 0.32.0.2 * Allow random 1.1.* diff --git a/rest-core.cabal b/rest-core.cabal --- a/rest-core.cabal +++ b/rest-core.cabal @@ -1,5 +1,5 @@ name: rest-core -version: 0.32.0.2 +version: 0.33 description: Rest API library. synopsis: Rest API library. maintainer: code@silk.co @@ -37,6 +37,7 @@ Rest.Resource Rest.Run Rest.Schema + Rest.ShowUrl build-depends: base >= 4.5 && < 4.8 , aeson >= 0.7 && < 0.9 @@ -52,7 +53,7 @@ , multipart >= 0.1.1 && < 0.2 , random >= 1.0 && < 1.2 , rest-stringmap == 0.2.* - , rest-types == 1.10.* + , rest-types == 1.11.* , safe >= 0.2 && < 0.4 , split >= 0.1 && < 0.3 , text >= 0.11 && < 1.3 diff --git a/src/Rest/Dictionary/Combinators.hs b/src/Rest/Dictionary/Combinators.hs --- a/src/Rest/Dictionary/Combinators.hs +++ b/src/Rest/Dictionary/Combinators.hs @@ -61,6 +61,7 @@ import Rest.Dictionary.Types import Rest.Info +import Rest.Types.Error -- | Set custom sub-dictionary for recognizing headers. @@ -166,12 +167,12 @@ -- | Allow error output as JSON using the `Json` type class. -jsonE :: (Typeable e, ToJSON e, JSONSchema e) => Dict h p i o e -> Dict h p i o e +jsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e) => Dict h p i o e -> Dict h p i o e jsonE = L.modify (dicts . errors) (JsonE:) -- | Allow error output as XML using the `XmlPickler` type class. -xmlE :: (Typeable e, XmlPickler e) => Dict h p i o e -> Dict h p i o e +xmlE :: (ToResponseCode e, Typeable e, XmlPickler e) => Dict h p i o e -> Dict h p i o e xmlE = L.modify (dicts . errors) (XmlE:) -- | The input can be read into some instance of both `Json` and `XmlPickler`. @@ -188,7 +189,7 @@ -- | Allow error output as JSON using the `Json` type class and allow output as -- XML using the `XmlPickler` type class. -xmlJsonE :: (Typeable e, ToJSON e, JSONSchema e, XmlPickler e) => Dict h p i o () -> Dict h p i o e +xmlJsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e, XmlPickler e) => Dict h p i o () -> Dict h p i o e xmlJsonE = xmlE . jsonE . someE -- | The input can be read into some instance of both `Json` and `XmlPickler` diff --git a/src/Rest/Dictionary/Types.hs b/src/Rest/Dictionary/Types.hs --- a/src/Rest/Dictionary/Types.hs +++ b/src/Rest/Dictionary/Types.hs @@ -1,9 +1,9 @@ {-# LANGUAGE - GADTs + FlexibleContexts + , GADTs , StandaloneDeriving , TemplateHaskell , TypeOperators - , FlexibleContexts #-} module Rest.Dictionary.Types ( @@ -160,8 +160,8 @@ -- error value to a response body. data Error e where - JsonE :: (Typeable e, ToJSON e, JSONSchema e) => Error e - XmlE :: (Typeable e, XmlPickler e) => Error e + JsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e) => Error e + XmlE :: (ToResponseCode e, Typeable e, XmlPickler e) => Error e deriving instance Show (Error e) deriving instance Eq (Error e) diff --git a/src/Rest/Driver/Perform.hs b/src/Rest/Driver/Perform.hs --- a/src/Rest/Driver/Perform.hs +++ b/src/Rest/Driver/Perform.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE RankNTypes - , GADTs - , ScopedTypeVariables - , OverloadedStrings - #-} +{-# LANGUAGE + GADTs + , OverloadedStrings + , RankNTypes + , ScopedTypeVariables + #-} module Rest.Driver.Perform where import Control.Applicative @@ -22,7 +23,7 @@ import Data.Maybe import Data.Text.Lazy.Encoding (decodeUtf8) import Data.UUID (UUID) -import Network.Multipart (showMultipartBody, MultiPart(..), BodyPart (..)) +import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody) import Safe import System.IO.Unsafe import System.Random (randomIO) @@ -33,10 +34,7 @@ import qualified Data.ByteString.Lazy.UTF8 as UTF8 import qualified Data.Label.Total as L -import Rest.Dictionary ( Dict, Format (..) - , Param (..), Header (..), Input (..), Output (..), Error (..) - , Dicts (..), Inputs, Outputs, Errors - ) +import Rest.Dictionary (Dict, Dicts (..), Error (..), Errors, Format (..), Header (..), Input (..), Inputs, Output (..), Outputs, Param (..)) import Rest.Driver.Types import Rest.Error import Rest.Handler @@ -229,14 +227,14 @@ ) where tryPrint :: forall m e. Rest m => Reason e -> Errors e -> Format -> MaybeT m UTF8.ByteString - tryPrint e None JsonFormat = printError JsonFormat (toRespCode e) (encode e) - tryPrint e None XmlFormat = printError XmlFormat (toRespCode e) (UTF8.fromString (toXML e)) + tryPrint e None JsonFormat = printError JsonFormat (toResponseCode e) (encode e) + tryPrint e None XmlFormat = printError XmlFormat (toResponseCode e) (UTF8.fromString (toXML e)) tryPrint _ None _ = mzero tryPrint e (Dicts ds) f = tryPrintD ds f where tryPrintD :: Rest m => [D.Error e] -> Format -> MaybeT m UTF8.ByteString - tryPrintD (JsonE : _ ) JsonFormat = printError JsonFormat (toRespCode e) (encode e) - tryPrintD (XmlE : _ ) XmlFormat = printError XmlFormat (toRespCode e) (UTF8.fromString (toXML e)) + tryPrintD (JsonE : _ ) JsonFormat = printError JsonFormat (toResponseCode e) (encode e) + tryPrintD (XmlE : _ ) XmlFormat = printError XmlFormat (toResponseCode e) (UTF8.fromString (toXML e)) tryPrintD (_ : xs) t = tryPrintD xs t tryPrintD [] _ = mzero @@ -245,7 +243,7 @@ setResponseCode cd return x - printFallback fs = printError XmlFormat (toRespCode (fallbackError fs)) (UTF8.fromString (toXML $ fallbackError fs)) + printFallback fs = printError XmlFormat (toResponseCode (fallbackError fs)) (UTF8.fromString (toXML $ fallbackError fs)) fallbackError :: [Format] -> Reason_ fallbackError fs = OutputError (UnsupportedFormat $ intercalate "," $ map formatCT fs) @@ -261,24 +259,6 @@ fromMaybeT def = runMaybeT >=> maybe def return - toRespCode e = - case e of - NotFound -> 404 - UnsupportedRoute -> 404 - UnsupportedMethod -> 404 - UnsupportedVersion -> 404 - NotAllowed -> 403 - AuthenticationFailed -> 401 - Busy -> 503 - Gone -> 410 - OutputError (UnsupportedFormat _) -> 406 - InputError _ -> 400 - OutputError _ -> 500 - IdentError _ -> 400 - HeaderError _ -> 400 - ParamError _ -> 400 - CustomReason (DomainReason r _) -> r - ------------------------------------------------------------------------------- -- Printing the output resource. @@ -379,13 +359,14 @@ trim = f . f where f = reverse . dropWhile isSpace - txt "*" = [XmlFormat, JsonFormat, StringFormat] - txt "json" = [JsonFormat] - txt "xml" = [XmlFormat] - txt "plain" = [StringFormat] - txt _ = [] - app "*" = [XmlFormat, JsonFormat] - app "xml" = [XmlFormat] - app "json" = [JsonFormat] - app _ = [] - img _ = [FileFormat] + txt "*" = [XmlFormat, JsonFormat, StringFormat] + txt "json" = [JsonFormat] + txt "xml" = [XmlFormat] + txt "plain" = [StringFormat] + txt _ = [] + app "*" = [XmlFormat, JsonFormat, FileFormat] + app "xml" = [XmlFormat] + app "json" = [JsonFormat] + app "octet-stream" = [FileFormat] + app _ = [] + img _ = [FileFormat] diff --git a/src/Rest/Error.hs b/src/Rest/Error.hs --- a/src/Rest/Error.hs +++ b/src/Rest/Error.hs @@ -1,11 +1,11 @@ {-# LANGUAGE - TemplateHaskell + DeriveDataTypeable , EmptyDataDecls - , TypeFamilies , GADTs , ScopedTypeVariables , StandaloneDeriving - , DeriveDataTypeable + , TemplateHaskell + , TypeFamilies #-} -- | Error types that can be returned by handlers, as well as some -- utilities for manipulating these errors. @@ -40,8 +40,8 @@ eitherToStatus (Left e) = Failure e eitherToStatus (Right e) = Success e --- | Wrap your custom error type in a 'Reason'. The first argument is --- a function for converting your error to an HTTP status code. - -domainReason :: (a -> Int) -> a -> Reason a -domainReason f x = CustomReason (DomainReason (f x) x) +-- | Wrap your custom error type in a 'Reason'. +-- This requires the ToResponseCode dictionary to pick a response code when +-- the error is served. +domainReason :: ToResponseCode a => a -> Reason a +domainReason = CustomReason . DomainReason diff --git a/src/Rest/Info.hs b/src/Rest/Info.hs --- a/src/Rest/Info.hs +++ b/src/Rest/Info.hs @@ -1,31 +1,4 @@ -- | Module facilitating informative inspection of datatypes. - -{-# LANGUAGE - FlexibleInstances - , TypeSynonymInstances - #-} -module Rest.Info where - -import Data.Text (Text) -import Data.Typeable - --- | Type class representing information about the read/show function on a data --- type. - -class Typeable a => Info a where - describe :: proxy a -> String - example :: proxy a -> String - example _ = "" - -instance Info String where - describe _ = "string" - -instance Info Text where - describe _ = "string" - -instance Info Int where - describe _ = "integer" - -instance Info Integer where - describe _ = "integer" +module Rest.Info ( module Rest.Types.Info ) where +import Rest.Types.Info diff --git a/src/Rest/Resource.hs b/src/Rest/Resource.hs --- a/src/Rest/Resource.hs +++ b/src/Rest/Resource.hs @@ -98,3 +98,4 @@ -- can't be routed to. It contains no values apart from bottom. newtype Void = Void { magic :: forall a. a } + diff --git a/src/Rest/ShowUrl.hs b/src/Rest/ShowUrl.hs new file mode 100644 --- /dev/null +++ b/src/Rest/ShowUrl.hs @@ -0,0 +1,3 @@ +module Rest.ShowUrl (module Rest.Types.ShowUrl) where + +import Rest.Types.ShowUrl