diff --git a/lib/Web/Hikaru/Action.hs b/lib/Web/Hikaru/Action.hs index 082e0fcc9b76e1dbd612a545bdd4da4fe1843685..9d28eb07ae83cd6f634bebd2d6316e3af3e23211 100644 --- a/lib/Web/Hikaru/Action.hs +++ b/lib/Web/Hikaru/Action.hs @@ -18,7 +18,7 @@ module Web.Hikaru.Action , getRequest , getMethod , getHeaders - , getHeader + , getHeaderMaybe , getAccept , getAcceptCharset , getAcceptEncoding @@ -29,6 +29,7 @@ module Web.Hikaru.Action , getParams , getParamMaybe , getParamList + , getParamDefault , getBodyLength , setBodyLimit , getBodyLimit @@ -38,7 +39,12 @@ module Web.Hikaru.Action , getJSON , getBody , getFields + , getFieldMaybe + , getFieldDefault + , getFieldList , getFiles + , getFileMaybe + , getFileList -- ** Building Response , setStatus @@ -204,7 +210,7 @@ where -- ^ Body has not yet been touched. | BodyTainted -- ^ Body has been partially consumed. - | BodyForm ([Param], [File FilePath]) + | BodyForm ([(Text, Text)], [(Text, FileInfo FilePath)]) -- ^ Body has been successfully parsed as a form. | BodyJSON Value -- ^ Body has been successfully parsed as a JSON. @@ -253,8 +259,8 @@ where -- | -- Obtain a specific request header. -- - getHeader :: (MonadAction m) => HeaderName -> m (Maybe ByteString) - getHeader n = lookup n <$> getHeaders + getHeaderMaybe :: (MonadAction m) => HeaderName -> m (Maybe ByteString) + getHeaderMaybe n = lookup n <$> getHeaders -- | @@ -262,7 +268,7 @@ where -- getAccept :: (MonadAction m) => m [Media] getAccept = parseMedia <$> cs . fromMaybe "*/*" - <$> getHeader hAccept + <$> getHeaderMaybe hAccept -- | @@ -270,7 +276,7 @@ where -- getAcceptCharset :: (MonadAction m) => m [Media] getAcceptCharset = parseMedia <$> cs . fromMaybe "*" - <$> getHeader hAcceptCharset + <$> getHeaderMaybe hAcceptCharset -- | @@ -279,7 +285,7 @@ where -- getAcceptEncoding :: (MonadAction m) => m [Media] getAcceptEncoding = parseMedia <$> cs . fromMaybe "identity,*;q=0" - <$> getHeader hAcceptEncoding + <$> getHeaderMaybe hAcceptEncoding -- | @@ -287,7 +293,7 @@ where -- getAcceptLanguage :: (MonadAction m) => m [Media] getAcceptLanguage = parseMedia <$> cs . fromMaybe "*/*" - <$> getHeader hAcceptLanguage + <$> getHeaderMaybe hAcceptLanguage -- | @@ -296,7 +302,7 @@ where -- getContentType :: (MonadAction m) => m Media getContentType = do - media <- fmap parseMedia <$> fmap cs <$> getHeader hContentType + media <- fmap parseMedia <$> fmap cs <$> getHeaderMaybe hContentType case media of Just (x:_) -> return x @@ -332,6 +338,14 @@ where Just val -> return $ fromParam val + -- | + -- Similar to 'getParamMaybe', but return either the parsed parameter + -- or a specified default value. + -- + getParamDefault :: (MonadAction m, FromParam a) => Text -> a -> m a + getParamDefault n v = fromMaybe v <$> getParamMaybe n + + -- | -- Obtain a group of request query string parameters with the same name -- and parse them on the fly to the target type. @@ -526,19 +540,64 @@ where where convert (n, v) = (cs n, cs v) + -- | + -- Obtain a specific form field and parse it on the fly to the target type. + -- Parsing failure maps to 'Nothing'. + -- + getFieldMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a) + getFieldMaybe n = lookup n <$> getFields + >>= \case Nothing -> return $ Nothing + Just val -> return $ fromParam val + + + -- | + -- Similar to 'getFieldMaybe', but return either the parsed field + -- or a specified default value. + -- + getFieldDefault :: (MonadAction m, FromParam a) => Text -> a -> m a + getFieldDefault n v = fromMaybe v <$> getFieldMaybe n + + + -- | + -- Obtain a group of form fields with the same name and parse them on the + -- fly to the target type. + -- + getFieldList :: (MonadAction m, FromParam a) => Text -> m [a] + getFieldList n = mapMaybe (fromParam . snd) + <$> filter ((n ==) . fst) + <$> getFields + + -- | -- Identical to 'getFields', except it returns information about -- files uploaded through the form. -- - getFiles :: (MonadAction m) => m [File FilePath] + getFiles :: (MonadAction m) => m [(Text, FileInfo FilePath)] getFiles = snd <$> getForm + -- | + -- Obtain a specific form file + -- + getFileMaybe :: (MonadAction m) => Text -> m (Maybe (FileInfo FilePath)) + getFileMaybe n = lookup n <$> getFiles + >>= \case Nothing -> return $ Nothing + Just val -> return $ Just val + + + -- | + -- Obtain a group of form files with the same name. + -- + getFileList :: (MonadAction m) => Text -> m [FileInfo FilePath] + getFileList n = map snd . filter ((n ==) . fst) <$> getFiles + + -- | -- Backend for both 'getFields' and 'getFiles' that parses, -- caches and returns form data. -- - getForm :: (MonadAction m) => m ([Param], [File FilePath]) + getForm :: (MonadAction m) + => m ([(Text, Text)], [(Text, FileInfo FilePath)]) getForm = do cache <- getActionField aeBody @@ -559,9 +618,12 @@ where registerFinalizer (closeInternalState rtis) -- Parse the form data. - form <- liftIO do + form' <- liftIO do sinkRequestBody (tempFileBackEnd rtis) bt getChunk + -- Convert ByteString to Text fields. + let form = csForm form' + -- Cache and return. setActionField aeBody (BodyForm form) return form @@ -572,6 +634,17 @@ where throwError InternalError "Body has been parsed as a non-form." + -- | + -- Convert form names and fields from 'ByteString' to 'Text'. + -- + csForm :: ([Param], [File FilePath]) + -> ([(Text, Text)], [(Text, FileInfo FilePath)]) + csForm (ps, fs) = (ps', fs') + where + ps' = map (\(n, v) -> (cs n, cs v)) ps + fs' = map (\(n, f) -> (cs n, f)) fs + + -- | -- Read, cache and return payload sent by the user. --