packages feed

rest-core 0.37 → 0.38

raw patch · 13 files changed

+221/−135 lines, 13 filesdep +base-compatdep ~aesondep ~base

Dependencies added: base-compat

Dependency ranges changed: aeson, base

Files

CHANGELOG.md view
@@ -1,5 +1,10 @@ # Changelog +## 0.38++* Add `RawJsonO`, `RawJsonI`, `RawJsonAndXmlI`, and `RawJsonAndXmlO`.+* Remove Show constraint from ReadId+ ## 0.37  * Allow specifying custom multi-action. Previously there was always a
rest-core.cabal view
@@ -1,5 +1,5 @@ name:                rest-core-version:             0.37+version:             0.38 description:         Rest API library. synopsis:            Rest API library. maintainer:          code@silk.co@@ -43,9 +43,10 @@       base >= 4.5 && < 4.9     , aeson >= 0.7 && < 0.11     , aeson-utils >= 0.2 && < 0.4+    , base-compat >= 0.8 && < 0.10     , bytestring >= 0.9 && < 0.11     , case-insensitive >= 1.2 && < 1.3-    , errors >= 1.4 && < 2.1+    , errors >= 1.4 && < 2.2     , fclabels == 2.0.*     , hxt >= 9.2 && < 9.4     , hxt-pickle-utils == 0.1.*@@ -59,8 +60,8 @@     , safe >= 0.2 && < 0.4     , split >= 0.1 && < 0.3     , text >= 0.11 && < 1.3-    , transformers >= 0.2 && < 0.5-    , transformers-compat >= 0.3 && < 0.5+    , transformers >= 0.2 && < 0.6+    , transformers-compat >= 0.3 && < 0.6     , unordered-containers == 0.2.*     , uri-encode == 1.5.*     , utf8-string >= 0.3 && < 1.1@@ -79,6 +80,6 @@     , rest-core     , test-framework == 0.8.*     , test-framework-hunit == 0.3.*-    , transformers >= 0.3 && < 0.5-    , transformers-compat >= 0.3 && < 0.5+    , transformers >= 0.3 && < 0.6+    , transformers-compat >= 0.3 && < 0.6     , unordered-containers == 0.2.*
src/Rest.hs view
@@ -9,6 +9,7 @@   , module Rest.Schema     -- | Defining 'Handler's for endpoints in the resource.   , module Rest.Handler+  , module Rest.Dictionary.Types     -- | Combinators for defining input and ouput dictionaries of     -- handlers.   , module Rest.Dictionary.Combinators@@ -16,6 +17,7 @@   , module Rest.Error   ) where +import Rest.Dictionary.Types (Json (..), Xml (..)) import Rest.Dictionary.Combinators import Rest.Error import Rest.Handler ( Env (..), Handler, ListHandler, secureHandler
src/Rest/Api.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE     GADTs   , KindSignatures+  , NoImplicitPrelude   #-} -- | This module allows you to combine 'Resource's into an 'Api'. This -- can then be served using 'rest-happstack' or 'rest-snap', or used@@ -32,7 +33,8 @@   , withVersion   ) where -import Control.Applicative (Applicative)+import Prelude.Compat+ import Data.Char import Data.Function (on) import Data.List (sortBy)
src/Rest/Container.hs view
@@ -27,7 +27,7 @@ import Rest.Types.Container import Rest.Types.Void -listI :: Inputs i -> Maybe (Inputs (Just (List (FromMaybe () i))))+listI :: Inputs i -> Maybe (Inputs ('Just (List (FromMaybe () i)))) listI None       = Just (Dicts [XmlI, JsonI]) listI (Dicts is) =   case mapMaybe listDictI is of@@ -39,7 +39,7 @@     listDictI JsonI = Just JsonI     listDictI _     = Nothing -listO :: Outputs o -> Maybe (Outputs (Just (List (FromMaybe () o))))+listO :: Outputs o -> Maybe (Outputs ('Just (List (FromMaybe () o)))) listO None       = Just (Dicts [XmlO, JsonO]) listO (Dicts os) =   case mapMaybe listDictO os of@@ -51,7 +51,7 @@     listDictO JsonO = Just JsonO     listDictO _     = Nothing -mappingI :: forall i i'. i ~ FromMaybe () i' => Inputs i' -> Maybe (Inputs (Just (StringHashMap String i)))+mappingI :: forall i i'. i ~ FromMaybe () i' => Inputs i' -> Maybe (Inputs ('Just (StringHashMap String i))) mappingI None       = Just (Dicts [XmlI, JsonI]) mappingI (Dicts is) =   case mapMaybe mappingDictI is of@@ -63,7 +63,7 @@     mappingDictI JsonI = Just JsonI     mappingDictI _     = Nothing -mappingO :: forall o o'. o ~ FromMaybe () o' => Outputs o' -> Maybe (Outputs (Just (StringHashMap String o)))+mappingO :: forall o o'. o ~ FromMaybe () o' => Outputs o' -> Maybe (Outputs ('Just (StringHashMap String o))) mappingO None       = Just (Dicts [XmlO, JsonO]) mappingO (Dicts os) =   case mapMaybe mappingDictO os of@@ -76,13 +76,13 @@     mappingDictO _     = Nothing  statusO :: (e ~ FromMaybe Void e', o ~ FromMaybe () o')-        => Errors e' -> Outputs o' -> Maybe (Outputs (Just (Status e o)))+        => Errors e' -> Outputs o' -> Maybe (Outputs ('Just (Status e o))) statusO None       None       = Just (Dicts [XmlO, JsonO]) statusO None       (Dicts os) = mkStatusDict [XmlE, JsonE] os statusO (Dicts es) None       = mkStatusDict es           [XmlO, JsonO] statusO (Dicts es) (Dicts os) = mkStatusDict es           os -mkStatusDict :: forall e o. [Error e] -> [Output o] -> Maybe (Outputs (Just (Status e o)))+mkStatusDict :: forall e o. [Error e] -> [Output o] -> Maybe (Outputs ('Just (Status e o))) mkStatusDict es os =     case mapMaybe mappingDictO (intersect es os) of       []  -> Nothing@@ -102,7 +102,7 @@     JsonE `eq` JsonO = True     _     `eq` _     = False -reasonE :: e ~ FromMaybe Void e' => Errors e' -> Errors (Just (Reason e))+reasonE :: e ~ FromMaybe Void e' => Errors e' -> Errors ('Just (Reason e)) reasonE None       = Dicts [XmlE, JsonE] reasonE (Dicts es) = Dicts (map reasonDictE es)   where@@ -110,5 +110,5 @@     reasonDictE XmlE  = XmlE     reasonDictE JsonE = JsonE -defaultE :: Errors (Just Reason_)+defaultE :: Errors ('Just Reason_) defaultE = Dicts [XmlE, JsonE]
src/Rest/Dictionary/Combinators.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE     DataKinds-  , TypeFamilies   , RankNTypes   , ScopedTypeVariables+  , TypeFamilies   #-} -- | Combinators for specifying the input/output dictionaries of a -- 'Handler'. The combinators can be combined using @(@'.'@)@.@@ -17,6 +17,8 @@   , xmlI   , rawXmlI   , jsonI+  , rawJsonI+  , rawJsonAndXmlI    -- ** Output dictionaries @@ -25,6 +27,8 @@   , xmlO   , rawXmlO   , jsonO+  , rawJsonO+  , rawJsonAndXmlO   , multipartO    -- ** Error dictionaries@@ -100,40 +104,52 @@  -- | Allow direct usage of as input as `String`. -stringI :: Dict h p Nothing o e -> Dict h p (Just String) o e+stringI :: Dict h p 'Nothing o e -> Dict h p ('Just String) o e stringI = L.set inputs (Dicts [StringI])  -- | Allow direct usage of as input as raw Xml `Text`. -xmlTextI :: Dict h p Nothing o e -> Dict h p (Just Text) o e+xmlTextI :: Dict h p 'Nothing o e -> Dict h p ('Just Text) o e xmlTextI = L.set inputs (Dicts [XmlTextI])  -- | Allow usage of input as file contents, represented as a `ByteString`. -fileI :: Dict h p Nothing o e -> Dict h p (Just ByteString) o e+fileI :: Dict h p 'Nothing o e -> Dict h p ('Just ByteString) o e fileI = L.set inputs (Dicts [FileI])  -- | The input can be read into some instance of `Read`. For inspection reasons -- the type must also be an instance of both `Info` and `Show`. -readI :: (Info i, Read i, Show i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p (Just i) o e+readI :: (Info i, Read i, Show i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p ('Just i) o e readI = L.modify inputs (modDicts (ReadI:))  -- | The input can be read into some instance of `XmlPickler`. -xmlI :: (Typeable i, XmlPickler i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p (Just i) o e+xmlI :: (Typeable i, XmlPickler i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p ('Just i) o e xmlI = L.modify inputs (modDicts (XmlI:))  -- | The input can be used as an XML `ByteString`. -rawXmlI :: Dict h p Nothing o e -> Dict h p (Just ByteString) o e+rawXmlI :: Dict h p 'Nothing o e -> Dict h p ('Just ByteString) o e rawXmlI = L.set inputs (Dicts [RawXmlI]) +-- | The input can be used as a JSON `ByteString`.++rawJsonI :: Dict h p 'Nothing o e -> Dict h p ('Just ByteString) o e+rawJsonI = L.set inputs (Dicts [RawJsonI])+ -- | The input can be read into some instance of `Json`. -jsonI :: (Typeable i, FromJSON i, JSONSchema i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p (Just i) o e+jsonI :: (Typeable i, FromJSON i, JSONSchema i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p ('Just i) o e jsonI = L.modify inputs (modDicts (JsonI:)) +-- | The input can be used as a JSON or XML `ByteString`.+--+-- An API client can send either format so the handler needs to handle both.++rawJsonAndXmlI :: Dict h p 'Nothing o e -> Dict h p ('Just (Either Json Xml)) o e+rawJsonAndXmlI = L.set inputs (Dicts [RawJsonAndXmlI])+ -- | Open up output type for extension with custom dictionaries.  {-# DEPRECATED someO "This can be safely removed, it is now just the identity." #-}@@ -142,7 +158,7 @@  -- | Allow output as plain String. -stringO :: Dict h p i Nothing e -> Dict h p i (Just String) e+stringO :: Dict h p i 'Nothing e -> Dict h p i ('Just String) e stringO = L.set outputs (Dicts [StringO])  -- | Allow file output using a combination of the raw data, the file@@ -151,28 +167,40 @@ -- the file extension by your web server library, or -- "application/octet-stream" with an unknown extension. -fileO :: Dict h p i Nothing e -> Dict h p i (Just (ByteString, String, Bool)) e+fileO :: Dict h p i 'Nothing e -> Dict h p i ('Just (ByteString, String, Bool)) e fileO = L.set outputs (Dicts [FileO])  -- | Allow output as XML using the `XmlPickler` type class. -xmlO :: (Typeable o, XmlPickler o, FromMaybe o o' ~ o) => Dict h p i o' e -> Dict h p i (Just o) e+xmlO :: (Typeable o, XmlPickler o, FromMaybe o o' ~ o) => Dict h p i o' e -> Dict h p i ('Just o) e xmlO = L.modify outputs (modDicts (XmlO:))  -- | Allow output as raw XML represented as a `ByteString`. -rawXmlO :: Dict h p i Nothing e -> Dict h p i (Just ByteString) e+rawXmlO :: Dict h p i 'Nothing e -> Dict h p i ('Just ByteString) e rawXmlO = L.set outputs (Dicts [RawXmlO]) +-- | Allow output as raw JSON represented as a `ByteString`.++rawJsonO :: Dict h p i 'Nothing e -> Dict h p i ('Just ByteString) e+rawJsonO = L.set outputs (Dicts [RawJsonO])+ -- | Allow output as JSON using the `Json` type class. -jsonO :: (Typeable o, ToJSON o, JSONSchema o, FromMaybe o o' ~ o) => Dict h p i o' e -> Dict h p i (Just o) e+jsonO :: (Typeable o, ToJSON o, JSONSchema o, FromMaybe o o' ~ o) => Dict h p i o' e -> Dict h p i ('Just o) e jsonO = L.modify outputs (modDicts (JsonO:)) +-- | Allow output as raw JSON and XML represented as `ByteString`s.+-- Both values are needed since the accept header determines which one+-- to send.++rawJsonAndXmlO :: Dict h p i 'Nothing e -> Dict h p i ('Just ByteString) e+rawJsonAndXmlO = L.set outputs (Dicts [RawJsonAndXmlO])+ -- | Allow output as multipart. Writes out the ByteStrings separated -- by boundaries, with content type 'multipart/mixed'. -multipartO :: Dict h p i Nothing e -> Dict h p i (Just [BodyPart]) e+multipartO :: Dict h p i 'Nothing e -> Dict h p i ('Just [BodyPart]) e multipartO = L.set outputs (Dicts [MultipartO])  -- | Open up error type for extension with custom dictionaries.@@ -183,29 +211,29 @@  -- | Allow error output as JSON using the `Json` type class. -jsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e, FromMaybe e e' ~ e) => Dict h p i o e' -> Dict h p i o (Just e)+jsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e, FromMaybe e e' ~ e) => Dict h p i o e' -> Dict h p i o ('Just e) jsonE = L.modify errors (modDicts (JsonE:))  -- | Allow error output as XML using the `XmlPickler` type class. -xmlE :: (ToResponseCode e, Typeable e, XmlPickler e, FromMaybe e e' ~ e) => Dict h p i o e' -> Dict h p i o (Just e)+xmlE :: (ToResponseCode e, Typeable e, XmlPickler e, FromMaybe e e' ~ e) => Dict h p i o e' -> Dict h p i o ('Just e) xmlE = L.modify errors (modDicts (XmlE:))  -- | The input can be read into some instance of both `Json` and `XmlPickler`. -xmlJsonI :: (Typeable i, FromJSON i, JSONSchema i, XmlPickler i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p (Just i) o e+xmlJsonI :: (Typeable i, FromJSON i, JSONSchema i, XmlPickler i, FromMaybe i i' ~ i) => Dict h p i' o e -> Dict h p ('Just i) o e xmlJsonI = xmlI . jsonI  -- | Allow output as JSON using the `Json` type class and allow output as XML -- using the `XmlPickler` type class. -xmlJsonO :: (Typeable o, ToJSON o, JSONSchema o, XmlPickler o, FromMaybe o o' ~ o) => Dict h p i o' e -> Dict h p i (Just o) e+xmlJsonO :: (Typeable o, ToJSON o, JSONSchema o, XmlPickler o, FromMaybe o o' ~ o) => Dict h p i o' e -> Dict h p i ('Just o) e xmlJsonO = xmlO . jsonO  -- | Allow error output as JSON using the `Json` type class and allow output as -- XML using the `XmlPickler` type class. -xmlJsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e, XmlPickler e, FromMaybe e e' ~ e) => Dict h p i o e' -> Dict h p i o (Just e)+xmlJsonE :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e, XmlPickler e, FromMaybe e e' ~ e) => Dict h p i o e' -> Dict h p i o ('Just e) xmlJsonE = xmlE . jsonE  -- | The input can be read into some instance of both `Json` and `XmlPickler`@@ -216,5 +244,5 @@            , Typeable o, ToJSON o, JSONSchema o, XmlPickler o            , FromMaybe i i' ~ i, FromMaybe o o' ~ o            )-        => Dict h p i' o' e -> Dict h p (Just i) (Just o) e+        => Dict h p i' o' e -> Dict h p ('Just i) ('Just o) e xmlJson = xmlJsonI . xmlJsonO
src/Rest/Dictionary/Types.hs view
@@ -3,6 +3,7 @@   , DataKinds   , FlexibleContexts   , GADTs+  , GeneralizedNewtypeDeriving   , KindSignatures   , ScopedTypeVariables   , StandaloneDeriving@@ -37,6 +38,8 @@   , Input (..)   , Output (..)   , Error (..)+  , Xml (..)+  , Json (..)    -- * Plural dictionaries. @@ -86,8 +89,8 @@ -- plain `String` identifiers or all Haskell types that have a `Read` instance.  data Ident id where-  ReadId   :: (Info id, Read id, Show id) => Ident id-  StringId ::                                Ident String+  ReadId   :: (Info id, Read id) => Ident id+  StringId ::                       Ident String  deriving instance Show (Ident id) @@ -140,13 +143,15 @@ -- needs of the backend resource.  data Input i where-  JsonI    :: (Typeable i, FromJSON i, JSONSchema i) => Input i-  ReadI    :: (Info i, Read i, Show i)               => Input i-  StringI  ::                                           Input String-  FileI    ::                                           Input ByteString-  XmlI     :: (Typeable i, XmlPickler i)             => Input i-  XmlTextI ::                                           Input Text-  RawXmlI  ::                                           Input ByteString+  JsonI          :: (Typeable i, FromJSON i, JSONSchema i) => Input i+  ReadI          :: (Info i, Read i, Show i)               => Input i+  StringI        ::                                           Input String+  FileI          ::                                           Input ByteString+  XmlI           :: (Typeable i, XmlPickler i)             => Input i+  XmlTextI       ::                                           Input Text+  RawJsonI       ::                                           Input ByteString+  RawXmlI        ::                                           Input ByteString+  RawJsonAndXmlI ::                                           Input (Either Json Xml)  deriving instance Show (Input i) deriving instance Eq   (Input i)@@ -157,17 +162,29 @@ -- combination of input type to output type.  data Output o where-  FileO      ::                                         Output (ByteString, String, Bool)-  RawXmlO    ::                                         Output ByteString-  JsonO      :: (Typeable o, ToJSON o, JSONSchema o) => Output o-  XmlO       :: (Typeable o, XmlPickler o)           => Output o-  StringO    ::                                         Output String-  MultipartO ::                                         Output [BodyPart]+  FileO          ::                                         Output (ByteString, String, Bool)+  RawJsonO       ::                                         Output ByteString+  RawXmlO        ::                                         Output ByteString+  JsonO          :: (Typeable o, ToJSON o, JSONSchema o) => Output o+  XmlO           :: (Typeable o, XmlPickler o)           => Output o+  StringO        ::                                         Output String+  RawJsonAndXmlO ::                                         Output ByteString+  MultipartO     ::                                         Output [BodyPart]  deriving instance Show (Output o) deriving instance Eq   (Output o) deriving instance Ord  (Output o) +-- | Newtype around ByteStrings used in `RawJsonAndXmlI` to add some+-- protection from parsing the input incorrectly.+newtype Xml = Xml { unXml :: ByteString }+  deriving (Eq, Show)++-- | Newtype around ByteStrings used in `RawJsonAndXmlI` to add some+-- protection from parsing the input incorrectly.+newtype Json = Json { unJson :: ByteString }+  deriving (Eq, Show)+ -- | The explicit dictionary `Error` describes how to translate some Haskell -- error value to a response body. @@ -184,16 +201,16 @@ type Errors  e = Dicts Error  e  data Dicts f a where-  None  :: Dicts f Nothing-  Dicts :: [f a] -> Dicts f (Just a)+  None  :: Dicts f 'Nothing+  Dicts :: [f a] -> Dicts f ('Just a)  -- Needs UndecidableInstances deriving instance Show (f (FromMaybe Void a)) => Show (Dicts f a)  #if GLASGOW_HASKELL < 708 type family FromMaybe d (m :: Maybe *) :: *-type instance FromMaybe b Nothing  = b-type instance FromMaybe b (Just a) = a+type instance FromMaybe b 'Nothing  = b+type instance FromMaybe b ('Just a) = a #else type family FromMaybe d (m :: Maybe *) :: * where   FromMaybe b Nothing  = b@@ -226,7 +243,7 @@ getDicts_ None = [] getDicts_ (Dicts ds) = ds -modDicts :: (FromMaybe o i ~ o) => ([f o] -> [f o]) -> Dicts f i -> Dicts f (Just o)+modDicts :: (FromMaybe o i ~ o) => ([f o] -> [f o]) -> Dicts f i -> Dicts f ('Just o) modDicts f None       = Dicts (f []) modDicts f (Dicts ds) = Dicts (f ds) @@ -247,7 +264,7 @@  -- | The empty dictionary, recognizing no types. -empty :: Dict () () Nothing Nothing Nothing+empty :: Dict () () 'Nothing 'Nothing 'Nothing empty = Dict NoHeader NoParam None None None  -- | Custom existential packing an error together with a Reason.@@ -257,4 +274,4 @@  -- | Type synonym for dictionary modification. -type Modifier h p i o e = Dict () () Nothing Nothing Nothing -> Dict h p i o e+type Modifier h p i o e = Dict () () 'Nothing 'Nothing 'Nothing -> Dict h p i o e
src/Rest/Driver/Perform.hs view
@@ -24,7 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..)) import Control.Monad.Writer import Data.Aeson.Utils-import Data.Char (isSpace, toLower, ord)+import Data.Char (isSpace, ord, toLower) import Data.List import Data.List.Split import Data.Maybe@@ -40,7 +40,8 @@ import qualified Data.ByteString.Lazy.UTF8 as UTF8 import qualified Data.Label.Total          as L -import Rest.Dictionary (Dict, Dicts (..), Error (..), Errors, Format (..), FromMaybe, Header (..), Input (..), Inputs, Output (..), Outputs, Param (..))+import Rest.Dictionary (Dict, Dicts (..), Error (..), Errors, Format (..), FromMaybe, Header (..),+                        Input (..), Inputs, Json (..), Output (..), Outputs, Param (..), Xml (..)) import Rest.Driver.Types import Rest.Error import Rest.Handler@@ -156,7 +157,7 @@ fetchInputs :: Rest m => Dict h p j o e -> ExceptT (Reason (FromMaybe Void e)) m (Env h p (FromMaybe () j)) fetchInputs dict =   do bs <- getBody-     ct <- parseContentType+     ct <- parseContentType <$> getContentType       h <- HeaderError `mapE` headers    (L.get D.headers dict)      p <- ParamError  `mapE` parameters (L.get D.params dict)@@ -175,23 +176,25 @@                   Nothing             -> throwError (UnsupportedFormat "unknown")      return (Env h p j) -parseContentType :: Rest m => m (Maybe Format)-parseContentType =-  do ct <- fromMaybe "" <$> getHeader "Content-Type"-     let segs  = concat (take 1 . splitOn ";" <$> splitOn "," ct)-         types = flip concatMap segs $ \ty ->-                   case splitOn "/" ty of-                     ["application", "xml"]          -> [XmlFormat]-                     ["application", "json"]         -> [JsonFormat]-                     ["text",        "xml"]          -> [XmlFormat]-                     ["text",        "json"]         -> [JsonFormat]-                     ["text",        "plain"]        -> [StringFormat]-                     ["application", "octet-stream"] -> [FileFormat]-                     ["application", _             ] -> [FileFormat]-                     ["image",       _             ] -> [FileFormat]-                     _                               -> []-     return (headMay types)+getContentType :: Rest m => m (Maybe String)+getContentType = getHeader "Content-Type" +parseContentType :: Maybe String -> Maybe Format+parseContentType mct =+  let segs  = concat (take 1 . splitOn ";" <$> splitOn "," (fromMaybe "" mct))+      types = flip concatMap segs $ \ty ->+                case splitOn "/" ty of+                  ["application", "xml"]          -> [XmlFormat]+                  ["application", "json"]         -> [JsonFormat]+                  ["text",        "xml"]          -> [XmlFormat]+                  ["text",        "json"]         -> [JsonFormat]+                  ["text",        "plain"]        -> [StringFormat]+                  ["application", "octet-stream"] -> [FileFormat]+                  ["application", _             ] -> [FileFormat]+                  ["image",       _             ] -> [FileFormat]+                  _                               -> []+  in headMay types+ headers :: Rest m => Header h -> ExceptT DataError m h headers NoHeader      = return () headers (Header xs h) = mapM getHeader xs >>= either throwError return . h@@ -208,26 +211,29 @@ parser f        (Dicts ds) v = parserD f ds   where     parserD :: Monad m => Format -> [D.Input j] -> ExceptT DataError m j-    parserD XmlFormat     (XmlI     : _ ) = case eitherFromXML (UTF8.toString v) of-                                              Left err -> throwError (ParseError err)-                                              Right  r -> return r-    parserD XmlFormat     (XmlTextI : _ ) = return (decodeUtf8 v)-    parserD StringFormat  (ReadI    : _ ) = (throwError (ParseError "Read") `maybe` return) (readMay (UTF8.toString v))-    parserD JsonFormat    (JsonI    : _ ) = case eitherDecodeV v of-                                              Right a -> return a-                                              Left  e -> throwError (ParseError e)-    parserD StringFormat  (StringI  : _ ) = return (UTF8.toString v)-    parserD FileFormat    (FileI    : _ ) = return v-    parserD XmlFormat     (RawXmlI  : _ ) = return v-    parserD t             []              = throwError (UnsupportedFormat (show t))-    parserD t             (_        : xs) = parserD t xs+    parserD XmlFormat     (XmlI           : _ ) = case eitherFromXML (UTF8.toString v) of+                                                    Left err -> throwError (ParseError err)+                                                    Right  r -> return r+    parserD XmlFormat     (XmlTextI       : _ ) = return (decodeUtf8 v)+    parserD StringFormat  (ReadI          : _ ) = (throwError (ParseError "Read") `maybe` return) (readMay (UTF8.toString v))+    parserD JsonFormat    (JsonI          : _ ) = case eitherDecodeV v of+                                                    Right a -> return a+                                                    Left  e -> throwError (ParseError e)+    parserD StringFormat  (StringI        : _ ) = return (UTF8.toString v)+    parserD FileFormat    (FileI          : _ ) = return v+    parserD XmlFormat     (RawXmlI        : _ ) = return v+    parserD JsonFormat    (RawJsonI       : _ ) = return v+    parserD JsonFormat    (RawJsonAndXmlI : _ ) = return (Left $ Json v)+    parserD XmlFormat     (RawJsonAndXmlI : _ ) = return (Right $ Xml v)+    parserD t             []                    = throwError (UnsupportedFormat (show t))+    parserD t             (_              : xs) = parserD t xs  ------------------------------------------------------------------------------- -- Failure responses.  failureWriter :: Rest m => Errors e -> Reason (FromMaybe Void e) -> m UTF8.ByteString failureWriter es err =-  do formats <- accept+  do formats <- acceptM      fromMaybeT (printFallback formats) $        msum (  (tryPrint err                     es   <$> (formats ++ [XmlFormat]))             ++ (tryPrint (fallbackError formats) None <$> formats                 )@@ -291,14 +297,16 @@     try (Dicts ds) f = tryD ds f       where         tryD :: forall v'. [Output v'] -> Format -> ExceptT (Last DataError) m ()-        tryD (XmlO       : _ ) XmlFormat    = return ()-        tryD (RawXmlO    : _ ) XmlFormat    = return ()-        tryD (JsonO      : _ ) JsonFormat   = return ()-        tryD (StringO    : _ ) StringFormat = return ()-        tryD (FileO      : _ ) FileFormat   = return ()-        tryD (MultipartO : _ ) _            = return () -- Multipart is always ok, subparts can fail.-        tryD []                t            = unsupportedFormat t-        tryD (_          : xs) t            = tryD xs t+        tryD (XmlO           : _ ) XmlFormat    = return ()+        tryD (RawXmlO        : _ ) XmlFormat    = return ()+        tryD (JsonO          : _ ) JsonFormat   = return ()+        tryD (RawJsonO       : _ ) JsonFormat   = return ()+        tryD (StringO        : _ ) StringFormat = return ()+        tryD (FileO          : _ ) FileFormat   = return ()+        tryD (RawJsonAndXmlO : _ ) _            = return ()+        tryD (MultipartO     : _ ) _            = return () -- Multipart is always ok, subparts can fail.+        tryD []                    t            = unsupportedFormat t+        tryD (_              : xs) t            = tryD xs t  outputWriter :: forall v m e. Rest m => Outputs v -> FromMaybe () v -> ExceptT (Reason e) m UTF8.ByteString outputWriter outputs v = tryOutputs try outputs@@ -313,12 +321,15 @@     try (Dicts ds) f = tryD ds f       where         tryD :: forall v'. FromMaybe () v ~ v' => [Output v'] -> Format -> ExceptT (Last DataError) m UTF8.ByteString-        tryD (XmlO       : _ ) XmlFormat    = contentType XmlFormat    >> ok (UTF8.fromString (toXML v))-        tryD (RawXmlO    : _ ) XmlFormat    = contentType XmlFormat    >> ok v-        tryD (JsonO      : _ ) JsonFormat   = contentType JsonFormat   >> ok (encode v)-        tryD (StringO    : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)-        tryD (MultipartO : _ ) _            = outputMultipart v-        tryD (FileO      : _ ) FileFormat   =+        tryD (XmlO           : _ ) XmlFormat    = contentType XmlFormat    >> ok (UTF8.fromString (toXML v))+        tryD (RawXmlO        : _ ) XmlFormat    = contentType XmlFormat    >> ok v+        tryD (JsonO          : _ ) JsonFormat   = contentType JsonFormat   >> ok (encode v)+        tryD (RawJsonO       : _ ) JsonFormat   = contentType JsonFormat   >> ok v+        tryD (RawJsonAndXmlO : _ ) JsonFormat   = contentType JsonFormat   >> ok v+        tryD (RawJsonAndXmlO : _ ) XmlFormat    = contentType XmlFormat    >> ok v+        tryD (StringO        : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)+        tryD (MultipartO     : _ ) _            = outputMultipart v+        tryD (FileO          : _ ) FileFormat   =           do let (content, filename, isAttachment) = v                  ext = (reverse . takeWhile (/='.') . reverse) filename              mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower ext)@@ -343,7 +354,7 @@  tryOutputs :: Rest m => (t -> Format -> ExceptT (Last DataError) m a) -> t -> ExceptT (Reason e) m a tryOutputs try outputs = do-  formats <- lift accept+  formats <- lift acceptM   rethrowLast $ (msum $ try outputs <$> formats) <|> unsupportedFormat formats   where     rethrowLast :: Monad m => ExceptT (Last DataError) m a -> ExceptT (Reason e) m a@@ -355,25 +366,35 @@      setHeader "Content-Type" ("multipart/mixed; boundary=" ++ boundary)      return $ showMultipartBody boundary (MultiPart vs) -accept :: Rest m => m [Format]-accept =+acceptM :: Rest m => m [Format]+acceptM =   do acceptHeader <- getHeader "Accept"-     ct <- parseContentType-     ty <- fromMaybe "" <$> getParameter "type"-     let fromQuery =-           case ty of-             "json" -> [JsonFormat]-             "xml"  -> [XmlFormat]-             _      -> []-         fromAccept = maybe (allFormats ct) (splitter ct) acceptHeader-     return (fromQuery ++ fromAccept)+     ct <- getHeader "Content-Type"+     ty <- getParameter "type"+     return $ accept acceptHeader ct ty +accept :: Maybe String -> Maybe String -> Maybe String -> [Format]+accept acceptHeader mct mty =+  let ct :: Maybe Format+      ct = parseContentType mct+      fromQuery :: [Format]+      fromQuery =+        case mty of+          Just "json" -> [JsonFormat]+          Just "xml"  -> [XmlFormat]+          _           -> []+      fromAccept :: [Format]+      fromAccept = maybe (allFormats ct) (splitter ct) acceptHeader+  in (fromQuery ++ fromAccept)   where+    allFormats :: Maybe Format -> [Format]     allFormats ct = (maybe id (:) ct) [minBound .. maxBound]+    splitter :: Maybe Format -> String -> [Format]     splitter ct hdr = nub (match ct =<< takeWhile (/= ';') . trim <$> splitOn "," hdr) -    match ct ty =-      case map trim <$> (splitOn "+" . trim <$> splitOn "/" ty) of+    match :: Maybe Format -> String -> [Format]+    match ct ty' =+      case map trim <$> (splitOn "+" . trim <$> splitOn "/" ty') of         [ ["*"]           , ["*"] ] -> allFormats ct         [ ["*"]                   ] -> allFormats ct         [ ["text"]        , xs    ] -> xs >>= txt
src/Rest/Error.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE     FlexibleContexts   , GADTs+  , NoImplicitPrelude   #-} -- | Error types that can be returned by handlers, as well as some -- utilities for manipulating these errors.@@ -14,7 +15,8 @@   , (>|<)   ) where -import Control.Applicative+import Prelude.Compat+ import Control.Monad.Except  import Rest.Types.Error
src/Rest/Handler.hs view
@@ -3,6 +3,7 @@   , DeriveDataTypeable   , GADTs   , KindSignatures+  , NoImplicitPrelude   , TupleSections   , TypeFamilies   #-}@@ -34,7 +35,8 @@   , secureHandler   ) where -import Control.Applicative hiding (empty)+import Prelude.Compat+ import Control.Arrow import Control.Monad.Except () import Control.Monad.Identity@@ -109,7 +111,7 @@  mkListing   :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void e')-  => Modifier h p Nothing o' e'+  => Modifier h p 'Nothing o' e'   -> (Range -> ExceptT (Reason e) m [o])   -> ListHandler m mkListing d a = mkGenHandler (mkPar range . d) (a . param)@@ -136,7 +138,7 @@  mkOrderedListing   :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void e')-  => Modifier h p Nothing o' e'+  => Modifier h p 'Nothing o' e'   -> ((Range, Maybe String, Maybe String) -> ExceptT (Reason e) m [o])   -> ListHandler m mkOrderedListing d a = mkGenHandler (mkPar orderedRange . d) (a . param)@@ -175,7 +177,7 @@ -- | Create a handler for a single resource. Doesn't take any input.  mkConstHandler :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void e')-               => Modifier () () Nothing o' e' -> ExceptT (Reason e) m o -> Handler m+               => Modifier () () 'Nothing o' e' -> ExceptT (Reason e) m o -> Handler m mkConstHandler d a = mkHandler d (const a)  -- | Create a handler for a single resource. Take body information and
src/Rest/Resource.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE-    TemplateHaskell-  , MultiParamTypeClasses+    FlexibleContexts   , FlexibleInstances-  , FlexibleContexts-  , TypeSynonymInstances-  , RankNTypes-  , KindSignatures   , GADTs+  , KindSignatures+  , MultiParamTypeClasses   , NamedFieldPuns+  , NoImplicitPrelude+  , RankNTypes+  , TemplateHaskell+  , TypeSynonymInstances   #-} -- | A 'Resource' type for representing a REST resource, as well as -- smart constructors for empty resources which can then be filled in@@ -21,7 +22,8 @@   , module Rest.Types.Void   ) where -import Control.Applicative (Applicative)+import Prelude.Compat+ import Control.Monad.Reader  import Rest.Handler
src/Rest/Run.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE+    NoImplicitPrelude+  , RankNTypes+  #-} module Rest.Run   ( apiToHandler   , apiToHandler'@@ -6,11 +9,12 @@   , Config (..)   ) where -import Control.Applicative+import Prelude.Compat+ import qualified Data.ByteString.Lazy.UTF8 as UTF8  import Rest.Api (Api)-import Rest.Dictionary ( Dicts (..) )+import Rest.Dictionary (Dicts (..)) import Rest.Driver.Perform import Rest.Driver.Types import qualified Rest.Driver.Routing.Internal as I
tests/Runner.hs view
@@ -11,7 +11,7 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertEqual, assertFailure) -import qualified Data.HashMap.Strict   as H+import qualified Data.HashMap.Strict as H  import Rest.Api hiding (route) import Rest.Dictionary@@ -206,5 +206,5 @@  testAcceptHeaders :: Assertion testAcceptHeaders =-  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "text/json" } accept+  do let fmt = accept (Just "text/json") Nothing Nothing      assertEqual "Accept json format." [JsonFormat] fmt