diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/rest-core.cabal b/rest-core.cabal --- a/rest-core.cabal +++ b/rest-core.cabal @@ -1,5 +1,5 @@ name: rest-core -version: 0.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.* diff --git a/src/Rest.hs b/src/Rest.hs --- a/src/Rest.hs +++ b/src/Rest.hs @@ -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" #-} diff --git a/src/Rest/Api.hs b/src/Rest/Api.hs --- a/src/Rest/Api.hs +++ b/src/Rest/Api.hs @@ -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 diff --git a/src/Rest/Container.hs b/src/Rest/Container.hs --- a/src/Rest/Container.hs +++ b/src/Rest/Container.hs @@ -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] diff --git a/src/Rest/Dictionary/Combinators.hs b/src/Rest/Dictionary/Combinators.hs --- a/src/Rest/Dictionary/Combinators.hs +++ b/src/Rest/Dictionary/Combinators.hs @@ -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 diff --git a/src/Rest/Dictionary/Types.hs b/src/Rest/Dictionary/Types.hs --- a/src/Rest/Dictionary/Types.hs +++ b/src/Rest/Dictionary/Types.hs @@ -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 diff --git a/src/Rest/Driver/Perform.hs b/src/Rest/Driver/Perform.hs --- a/src/Rest/Driver/Perform.hs +++ b/src/Rest/Driver/Perform.hs @@ -1,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 diff --git a/src/Rest/Driver/RestM.hs b/src/Rest/Driver/RestM.hs --- a/src/Rest/Driver/RestM.hs +++ b/src/Rest/Driver/RestM.hs @@ -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 } diff --git a/src/Rest/Driver/Routing.hs b/src/Rest/Driver/Routing.hs --- a/src/Rest/Driver/Routing.hs +++ b/src/Rest/Driver/Routing.hs @@ -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 diff --git a/src/Rest/Driver/Routing/Internal.hs b/src/Rest/Driver/Routing/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Driver/Routing/Internal.hs @@ -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 diff --git a/src/Rest/Driver/Types.hs b/src/Rest/Driver/Types.hs --- a/src/Rest/Driver/Types.hs +++ b/src/Rest/Driver/Types.hs @@ -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] + } diff --git a/src/Rest/Error.hs b/src/Rest/Error.hs --- a/src/Rest/Error.hs +++ b/src/Rest/Error.hs @@ -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 diff --git a/src/Rest/Handler.hs b/src/Rest/Handler.hs --- a/src/Rest/Handler.hs +++ b/src/Rest/Handler.hs @@ -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 diff --git a/src/Rest/Resource.hs b/src/Rest/Resource.hs --- a/src/Rest/Resource.hs +++ b/src/Rest/Resource.hs @@ -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 diff --git a/src/Rest/Run.hs b/src/Rest/Run.hs --- a/src/Rest/Run.hs +++ b/src/Rest/Run.hs @@ -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) diff --git a/src/Rest/Schema.hs b/src/Rest/Schema.hs --- a/src/Rest/Schema.hs +++ b/src/Rest/Schema.hs @@ -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'. diff --git a/tests/Runner.hs b/tests/Runner.hs --- a/tests/Runner.hs +++ b/tests/Runner.hs @@ -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]