packages feed

rest-core 0.34.0.3 → 0.35

raw patch · 12 files changed

+299/−166 lines, 12 filesdep +case-insensitivedep +mtl-compatdep +semigroupsdep ~rest-typesdep ~transformers

Dependencies added: case-insensitive, mtl-compat, semigroups, transformers-compat

Dependency ranges changed: rest-types, transformers

Files

CHANGELOG.md view
@@ -1,5 +1,34 @@ # Changelog +## 0.35++* Change input/output dictionaries to indicate separately if there are+  dictionaries, and for what type. This is a breaking change. The most+  likely problems are where `Reason ()` is explicitly used in handlers+  without error dictionaries. Simply replace these with `Reason_`.+  Additionally, all `some*` combinators are deprecated now. They are+  just the identity function and can be removed.++* The types of all dictionary combinators have changed, the Dicts+  type, the dicts smart constructor, empty, SomeError, Modifier, many+  internal (but exported) things in Rest.Driver.Perform, some types in+  Rest.Handler, and Void was moved.++* Switched all usages of `ErrorT` to `ExceptT`. To stay backwards+  compatible with older versions of `transformers` and `mtl` you can+  use the `transformers-compat` and `mtl-compat` packages. To update+  your code: `s/ErrorT/ExceptT` and+  `s/Control.Monad.Error/Control.Monad.Except/`.++* Add `>|<` to `Rest.Error`. It combines two `ExceptT` computations+  yielding the last error if both fail. This is a replacement for+  using `<|>` with `ErrorT` since the `Alternative ExceptT` instance+  needs a `Monoid` instance for the error.++* Fix typos in haddock for `Param` dictionary.++* Switch to explicit export lists where missing.+ #### 0.34.0.3  * Allow `aeson-utils 0.3.*`
rest-core.cabal view
@@ -1,5 +1,5 @@ name:                rest-core-version:             0.34.0.3+version:             0.35 description:         Rest API library. synopsis:            Rest API library. maintainer:          code@silk.co@@ -14,8 +14,8 @@   LICENSE  source-repository head-  Type:              Git-  Location:          https://github.com/silkapp/rest.git+  type:              git+  location:          https://github.com/silkapp/rest.git  library   ghc-options:       -Wall@@ -43,6 +43,7 @@     , aeson >= 0.7 && < 0.9     , aeson-utils >= 0.2 && < 0.4     , bytestring >= 0.9 && < 0.11+    , case-insensitive >= 1.2 && < 1.3     , either >= 3.4 && < 4.4     , errors == 1.4.*     , fclabels == 2.0.*@@ -50,14 +51,17 @@     , hxt-pickle-utils == 0.1.*     , json-schema >= 0.6 && < 0.8     , mtl >= 2.0 && < 2.3+    , mtl-compat >= 0.1 && < 0.3     , multipart >= 0.1.1 && < 0.2     , random >= 1.0 && < 1.2     , rest-stringmap == 0.2.*-    , rest-types == 1.12.*+    , rest-types == 1.13.*     , safe >= 0.2 && < 0.4+    , semigroups == 0.16.*     , split >= 0.1 && < 0.3     , text >= 0.11 && < 1.3     , transformers >= 0.2 && < 0.5+    , transformers-compat >= 0.3 && < 0.5     , unordered-containers == 0.2.*     , uri-encode == 1.5.*     , utf8-string >= 0.3 && < 1.1@@ -76,4 +80,6 @@     , rest-core     , test-framework == 0.8.*     , test-framework-hunit == 0.3.*+    , transformers >= 0.3 && < 0.5+    , transformers-compat >= 0.3 && < 0.5     , unordered-containers == 0.2.*
src/Rest/Container.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE-    DeriveDataTypeable+    DataKinds+  , DeriveDataTypeable   , EmptyDataDecls   , FlexibleInstances   , GADTs@@ -24,8 +25,9 @@ import Rest.Error import Rest.StringMap.HashMap.Strict import Rest.Types.Container+import Rest.Types.Void -listI :: Inputs a -> Maybe (Inputs (List a))+listI :: Inputs i -> Maybe (Inputs (Just (List (FromMaybe () i)))) listI None       = Just (Dicts [XmlI, JsonI]) listI (Dicts is) =   case mapMaybe listDictI is of@@ -37,7 +39,7 @@     listDictI JsonI = Just JsonI     listDictI _     = Nothing -listO :: Outputs a -> Maybe (Outputs (List a))+listO :: Outputs o -> Maybe (Outputs (Just (List (FromMaybe () o)))) listO None       = Just (Dicts [XmlO, JsonO]) listO (Dicts os) =   case mapMaybe listDictO os of@@ -49,7 +51,7 @@     listDictO JsonO = Just JsonO     listDictO _     = Nothing -mappingI :: forall i. Inputs i -> Maybe (Inputs (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@@ -61,7 +63,7 @@     mappingDictI JsonI = Just JsonI     mappingDictI _     = Nothing -mappingO :: forall o. Outputs o -> Maybe (Outputs (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@@ -73,13 +75,14 @@     mappingDictO JsonO = Just JsonO     mappingDictO _     = Nothing -statusO :: Errors e -> Outputs o -> Maybe (Outputs (Status e o))+statusO :: (e ~ FromMaybe Void e', o ~ FromMaybe () 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 (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@@ -99,7 +102,7 @@     JsonE `eq` JsonO = True     _     `eq` _     = False -reasonE :: Errors a -> Errors (Reason a)+reasonE :: e ~ FromMaybe Void e' => Errors e' -> Errors (Just (Reason e)) reasonE None       = Dicts [XmlE, JsonE] reasonE (Dicts es) = Dicts (map reasonDictE es)   where@@ -107,5 +110,5 @@     reasonDictE XmlE  = XmlE     reasonDictE JsonE = JsonE -defaultE :: Errors ()+defaultE :: Errors (Just Reason_) defaultE = Dicts [XmlE, JsonE]
src/Rest/Dictionary/Combinators.hs view
@@ -1,11 +1,16 @@+{-# LANGUAGE+    DataKinds+  , TypeFamilies+  , RankNTypes+  , ScopedTypeVariables+  #-} -- | Combinators for specifying the input/output dictionaries of a -- 'Handler'. The combinators can be combined using @(@'.'@)@. module Rest.Dictionary.Combinators   (   -- ** Input dictionaries -    someI-  , stringI+    stringI   , xmlTextI   , fileI   , readI@@ -15,7 +20,6 @@    -- ** Output dictionaries -  , someO   , stringO   , fileO   , xmlO@@ -25,7 +29,6 @@    -- ** Error dictionaries -  , someE   , jsonE   , xmlE @@ -45,6 +48,12 @@    , mkPar   , addPar++  -- ** Deprecated++  , someI+  , someO+  , someE   ) where  import Prelude hiding (id, (.))@@ -85,118 +94,123 @@  -- | Open up input type for extension with custom dictionaries. -someI :: Dict h p () o e -> Dict h p i o e-someI = L.set inputs (Dicts [])+{-# DEPRECATED someI "This can be safely removed, it is now just the identity." #-}+someI :: Dict h p i o e -> Dict h p i o e+someI = id  -- | Allow direct usage of as input as `String`. -stringI :: Dict h p i o e -> Dict h p 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 i o e -> Dict h p 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 i o e -> Dict h p 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) => Dict h p i o e -> Dict h p i o e-readI = L.modify (dicts . inputs) (ReadI:)+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) => Dict h p i o e -> Dict h p i o e-xmlI = L.modify (dicts . inputs) (XmlI:)+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 i o e -> Dict h p 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 read into some instance of `Json`. -jsonI :: (Typeable i, FromJSON i, JSONSchema i) => Dict h p i o e -> Dict h p i o e-jsonI = L.modify (dicts . inputs) (JsonI:)+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:))  -- | Open up output type for extension with custom dictionaries. -someO :: Dict h p i () e -> Dict h p i o e-someO = L.set outputs (Dicts [])+{-# DEPRECATED someO "This can be safely removed, it is now just the identity." #-}+someO :: Dict h p i o e -> Dict h p i o e+someO = id  -- | Allow output as plain String. -stringO :: Dict h p i () e -> Dict h p i 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 and a mime type. -fileO :: Dict h p i o e -> Dict h p i (ByteString, String) e+fileO :: Dict h p i Nothing e -> Dict h p i (Just (ByteString, String)) e fileO = L.set outputs (Dicts [FileO])  -- | Allow output as XML using the `XmlPickler` type class. -xmlO :: (Typeable o, XmlPickler o) => Dict h p i o e -> Dict h p i o e-xmlO = L.modify (dicts . outputs) (XmlO:)+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 () e -> Dict h p i 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 JSON using the `Json` type class. -jsonO :: (Typeable o, ToJSON o, JSONSchema o) => Dict h p i o e -> Dict h p i o e-jsonO = L.modify (dicts . outputs) (JsonO:)+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 multipart. Writes out the ByteStrings separated -- by boundaries, with content type 'multipart/mixed'. -multipartO :: Dict h p i () e -> Dict h p i [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. -someE :: (Typeable e, ToJSON e, JSONSchema e) => Dict h p i o () -> Dict h p i o e-someE = L.set errors (Dicts [])+{-# DEPRECATED someE "This can be safely removed, it is now just the identity." #-}+someE :: Dict h p i o e -> Dict h p i o e+someE = id  -- | Allow error output as JSON using the `Json` type class. -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:)+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) => Dict h p i o e -> Dict h p i o e-xmlE = L.modify (dicts . errors) (XmlE:)+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) => Dict h p () o e -> Dict h p i o e-xmlJsonI = xmlI . jsonI . someI+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) => Dict h p i () e -> Dict h p i o e-xmlJsonO = xmlO . jsonO . someO+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) => Dict h p i o () -> Dict h p i o e-xmlJsonE = xmlE . jsonE . someE+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` -- and allow output as JSON using the `Json` type class and allow output as XML -- using the `XmlPickler` type class. -xmlJson :: (Typeable i, FromJSON i, JSONSchema i, XmlPickler i-           ,Typeable o, ToJSON o, JSONSchema o, XmlPickler o)-        => Dict h p () () e -> Dict h p i o e+xmlJson :: ( Typeable i, FromJSON i, JSONSchema i, XmlPickler i+           , 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 xmlJson = xmlJsonI . xmlJsonO
src/Rest/Dictionary/Types.hs view
@@ -1,9 +1,15 @@ {-# LANGUAGE-    FlexibleContexts+    CPP+  , DataKinds+  , FlexibleContexts   , GADTs+  , KindSignatures+  , ScopedTypeVariables   , StandaloneDeriving   , TemplateHaskell+  , TypeFamilies   , TypeOperators+  , UndecidableInstances   #-} module Rest.Dictionary.Types   (@@ -36,11 +42,16 @@    , Dicts (..)   , dicts+  , getDicts+  , getDicts_+  , modDicts   , Inputs   , Outputs   , Errors   , SomeError (..) +  , FromMaybe+   )  where@@ -57,6 +68,7 @@  import Rest.Error import Rest.Info+import Rest.Types.Void  -- | The `Format` datatype enumerates all input and output formats we might recognize. @@ -100,8 +112,8 @@                                                    . showsPrec 10 k                                                    ) --- | The explicit dictionary `Parameter` describes how to translate the request--- parameters to some Haskell value. The first field in the `Header`+-- | The explicit dictionary `Param` describes how to translate the request+-- parameters to some Haskell value. The first field in the `Param` -- constructor is a white list of paramters we can recognize, used in generic -- validation and for generating documentation. The second field is a custom -- parser that can fail with a `DataError` or can produce a some value. When@@ -172,20 +184,52 @@ type Errors  e = Dicts Error  e  data Dicts f a where-  None  :: Dicts f ()-  Dicts :: [f a] -> Dicts f a+  None  :: Dicts f Nothing+  Dicts :: [f a] -> Dicts f (Just a) -deriving instance Show (f a) => Show (Dicts f a)+-- Needs UndecidableInstances+deriving instance Show (f (FromMaybe Void a)) => Show (Dicts f a) -dicts :: Dicts f a :-> [f a]-dicts = lens getDicts modDicts+#if GLASGOW_HASKELL < 708+type family FromMaybe d (m :: Maybe *) :: *+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+  FromMaybe b (Just a) = a+#endif++{-# DEPRECATED dicts "The modifier for this lens doesn't do anything when Dicts is None. Use getDicts and modDicts instead." #-}+dicts :: forall a o f. o ~ FromMaybe o a => Dicts f a :-> [f o]+dicts = lens get modify   where-    getDicts None       = []-    getDicts (Dicts ds) = ds-    modDicts :: ([f a] -> [f a]) -> Dicts f a -> Dicts f a-    modDicts _ None       = None-    modDicts f (Dicts ds) = Dicts (f ds)+    get :: Dicts f a -> [f o]+    get None       = []+    get (Dicts ds) = ds+    modify :: ([f o] -> [f o]) -> Dicts f a -> Dicts f a+    modify _ None       = None+    modify f (Dicts ds) = Dicts (f ds) +-- | Get the list of dictionaries. If there are none, you get a [o].+-- If this is too polymorphic, try `getDicts_`.++getDicts :: o ~ FromMaybe o a => Dicts f a -> [f o]+getDicts None       = []+getDicts (Dicts ds) = ds++-- | Get the list of dictionaries. If there are none, you get a [()].+-- Sometimes useful to constraint the types if the element type of the+-- list isn't clear from the context.++getDicts_ :: o ~ FromMaybe () a => Dicts f a -> [f o]+getDicts_ None = []+getDicts_ (Dicts ds) = ds++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)+ -- | The `Dict` datatype containing sub-dictionaries for translation of -- identifiers (i), headers (h), parameters (p), inputs (i), outputs (o), and -- errors (e). Inputs, outputs and errors can have multiple associated@@ -203,14 +247,14 @@  -- | The empty dictionary, recognizing no types. -empty :: Dict () () () () ()+empty :: Dict () () Nothing Nothing Nothing empty = Dict NoHeader NoParam None None None  -- | Custom existential packing an error together with a Reason.  data SomeError where-  SomeError :: Errors e -> Reason e -> SomeError+  SomeError :: Errors e -> Reason (FromMaybe Void e) -> SomeError  -- | Type synonym for dictionary modification. -type Modifier h p i o e = Dict () () () () () -> 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
@@ -1,18 +1,25 @@ {-# LANGUAGE-    GADTs+    FlexibleContexts+  , GADTs   , OverloadedStrings   , RankNTypes   , ScopedTypeVariables   #-}-module Rest.Driver.Perform where+module Rest.Driver.Perform+  ( Rest (..)+  , failureWriter+  , writeResponse+  , accept+  ) where  import Control.Applicative import Control.Monad import Control.Monad.Cont-import Control.Monad.Error+import Control.Monad.Error.Class import Control.Monad.RWS import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe (MaybeT (..)) import Control.Monad.Writer@@ -29,15 +36,15 @@ import System.Random (randomIO) import Text.Xml.Pickle -import qualified Control.Monad.Error       as E import qualified Data.ByteString.Lazy      as B import qualified Data.ByteString.Lazy.UTF8 as UTF8 import qualified Data.Label.Total          as L -import Rest.Dictionary (Dict, Dicts (..), Error (..), Errors, Format (..), Header (..), Input (..), Inputs, Output (..), Outputs, Param (..))+import Rest.Dictionary (Dict, Dicts (..), Error (..), Errors, Format (..), FromMaybe, Header (..), Input (..), Inputs, Output (..), Outputs, Param (..)) import Rest.Driver.Types import Rest.Error import Rest.Handler+import Rest.Types.Void import qualified Rest.Dictionary   as D import qualified Rest.Driver.Types as Rest @@ -61,7 +68,7 @@   setHeader nm    = lift . setHeader nm   setResponseCode = lift . setResponseCode -instance (E.Error e, Rest m) => Rest (ErrorT e m) where+instance Rest m => Rest (ExceptT e m) where   getHeader       = lift . getHeader   getParameter    = lift . getParameter   getBody         = lift getBody@@ -133,11 +140,11 @@  writeResponse :: Rest m => RunnableHandler m -> m UTF8.ByteString writeResponse (RunnableHandler run (GenHandler dict act _)) = do-  res <- runErrorT $ do+  res <- runExceptT $ do     let os = L.get D.outputs dict     validator os     inp <- fetchInputs dict-    output <- mapErrorT run (act inp)+    output <- mapExceptT run (act inp)     outputWriter os output   case res of     Left  er -> failureWriter (L.get D.errors dict) er@@ -146,7 +153,7 @@ ------------------------------------------------------------------------------- -- Fetching the input resource. -fetchInputs :: Rest m => Dict h p j o e -> ErrorT (Reason e) m (Env h p j)+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@@ -185,22 +192,22 @@                      _                               -> []      return (headMay types) -headers :: Rest m => Header h -> ErrorT DataError m h+headers :: Rest m => Header h -> ExceptT DataError m h headers NoHeader      = return () headers (Header xs h) = mapM getHeader xs >>= either throwError return . h headers (TwoHeaders h1 h2) = (,) <$> headers h1 <*> headers h2 -parameters :: Rest m => Param p -> ErrorT DataError m p+parameters :: Rest m => Param p -> ExceptT DataError m p parameters NoParam      = return () parameters (Param xs p) = mapM (lift . getParameter) xs >>= either throwError return . p parameters (TwoParams p1 p2) = (,) <$> parameters p1 <*> parameters p2 -parser :: Monad m => Format -> Inputs j -> B.ByteString -> ErrorT DataError m j+parser :: Monad m => Format -> Inputs j -> B.ByteString -> ExceptT DataError m (FromMaybe () j) parser NoFormat None       _ = return () parser f        None       _ = throwError (UnsupportedFormat (show f)) parser f        (Dicts ds) v = parserD f ds   where-    parserD :: Monad m => Format -> [D.Input j] -> ErrorT DataError m j+    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@@ -218,7 +225,7 @@ ------------------------------------------------------------------------------- -- Failure responses. -failureWriter :: Rest m => Errors e -> Reason e -> m UTF8.ByteString+failureWriter :: Rest m => Errors e -> Reason (FromMaybe Void e) -> m UTF8.ByteString failureWriter es err =   do formats <- accept      fromMaybeT (printFallback formats) $@@ -226,7 +233,8 @@             ++ (tryPrint (fallbackError formats) None <$> formats                 )             )   where-    tryPrint :: forall m e. Rest m => Reason e -> Errors e -> Format -> MaybeT m UTF8.ByteString+    tryPrint :: forall m e e'. (e ~ FromMaybe Void e', Rest m)+             => Reason e -> Errors e' -> Format -> MaybeT m UTF8.ByteString     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@@ -269,45 +277,42 @@     XmlFormat  -> "application/xml; charset=UTF-8"     _          -> "text/plain; charset=UTF-8" -validator :: forall v m e. Rest m => Outputs v -> ErrorT (Reason e) m ()-validator outputs = lift accept >>= \formats -> OutputError `mapE`-   (msum (try outputs <$> formats) <|> throwError (UnsupportedFormat (show formats))) +validator :: forall v m e. Rest m => Outputs v -> ExceptT (Reason e) m ()+validator = tryOutputs try   where-    try :: Outputs v -> Format -> ErrorT DataError m ()+    try :: Outputs v -> Format -> ExceptT (Last DataError) m ()     try None NoFormat        = return ()     try None XmlFormat       = return ()     try None JsonFormat      = return ()     try None StringFormat    = return ()     try None MultipartFormat = return ()-    try None FileFormat      = throwError (UnsupportedFormat (show FileFormat))+    try None FileFormat      = unsupportedFormat FileFormat     try (Dicts ds) f = tryD ds f       where-        tryD :: [Output v] -> Format -> ErrorT DataError m ()+        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            = throwError (UnsupportedFormat (show t))+        tryD []                t            = unsupportedFormat t         tryD (_          : xs) t            = tryD xs t -outputWriter :: forall v m e. Rest m => Outputs v -> v -> ErrorT (Reason e) m UTF8.ByteString-outputWriter outputs v = lift accept >>= \formats -> OutputError `mapE`-  (msum (try outputs <$> formats) <|> throwError (UnsupportedFormat (show formats)))-+outputWriter :: forall v m e. Rest m => Outputs v -> FromMaybe () v -> ExceptT (Reason e) m UTF8.ByteString+outputWriter outputs v = tryOutputs try outputs   where-    try :: Outputs v -> Format -> ErrorT DataError m UTF8.ByteString+    try :: Outputs v -> Format -> ExceptT (Last DataError) m UTF8.ByteString     try None NoFormat        = contentType NoFormat >> ok ""     try None XmlFormat       = contentType NoFormat >> ok "<done/>"     try None JsonFormat      = contentType NoFormat >> ok "{}"     try None StringFormat    = contentType NoFormat >> ok "done"-    try None FileFormat      = throwError (UnsupportedFormat (show FileFormat))+    try None FileFormat      = unsupportedFormat FileFormat     try None MultipartFormat = contentType NoFormat >> ok ""     try (Dicts ds) f = tryD ds f       where-        tryD :: [Output v] -> Format -> ErrorT DataError m UTF8.ByteString+        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)@@ -320,11 +325,22 @@              setHeader "Cache-Control" "max-age=604800"              setHeader "Content-Disposition" ("filename=\"" ++ escapeQuotes (snd v) ++ "\"")              ok (fst v)-        tryD []                t            = throwError (UnsupportedFormat (show t))+        tryD []                t            = unsupportedFormat t         tryD (_          : xs) t            = tryD xs t     ok r = setResponseCode 200 >> return r     escapeQuotes :: String -> String     escapeQuotes = intercalate "\\\"" . splitOn "\""++unsupportedFormat :: (Monad m, Show a) => a -> ExceptT (Last DataError) m a1+unsupportedFormat = throwError . Last . Just . UnsupportedFormat . show++tryOutputs :: Rest m => (t -> Format -> ExceptT (Last DataError) m a) -> t -> ExceptT (Reason e) m a+tryOutputs try outputs = do+  formats <- lift accept+  rethrowLast $ (msum $ try outputs <$> formats) <|> unsupportedFormat formats+  where+    rethrowLast :: Monad m => ExceptT (Last DataError) m a -> ExceptT (Reason e) m a+    rethrowLast = either (maybe (error "Rest.Driver.Perform: ExceptT threw Last Nothing, this is a bug") (throwError . OutputError) . getLast) return <=< lift . runExceptT  outputMultipart :: Rest m => [BodyPart] -> m UTF8.ByteString outputMultipart vs =
src/Rest/Driver/RestM.hs view
@@ -11,6 +11,7 @@ import Control.Applicative import Control.Monad.Reader import Control.Monad.Writer+import Data.CaseInsensitive (CI, mk) import Data.HashMap.Strict (HashMap) import qualified Data.ByteString.Lazy.UTF8 as UTF8 import qualified Data.HashMap.Strict       as H@@ -20,7 +21,7 @@ import qualified Rest.Driver.Types   as Rest  data RestInput = RestInput-  { headers    :: HashMap String String+  { headers    :: HashMap (CI String) String   , parameters :: HashMap String String   , body       :: UTF8.ByteString   , method     :: Maybe Rest.Method@@ -69,11 +70,11 @@ runRestM_ i = fmap fst . runRestM i  instance (Functor m, Applicative m, Monad m) => Rest (RestM m) where-  getHeader    h     = RestM $ asks (H.lookup h . headers   )-  getParameter p     = RestM $ asks (H.lookup p . parameters)+  getHeader    h     = RestM $ asks (H.lookup (mk h) . headers   )+  getParameter p     = RestM $ asks (H.lookup p      . parameters)   getBody            = RestM $ asks body   getMethod          = RestM $ asks method   getPaths           = RestM $ asks paths-  lookupMimeType t   = RestM $ asks (H.lookup t . mimeTypes)+  lookupMimeType t   = RestM $ asks (H.lookup t      . mimeTypes)   setHeader h v      = RestM $ tell (outputHeader h v)   setResponseCode cd = RestM $ tell (outputCode cd)
src/Rest/Driver/Routing.hs view
@@ -1,16 +1,15 @@-{-# LANGUAGE ExistentialQuantification-           , GeneralizedNewtypeDeriving-           , RankNTypes-           , NamedFieldPuns-           , FlexibleContexts-           , StandaloneDeriving-    , ViewPatterns-    , NamedFieldPuns-           , GADTs-           , ScopedTypeVariables-           , DeriveDataTypeable-           , TupleSections-           #-}+{-# LANGUAGE+    DeriveDataTypeable+  , ExistentialQuantification+  , FlexibleContexts+  , GADTs+  , GeneralizedNewtypeDeriving+  , NamedFieldPuns+  , RankNTypes+  , ScopedTypeVariables+  , StandaloneDeriving+  , TupleSections+  #-} module Rest.Driver.Routing   ( route   , mkListHandler@@ -26,13 +25,14 @@ import Control.Arrow import Control.Category import Control.Error.Util-import Data.List.Split-import Control.Monad.Error+import Control.Monad.Error.Class import Control.Monad.Identity import Control.Monad.Reader-import Control.Monad.State (StateT, evalStateT, MonadState)+import Control.Monad.State (MonadState, StateT, evalStateT) import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe+import Data.List.Split import Network.Multipart (BodyPart (..), HeaderName (..)) import Safe import qualified Control.Monad.State       as State@@ -41,21 +41,21 @@ import qualified Data.Label.Total          as L  import Network.URI.Encode (decode)-import Rest.Api (Some1(..))+import Rest.Api (Some1 (..)) import Rest.Container import Rest.Dictionary-import qualified Rest.StringMap.HashMap.Strict as StringHashMap import Rest.Error-import Rest.Handler (ListHandler, Handler, GenHandler (..), Env (..), range, mkInputHandler, Range (..))+import Rest.Handler (Env (..), GenHandler (..), Handler, ListHandler, Range (..), mkInputHandler, range) import Rest.Types.Container.Resource (Resource, Resources (..))-import qualified Rest.Types.Container.Resource as R import qualified Rest.Api                      as Rest import qualified Rest.Resource                 as Rest import qualified Rest.Schema                   as Rest+import qualified Rest.StringMap.HashMap.Strict as StringHashMap+import qualified Rest.Types.Container.Resource as R -import Rest.Driver.Types-import Rest.Driver.Perform (writeResponse, failureWriter)+import Rest.Driver.Perform (failureWriter, writeResponse) import Rest.Driver.RestM (runRestM)+import Rest.Driver.Types  import qualified Rest.Driver.RestM as Rest @@ -299,9 +299,9 @@      return $ GenHandler newDict (mkListAction act) sec  mkListAction :: Monad m-            => (Env h p i -> ErrorT (Reason e) m [a])+            => (Env h p i -> ExceptT (Reason e) m [a])             -> Env h (Range, p) i-            -> ErrorT (Reason e) m (List a)+            -> ExceptT (Reason e) m (List a) mkListAction act (Env h (Range f c, p) i) = do   xs <- act (Env h p i)   return (List f (min c (length xs)) (take c xs))@@ -315,13 +315,13 @@              .  L.set errors defaultE              $  dict     newAct (Env hs ps vs) =-      do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runErrorT $+      do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runExceptT $            do i <- parseIdent sBy k-              mapErrorT (run i) (act (Env hs ps v))+              mapExceptT (run i) (act (Env hs ps v))          return . StringHashMap.fromList $ zipWith (\(k, _) b -> (k, eitherToStatus b)) (StringHashMap.toList vs) bs  mkMultiGetHandler :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Handler m-mkMultiGetHandler root = mkInputHandler (xmlJsonI . someI . multipartO) $ \(Resources rs) -> multiGetHandler rs+mkMultiGetHandler root = mkInputHandler (xmlJsonI . multipartO) $ \(Resources rs) -> multiGetHandler rs   where     multiGetHandler rs = lift $       do mapM (runResource root) rs
src/Rest/Error.hs view
@@ -1,11 +1,6 @@ {-# LANGUAGE-    DeriveDataTypeable-  , EmptyDataDecls+    FlexibleContexts   , GADTs-  , ScopedTypeVariables-  , StandaloneDeriving-  , TemplateHaskell-  , TypeFamilies   #-} -- | Error types that can be returned by handlers, as well as some -- utilities for manipulating these errors.@@ -16,10 +11,13 @@   , orThrowWith   , eitherToStatus   , domainReason+  , (>|<)   ) where  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Error.Class+import Control.Monad.Trans.Except+import Data.Semigroup  import Rest.Types.Error @@ -27,8 +25,8 @@  infixl 8 `mapE` -mapE :: (Applicative m, Monad m) => (e -> e') -> ErrorT e m a -> ErrorT e' m a-mapE f = mapErrorT (either (Left . f) Right <$>)+mapE :: (Applicative m, Monad m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a+mapE f = mapExceptT (either (Left . f) Right <$>)  orThrow :: MonadError e m => m (Maybe b) -> e -> m b orThrow a e = a >>= throwError e `maybe` return@@ -45,3 +43,15 @@ -- the error is served. domainReason :: ToResponseCode a => a -> Reason a domainReason = CustomReason . DomainReason++infixl 3 >|<+-- | Combine two ExceptT computations yielding the last error if both fail.+-- This prevents the need for a Semigroup or Monoid instance for the error type, which is necessary if using (<!>) or (<|>) respectively.+(>|<) :: (Applicative m, Monad m) => ExceptT e m a -> ExceptT e m a -> ExceptT e m a+a >|< b = mapE getLast (mapE Last a <!> mapE Last b)+  where+    ExceptT m <!> ExceptT n = ExceptT $ do+      v <- m+      case v of+        Left e -> fmap (either (Left . (<>) e) Right) n+        Right x -> return (Right x)
src/Rest/Handler.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE-    DeriveDataTypeable+    DataKinds+  , DeriveDataTypeable   , GADTs   , KindSignatures   , TupleSections@@ -35,14 +36,16 @@  import Control.Applicative hiding (empty) import Control.Arrow-import Control.Monad.Error+import Control.Monad.Except () import Control.Monad.Identity import Control.Monad.Reader+import Control.Monad.Trans.Except import Rest.Types.Range import Safe  import Rest.Dictionary import Rest.Error+import Rest.Types.Void  ------------------------------------------------------------------------------- @@ -68,16 +71,19 @@ -- running the API.  data GenHandler m f where-  GenHandler ::-    { dictionary :: Dict h p i o e-    , handler    :: Env h p i -> ErrorT (Reason e) m (Apply f o)+  GenHandler :: (i ~ FromMaybe () i', o ~ FromMaybe () o', e ~ FromMaybe Void e') =>+    { dictionary :: Dict h p i' o' e'+    , handler    :: Env h p i -> ExceptT (Reason e) m (Apply f o)     , secure     :: Bool     } -> GenHandler m f  -- | Construct a 'GenHandler' using a 'Modifier' instead of a 'Dict'. -- The 'secure' flag will be 'False'. -mkGenHandler :: Monad m => Modifier h p i o e -> (Env h p i -> ErrorT (Reason e) m (Apply f o)) -> GenHandler m f+mkGenHandler :: (Monad m, i ~ FromMaybe () i', o ~ FromMaybe () o', e ~ FromMaybe Void e')+             => Modifier h p i' o' e'+             -> (Env h p i -> ExceptT (Reason e) m (Apply f o))+             -> GenHandler m f mkGenHandler d a = GenHandler (d empty) a False  -- | Apply a Functor @f@ to a type @a@. In general will result in @f@@ -102,9 +108,9 @@ -- Restricts the type of the 'Input' dictionary to 'None'  mkListing-  :: Monad m-  => Modifier h p () o e-  -> (Range -> ErrorT (Reason e) m [o])+  :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void e')+  => Modifier h p Nothing o' e'+  -> (Range -> ExceptT (Reason e) m [o])   -> ListHandler m mkListing d a = mkGenHandler (mkPar range . d) (a . param) @@ -129,9 +135,9 @@ -- Restricts the type of the 'Input' dictionary to 'None'  mkOrderedListing-  :: Monad m-  => Modifier h p () o e-  -> ((Range, Maybe String, Maybe String) -> ErrorT (Reason e) m [o])+  :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void 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) @@ -155,23 +161,27 @@ -- | Create a handler for a single resource. Takes the entire -- environmend as input. -mkHandler :: Monad m => Modifier h p i o e -> (Env h p i -> ErrorT (Reason e) m o) -> Handler m+mkHandler :: (Monad m, i ~ FromMaybe () i', o ~ FromMaybe () o', e ~ FromMaybe Void e')+          => Modifier h p i' o' e' -> (Env h p i -> ExceptT (Reason e) m o) -> Handler m mkHandler = mkGenHandler  -- | Create a handler for a single resource. Takes only the body -- information as input. -mkInputHandler :: Monad m => Modifier () () i o e -> (i -> ErrorT (Reason e) m o) -> Handler m+mkInputHandler :: (Monad m, i ~ FromMaybe () i', o ~ FromMaybe () o', e ~ FromMaybe Void e')+               => Modifier () () i' o' e' -> (i -> ExceptT (Reason e) m o) -> Handler m mkInputHandler d a = mkHandler d (a . input)  -- | Create a handler for a single resource. Doesn't take any input. -mkConstHandler :: Monad m => Modifier () () () o e -> ErrorT (Reason e) m o -> Handler m+mkConstHandler :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void e')+               => 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 -- the resource identifier as input. The monad @m@ must be a -- 'Reader'-like type containing the idenfier. -mkIdHandler :: MonadReader id m => Modifier h p i o e -> (i -> id -> ErrorT (Reason e) m o) -> Handler m+mkIdHandler :: (MonadReader id m, i ~ FromMaybe () i', o ~ FromMaybe () o', e ~ FromMaybe Void e')+            => Modifier h p i' o' e' -> (i -> id -> ExceptT (Reason e) m o) -> Handler m mkIdHandler d a = mkHandler d (\env -> ask >>= a (input env))
src/Rest/Info.hs view
@@ -1,4 +1,4 @@ -- | Module facilitating informative inspection of datatypes.-module Rest.Info ( module Rest.Types.Info ) where+module Rest.Info (module Rest.Types.Info) where  import Rest.Types.Info
src/Rest/Resource.hs view
@@ -12,13 +12,21 @@ -- | A 'Resource' type for representing a REST resource, as well as -- smart constructors for empty resources which can then be filled in -- using record updates.-module Rest.Resource where+module Rest.Resource+  ( Resource (..)+  , mkResource+  , mkResourceId+  , mkResourceReader+  , mkResourceReaderWith+  , module Rest.Types.Void+  ) where  import Control.Applicative (Applicative) import Control.Monad.Reader  import Rest.Handler import Rest.Schema (Schema (..), Step (..))+import Rest.Types.Void  -- * The @Resource@ type. @@ -91,11 +99,3 @@  mkResourceReaderWith :: (Applicative m, Monad m, Applicative s, Monad s) => (forall b. s b -> ReaderT sid m b) -> Resource m s sid Void Void mkResourceReaderWith f = mkResource (\a -> flip runReaderT a . f)---- * The @Void@ type.---- | The 'Void' type is used as the identifier for resources that--- can't be routed to. It contains no values apart from bottom.--newtype Void = Void { magic :: forall a. a }-