From 4c146dcf43465904a700117597d8e9fde3058ec4 Mon Sep 17 00:00:00 2001 From: theNerd247 Date: Thu, 2 Nov 2017 23:23:30 -0400 Subject: [PATCH 1/4] change Param to be a type supporting Monadness --- rest-core/src/Rest/Dictionary/Combinators.hs | 31 +++++++++++++++++- rest-core/src/Rest/Dictionary/Types.hs | 34 ++++++++++++-------- rest-core/src/Rest/Driver/Perform.hs | 10 +++--- 3 files changed, 57 insertions(+), 18 deletions(-) diff --git a/rest-core/src/Rest/Dictionary/Combinators.hs b/rest-core/src/Rest/Dictionary/Combinators.hs index 2104aac..0ec4467 100644 --- a/rest-core/src/Rest/Dictionary/Combinators.hs +++ b/rest-core/src/Rest/Dictionary/Combinators.hs @@ -52,6 +52,10 @@ module Rest.Dictionary.Combinators , mkPar , addPar + , withParam + , withParamDefault + , withParamParser + , withParamParserDefault -- ** Deprecated @@ -64,10 +68,13 @@ import Prelude hiding (id, (.)) import Control.Category import Data.Aeson +import Control.Monad.Except import Data.ByteString.Lazy (ByteString) import Data.JSON.Schema import Data.Text.Lazy (Text) +import Data.List (lookup) import Data.Typeable +import Control.Monad.Reader.Class (asks) import Network.Multipart (BodyPart) import Text.XML.HXT.Arrow.Pickle import qualified Data.Label.Total as L @@ -93,8 +100,30 @@ mkPar = L.set params -- | Add custom sub-dictionary for recognizing parameters. +{-# DEPRECATED addPar "This is now undefined as it doesn't fit the new Param datatype. Use withParam as an Applicative instead" #-} addPar :: Param p -> Dict h p' i o e -> Dict h (p, p') i o e -addPar = L.modify params . TwoParams +addPar = undefined + +withParam :: (Read a) => String -> ParamM a +withParam = flip withParamParser read + +-- | @withParamParser name parser@ parses the parameter with name @name@ using +-- the parser @parser@. If the desiered parameter is missing then a +-- @MissingField@ DataError is thrown. +withParamParser :: String -> (String -> a) -> ParamM a +withParamParser n f = do + s <- asks $ lookup n + maybe (throwError $ MissingField n) (return . f) s + +withParamDefault :: (Read a) => String -> a -> ParamM a +withParamDefault n d = withParamParserDefault n d read + +-- | like withParamParser except it returns a default value if the parameter +-- can't be found. +withParamParserDefault :: String -> a -> (String -> a) -> ParamM a +withParamParserDefault n d f = do + s <- asks $ lookup n + maybe (return d) (return . f) s -- | Open up input type for extension with custom dictionaries. diff --git a/rest-core/src/Rest/Dictionary/Types.hs b/rest-core/src/Rest/Dictionary/Types.hs index 60049e6..9a42d3a 100644 --- a/rest-core/src/Rest/Dictionary/Types.hs +++ b/rest-core/src/Rest/Dictionary/Types.hs @@ -26,6 +26,7 @@ module Rest.Dictionary.Types , inputs , outputs , errors + , noParam , empty , Modifier @@ -35,6 +36,7 @@ module Rest.Dictionary.Types , Ident (..) , Header (..) , Param (..) + , ParamM , Input (..) , Output (..) , Error (..) @@ -59,6 +61,8 @@ module Rest.Dictionary.Types where +import Control.Monad.Except +import Control.Monad.Reader import Data.Aeson import Data.ByteString.Lazy (ByteString) import Data.JSON.Schema @@ -115,26 +119,30 @@ instance Show (Header h) where . showsPrec 10 k ) +{-data Param p where-} + {-NoParam :: Param ()-} + {-Param :: [String] -> ([Maybe String] -> Either DataError p) -> Param p-} + {-TwoParams :: Param p -> Param q -> Param (p, q)-} + -- | The explicit dictionary `Param` describes how to translate the request -- parameters to some Haskell value. The first field in the `Param` -- constructor is a white list of paramters we can recognize, used in generic -- validation and for generating documentation. The second field is a custom --- parser that can fail with a `DataError` or can produce a some value. When --- explicitly not interested in the parameters we can use `NoParam`. +-- parser that can fail with a `DataError` or can produce a some value. It has a +-- Reader context of all the parameter names and their (possibly) raw string data. +-- use withParam to write an Applicative style parser +type ParamM a = ExceptT DataError (Reader [(String,String)]) a + +data Param a = Param + { paramNames :: [String] + , paramParser :: ParamM a + } -data Param p where - NoParam :: Param () - Param :: [String] -> ([Maybe String] -> Either DataError p) -> Param p - TwoParams :: Param p -> Param q -> Param (p, q) +noParam :: Param () +noParam = Param [] (return ()) instance Show (Param p) where - showsPrec _ NoParam = showString "NoParam" showsPrec n (Param ns _) = showParen (n > 9) (showString "Param " . showsPrec 10 ns) - showsPrec n (TwoParams p q) = showParen (n > 9) ( showString "TwoParams " - . showsPrec 10 p - . showString " " - . showsPrec 10 q - ) -- | The explicit dictionary `Input` describes how to translate the request -- body into some Haskell value. We currently use a constructor for every @@ -265,7 +273,7 @@ fclabels [d| -- | The empty dictionary, recognizing no types. empty :: Dict () () 'Nothing 'Nothing 'Nothing -empty = Dict NoHeader NoParam None None None +empty = Dict NoHeader noParam None None None -- | Custom existential packing an error together with a Reason. diff --git a/rest-core/src/Rest/Driver/Perform.hs b/rest-core/src/Rest/Driver/Perform.hs index a38d0b5..867bfb5 100644 --- a/rest-core/src/Rest/Driver/Perform.hs +++ b/rest-core/src/Rest/Driver/Perform.hs @@ -204,10 +204,12 @@ headers (Header xs h) = mapM getHeader xs >>= either throwError return . h headers (TwoHeaders h1 h2) = (,) <$> headers h1 <*> headers h2 parameters :: Rest m => Param p -> ExceptT DataError m p -parameters NoParam = return () -parameters (Param xs p) = mapM (lift . getParameter) xs >>= either throwError return . p -parameters (TwoParams p1 p2) = (,) <$> parameters p1 <*> parameters p2 - +parameters p = do + ps <- lift $ mapM getPar (paramNames p) + mapExceptT (runReader $ catMaybes ps) (paramParser p) + where + getPar s = getParameter s >>= \x -> return . return . (s,) + parser :: Monad m => Format -> Inputs j -> B.ByteString -> ExceptT DataError m (FromMaybe () j) parser NoFormat None _ = return () parser f None _ = throwError (UnsupportedFormat (show f)) From 208a3e96431a7b1d0485b046470882ada14cd3a8 Mon Sep 17 00:00:00 2001 From: theNerd247 Date: Thu, 2 Nov 2017 23:24:38 -0400 Subject: [PATCH 2/4] start changing range and orderRange parame... ...ter parsers to support new Param type --- rest-core/src/Rest/Handler.hs | 36 ++++++++++------------------------- 1 file changed, 10 insertions(+), 26 deletions(-) diff --git a/rest-core/src/Rest/Handler.hs b/rest-core/src/Rest/Handler.hs index 43ddaf5..3717799 100644 --- a/rest-core/src/Rest/Handler.hs +++ b/rest-core/src/Rest/Handler.hs @@ -124,22 +124,13 @@ mkListing d a = mkGenHandler (mkPar range . d) (a . param) -- parameters, @offset@ and @count@. If not passed, the defaults are 0 -- and 100. The maximum range that can be passed is 1000. -range :: Param Range -range = Param ["offset", "count"] $ \xs -> - maybe (Left (ParseError "range")) - (Right . normalize) - $ case xs of - [Just o, Just c] -> Range <$> readMay o <*> readMay c - [_ , Just c] -> Range 0 <$> readMay c - [Just o, _ ] -> (`Range` 100) <$> readMay o - _ -> Just $ Range 0 100 - where normalize r = Range { offset = max 0 . offset $ r - , count = min 1000 . max 0 . count $ r - } +range :: ParamM Range +range = Range + <$> (max 0 <$> (withParamDefault "offset" 0)) + <*> ((min 1000 . max 0) <$> (withParamDefault "count" 100)) -- | Create a list handler that accepts ordering information. -- Restricts the type of the 'Input' dictionary to 'None' - mkOrderedListing :: (Monad m, o ~ FromMaybe () o', e ~ FromMaybe Void e') => Modifier h p 'Nothing o' e' @@ -150,19 +141,12 @@ mkOrderedListing d a = mkGenHandler (mkPar orderedRange . d) (a . param) -- | Dictionary for taking ordering information. In addition to the -- parameters accepted by 'range', this accepts @order@ and -- @direction@. -orderedRange :: Param (Range, Maybe String, Maybe String) -orderedRange = Param ["offset", "count", "order", "direction"] $ \xs -> - case xs of - [mo, mc, mor, md] -> - maybe (Left (ParseError "range")) - (Right . (\(o, c) -> (Range o c, mor, md)) . normalize) - $ case (mo, mc) of - (Just o, Just c) -> (,) <$> readMay o <*> readMay c - (_ , Just c) -> (0,) <$> readMay c - (Just o, _ ) -> (,100) <$> readMay o - _ -> Just (0, 100) - _ -> error "Internal error in orderedRange rest parameters" - where normalize = (max 0 *** (min 1000 . max 0)) +orderedRange :: ParamM (Range, Maybe String, Maybe String) +orderedRange = do + r <- range + mo <- withParamParserDefault "order" Nothing Just + mo <- withParamParserDefault "direction" Nothing Just + return (r, mo, md) -- | Create a handler for a single resource. Takes the entire -- environmend as input. From 064ebaf2f35c18d1d17d555ccca18221bd5679f2 Mon Sep 17 00:00:00 2001 From: theNerd247 Date: Fri, 3 Nov 2017 01:11:12 -0400 Subject: [PATCH 3/4] adds Functor and Applicative instances for Param... ... and some cleanup --- rest-core/src/Rest/Dictionary/Combinators.hs | 17 ++++++++++------- rest-core/src/Rest/Dictionary/Types.hs | 14 +++++++++----- rest-core/src/Rest/Driver/Perform.hs | 7 ++++--- rest-core/src/Rest/Handler.hs | 15 ++++++--------- 4 files changed, 29 insertions(+), 24 deletions(-) diff --git a/rest-core/src/Rest/Dictionary/Combinators.hs b/rest-core/src/Rest/Dictionary/Combinators.hs index 0ec4467..62e0424 100644 --- a/rest-core/src/Rest/Dictionary/Combinators.hs +++ b/rest-core/src/Rest/Dictionary/Combinators.hs @@ -102,26 +102,29 @@ mkPar = L.set params {-# DEPRECATED addPar "This is now undefined as it doesn't fit the new Param datatype. Use withParam as an Applicative instead" #-} addPar :: Param p -> Dict h p' i o e -> Dict h (p, p') i o e -addPar = undefined +addPar p d = L.set params newParam d + where + newParam = Param ((paramKeyNames cp) ++ (paramKeyNames p)) $ (,) <$> (paramParser p) <*> (paramParser cp) + cp = L.get params d -withParam :: (Read a) => String -> ParamM a +withParam :: (Read a) => String -> Param a withParam = flip withParamParser read -- | @withParamParser name parser@ parses the parameter with name @name@ using -- the parser @parser@. If the desiered parameter is missing then a -- @MissingField@ DataError is thrown. -withParamParser :: String -> (String -> a) -> ParamM a -withParamParser n f = do +withParamParser :: String -> (String -> a) -> Param a +withParamParser n f = Param [n] $ do s <- asks $ lookup n maybe (throwError $ MissingField n) (return . f) s -withParamDefault :: (Read a) => String -> a -> ParamM a +withParamDefault :: (Read a) => String -> a -> Param a withParamDefault n d = withParamParserDefault n d read -- | like withParamParser except it returns a default value if the parameter -- can't be found. -withParamParserDefault :: String -> a -> (String -> a) -> ParamM a -withParamParserDefault n d f = do +withParamParserDefault :: String -> a -> (String -> a) -> Param a +withParamParserDefault n d f = Param [n] $ do s <- asks $ lookup n maybe (return d) (return . f) s diff --git a/rest-core/src/Rest/Dictionary/Types.hs b/rest-core/src/Rest/Dictionary/Types.hs index 9a42d3a..64fb5ce 100644 --- a/rest-core/src/Rest/Dictionary/Types.hs +++ b/rest-core/src/Rest/Dictionary/Types.hs @@ -36,7 +36,6 @@ module Rest.Dictionary.Types , Ident (..) , Header (..) , Param (..) - , ParamM , Input (..) , Output (..) , Error (..) @@ -131,13 +130,18 @@ instance Show (Header h) where -- parser that can fail with a `DataError` or can produce a some value. It has a -- Reader context of all the parameter names and their (possibly) raw string data. -- use withParam to write an Applicative style parser -type ParamM a = ExceptT DataError (Reader [(String,String)]) a - data Param a = Param - { paramNames :: [String] - , paramParser :: ParamM a + { paramKeyNames :: [String] + , paramParser :: ExceptT DataError (Reader [(String,String)]) a } +instance Functor Param where + fmap f (Param ns a) = Param ns $ f <$> a + +instance Applicative Param where + pure x = Param [] $ pure x + (Param ns f) <*> (Param ms x) = Param (ns ++ ms) $ f <*> x + noParam :: Param () noParam = Param [] (return ()) diff --git a/rest-core/src/Rest/Driver/Perform.hs b/rest-core/src/Rest/Driver/Perform.hs index 867bfb5..ccf01a9 100644 --- a/rest-core/src/Rest/Driver/Perform.hs +++ b/rest-core/src/Rest/Driver/Perform.hs @@ -5,6 +5,7 @@ , OverloadedStrings , RankNTypes , ScopedTypeVariables + , TupleSections #-} #if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -205,10 +206,10 @@ headers (TwoHeaders h1 h2) = (,) <$> headers h1 <*> headers h2 parameters :: Rest m => Param p -> ExceptT DataError m p parameters p = do - ps <- lift $ mapM getPar (paramNames p) - mapExceptT (runReader $ catMaybes ps) (paramParser p) + ps <- lift $ mapM getPar (paramKeyNames p) + mapExceptT (\x -> return $ runReader x $ catMaybes ps) (paramParser p) where - getPar s = getParameter s >>= \x -> return . return . (s,) + getPar s = getParameter s >>= return . fmap (s,) parser :: Monad m => Format -> Inputs j -> B.ByteString -> ExceptT DataError m (FromMaybe () j) parser NoFormat None _ = return () diff --git a/rest-core/src/Rest/Handler.hs b/rest-core/src/Rest/Handler.hs index 3717799..20af994 100644 --- a/rest-core/src/Rest/Handler.hs +++ b/rest-core/src/Rest/Handler.hs @@ -41,13 +41,11 @@ module Rest.Handler import Prelude.Compat -import Control.Arrow import Control.Monad.Except () import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.Trans.Except import Rest.Types.Range -import Safe import Rest.Dictionary import Rest.Error @@ -124,7 +122,7 @@ mkListing d a = mkGenHandler (mkPar range . d) (a . param) -- parameters, @offset@ and @count@. If not passed, the defaults are 0 -- and 100. The maximum range that can be passed is 1000. -range :: ParamM Range +range :: Param Range range = Range <$> (max 0 <$> (withParamDefault "offset" 0)) <*> ((min 1000 . max 0) <$> (withParamDefault "count" 100)) @@ -141,12 +139,11 @@ mkOrderedListing d a = mkGenHandler (mkPar orderedRange . d) (a . param) -- | Dictionary for taking ordering information. In addition to the -- parameters accepted by 'range', this accepts @order@ and -- @direction@. -orderedRange :: ParamM (Range, Maybe String, Maybe String) -orderedRange = do - r <- range - mo <- withParamParserDefault "order" Nothing Just - mo <- withParamParserDefault "direction" Nothing Just - return (r, mo, md) +orderedRange :: Param (Range, Maybe String, Maybe String) +orderedRange = (,,) + <$> range + <*> (withParamParserDefault "order" Nothing Just) + <*> (withParamParserDefault "direction" Nothing Just) -- | Create a handler for a single resource. Takes the entire -- environmend as input. From 45927b2d5253ec9e4144d273a5f6e79c63fc09bb Mon Sep 17 00:00:00 2001 From: theNerd247 Date: Fri, 3 Nov 2017 01:23:37 -0400 Subject: [PATCH 4/4] updates rest-example to use new Param definition --- rest-example/example-api/Api/Test.hs | 5 ++++- rest-gen/src/Rest/Gen/Base/ActionInfo.hs | 2 -- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/rest-example/example-api/Api/Test.hs b/rest-example/example-api/Api/Test.hs index f409510..2e65b69 100644 --- a/rest-example/example-api/Api/Test.hs +++ b/rest-example/example-api/Api/Test.hs @@ -129,10 +129,13 @@ rawJsonAndXmlO_ = mkHandler (addHeader contentType . mkHeader accept . mkPar typ else if XmlFormat `elem` accs then return "" else throwError . OutputError $ UnsupportedFormat "Only json and xml accept headers are allowed" + contentType :: Header (Maybe String) contentType = Header ["Content-Type"] (return . headMay . catMaybes) + typeParam :: Param (Maybe String) - typeParam = Param ["type"] (return . headMay . catMaybes) + typeParam = withParamParserDefault "type" Nothing Just + accept :: Header (Maybe String) accept = Header ["Accept"] (return . headMay . catMaybes) diff --git a/rest-gen/src/Rest/Gen/Base/ActionInfo.hs b/rest-gen/src/Rest/Gen/Base/ActionInfo.hs index eeeed07..12e60ef 100644 --- a/rest-gen/src/Rest/Gen/Base/ActionInfo.hs +++ b/rest-gen/src/Rest/Gen/Base/ActionInfo.hs @@ -417,9 +417,7 @@ paramNames :: Param a -> [String] paramNames = nub . paramNames_ paramNames_ :: Param a -> [String] -paramNames_ NoParam = [] paramNames_ (Param s _) = s -paramNames_ (TwoParams p1 p2) = paramNames p1 ++ paramNames p2 -- | Extract input description from handlers handlerInputs :: Handler m -> [DataDescription]