Make Params Applicative

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,33 @@ 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 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 -> 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) -> Param a
+withParamParser n f = Param [n] $ do
+  s <- asks $ lookup n
+  maybe (throwError $ MissingField n) (return . f) s
+
+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) -> Param a
+withParamParserDefault n d f = Param [n] $ do
+  s <- asks $ lookup n
+  maybe (return d) (return . f) s
 
 -- | Open up input type for extension with custom dictionaries.
 

rest-core/src/Rest/Dictionary/Types.hs

@@ -26,6 +26,7 @@ module Rest.Dictionary.Types
   , inputs
   , outputs
   , errors
+  , noParam
 
   , empty
   , Modifier
@@ -59,6 +60,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 +118,35 @@ 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
+data Param a = Param
+  { 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
 
-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 +277,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.
 

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 #-}
@@ -204,10 +205,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 (paramKeyNames p)
+  mapExceptT (\x -> return $ runReader x $ catMaybes ps) (paramParser p)
+  where
+    getPar s = getParameter s >>= return . fmap (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))

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
@@ -125,21 +123,12 @@ mkListing d a = mkGenHandler (mkPar range . d) (a . param)
 -- 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 = 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'
@@ -151,18 +140,10 @@ mkOrderedListing d a = mkGenHandler (mkPar orderedRange . d) (a . param)
 -- 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 = (,,)
+  <$> range
+  <*> (withParamParserDefault "order" Nothing Just)
+  <*> (withParamParserDefault "direction" Nothing Just)
 
 -- | Create a handler for a single resource. Takes the entire
 -- environmend as input.

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 "<xml/>"
           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)
 

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]