{-# LANGUAGE FlexibleContexts #-}
module Yesod.Form.JSON
(
-- * The example of use
-- $use
-- * Functions
runJSONForm
, jsonField
)
where
import Prelude
import Data.Aeson (eitherDecode, encode)
import Yesod.Form.Types
import Data.Text (Text, pack)
import Control.Applicative (Applicative (..))
import Yesod.Core
import Control.Monad (liftM)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, catMaybes)
import Control.Arrow ((***))
import Yesod.Form.Input (FormInput(..))
import qualified Data.HashMap.Strict as HM (toList)
import Yesod.Form.Functions (parseHelper)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.ByteString.Lazy as B (fromStrict, toStrict)
-- |Run JSON form
runJSONForm :: MonadHandler m => FormInput m a -> m a
runJSONForm (FormInput f) = do
obj <- requireJsonBody
let env = toEnv obj
m <- getYesod
l <- languages
emx <- f m l env Map.empty
case emx of
Left errs -> invalidArgs $ errs []
Right x -> return x
-- |Obtain JSON field from json request
jsonField :: (Monad m, FromJSON a) => RenderMessage (HandlerSite m) FormMessage => Field m a
jsonField = Field (parseHelper helper) undefined undefined
where
helper json = case (eitherDecode . B.fromStrict . encodeUtf8) json of
Left err -> Left $ MsgInvalidEntry $ pack err
Right v -> Right v
toEnv :: Value -> Env
toEnv (Object obj) =
let l = map json2Text $ HM.toList obj
in Map.fromList $ catMaybes l
where
json2Text (name, obj@(Object _)) = Just $ (name, [(decodeUtf8 . B.toStrict . encode) obj])
json2Text (name, arr@(Array _)) = Just $ (name, [(decodeUtf8 . B.toStrict . encode) arr])
json2Text (name, String str) = Just $ (name, [str])
json2Text (name, Number n) = Just $ (name, [pack $ show n])
json2Text (name, Bool b) = Just $ (name, [pack $ show b])
toEnv _ = Map.empty
-- toMap :: [(Text, a)] -> Map.Map Text [a]
-- toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
-- $use
--
-- > data Offer = Offer {
-- > name :: Text
-- > , description Text
-- > , supplier :: SupplierId
-- > , category :: CategoryId
-- > , tags :: [TagId]
-- > , images :: [Image]
-- > , variants :: [Variant]
-- > , active :: Bool
-- > }
--
-- > offer <- runJSONForm $ Offer <$> ireq textField "name"
-- > <*> ireq textField "description"
-- > <*> ireq jsonField "supplier"
-- > <*> ireq jsonField "category")
-- > <*> ireq jsonField "tags")
-- > <*> ireq jsonField "images"
-- > <*> (fmap nub $ ireq jsonField "variants")
-- > <*> ireq boolField "active"