packages feed

rest-core 0.36.0.6 → 0.39.0.2

raw patch · 18 files changed

Files

CHANGELOG.md view
@@ -1,5 +1,33 @@ # Changelog +## 0.39++* Add support for versionless APIs, thanks to Tenor Biel. This is a+  breaking change. Old API users will have to add `Versioned` before+  their list of api versions, so it becomes `Versioned [ (mkVersion+  ...) ]`.++## 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+  top-level POST that could perform multiple actions in the API at+  once. Now you can customize this handler (e.g. to add logging or+  optimisations) , or turn it off completely by returning `NotFound`.++  Because this is an experimental feature, it's exposed through+  `Rest.Driver.Routing.Internal` and is subject to future breaking+  changes without a major bump.++  There is one breaking change due to this: the signature of `route`+  now requires a `Monad` and `Applicative` constraint on `m`. This+  propagates to `Rest.Run.apiToHandler(')` and related functions in+  the rest-happstack, rest-snap and rest-wai packages.+ #### 0.36.0.6  * Security: don't allow newlines in filenames.
rest-core.cabal view
@@ -1,5 +1,5 @@ name:                rest-core-version:             0.36.0.6+version:             0.39.0.2 description:         Rest API library. synopsis:            Rest API library. maintainer:          code@silk.co@@ -30,6 +30,7 @@     Rest.Driver.Perform     Rest.Driver.RestM     Rest.Driver.Routing+    Rest.Driver.Routing.Internal     Rest.Driver.Types     Rest.Error     Rest.Handler@@ -39,12 +40,13 @@     Rest.Schema     Rest.ShowUrl   build-depends:-      base >= 4.5 && < 4.9-    , aeson >= 0.7 && < 0.10+      base >= 4.5 && < 4.12+    , aeson >= 0.7 && < 1.4     , 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.3     , fclabels == 2.0.*     , hxt >= 9.2 && < 9.4     , hxt-pickle-utils == 0.1.*@@ -58,12 +60,14 @@     , 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.7     , unordered-containers == 0.2.*     , uri-encode == 1.5.*     , utf8-string >= 0.3 && < 1.1     , uuid >= 1.2 && < 1.4+  if impl(ghc < 8.0)+    build-depends: semigroups == 0.18.*  test-suite rest-tests   ghc-options:       -Wall@@ -71,13 +75,14 @@   main-is:           Runner.hs   type:              exitcode-stdio-1.0   build-depends:-      base >= 4.5 && < 4.9-    , HUnit >= 1.2 && < 1.4+      base >= 4.5 && < 4.12+    , aeson >= 0.7 && < 1.4+    , HUnit >= 1.2 && < 1.7     , bytestring >= 0.9 && < 0.11     , mtl >= 2.0 && < 2.3     , 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.7     , 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@@ -24,3 +26,5 @@                     ) import Rest.Resource (Resource, mkResource, mkResourceId, mkResourceReader, mkResourceReaderWith, Void) import Rest.Schema++{-# ANN module "HLint: ignore Use import/export shortcut" #-}
src/Rest/Api.hs view
@@ -1,13 +1,19 @@ {-# LANGUAGE-    GADTs+    CPP+  , GADTs   , KindSignatures+  , NoImplicitPrelude   #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif -- | This module allows you to combine 'Resource's into an 'Api'. This -- can then be served using 'rest-happstack' or 'rest-snap', or used -- to generate clients or documentation using 'rest-gen'. module Rest.Api   ( -- * Api data types.-    Api+    Api (..)+  , VersionSet   , Router (..)   , Some1 (..) @@ -32,7 +38,8 @@   , withVersion   ) where -import Control.Applicative (Applicative)+import Prelude.Compat+ import Data.Char import Data.Function (on) import Data.List (sortBy)@@ -111,14 +118,22 @@ instance Show Version where   show v = show (full v) ++ "." ++ show (major v) ++ maybe "" (\x -> "." ++ show x) (minor v) --- | An API is a list of versioned routers.+-- | A version set is a list of versioned routers. -type Api m = [(Version, Some1 (Router m))]+type VersionSet m = [(Version, Some1 (Router m))] +-- | An API can be versioned or unversioned.+-- A versioned API is a set of versioned routers.+-- An unversioned API is just a single router.++data Api m where+    Unversioned :: Some1 (Router m) -> Api m+    Versioned   :: VersionSet m -> Api m+ -- | Get the latest version of an API. -latest :: Api m -> Maybe (Version, Some1 (Router m))-latest = headMay . reverse . sortBy (compare `on` fst)+latest :: VersionSet m -> Maybe (Version, Some1 (Router m))+latest = headMay . sortBy (flip compare `on` fst)  -- | Parse a 'String' as a 'Version'. The string should contain two or -- three numbers separated by dots, e.g. @1.12.3@.@@ -133,13 +148,13 @@ -- | Look up a version in an API. The string can either be a valid -- version according to 'parseVersion', or "latest". -lookupVersion :: String -> Api m -> Maybe (Some1 (Router m))+lookupVersion :: String -> VersionSet m -> Maybe (Some1 (Router m)) lookupVersion "latest" = fmap snd . latest lookupVersion str      = (parseVersion str >>=) . flip lookupVersion'  -- | Look up a version in the API. -lookupVersion' :: Version -> Api m -> Maybe (Some1 (Router m))+lookupVersion' :: Version -> VersionSet m -> Maybe (Some1 (Router m)) lookupVersion' v versions = best (filter (matches v . fst) versions)   where best = fmap snd . headMay . sortBy (flip (comparing fst))         matches :: Version -> Version -> Bool@@ -158,10 +173,15 @@ -- * If not parsed or found, return the fallback.  withVersion :: String -> Api m -> r -> (Version -> Some1 (Router m) -> r) -> r-withVersion ver api err ok =+withVersion ver (Versioned vrs) err ok =   maybe err (uncurry ok) $     case ver of-      "latest" -> latest api+      "latest" -> latest vrs       _        -> do pv <- parseVersion ver-                     r <- lookupVersion' pv api+                     r <- lookupVersion' pv vrs                      return (pv, r)+withVersion ver (Unversioned r) err ok =+  maybe err (uncurry ok) $+    case ver of+      "latest" -> return (mkVersion 1 0 0, r)+      _        -> Nothing
src/Rest/Container.hs view
@@ -1,11 +1,7 @@ {-# LANGUAGE     DataKinds-  , DeriveDataTypeable-  , EmptyDataDecls-  , FlexibleInstances   , GADTs   , ScopedTypeVariables-  , TemplateHaskell   , TypeFamilies   #-} module Rest.Container@@ -27,7 +23,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 +35,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 +47,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 +59,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,15 +72,15 @@     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+    case mapMaybe mappingDictO (es `intersect` os) of       []  -> Nothing       sos -> Just (Dicts sos)     where@@ -102,7 +98,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 +106,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
@@ -1,10 +1,14 @@ {-# LANGUAGE-    FlexibleContexts+    CPP+  , FlexibleContexts   , GADTs   , OverloadedStrings   , RankNTypes   , ScopedTypeVariables   #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif module Rest.Driver.Perform   ( Rest (..)   , failureWriter@@ -24,23 +28,23 @@ 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 import Data.Text.Lazy.Encoding (decodeUtf8)-import Data.UUID (UUID)+import Data.UUID.V4 (nextRandom) import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody) import Safe import System.IO.Unsafe-import System.Random (randomIO) import Text.Xml.Pickle  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 (..), 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 +160,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 +179,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 +214,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 +300,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 +324,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,37 +357,47 @@  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+  formats <- lift acceptM+  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 =-  do let boundary = show $ unsafePerformIO (randomIO :: IO UUID)+  do let boundary = show $ unsafePerformIO nextRandom      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 ct = (maybe id (:) ct) [minBound .. maxBound]+    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/Driver/RestM.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE+    CPP+  , GeneralizedNewtypeDeriving+  #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif module Rest.Driver.RestM   ( RestM   , runRestM@@ -10,9 +16,10 @@  import Control.Applicative import Control.Monad.Reader-import Control.Monad.Writer+import Control.Monad.Writer (WriterT (..), tell) import Data.CaseInsensitive (CI, mk) import Data.HashMap.Strict (HashMap)+import Data.Semigroup import qualified Data.ByteString.Lazy.UTF8 as UTF8 import qualified Data.HashMap.Strict       as H @@ -44,12 +51,15 @@   , responseCode :: Maybe Int   } deriving Show -instance Monoid RestOutput where-  mempty = RestOutput { headersSet = H.empty, responseCode = Nothing }-  o1 `mappend` o2 = RestOutput+instance Semigroup RestOutput where+  o1 <> o2 = RestOutput     { headersSet   = headersSet o2 `H.union` headersSet o1     , responseCode = responseCode o2 <|> responseCode o1     }++instance Monoid RestOutput where+  mempty = RestOutput { headersSet = H.empty, responseCode = Nothing }+  mappend = (<>)  outputHeader :: String -> String -> RestOutput outputHeader h v = mempty { headersSet = H.singleton h v }
src/Rest/Driver/Routing.hs view
@@ -1,15 +1,3 @@-{-# LANGUAGE-    DeriveDataTypeable-  , ExistentialQuantification-  , FlexibleContexts-  , GADTs-  , GeneralizedNewtypeDeriving-  , NamedFieldPuns-  , RankNTypes-  , ScopedTypeVariables-  , StandaloneDeriving-  , TupleSections-  #-} module Rest.Driver.Routing   ( route   , mkListHandler@@ -19,339 +7,4 @@   , splitUriString   ) where -import Prelude hiding (id, (.))--import Control.Applicative-import Control.Arrow-import Control.Category-import Control.Error.Util-import Control.Monad.Error.Class-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State (MonadState, StateT, evalStateT)-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-import qualified Data.ByteString.Lazy.UTF8 as LUTF8-import qualified Data.HashMap.Strict       as H-import qualified Data.Label.Total          as L--import Network.URI.Encode (decode)-import Rest.Api (Some1 (..))-import Rest.Container-import Rest.Dictionary-import Rest.Error-import Rest.Handler (Env (..), GenHandler (..), Handler, ListHandler, Range (..), mkInputHandler, range)-import Rest.Types.Container.Resource (Resource, Resources (..))-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.Perform (failureWriter, writeResponse)-import Rest.Driver.RestM (runRestM)-import Rest.Driver.Types--import qualified Rest.Driver.RestM as Rest--type UriParts = [String]--apiError :: (MonadError (Reason e) m) => Reason e -> m a-apiError = throwError--newtype Router a =-  Router { unRouter :: ReaderT Method (StateT UriParts (ExceptT Reason_ Identity)) a }-  deriving ( Functor-           , Applicative-           , Monad-           , MonadReader Method-           , MonadState UriParts-           , MonadError Reason_-           )--runRouter :: Method -> UriParts -> Router (RunnableHandler m) -> Either Reason_ (RunnableHandler m)-runRouter method uri = runIdentity-                     . runExceptT-                     . flip evalStateT uri-                     . flip runReaderT method-                     . unRouter--route :: Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m)-route Nothing       _   _   = apiError UnsupportedMethod-route (Just method) uri api = runRouter method uri $-  do versionStr <- popSegment-     case versionStr `Rest.lookupVersion` api of-          Just (Some1 router) -> routeRoot router-          _                   -> apiError UnsupportedVersion--routeRoot :: Rest.Router m s -> Router (RunnableHandler m)-routeRoot router@(Rest.Embed resource _) = do-  routeName (Rest.name resource)-  fromMaybeT (routeRouter router) (routeMultiGet router)--routeMultiGet :: Rest.Router m s -> MaybeT Router (RunnableHandler m)-routeMultiGet root@(Rest.Embed Rest.Resource{} _) =-  do guardNullPath-     guardMethod POST-     return (RunnableHandler id (mkMultiGetHandler root))--routeRouter :: Rest.Router m s -> Router (RunnableHandler m)-routeRouter (Rest.Embed resource@(Rest.Resource { Rest.schema }) subRouters) =-  case schema of-    (Rest.Schema mToplevel step) -> maybe (apiError UnsupportedRoute) return =<< runMaybeT-       (  routeToplevel resource subRouters mToplevel-      <|> routeCreate resource-      <|> lift (routeStep resource subRouters step)-       )--routeToplevel :: Rest.Resource m s sid mid aid-              -> [Some1 (Rest.Router s)]-              -> Maybe (Rest.Cardinality sid mid)-              -> MaybeT Router (RunnableHandler m)-routeToplevel resource@(Rest.Resource { Rest.list }) subRouters mToplevel =-  hoistMaybe mToplevel >>= \toplevel ->-  case toplevel of-    Rest.Single sid -> lift $ withSubresource sid resource subRouters-    Rest.Many   mid ->-      do guardNullPath-         guardMethod GET-         lift $ routeListHandler (list mid)--routeCreate :: Rest.Resource m s sid mid aid -> MaybeT Router (RunnableHandler m)-routeCreate (Rest.Resource { Rest.create }) = guardNullPath >> guardMethod POST >>-  maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create--routeStep :: Rest.Resource m s sid mid aid-          -> [Some1 (Rest.Router s)]-          -> Rest.Step sid mid aid-          -> Router (RunnableHandler m)-routeStep resource subRouters step =-  case step of-    Rest.Named ns -> popSegment >>= \seg ->-      case lookup seg ns of-        Nothing -> apiError UnsupportedRoute-        Just h  -> routeNamed resource subRouters h-    Rest.Unnamed h -> routeUnnamed resource subRouters h--routeNamed :: Rest.Resource m s sid mid aid-           -> [Some1 (Rest.Router s)]-           -> Rest.Endpoint sid mid aid-           -> Router (RunnableHandler m)-routeNamed resource@(Rest.Resource { Rest.list, Rest.statics }) subRouters h =-  case h of-    Left aid -> noRestPath >> hasMethod POST >> return (RunnableHandler id (statics aid))-    Right (Rest.Single getter) -> routeGetter getter resource subRouters-    Right (Rest.Many   getter) -> routeListGetter getter list--routeUnnamed :: Rest.Resource m s sid mid aid-             -> [Some1 (Rest.Router s)]-             -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid)-             -> Router (RunnableHandler m)-routeUnnamed resource@(Rest.Resource { Rest.list }) subRouters cardinality =-  case cardinality of-    Rest.Single sBy -> withSegment (multi resource sBy) $ \seg ->-      parseIdent sBy seg >>= \sid -> withSubresource sid resource subRouters-    Rest.Many   mBy ->-      do seg <- popSegment-         mid <- parseIdent mBy seg-         noRestPath-         hasMethod GET-         routeListHandler (list mid)--routeGetter :: Rest.Getter sid-            -> Rest.Resource m s sid mid aid-            -> [Some1 (Rest.Router s)]-            -> Router (RunnableHandler m)-routeGetter getter resource subRouters =-  case getter of-    Rest.Singleton sid -> getOrDeep sid-    Rest.By        sBy -> withSegment (multi resource sBy) $ \seg ->-                            parseIdent sBy seg >>= getOrDeep-  where-    getOrDeep sid = withSubresource sid resource subRouters--multi :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router (RunnableHandler m)-multi (Rest.Resource { Rest.update, Rest.remove, Rest.enter }) sBy =-  ask >>= \method ->-  case method of-    PUT    -> handleOrNotFound update-    DELETE -> handleOrNotFound remove-    _      -> apiError UnsupportedMethod-  where-    handleOrNotFound handler =-      maybe (apiError UnsupportedRoute)-            (return . RunnableHandler id)-            (handler >>= mkMultiHandler sBy enter)--routeListGetter :: Monad m-                => Rest.Getter mid-                -> (mid -> ListHandler m)-                -> Router (RunnableHandler m)-routeListGetter getter list = hasMethod GET >>-  case getter of-    Rest.Singleton mid -> noRestPath >> routeListHandler (list mid)-    Rest.By        mBy ->-      do seg <- popSegment-         mid <- parseIdent mBy seg-         noRestPath-         routeListHandler (list mid)--withSubresource :: sid-                -> Rest.Resource m s sid mid aid-                -> [Some1 (Rest.Router s)]-                -> Router (RunnableHandler m)-withSubresource sid resource@(Rest.Resource { Rest.enter, Rest.selects, Rest.actions }) subRouters =-  withSegment (routeSingle sid resource) $ \seg ->-  case lookup seg selects of-    Just select -> noRestPath >> hasMethod GET >> return (RunnableHandler (enter sid) select)-    Nothing -> case lookup seg actions of-      Just action -> noRestPath >> hasMethod POST >> return (RunnableHandler (enter sid) action)-      Nothing ->-        case lookupRouter seg subRouters of-          Just (Some1 subRouter) -> do-            (RunnableHandler subRun subHandler) <- routeRouter subRouter-            return (RunnableHandler (enter sid . subRun) subHandler)-          Nothing -> apiError UnsupportedRoute--routeSingle :: sid -> Rest.Resource m s sid mid aid -> Router (RunnableHandler m)-routeSingle sid (Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove }) =-  ask >>= \method ->-  case method of-    GET    -> handleOrNotFound get-    PUT    -> handleOrNotFound update-    DELETE -> handleOrNotFound remove-    _      -> apiError UnsupportedMethod-  where-    handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid))--routeName :: String -> Router ()-routeName ident = when (not . null $ ident) $-  do identStr <- popSegment-     when (identStr /= ident) $-       apiError UnsupportedRoute--routeListHandler :: Monad m => ListHandler m -> Router (RunnableHandler m)-routeListHandler list =-      maybe (apiError UnsupportedRoute)-            (return . RunnableHandler id)-            (mkListHandler list)--lookupRouter :: String -> [Some1 (Rest.Router s)] -> Maybe (Some1 (Rest.Router s))-lookupRouter _    [] = Nothing-lookupRouter name (Some1 router@(Rest.Embed resource _) : routers)-   =  (guard (Rest.name resource == name) >> return (Some1 router))-  <|> lookupRouter name routers--parseIdent :: MonadError (Reason e) m => Rest.Id id -> String -> m id-parseIdent (Rest.Id StringId byF) seg = return (byF seg)-parseIdent (Rest.Id ReadId   byF) seg =-  case readMay seg of-    Nothing  -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg))-    Just sid -> return (byF sid)--splitUriString :: String -> UriParts-splitUriString = filter (/= "") . map decode . splitOn "/"--popSegment :: Router String-popSegment =-  do uriParts <- State.get-     case uriParts of-       []      -> apiError UnsupportedRoute-       (hd:tl) -> do-         State.put tl-         return hd--withSegment :: Router a -> (String -> Router a) -> Router a-withSegment noSeg withSeg =-  do uriParts <- State.get-     case uriParts of-       [] -> noSeg-       (hd:tl) -> do-         State.put tl-         withSeg hd--noRestPath :: Router ()-noRestPath =-  do uriParts <- State.get-     unless (null uriParts) $-       apiError UnsupportedRoute--guardNullPath :: (MonadPlus m, MonadState UriParts m) => m ()-guardNullPath = State.get >>= guard . null--hasMethod :: Method -> Router ()-hasMethod wantedMethod = ask >>= \method ->-  if method == wantedMethod-  then return ()-  else apiError UnsupportedMethod--guardMethod :: (MonadPlus m, MonadReader Method m) => Method -> m ()-guardMethod method = ask >>= guard . (== method)--mkListHandler :: Monad m => ListHandler m -> Maybe (Handler m)-mkListHandler (GenHandler dict act sec) =-  do newDict <- L.traverse outputs listO . addPar range $ dict-     return $ GenHandler newDict (mkListAction act) sec--mkListAction :: Monad m-            => (Env h p i -> ExceptT (Reason e) m [a])-            -> Env h (Range, p) i-            -> 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))--mkMultiHandler :: Monad m => Rest.Id id -> (id -> Run s m) -> Handler s -> Maybe (Handler m)-mkMultiHandler sBy run (GenHandler dict act sec) = GenHandler <$> mNewDict <*> pure newAct <*> pure sec-  where-    newErrDict = L.modify errors reasonE dict-    mNewDict =  L.traverse inputs mappingI-            <=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict))-             .  L.set errors defaultE-             $  dict-    newAct (Env hs ps vs) =-      do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runExceptT $-           do i <- parseIdent sBy k-              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 . multipartO) $ \(Resources rs) -> multiGetHandler rs-  where-    multiGetHandler rs = lift $-      do mapM (runResource root) rs--runResource :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Resource -> m BodyPart-runResource root res-  = fmap (uncurry mkBodyPart)-  . runRestM (toRestInput res)-  . either (failureWriter None) (writeResponse . mapHandler lift)-  . routeResource-  $ R.uri res-  where-    routeResource :: String -> Either Reason_ (RunnableHandler m)-    routeResource uri = runRouter (R.method res) (splitUriString uri) (routeRoot root)--    toRestInput r = Rest.emptyInput-      { Rest.headers    = H.map (R.unValue) . StringHashMap.toHashMap . R.headers    $ r-      , Rest.parameters = H.map (R.unValue) . StringHashMap.toHashMap . R.parameters $ r-      , Rest.body       = LUTF8.fromString (R.input r)-      , Rest.method     = Just (R.method r)-      , Rest.paths      = splitUriString (R.uri r)-      }--    mkHeaders = map (first HeaderName) . H.toList--    mkBodyPart bdy restOutput =-      let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput))-               : mkHeaders (Rest.headersSet restOutput)-      in BodyPart hdrs bdy---- * Utilities--fromMaybeT :: Monad m => m a -> MaybeT m a -> m a-fromMaybeT def act = runMaybeT act >>= maybe def return+import Rest.Driver.Routing.Internal
+ src/Rest/Driver/Routing/Internal.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE+    CPP+  , ExistentialQuantification+  , FlexibleContexts+  , GADTs+  , GeneralizedNewtypeDeriving+  , NamedFieldPuns+  , RankNTypes+  , ScopedTypeVariables+  , TupleSections+  #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif++module Rest.Driver.Routing.Internal where++import Prelude hiding (id, (.))++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Error.Util+import Control.Monad.Error.Class+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State (MonadState, StateT, evalStateT)+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+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.HashMap.Strict       as H+import qualified Data.Label.Total          as L++import Network.URI.Encode (decode)+import Rest.Api (Some1 (..))+import Rest.Container+import Rest.Dictionary+import Rest.Error+import Rest.Handler (Env (..), GenHandler (..), Handler, ListHandler, Range (..), mkInputHandler, range)+import Rest.Types.Container.Resource (Resource, Resources (..))+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.Perform (failureWriter, writeResponse)+import Rest.Driver.RestM (runRestM)+import Rest.Driver.Types++import qualified Rest.Driver.RestM as Rest++{-# ANN module "HLint: ignore Reduce duplication" #-}++type UriParts = [String]++apiError :: (MonadError (Reason e) m) => Reason e -> m a+apiError = throwError++data RouterData m = RouterData { method :: Method, config :: Config m }++newtype Router m a =+  Router { unRouter :: ReaderT (RouterData m) (StateT UriParts (ExceptT Reason_ Identity)) a }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadReader (RouterData m)+           , MonadState UriParts+           , MonadError Reason_+           )++runRouter :: Config m -> Method -> UriParts -> Router m (RunnableHandler m) -> Either Reason_ (RunnableHandler m)+runRouter cfg mtd uri = runIdentity+                      . runExceptT+                      . flip evalStateT uri+                      . flip runReaderT (RouterData mtd cfg)+                      . unRouter++route :: (Applicative m, Monad m) => Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m)+route = routeWith defaultConfig++routeWith :: Config m -> Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m)+routeWith _    Nothing   _   _   = apiError UnsupportedMethod+routeWith cfg (Just mtd) uri api = runRouter cfg mtd uri $+  case api of+    Rest.Unversioned (Some1 router) -> routeRoot router+    Rest.Versioned   vrs            -> do+      versionStr <- popSegment+      case versionStr `Rest.lookupVersion` vrs of+          Just (Some1 router) -> routeRoot router+          _                   -> apiError UnsupportedVersion++routeRoot :: Rest.Router m s -> Router m (RunnableHandler m)+routeRoot router@(Rest.Embed resource _) = do+  routeName (Rest.name resource)+  fromMaybeT (routeRouter router) (routeMultiGet router)++routeMultiGet :: Rest.Router m s -> MaybeT (Router m) (RunnableHandler m)+routeMultiGet root@(Rest.Embed Rest.Resource{} _) =+  do guardNullPath+     guardMethod POST+     cfg <- asks config+     return (RunnableHandler id (mkMultiGetHandler cfg root))++routeRouter :: Rest.Router m s -> Router n (RunnableHandler m)+routeRouter (Rest.Embed resource@Rest.Resource { Rest.schema } subRouters) =+  case schema of+    (Rest.Schema mToplevel step) -> maybe (apiError UnsupportedRoute) return =<< runMaybeT+       (  routeToplevel resource subRouters mToplevel+      <|> routeCreate resource+      <|> lift (routeStep resource subRouters step)+       )++routeToplevel :: Rest.Resource m s sid mid aid+              -> [Some1 (Rest.Router s)]+              -> Maybe (Rest.Cardinality sid mid)+              -> MaybeT (Router n) (RunnableHandler m)+routeToplevel resource@Rest.Resource { Rest.list } subRouters mToplevel =+  hoistMaybe mToplevel >>= \toplevel ->+  case toplevel of+    Rest.Single sid -> lift $ withSubresource sid resource subRouters+    Rest.Many   mid ->+      do guardNullPath+         guardMethod GET+         lift $ routeListHandler (list mid)++routeCreate :: Rest.Resource m s sid mid aid -> MaybeT (Router n) (RunnableHandler m)+routeCreate Rest.Resource { Rest.create } = guardNullPath >> guardMethod POST >>+  maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create++routeStep :: Rest.Resource m s sid mid aid+          -> [Some1 (Rest.Router s)]+          -> Rest.Step sid mid aid+          -> Router n (RunnableHandler m)+routeStep resource subRouters step =+  case step of+    Rest.Named ns -> popSegment >>= \seg ->+      case lookup seg ns of+        Nothing -> apiError UnsupportedRoute+        Just h  -> routeNamed resource subRouters h+    Rest.Unnamed h -> routeUnnamed resource subRouters h++routeNamed :: Rest.Resource m s sid mid aid+           -> [Some1 (Rest.Router s)]+           -> Rest.Endpoint sid mid aid+           -> Router n (RunnableHandler m)+routeNamed resource@Rest.Resource { Rest.list, Rest.statics } subRouters h =+  case h of+    Left aid -> noRestPath >> hasMethod POST >> return (RunnableHandler id (statics aid))+    Right (Rest.Single getter) -> routeGetter getter resource subRouters+    Right (Rest.Many   getter) -> routeListGetter getter list++routeUnnamed :: Rest.Resource m s sid mid aid+             -> [Some1 (Rest.Router s)]+             -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid)+             -> Router n (RunnableHandler m)+routeUnnamed resource@Rest.Resource { Rest.list } subRouters cardinality =+  case cardinality of+    Rest.Single sBy -> withSegment (multi resource sBy) $+      parseIdent sBy >=> \sid -> withSubresource sid resource subRouters+    Rest.Many   mBy ->+      do seg <- popSegment+         mid <- parseIdent mBy seg+         noRestPath+         hasMethod GET+         routeListHandler (list mid)++routeGetter :: Rest.Getter sid+            -> Rest.Resource m s sid mid aid+            -> [Some1 (Rest.Router s)]+            -> Router n (RunnableHandler m)+routeGetter getter resource subRouters =+  case getter of+    Rest.Singleton sid -> getOrDeep sid+    Rest.By        sBy -> withSegment (multi resource sBy) $+                            parseIdent sBy >=> getOrDeep+  where+    getOrDeep sid = withSubresource sid resource subRouters++multi :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router n (RunnableHandler m)+multi Rest.Resource { Rest.update, Rest.remove, Rest.enter } sBy =+  asks method >>= \mtd ->+  case mtd of+    PUT    -> handleOrNotFound update+    DELETE -> handleOrNotFound remove+    _      -> apiError UnsupportedMethod+  where+    handleOrNotFound handler =+      maybe (apiError UnsupportedRoute)+            (return . RunnableHandler id)+            (handler >>= mkMultiHandler sBy enter)++routeListGetter :: Monad m+                => Rest.Getter mid+                -> (mid -> ListHandler m)+                -> Router n (RunnableHandler m)+routeListGetter getter list = hasMethod GET >>+  case getter of+    Rest.Singleton mid -> noRestPath >> routeListHandler (list mid)+    Rest.By        mBy ->+      do seg <- popSegment+         mid <- parseIdent mBy seg+         noRestPath+         routeListHandler (list mid)++withSubresource :: sid+                -> Rest.Resource m s sid mid aid+                -> [Some1 (Rest.Router s)]+                -> Router n (RunnableHandler m)+withSubresource sid resource@Rest.Resource { Rest.enter, Rest.selects, Rest.actions } subRouters =+  withSegment (routeSingle sid resource) $ \seg ->+  case lookup seg selects of+    Just select -> noRestPath >> hasMethod GET >> return (RunnableHandler (enter sid) select)+    Nothing -> case lookup seg actions of+      Just action -> noRestPath >> hasMethod POST >> return (RunnableHandler (enter sid) action)+      Nothing ->+        case lookupRouter seg subRouters of+          Just (Some1 subRouter) -> do+            (RunnableHandler subRun subHandler) <- routeRouter subRouter+            return (RunnableHandler (enter sid . subRun) subHandler)+          Nothing -> apiError UnsupportedRoute++routeSingle :: sid -> Rest.Resource m s sid mid aid -> Router n (RunnableHandler m)+routeSingle sid Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove } =+  asks method >>= \mtd ->+  case mtd of+    GET    -> handleOrNotFound get+    PUT    -> handleOrNotFound update+    DELETE -> handleOrNotFound remove+    _      -> apiError UnsupportedMethod+  where+    handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid))++routeName :: String -> Router n ()+routeName ident = unless (null ident) $+  do identStr <- popSegment+     when (identStr /= ident) $+       apiError UnsupportedRoute++routeListHandler :: Monad m => ListHandler m -> Router n (RunnableHandler m)+routeListHandler list =+      maybe (apiError UnsupportedRoute)+            (return . RunnableHandler id)+            (mkListHandler list)++lookupRouter :: String -> [Some1 (Rest.Router s)] -> Maybe (Some1 (Rest.Router s))+lookupRouter _    [] = Nothing+lookupRouter name (Some1 router@(Rest.Embed resource _) : routers)+   =  (guard (Rest.name resource == name) >> return (Some1 router))+  <|> lookupRouter name routers++parseIdent :: MonadError (Reason e) m => Rest.Id id -> String -> m id+parseIdent (Rest.Id StringId byF) seg = return (byF seg)+parseIdent (Rest.Id ReadId   byF) seg =+  case readMay seg of+    Nothing  -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg))+    Just sid -> return (byF sid)++splitUriString :: String -> UriParts+splitUriString = filter (/= "") . map decode . splitOn "/"++popSegment :: Router n String+popSegment =+  do uriParts <- State.get+     case uriParts of+       []      -> apiError UnsupportedRoute+       (hd:tl) -> do+         State.put tl+         return hd++withSegment :: Router n a -> (String -> Router n a) -> Router n a+withSegment noSeg withSeg =+  do uriParts <- State.get+     case uriParts of+       [] -> noSeg+       (hd:tl) -> do+         State.put tl+         withSeg hd++noRestPath :: Router n ()+noRestPath =+  do uriParts <- State.get+     unless (null uriParts) $+       apiError UnsupportedRoute++guardNullPath :: (MonadPlus m, MonadState UriParts m) => m ()+guardNullPath = State.get >>= guard . null++hasMethod :: Method -> Router n ()+hasMethod wantedMethod = asks method >>= \mtd ->+  unless (mtd == wantedMethod) $+    apiError UnsupportedMethod++guardMethod :: (MonadPlus m, MonadReader (RouterData c) m) => Method -> m ()+guardMethod mtd = asks method >>= guard . (== mtd)++mkListHandler :: Monad m => ListHandler m -> Maybe (Handler m)+mkListHandler (GenHandler dict act sec) =+  do newDict <- L.traverse outputs listO . addPar range $ dict+     return $ GenHandler newDict (mkListAction act) sec++mkListAction :: Monad m+            => (Env h p i -> ExceptT (Reason e) m [a])+            -> Env h (Range, p) i+            -> 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))++mkMultiHandler :: Monad m => Rest.Id id -> (id -> Run s m) -> Handler s -> Maybe (Handler m)+mkMultiHandler sBy run (GenHandler dict act sec) = GenHandler <$> mNewDict <*> pure newAct <*> pure sec+  where+    newErrDict = L.modify errors reasonE dict+    mNewDict =  L.traverse inputs mappingI+            <=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict))+             .  L.set errors defaultE+             $  dict+    newAct (Env hs ps vs) =+      do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runExceptT $+           do i <- parseIdent sBy k+              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) => Config m -> Rest.Router m s -> Handler m+mkMultiGetHandler cfg root = mkInputHandler (xmlJsonI . multipartO) $ \(Resources rs) -> runMultiResources cfg cfg root rs++defaultRunMultiResources :: (Applicative m, Monad m) => Config m -> Rest.Router m s -> [Resource] -> ExceptT Reason_ m [BodyPart]+defaultRunMultiResources cfg root rs = lift $ forM rs (runResource cfg root)++defaultConfig :: (Applicative m, Monad m) => Config m+defaultConfig = Config { runMultiResources = defaultRunMultiResources }++runResource :: (Applicative m, Monad m) => Config m -> Rest.Router m s -> Resource -> m BodyPart+runResource cfg root res+  = fmap (uncurry mkBodyPart)+  . runRestM (toRestInput res)+  . either (failureWriter None) (writeResponse . mapHandler lift)+  $ routeResource cfg root res++routeResource :: Config m -> Rest.Router m s -> Resource -> Either Reason_ (RunnableHandler m)+routeResource cfg root res = runRouter cfg (R.method res) (splitUriString $ R.uri res) (routeRoot root)++toRestInput :: Resource -> Rest.RestInput+toRestInput r = Rest.emptyInput+  { Rest.headers    = H.map R.unValue . StringHashMap.toHashMap . R.headers    $ r+  , Rest.parameters = H.map R.unValue . StringHashMap.toHashMap . R.parameters $ r+  , Rest.body       = LUTF8.fromString (R.input r)+  , Rest.method     = Just (R.method r)+  , Rest.paths      = splitUriString (R.uri r)+  }++mkHeaders :: H.HashMap String d -> [(HeaderName, d)]+mkHeaders = map (first HeaderName) . H.toList++mkBodyPart :: LUTF8.ByteString -> Rest.RestOutput -> BodyPart+mkBodyPart bdy restOutput =+  let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput))+           : mkHeaders (Rest.headersSet restOutput)+  in BodyPart hdrs bdy++-- * Utilities++fromMaybeT :: Monad m => m a -> MaybeT m a -> m a+fromMaybeT def act = runMaybeT act >>= maybe def return
src/Rest/Driver/Types.hs view
@@ -2,14 +2,22 @@ module Rest.Driver.Types   ( Run   , RunnableHandler (..)+  , Config (..)   , mapHandler    , module Rest.Types.Method   ) where +import Control.Monad.Trans.Except+import Network.Multipart (BodyPart)++import Rest.Api (Router)+import Rest.Error (Reason_) import Rest.Handler (Handler)+import Rest.Types.Container.Resource (Resource) import Rest.Types.Method (Method (..)) + type Run m n = forall a. m a -> n a  data RunnableHandler n = forall m. RunnableHandler@@ -18,3 +26,8 @@  mapHandler :: Run m n -> RunnableHandler m -> RunnableHandler n mapHandler run (RunnableHandler run' h) = RunnableHandler (run . run') h++newtype Config m+  = Config+  { runMultiResources :: forall s. Config m -> Router m s -> [Resource] -> ExceptT Reason_ m [BodyPart]+  }
src/Rest/Error.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE-    FlexibleContexts+    CPP+  , FlexibleContexts   , GADTs+  , NoImplicitPrelude   #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif -- | Error types that can be returned by handlers, as well as some -- utilities for manipulating these errors. module Rest.Error@@ -14,7 +19,8 @@   , (>|<)   ) where -import Control.Applicative+import Prelude.Compat+ import Control.Monad.Except  import Rest.Types.Error
src/Rest/Handler.hs view
@@ -1,11 +1,16 @@ {-# LANGUAGE-    DataKinds+    CPP+  , DataKinds   , DeriveDataTypeable   , GADTs   , KindSignatures+  , NoImplicitPrelude   , TupleSections   , TypeFamilies   #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif -- | Handlers for endpoints in a 'Resource'. module Rest.Handler   ( -- * Single handlers.@@ -34,7 +39,8 @@   , secureHandler   ) where -import Control.Applicative hiding (empty)+import Prelude.Compat+ import Control.Arrow import Control.Monad.Except () import Control.Monad.Identity@@ -109,7 +115,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 +142,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 +181,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,14 +1,18 @@ {-# LANGUAGE-    TemplateHaskell-  , MultiParamTypeClasses-  , FlexibleInstances+    CPP   , FlexibleContexts-  , TypeSynonymInstances-  , RankNTypes-  , KindSignatures+  , FlexibleInstances   , GADTs+  , KindSignatures+  , MultiParamTypeClasses   , NamedFieldPuns+  , NoImplicitPrelude+  , RankNTypes+  , TypeSynonymInstances   #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif -- | 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.@@ -21,7 +25,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,24 +1,38 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE+    CPP+  , NoImplicitPrelude+  , RankNTypes+  #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif module Rest.Run   ( apiToHandler   , apiToHandler'+  , apiToHandlerWith+  , Config (..)   ) where +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.Routing import Rest.Driver.Types+import qualified Rest.Driver.Routing.Internal as I -apiToHandler :: Rest m => Api m -> m UTF8.ByteString+apiToHandler :: (Applicative m, Monad m) => Rest m => Api m -> m UTF8.ByteString apiToHandler = apiToHandler' id -apiToHandler' :: Rest n => Run m n -> Api m -> n UTF8.ByteString-apiToHandler' run api = do+apiToHandler' :: (Applicative m, Monad m) => Rest n => Run m n -> Api m -> n UTF8.ByteString+apiToHandler' = apiToHandlerWith I.defaultConfig++apiToHandlerWith :: Config m -> Rest n => Run m n -> Api m -> n UTF8.ByteString+apiToHandlerWith cfg run api = do   method <- getMethod   paths  <- getPaths-  case route method paths api of+  case I.routeWith cfg method paths api of     Left  e -> failureWriter None e     Right h -> writeResponse (mapHandler run h)
src/Rest/Schema.hs view
@@ -82,7 +82,7 @@  -- | A single resource endpoint with an identifier that can be read. -singleRead :: (Show a, Read a, Info a) => (a -> sid) -> Endpoint sid mid aid+singleRead :: (Read a, Info a) => (a -> sid) -> Endpoint sid mid aid singleRead = singleIdent ReadId  -- | A single resource identified as specified by the 'Ident'.@@ -102,7 +102,7 @@  -- | A listing with an identifier that can be read. -listingRead :: (Show a, Read a, Info a) => (a -> mid) -> Endpoint sid mid aid+listingRead :: (Read a, Info a) => (a -> mid) -> Endpoint sid mid aid listingRead = listingIdent ReadId  -- | A listing identified as specified by the 'Ident'.@@ -118,7 +118,7 @@  -- | An unnamed single resource with an identifier that can be read. -unnamedSingleRead :: (Show a, Read a, Info a) => (a -> sid) -> Step sid mid aid+unnamedSingleRead :: (Read a, Info a) => (a -> sid) -> Step sid mid aid unnamedSingleRead = unnamedSingleIdent ReadId  -- | An unnamed single resource identified as specified by the@@ -133,7 +133,7 @@ unnamedListing = unnamedListingIdent StringId  -- | An unnamed listing with an identifier that can be read.-unnamedListingRead :: (Show a, Read a, Info a) => (a -> mid) -> Step sid mid aid+unnamedListingRead :: (Read a, Info a) => (a -> mid) -> Step sid mid aid unnamedListingRead = unnamedListingIdent ReadId  -- | An unnamed listing identified as specified by the 'Ident'.
tests/Runner.hs view
@@ -1,32 +1,38 @@ {-# LANGUAGE-    OverloadedStrings+    CPP+  , OverloadedStrings+  , RankNTypes   , ScopedTypeVariables   #-}--import Control.Applicative+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif import Control.Monad+import Control.Monad.Except+import Control.Monad.Identity import Control.Monad.Reader+import Data.Aeson import Data.Monoid import Test.Framework (defaultMain) 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 hiding (input) import Rest.Api hiding (route)-import Rest.Dictionary+import Rest.Dictionary (Format (..), Ident (..)) import Rest.Driver.Perform (accept)-import Rest.Driver.RestM (runRestM_) import Rest.Driver.Routing import Rest.Driver.Types-import Rest.Handler import Rest.Resource-import Rest.Schema import qualified Rest.Api          as Rest-import qualified Rest.Driver.RestM as RestM+import qualified Rest.Container    as C+import qualified Rest.Driver.RestM as RM+import qualified Rest.Resource     as Res+import qualified Rest.Run          as Run  main :: IO ()-main = do+main =   defaultMain [ testCase "Top level listing." testListing               , testCase "Top level listing (trailing slash)." testListingTrailingSlash               , testCase "Top level singleton." testToplevelSingleton@@ -44,21 +50,19 @@               , testCase "Multi-PUT." testMultiPut               , testCase "Multi-POST" testMultiPost               , testCase "Accept headers." testAcceptHeaders+              , testCase "Test listing count" testListingCount               ] -testListing :: Assertion-testListing = checkRoute GET "resource" (Rest.root -/ Rest.route resource)+listResource :: Resource IO IO Void () Void+listResource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }   where-    resource :: Resource IO IO Void () Void-    resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }     listHandler () = mkListing id $ \_ -> return [] +testListing :: Assertion+testListing = checkRoute GET "resource" (Rest.root -/ Rest.route listResource)+ testListingTrailingSlash :: Assertion-testListingTrailingSlash = checkRoute GET "resource/" (Rest.root -/ Rest.route resource)-  where-    resource :: Resource IO IO Void () Void-    resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }-    listHandler () = mkListing id $ \_ -> return []+testListingTrailingSlash = checkRoute GET "resource/" (Rest.root -/ Rest.route listResource)  testToplevelSingleton :: Assertion testToplevelSingleton = checkSingleRoute "resource" resource handler_@@ -159,7 +163,7 @@     resource = mkResourceReader       { name   = "resource"       , schema = Schema Nothing (Named [("foo", Right (Single (By (Id StringId id))))])-      , update = Just (mkConstHandler xmlJsonO (liftM void ask))+      , update = Just (mkConstHandler xmlJsonO (fmap void ask))       }  testMultiPost :: Assertion@@ -176,28 +180,28 @@      checkRoute GET    (uri <> "/select") (root -/ Rest.route resource { selects = [("select", handler_)] })      checkRoute POST   (uri <> "/action") (root -/ Rest.route resource { actions = [("action", handler_)] }) -checkRoute :: Method -> Uri -> Rest.Router m s -> Assertion+checkRoute :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion checkRoute method uri router = checkRouteWithIgnoredMethods [method] router method uri -checkRoutes :: [(Method, Uri)] -> Rest.Router m s -> Assertion+checkRoutes :: (Applicative m, Monad m) => [(Method, Uri)] -> Rest.Router m s -> Assertion checkRoutes reqs router =-  do forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router+  forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router -checkRouteWithIgnoredMethods :: [Method] -> Rest.Router m s -> Method -> Uri -> Assertion+checkRouteWithIgnoredMethods :: (Applicative m, Monad m) => [Method] -> Rest.Router m s -> Method -> Uri -> Assertion checkRouteWithIgnoredMethods ignoredMethods router method uri =   do checkRouteSuccess method uri router      forM_ (filter (not . (`elem` ignoredMethods)) allMethods) $ \badMethod -> checkRouteFailure badMethod uri router      checkRouteFailure method (uri <> "/trailing") router -checkRouteFailure :: Method -> Uri -> Rest.Router m s -> Assertion+checkRouteFailure :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion checkRouteFailure method uri router =-  case route (Just method) (splitUriString $ "v1.0/" <> uri) [(Version 1 0 Nothing, Some1 router)] of+  case route (Just method) (splitUriString $ "v1.0/" <> uri) (Versioned [(Version 1 0 Nothing, Some1 router)]) of     Left _  -> return ()     Right _ -> assertFailure ("Should be no route to " ++ show method ++ " " ++ uri ++ ".") -checkRouteSuccess :: Method -> Uri -> Rest.Router m s -> Assertion+checkRouteSuccess :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion checkRouteSuccess method uri router =-  case route (Just method) (splitUriString $ "v1.0/" <> uri) [(Version 1 0 Nothing, Some1 router)] of+  case route (Just method) (splitUriString $ "v1.0/" <> uri) (Versioned [(Version 1 0 Nothing, Some1 router)]) of     Left e  -> assertFailure ("No route to " ++ show method ++ " " ++ uri ++ ": " ++ show e)     Right _ -> return () @@ -206,5 +210,33 @@  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++testListingCount :: Assertion+testListingCount = assertEqual "listing count" (Right $ C.List 0 5 [1..5::Int]) (eitherDecode bs)+  where+    (bs, _meta) = runIdentity . RM.runRestM input $ Run.apiToHandler api+    input :: RM.RestInput+    input = RM.emptyInput+      { RM.parameters = H.fromList [("count", "5")]+      , RM.paths      = splitUriString "resource"+      , RM.headers    = H.fromList+          [ ("Accept"      , "application/json")+          , ("Content-Type", "application/json")+          ]+      }+    api :: Api (RM.RestM Identity)+    api = Unversioned (Some1 $ Rest.root -/ Rest.route resource)+    resource :: Resource (RM.RestM Identity) (RM.RestM Identity) String () Void+    resource = mkResourceId+      { Res.name   = "resource"+      , Res.schema = withListing () $ named []+      , Res.list   = const listHandler+      }+      where+      listHandler :: ListHandler (RM.RestM Identity)+      listHandler = mkListing jsonO h+        where+          h :: Range -> ExceptT Reason_ (RM.RestM Identity) [Int]+          h _rng = return [1..10]