From e77c275b4c0b0bf812e2c7d046a891d31d376bb5 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sun, 8 Nov 2020 14:20:29 +0100 Subject: [PATCH 1/2] Added support for JSON request bodies The functions fill and param (and related) now work with JSON requests. Previously they only worked with urlencoded form request bodies. For this to work, the request needs to have Content-Type: application/json --- IHP/Controller/FileUpload.hs | 6 +- IHP/Controller/Param.hs | 153 +++++++++++++++++++++---- IHP/Controller/RequestContext.hs | 8 +- IHP/ControllerSupport.hs | 33 +++++- IHP/HaskellSupport.hs | 12 +- Test/Controller/ParamSpec.hs | 186 +++++++++++++++++++++++++++++++ Test/Main.hs | 4 +- 7 files changed, 367 insertions(+), 35 deletions(-) create mode 100644 Test/Controller/ParamSpec.hs diff --git a/IHP/Controller/FileUpload.hs b/IHP/Controller/FileUpload.hs index e7f9eab06..9335f3f59 100644 --- a/IHP/Controller/FileUpload.hs +++ b/IHP/Controller/FileUpload.hs @@ -30,8 +30,10 @@ fileOrNothing :: (?context :: ControllerContext) => ByteString -> Maybe (FileInf fileOrNothing !name = ?context |> get #requestContext - |> getField @"files" - |> lookup name + |> get #requestBody + |> \case + FormBody { files } -> lookup name files + _ -> Nothing {-# INLINE fileOrNothing #-} -- | Options to be used together with 'uploadImageWithOptions' diff --git a/IHP/Controller/Param.hs b/IHP/Controller/Param.hs index 5bbb357bd..099996576 100644 --- a/IHP/Controller/Param.hs +++ b/IHP/Controller/Param.hs @@ -21,6 +21,11 @@ import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec import qualified GHC.Float as Float import qualified Control.Exception as Exception import IHP.Controller.Context +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.Scientific as Scientific +import qualified Data.Vector as Vector -- | Returns a query or body parameter from the current request. The raw string -- value is parsed before returning it. So the return value type depends on what @@ -81,9 +86,9 @@ import IHP.Controller.Context -- -- > param: Parameter 'firstname' not found param :: (?context :: ControllerContext) => (ParamReader valueType) => ByteString -> valueType -param !name = case paramOrNothing name of - Just value -> Either.fromRight (error (paramParserErrorMessage name)) (readParameter value) - Nothing -> Exception.throw (ParamNotFoundException name) +param !name = case paramOrError name of + Left exception -> Exception.throw exception + Right value -> value {-# INLINE param #-} -- | Similiar to 'param' but works with multiple params. Useful when working with checkboxes. @@ -117,10 +122,14 @@ paramList name = paramParserErrorMessage name = "param: Parameter '" <> cs name <> "' is invalid" -- | Thrown when a parameter is missing when calling 'param "myParam"' or related functions -data ParamNotFoundException = ParamNotFoundException ByteString deriving (Show) +data ParamException + = ParamNotFoundException { name :: ByteString } + | ParamCouldNotBeParsedException { name :: ByteString, parserError :: ByteString } + deriving (Show) -instance Exception ParamNotFoundException where - displayException (ParamNotFoundException name) = "param: Parameter '" <> cs name <> "' not found" +instance Exception ParamException where + displayException (ParamNotFoundException { name }) = "param: Parameter '" <> cs name <> "' not found" + displayException (ParamCouldNotBeParsedException { name, parserError }) = "param: Parameter '" <> cs name <> "' could not be parsed, " <> cs parserError -- | Specialisied version of param for 'Text'. -- @@ -194,14 +203,33 @@ paramOrDefault !defaultValue = fromMaybe defaultValue . paramOrNothing -- > let page :: Maybe Int = paramOrNothing "page" -- -- When calling @GET /Users?page=1@ the variable @page@ will be set to @Just 1@. -paramOrNothing :: (?context :: ControllerContext) => ParamReader a => ByteString -> Maybe a -paramOrNothing !name = case queryOrBodyParam name of - Just value -> case readParameter value of - Left error -> Nothing +paramOrNothing :: forall paramType. (?context :: ControllerContext) => ParamReader paramType => ByteString -> Maybe paramType +paramOrNothing !name = + case paramOrError name of + Left ParamNotFoundException {} -> Nothing + Left otherException -> Exception.throw otherException Right value -> Just value - Nothing -> Nothing {-# INLINE paramOrNothing #-} +-- | Like 'param', but returns @Left "Some error message"@ if the parameter is missing or invalid +paramOrError :: forall paramType. (?context :: ControllerContext) => ParamReader paramType => ByteString -> Either ParamException paramType +paramOrError !name = + let + RequestContext { requestBody } = ?context |> get #requestContext + in case requestBody of + FormBody {} -> case queryOrBodyParam name of + Just value -> case readParameter @paramType value of + Left parserError -> Left ParamCouldNotBeParsedException { name, parserError } + Right value -> Right value + Nothing -> Left ParamNotFoundException { name } + JSONBody json -> case json of + (Just (Aeson.Object hashMap)) -> case HashMap.lookup (cs name) hashMap of + Just value -> case readParameterJSON @paramType value of + Left parserError -> Left ParamCouldNotBeParsedException { name, parserError } + Right value -> Right value + _ -> Left ParamNotFoundException { name } +{-# INLINE paramOrError #-} + -- | Returns a parameter without any parsing. Returns @Nothing@ when the parameter is missing. queryOrBodyParam :: (?context :: ControllerContext) => ByteString -> Maybe ByteString queryOrBodyParam !name = join (lookup name allParams) @@ -209,9 +237,11 @@ queryOrBodyParam !name = join (lookup name allParams) -- | Returns all params available in the current request allParams :: (?context :: ControllerContext) => [(ByteString, Maybe ByteString)] -allParams = concat [(map (\(a, b) -> (a, Just b)) params), (Wai.queryString request)] +allParams = case requestBody of + FormBody { params, files } -> concat [(map (\(a, b) -> (a, Just b)) params), (Wai.queryString request)] + JSONBody value -> error "allParams: Not supported for JSON requests" where - RequestContext { request, params } = ?context |> get #requestContext + RequestContext { request, requestBody } = ?context |> get #requestContext -- | Input parser for 'param'. -- @@ -219,11 +249,15 @@ allParams = concat [(map (\(a, b) -> (a, Just b)) params), (Wai.queryString requ -- Returns @Right value@ when the parsing succeeded. class ParamReader a where readParameter :: ByteString -> Either ByteString a + readParameterJSON :: Aeson.Value -> Either ByteString a instance ParamReader ByteString where {-# INLINE readParameter #-} readParameter byteString = pure byteString + readParameterJSON (Aeson.String bytestring) = Right (cs bytestring) + readParameterJSON _ = Left "ParamReader ByteString: Expected String" + instance ParamReader Int where {-# INLINE readParameter #-} readParameter byteString = @@ -231,6 +265,12 @@ instance ParamReader Int where Right value -> Right value Left error -> Left ("ParamReader Int: " <> cs error) + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left float -> Left "ParamReader Int: Expected Int" + Right int -> Right int + readParameterJSON _ = Left "ParamReader Int: Expected Int" + instance ParamReader Integer where {-# INLINE readParameter #-} readParameter byteString = @@ -238,24 +278,50 @@ instance ParamReader Integer where Right value -> Right value Left error -> Left ("ParamReader Int: " <> cs error) + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left float -> Left "ParamReader Integer: Expected Integer" + Right integer -> Right integer + readParameterJSON _ = Left "ParamReader Integer: Expected Integer" + instance ParamReader Double where {-# INLINE readParameter #-} readParameter byteString = case Attoparsec.parseOnly (Attoparsec.double <* Attoparsec.endOfInput) byteString of Right value -> Right value - Left error -> Left ("ParamReader Dobule: " <> cs error) + Left error -> Left ("ParamReader Double: " <> cs error) + + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left double -> Right double + Right integer -> Right (fromIntegral integer) + readParameterJSON _ = Left "ParamReader Double: Expected Double" instance ParamReader Float where {-# INLINE readParameter #-} readParameter byteString = case Attoparsec.parseOnly (Attoparsec.double <* Attoparsec.endOfInput) byteString of Right value -> Right (Float.double2Float value) - Left error -> Left ("ParamReader Dobule: " <> cs error) + Left error -> Left ("ParamReader Float: " <> cs error) + + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left double -> Right double + Right integer -> Right (fromIntegral integer) + readParameterJSON _ = Left "ParamReader Float: Expected Float" instance ParamReader Text where {-# INLINE readParameter #-} readParameter byteString = pure (cs byteString) + readParameterJSON (Aeson.String text) = Right text + readParameterJSON _ = Left "ParamReader Text: Expected String" + +-- | Parses comma separated input like @userIds=1,2,3@ +-- +-- __Example:__ +-- +-- >>> let userIds :: [Int] = param "userIds" instance ParamReader value => ParamReader [value] where {-# INLINE readParameter #-} readParameter byteString = @@ -267,6 +333,16 @@ instance ParamReader value => ParamReader [value] where ([], values) -> Right values ((first:rest), _) -> Left first + readParameterJSON (Aeson.Array values) = + values + |> Vector.toList + |> map readParameterJSON + |> Either.partitionEithers + |> \case + ([], values) -> Right values + ((first:rest), _) -> Left first + readParameterJSON _ = Left "ParamReader Text: Expected Array" + -- | Parses a boolean. -- -- Html form checkboxes usually use @on@ or @off@ for representation. These @@ -277,13 +353,23 @@ instance ParamReader Bool where readParameter true | toLower (cs true) == "true" = pure True readParameter _ = pure False + readParameterJSON (Aeson.Bool bool) = Right bool + readParameterJSON _ = Left "ParamReader Bool: Expected Bool" + instance ParamReader UUID where {-# INLINE readParameter #-} readParameter byteString = case UUID.fromASCIIBytes byteString of Just uuid -> pure uuid - Nothing -> Left "FromParamter UUID: Parse error" + Nothing -> Left "FromParameter UUID: Parse error" + + readParameterJSON (Aeson.String string) = + case UUID.fromText string of + Just uuid -> pure uuid + Nothing -> Left "FromParameter UUID: Parse error" + readParameterJSON _ = Left "ParamReader UUID: Expected String" +-- | Accepts values such as @2020-11-08T12:03:35Z@ or @2020-11-08@ instance ParamReader UTCTime where {-# INLINE readParameter #-} readParameter "" = Left "ParamReader UTCTime: Parameter missing" @@ -298,6 +384,10 @@ instance ParamReader UTCTime where Nothing -> Left "ParamReader UTCTime: Failed parsing" Just value -> Right value + readParameterJSON (Aeson.String string) = readParameter (cs string) + readParameterJSON _ = Left "ParamReader UTCTime: Expected String" + +-- | Accepts values such as @2020-11-08@ instance ParamReader Day where {-# INLINE readParameter #-} readParameter "" = Left "ParamReader Day: Parameter missing" @@ -309,12 +399,13 @@ instance ParamReader Day where Just value -> Right value Nothing -> Left "ParamReader Day: Failed parsing" + readParameterJSON (Aeson.String string) = readParameter (cs string) + readParameterJSON _ = Left "ParamReader Day: Expected String" + instance {-# OVERLAPS #-} (ParamReader (ModelSupport.PrimaryKey model')) => ParamReader (ModelSupport.Id' model') where {-# INLINE readParameter #-} - readParameter uuid = - case (readParameter uuid) :: Either ByteString (ModelSupport.PrimaryKey model') of - Right uuid -> pure (ModelSupport.Id uuid) - Left error -> Left error + readParameter uuid = ModelSupport.Id <$> readParameter uuid + readParameterJSON value = ModelSupport.Id <$> readParameterJSON value instance ParamReader param => ParamReader (Maybe param) where {-# INLINE readParameter #-} @@ -324,6 +415,12 @@ instance ParamReader param => ParamReader (Maybe param) where Left error | param == "" -> Right Nothing Left error -> Left error + readParameterJSON value = + case (readParameterJSON value) :: Either ByteString param of + Right value -> Right (Just value) + Left error | value == (Aeson.String "") -> Right Nothing + Left error -> Left error + -- | Custom error hint when the 'param' is called with do-notation -- -- __Example:__ @@ -334,6 +431,7 @@ instance ParamReader param => ParamReader (Maybe param) where -- Now a custom type error will be shown telling the user to use @let myParam = param "hello"@ instead of do-notation. instance (TypeError ('Text ("Use 'let x = param \"..\"' instead of 'x <- param \"..\"'" :: Symbol))) => ParamReader (IO param) where readParameter _ = error "Unreachable" + readParameterJSON _ = error "Unreachable" -- | Can be used as a default implementation for 'readParameter' for enum structures -- @@ -412,5 +510,18 @@ ifNew :: forall record id. (?context :: ControllerContext, ?modelContext :: Mode ifNew thenBlock record = if ModelSupport.isNew record then thenBlock record else record --- Transforms `Just ""` to `Nothing` +-- | Transforms @Just ""@ to @Nothing@ +-- +-- __Example:__ We have record called @Company@ with a optional field @comment :: Maybe Text@ +-- +-- When we have a form that submits the @comment@ field and the field is empty, it will not be @NULL@ inside the database, +-- instead it will be set to the empty string. To avoid this we can apply @emptyValueToNothing #comment@. This function +-- turns the empty string into a 'Nothing' value. +-- +-- > action UpdateCompanyAction { companyId } = do +-- > company <- fetch companyId +-- > company +-- > |> fill '["name", "comment"] +-- > |> emptyValueToNothing #comment +-- > |> updateRecord emptyValueToNothing field = modify field (maybe Nothing (\value -> if null value then Nothing else Just value)) diff --git a/IHP/Controller/RequestContext.hs b/IHP/Controller/RequestContext.hs index be8fa8419..dcd294f95 100644 --- a/IHP/Controller/RequestContext.hs +++ b/IHP/Controller/RequestContext.hs @@ -2,6 +2,7 @@ module IHP.Controller.RequestContext ( RequestContext (..) , Respond , getConfig +, RequestBody (..) ) where import ClassyPrelude @@ -11,16 +12,17 @@ import Network.Wai.Parse (File, Param) import qualified Data.Vault.Lazy as Vault import Network.Wai.Session (Session) import IHP.FrameworkConfig - +import qualified Data.Aeson as Aeson type Respond = Response -> IO ResponseReceived +data RequestBody = FormBody { params :: [Param], files :: [File LBS.ByteString] } | JSONBody (Maybe Aeson.Value) + data RequestContext = RequestContext { request :: Request , respond :: Respond - , params :: [Param] - , files :: [File LBS.ByteString] + , requestBody :: RequestBody , vault :: (Vault.Key (Session IO String String)) , frameworkConfig :: FrameworkConfig } diff --git a/IHP/ControllerSupport.hs b/IHP/ControllerSupport.hs index 4a837876e..dca7ad21b 100644 --- a/IHP/ControllerSupport.hs +++ b/IHP/ControllerSupport.hs @@ -20,6 +20,7 @@ module IHP.ControllerSupport , respondAndExit , ResponseException (..) , jumpToAction +, requestBodyJSON ) where import ClassyPrelude @@ -44,6 +45,8 @@ import IHP.FrameworkConfig (FrameworkConfig) import qualified IHP.Controller.Context as Context import IHP.Controller.Context (ControllerContext) import IHP.FlashMessages.ControllerFunctions +import Network.HTTP.Types.Header +import qualified Data.Aeson as Aeson type Action' = IO ResponseReceived @@ -132,19 +135,39 @@ request = requestContext |> get #request {-# INLINE getFiles #-} getFiles :: (?context :: ControllerContext) => [File Data.ByteString.Lazy.ByteString] -getFiles = requestContext |> get #files +getFiles = requestContext + |> get #requestBody + |> \case + RequestContext.FormBody { files } -> files + _ -> [] requestContext :: (?context :: ControllerContext) => RequestContext requestContext = get #requestContext ?context {-# INLINE requestContext #-} +requestBodyJSON :: (?context :: ControllerContext) => Aeson.Value +requestBodyJSON = + ?context + |> get #requestContext + |> get #requestBody + |> \case + RequestContext.JSONBody (Just value) -> value + _ -> error "Expected JSON body" + {-# INLINE createRequestContext #-} createRequestContext :: ApplicationContext -> Request -> Respond -> IO RequestContext createRequestContext ApplicationContext { session, frameworkConfig } request respond = do - (params, files) <- WaiParse.parseRequestBodyEx WaiParse.defaultParseRequestBodyOptions WaiParse.lbsBackEnd request - pure RequestContext.RequestContext { request, respond, params, files, vault = session, frameworkConfig } - - + let contentType = lookup hContentType (requestHeaders request) + requestBody <- case contentType of + "application/json" -> do + payload <- Network.Wai.getRequestBodyChunk request + let value :: Maybe Aeson.Value = (Aeson.decode ((cs payload) :: LByteString)) + pure (RequestContext.JSONBody value) + _ -> do + (params, files) <- WaiParse.parseRequestBodyEx WaiParse.defaultParseRequestBodyOptions WaiParse.lbsBackEnd request + pure RequestContext.FormBody { .. } + + pure RequestContext.RequestContext { request, respond, requestBody, vault = session, frameworkConfig } -- Can be thrown from inside the action to abort the current action execution. -- Does not indicates a runtime error. It's just used for control flow management. diff --git a/IHP/HaskellSupport.hs b/IHP/HaskellSupport.hs index 1d99498fc..e1ef76914 100644 --- a/IHP/HaskellSupport.hs +++ b/IHP/HaskellSupport.hs @@ -34,7 +34,7 @@ module IHP.HaskellSupport ( import ClassyPrelude import Control.Monad (when) import qualified Data.Default -import qualified Data.UUID +import qualified Data.UUID as UUID import Data.Proxy import qualified Data.Time import GHC.TypeLits @@ -44,6 +44,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec import Data.String.Conversions (cs) import qualified Debug.Trace import qualified Data.Text as Text +import qualified Data.Maybe --(|>) :: a -> f -> f a infixl 8 |> @@ -78,8 +79,8 @@ includes :: (MonoFoldable container, Eq (Element container)) => Element containe includes = elem {-# INLINE includes #-} -instance Data.Default.Default Data.UUID.UUID where - def = Data.UUID.nil +instance Data.Default.Default UUID.UUID where + def = UUID.nil instance forall name name'. (KnownSymbol name, name' ~ name) => IsLabel name (Proxy name') where fromLabel = Proxy @name' @@ -253,3 +254,8 @@ stripTags html = let (a, b) = Text.splitAt 1 html in a <> stripTags b symbolToText :: forall symbol. (KnownSymbol symbol) => Text symbolToText = Text.pack (symbolVal @symbol Proxy) {-# INLINE symbolToText #-} + +instance IsString UUID.UUID where + fromString string = case UUID.fromString string of + Just uuid -> uuid + Nothing -> error ("Invalid UUID: " <> string) \ No newline at end of file diff --git a/Test/Controller/ParamSpec.hs b/Test/Controller/ParamSpec.hs new file mode 100644 index 000000000..0dcec6af2 --- /dev/null +++ b/Test/Controller/ParamSpec.hs @@ -0,0 +1,186 @@ +{-| +Module: Test.Controller.ParamSpec +Copyright: (c) digitally induced GmbH, 2020 +-} +module Test.Controller.ParamSpec where + +import IHP.Prelude +import IHP.HaskellSupport +import Test.Hspec +import IHP.Controller.Param +import qualified Data.Aeson as Aeson +import qualified Data.UUID as UUID + +tests = do + describe "IHP.Controller.Param" do + describe "ParamReader" do + describe "ByteString" do + it "should handle text input" do + (readParameter @ByteString "test") `shouldBe` (Right "test") + it "should handle JSON strings" do + (readParameterJSON @ByteString (json "\"test\"")) `shouldBe` (Right ("test" :: ByteString)) + + it "should fail on other JSON input" do + (readParameterJSON @ByteString (json "1")) `shouldBe` (Left ("ParamReader ByteString: Expected String" :: ByteString)) + + describe "Int" do + it "should accept numeric input" do + (readParameter @Int "1337") `shouldBe` (Right 1337) + + it "should accept JSON numerics " do + (readParameterJSON @Int (json "1337")) `shouldBe` (Right 1337) + + it "should fail on other JSON input " do + (readParameterJSON @Int (json "true")) `shouldBe` (Left "ParamReader Int: Expected Int") + + describe "Integer" do + it "should accept numeric input" do + (readParameter @Integer "1337") `shouldBe` (Right 1337) + + it "should accept JSON numerics " do + (readParameterJSON @Integer (json "1337")) `shouldBe` (Right 1337) + + it "should fail on other JSON input " do + (readParameterJSON @Integer (json "true")) `shouldBe` (Left "ParamReader Integer: Expected Integer") + (readParameterJSON @Integer (json "\"1\"")) `shouldBe` (Left "ParamReader Integer: Expected Integer") + + + describe "Double" do + it "should accept integer input" do + (readParameter @Double "1337") `shouldBe` (Right 1337) + + it "should accept floating point input" do + (readParameter @Double "1.2") `shouldBe` (Right 1.2) + (readParameter @Float "1.2345679") `shouldBe` (Right 1.2345679) + + it "should accept JSON integer input" do + (readParameterJSON @Double (json "1337")) `shouldBe` (Right 1337) + + it "should accept JSON floating point input" do + (readParameterJSON @Double (json "1.2")) `shouldBe` (Right 1.2) + + it "should fail on other JSON input " do + (readParameterJSON @Double (json "true")) `shouldBe` (Left "ParamReader Double: Expected Double") + (readParameterJSON @Double (json "\"1\"")) `shouldBe` (Left "ParamReader Double: Expected Double") + + describe "Float" do + it "should accept integer input" do + (readParameter @Float "1337") `shouldBe` (Right 1337) + + it "should accept floating point input" do + (readParameter @Float "1.2") `shouldBe` (Right 1.2) + (readParameter @Float "1.2345679") `shouldBe` (Right 1.2345679) + + it "should accept JSON integer input" do + (readParameterJSON @Float (json "1337")) `shouldBe` (Right 1337) + + it "should accept JSON floating point input" do + (readParameterJSON @Float (json "1.2")) `shouldBe` (Right 1.2) + + it "should fail on other JSON input " do + (readParameterJSON @Float (json "true")) `shouldBe` (Left "ParamReader Float: Expected Float") + (readParameterJSON @Float (json "\"1\"")) `shouldBe` (Left "ParamReader Float: Expected Float") + + describe "Text" do + it "should handle text input" do + (readParameter @Text "test") `shouldBe` (Right "test") + + it "should handle JSON strings" do + (readParameterJSON @Text (json "\"test\"")) `shouldBe` (Right ("test")) + + it "should fail on other JSON input" do + (readParameterJSON @Text (json "1")) `shouldBe` (Left ("ParamReader Text: Expected String")) + + describe "CSV" do + it "should handle empty input" do + (readParameter @[Int] "") `shouldBe` (Right []) + + it "should handle a single value" do + (readParameter @[Int] "1") `shouldBe` (Right [1]) + + it "should handle comma separated values" do + (readParameter @[Int] "1,2,3") `shouldBe` (Right [1,2,3]) + + it "should fail if a single value is invalid" do + (readParameter @[Int] "1,a,3") `shouldBe` (Left "ParamReader Int: Failed reading: takeWhile1") + + it "should handle JSON arrays" do + (readParameterJSON @[Int] (json "[1,2,3]")) `shouldBe` (Right [1,2,3]) + + it "should fail on JSON input that is not an array" do + (readParameterJSON @[Int] (json "true")) `shouldBe` (Left "ParamReader Text: Expected Array") + + describe "Bool" do + it "should accept 'on' as True" do + (readParameter @Bool "on") `shouldBe` (Right True) + + it "should accept 'true' as True" do + (readParameter @Bool "true") `shouldBe` (Right True) + (readParameter @Bool "TruE") `shouldBe` (Right True) + + it "should accept everything else as false input" do + (readParameter @Bool "off") `shouldBe` (Right False) + (readParameter @Bool "false") `shouldBe` (Right False) + (readParameter @Bool "invalid") `shouldBe` (Right False) + + describe "UUID" do + it "should accept UUID values" do + (readParameter @UUID "6188329c-6bad-47f6-800c-2fd19ce0b2df") `shouldBe` (Right "6188329c-6bad-47f6-800c-2fd19ce0b2df") + (readParameter @UUID "a020ba17-a94e-453f-9414-c54aa30caa54") `shouldBe` (Right "a020ba17-a94e-453f-9414-c54aa30caa54") + + it "should fail on invalid values" do + (readParameter @UUID "not a uuid") `shouldBe` (Left "FromParameter UUID: Parse error") + + it "should accept JSON UUIDs" do + (readParameterJSON @UUID (json "\"6188329c-6bad-47f6-800c-2fd19ce0b2df\"")) `shouldBe` (Right "6188329c-6bad-47f6-800c-2fd19ce0b2df") + + it "should fail on invalid JSON input" do + (readParameterJSON @UUID (json "\"not a uuid\"")) `shouldBe` (Left "FromParameter UUID: Parse error") + (readParameterJSON @UUID (json "false")) `shouldBe` (Left "ParamReader UUID: Expected String") + + describe "UTCTime" do + it "should accept timestamps" do + (tshow (readParameter @UTCTime "2020-11-08T12:03:35Z")) `shouldBe` ("Right 2020-11-08 12:03:35 UTC") + + it "should accept dates" do + (tshow (readParameter @UTCTime "2020-11-08")) `shouldBe` ("Right 2020-11-08 00:00:00 UTC") + + it "should fail on invalid inputs" do + (readParameter @UTCTime "not a timestamp") `shouldBe` (Left "ParamReader UTCTime: Failed parsing") + + it "should accept JSON strings" do + (tshow (readParameterJSON @UTCTime (json "\"2020-11-08T12:03:35Z\""))) `shouldBe` ("Right 2020-11-08 12:03:35 UTC") + + describe "Day" do + it "should accept dates" do + (tshow (readParameter @Day "2020-11-08")) `shouldBe` ("Right 2020-11-08") + + it "should fail on invalid inputs" do + (readParameter @Day "not a timestamp") `shouldBe` (Left "ParamReader Day: Failed parsing") + + it "should accept JSON strings" do + (tshow (readParameterJSON @Day (json "\"2020-11-08\""))) `shouldBe` ("Right 2020-11-08") + + describe "Maybe" do + it "should accept values" do + (readParameter @(Maybe Int) "1") `shouldBe` (Right (Just 1)) + (readParameter @(Maybe Text) "hello") `shouldBe` (Right (Just "hello")) + + it "should handle empty input as Nothing" do + (readParameter @(Maybe Int) "") `shouldBe` (Right Nothing) + (readParameter @(Maybe UUID) "") `shouldBe` (Right Nothing) + + it "should handle empty Text as Just" do + (readParameter @(Maybe Text) "") `shouldBe` (Right (Just "")) + (readParameter @(Maybe ByteString) "") `shouldBe` (Right (Just "")) + + it "should handle empty Bool as False" do + (readParameter @(Maybe Bool) "") `shouldBe` (Right (Just False)) + + it "should deal with parser errors" do + (readParameter @(Maybe Int) "not a number") `shouldBe` (Left "ParamReader Int: Failed reading: takeWhile1") + +json :: Text -> Aeson.Value +json string = + let (Just value) :: Maybe Aeson.Value = Aeson.decode (cs string) + in value \ No newline at end of file diff --git a/Test/Main.hs b/Test/Main.hs index 39ef31637..dd87314ba 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -28,6 +28,7 @@ import qualified Test.NameSupportSpec import qualified Test.HaskellSupportSpec import qualified Test.View.CSSFrameworkSpec import qualified Test.Controller.ContextSpec +import qualified Test.Controller.ParamSpec main :: IO () main = hspec do @@ -42,4 +43,5 @@ main = hspec do Test.HaskellSupportSpec.tests Test.HtmlSupport.ParserSpec.tests Test.View.CSSFrameworkSpec.tests - Test.Controller.ContextSpec.tests \ No newline at end of file + Test.Controller.ContextSpec.tests + Test.Controller.ParamSpec.tests \ No newline at end of file From df8e97ccb758ef7306d1a47b5b5ae5b6185af470 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sun, 8 Nov 2020 14:55:12 +0100 Subject: [PATCH 2/2] Fixed build --- ihp.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ihp.cabal b/ihp.cabal index 7dfa476aa..099cf1c19 100644 --- a/ihp.cabal +++ b/ihp.cabal @@ -76,6 +76,9 @@ common shared-properties , http-client , http-client-tls , resource-pool + , unordered-containers + , scientific + , vector default-extensions: OverloadedStrings , NoImplicitPrelude