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 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