trasa-form 0.3.2.0 → 0.4
raw patch · 3 files changed
+145/−140 lines, 3 filesdep ~dittodep ~ditto-lucid
Dependency ranges changed: ditto, ditto-lucid
Files
- src/Trasa/Form.hs +117/−102
- src/Trasa/Form/Lucid.hs +8/−20
- trasa-form.cabal +20/−18
src/Trasa/Form.hs view
@@ -1,40 +1,51 @@-{-# language ConstraintKinds #-}-{-# language OverloadedStrings #-}-{-# language TypeFamilies #-}-{-# language MultiParamTypeClasses #-}+{-# LANGUAGE + ConstraintKinds+ , OverloadedStrings+ , TypeFamilies+ , MultiParamTypeClasses+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , StandaloneDeriving +#-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Trasa.Form - ( reform- , reformQP- , reformPost- , liftParser- , TrasaForm- , TrasaSimpleForm+ ( FormData(..) , FormError(..)+ , TrasaFormT(..)+ , FormType(..)+ , TrasaForm+ , TrasaFormError(..)+ , bodyFormData+ , liftParser+ , liftToForm+ , reform+ , reformPost+ , trasaFormView+ , textError ) where +import Control.Applicative (Alternative(..)) import Control.Monad.Except import Control.Monad.Reader+import Data.String (IsString(..)) import Data.Text (Text)+import Data.Bifunctor import Ditto.Backend import Ditto.Core hiding (view)-import Ditto.Result+import Ditto.Types import Lucid import Trasa.Core hiding (optional) import Trasa.Server import Trasa.Url-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as HM import qualified Data.Text as T-import qualified Data.Text.Lazy as TL import qualified Web.FormUrlEncoded as HTTP -instance FormError QueryParam Text where- commonFormError = commonFormErrorText encQP+instance FormError QueryParam TrasaFormError where+ commonFormError e = TrasaFormError (Just e) (commonFormErrorText encQP e) where encQP QueryParamFlag = "<flag>" encQP (QueryParamSingle x) = x@@ -47,117 +58,121 @@ getInputStrings (QueryParamFlag) = [] getInputFile _ = Left $ commonFormError $ (NoFileFound (QueryParamSingle "No support for file uploads") :: CommonFormError QueryParam) -liftParser :: (Text -> Either Text a) -> (QueryParam -> Either Text a)+-- | @trasa-form@'s form error type: may have a @CommonFormError@, will have an error message+data TrasaFormError = TrasaFormError+ { trasaFormErrorType :: Maybe (CommonFormError QueryParam)+ , trasaFormErrorText :: Text+ } deriving Show++deriving instance Show QueryParam++instance ToHtml TrasaFormError where+ toHtml = toHtml . trasaFormErrorText+ toHtmlRaw = toHtmlRaw . trasaFormErrorText++instance IsString TrasaFormError where+ fromString = TrasaFormError Nothing . fromString++-- | convert @Text@ to a @TrasaFormError@+textError :: Text -> TrasaFormError+textError = TrasaFormError Nothing++-- | lift a function which parses @Text@ into a function which parses a @QueryParam@+liftParser :: (Text -> Either Text a) -> (QueryParam -> Either TrasaFormError a) liftParser f q = case q of- QueryParamSingle x -> f x- QueryParamList [x] -> f x- QueryParamFlag -> Left "Unexpected query flag"- QueryParamList [] -> Left "Unexpect empty query list"- QueryParamList (_:_:_) -> Left "Unexpected query string list"+ QueryParamSingle x -> first textError $ f x+ QueryParamList [x] -> first textError $ f x+ QueryParamFlag -> Left $ textError "Unexpected query flag"+ QueryParamList [] -> Left $ textError "Unexpect empty query list"+ QueryParamList (_:_:_) -> Left $ textError "Unexpected query string list" tshow :: Show a => a -> Text tshow = T.pack . show -type TrasaSimpleForm a = Form (TrasaT IO) Text Text (Html ()) a-type TrasaForm a = Form (TrasaT IO) QueryParam Text (Html ()) a+-- | a type alias for the most common type of form using @trasa-form@+type TrasaForm a = Form (TrasaFormT IO) QueryParam TrasaFormError (Html ()) a +-- | run a @Form@ with the @GET@ method reform :: (MonadIO m, Monoid view) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a <form> tag -> Text -- ^ form name prefix- -> Form (TrasaT m) Text err view a -- ^ the formlet+ -> Form (TrasaFormT m) QueryParam err view a -- ^ the formlet -> TrasaT m (Result err a, view) reform toForm prefix formlet = do - reformSingle toForm' prefix formlet- where- toForm' hidden view = toForm (("formname",prefix) : hidden) view--reformSingle :: (MonadIO m, Monoid view)- => ([(Text, Text)] -> view -> view)- -> Text- -> Form (TrasaT m) Text err view a- -> TrasaT m (Result err a, view)-reformSingle toForm prefix formlet = do- (View viewf, res') <- runForm (Environment env) (TL.fromStrict prefix) formlet- res <- res'+ (View viewf, res) <- flip runReaderT Get $ getTrasaFormT $ runForm prefix formlet case res of Error errs -> pure (Error errs, toForm [] $ viewf errs) Ok (Proved _ unProved') -> pure (Ok unProved', toForm [] $ viewf [])- where- env :: MonadIO m => FormId -> TrasaT m (Value Text)- env formId = do- QueryString queryString <- trasaQueryString <$> ask- let val = HM.lookup (tshow formId) queryString- case val of- Nothing -> pure Missing- Just QueryParamFlag -> pure Default -- ???- Just (QueryParamSingle x) -> pure (Found x)- Just (QueryParamList x) -> pure (Found $ T.intercalate ", " x) -- ??? -reformQP :: (MonadIO m, Monoid view) - => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a <form> tag- -> Text -- ^ form name prefix- -> Form (TrasaT m) QueryParam err view a -- ^ the formlet- -> TrasaT m (Result err a, view)-reformQP toForm prefix formlet = do - reformSingleQP toForm' prefix formlet- where- toForm' hidden view = toForm (("formname",prefix) : hidden) view--reformSingleQP :: (MonadIO m, Monoid view)- => ([(Text, Text)] -> view -> view)- -> Text- -> Form (TrasaT m) QueryParam err view a- -> TrasaT m (Result err a, view)-reformSingleQP toForm prefix formlet = do- (View viewf, res') <- runForm (Environment env) (TL.fromStrict prefix) formlet- res <- res'- case res of- Error errs -> pure (Error errs, toForm [] $ viewf errs)- Ok (Proved _ unProved') -> pure (Ok unProved', toForm [] $ viewf [])- where- env :: MonadIO m => FormId -> TrasaT m (Value QueryParam)- env formId = do+instance MonadIO m => Environment (TrasaT m) QueryParam where+ environment formId = do QueryString queryString <- trasaQueryString <$> ask- let val = HM.lookup (tshow formId) queryString+ let val = HM.lookup (encodeFormId formId) queryString case val of Nothing -> pure Missing Just x -> pure (Found x) +-- | run a @Form@ with the @POST@ method reformPost :: (MonadIO m, Monoid view) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a <form> tag -> Text -- ^ form name prefix- -> BS.ByteString- -> Form (TrasaT m) QueryParam err view a -- ^ the formlet- -> TrasaT m (Result err a, view)-reformPost toForm prefix reqBody formlet = do - reformSinglePost toForm' prefix reqBody formlet- where- toForm' hidden view = toForm (("formname",prefix) : hidden) view--reformSinglePost :: (MonadIO m, Monoid view)- => ([(Text, Text)] -> view -> view)- -> Text- -> BS.ByteString- -> Form (TrasaT m) QueryParam err view a+ -> Maybe (FormData a)+ -> Form (TrasaFormT m) QueryParam err view a -- ^ the formlet -> TrasaT m (Result err a, view)-reformSinglePost toForm prefix reqBody formlet = do- let formData = parseRequestBody reqBody- (View viewf, res') <- runForm (Environment $ env formData) (TL.fromStrict prefix) formlet- res <- res'+reformPost toForm prefix formData formlet = do + (View viewf, res) <- flip runReaderT (Post $ getFormData <$> formData) $ getTrasaFormT $ runForm prefix formlet case res of Error errs -> pure (Error errs, toForm [] $ viewf errs) Ok (Proved _ unProved') -> pure (Ok unProved', toForm [] $ viewf [])- where- env :: MonadIO m => HM.HashMap Text [Text] -> FormId -> TrasaT m (Value QueryParam)- env multipart formId = do- let val = HM.lookup (tshow formId) multipart- case val of- Nothing -> pure Missing- Just [] -> pure $ Found QueryParamFlag- Just [x] -> pure $ Found $ QueryParamSingle x- Just xs -> pure $ Found $ QueryParamList xs -parseRequestBody :: BS.ByteString -> HM.HashMap Text [Text]-parseRequestBody reqBody = case HTTP.urlDecodeForm (BSL.fromStrict reqBody) of- Left _ -> HM.empty- Right (HTTP.Form formData) -> formData+newtype FormData a = FormData { getFormData :: HM.HashMap Text [Text] }+ deriving (Monoid, Semigroup, Eq, Ord, Show)++-- | this is a @BodyCodec@, the intended use is to get the request body+-- without using @wai@ black magic to pass to @POST@ forms+bodyFormData :: BodyCodec (FormData a)+bodyFormData = BodyCodec+ (pure "application/x-www-form-urlencoded")+ (HTTP.urlEncodeAsFormStable . getFormData)+ (fmap (FormData . HTTP.unForm) . HTTP.urlDecodeForm)++-- | a newtype over TrasaT which allows it to have+-- different environments for @GET@ and @POST@ requests+newtype TrasaFormT m a = TrasaFormT+ { getTrasaFormT :: ReaderT FormType (TrasaT m) a }+ deriving (Monad, Applicative, Functor, Alternative)++instance MonadTrans (TrasaFormT) where+ lift = TrasaFormT . lift . lift++deriving instance Monad m => MonadReader FormType (TrasaFormT m)++-- | a GET request, or a @POST@ request which may hav the untyped @FormData@+data FormType = Get | Post (Maybe (HM.HashMap Text [Text]))++instance Monad m => Environment (TrasaFormT m) QueryParam where+ environment formId = ask >>= \case+ Post (Just urlEncoded) -> do+ case HM.lookup (encodeFormId formId) urlEncoded of+ Nothing -> pure Missing+ Just [] -> pure $ Found QueryParamFlag+ Just [x] -> pure $ Found $ QueryParamSingle x+ Just xs -> pure $ Found $ QueryParamList xs+ Post Nothing -> pure Default+ Get -> TrasaFormT $ lift $ do+ QueryString queryString <- trasaQueryString <$> ask+ case HM.lookup (encodeFormId formId) queryString of+ Nothing -> pure Missing+ Just x -> pure (Found x)++-- | lift a TrasaT to a TrasaFormT+liftToForm :: Monad m => TrasaT m a -> TrasaFormT m a+liftToForm = TrasaFormT . lift++-- | @viewForm@ helper function+trasaFormView :: Monad m+ => Text+ -> Form (TrasaFormT m) QueryParam err view a+ -> TrasaT m view+trasaFormView name form = flip runReaderT Get $ getTrasaFormT $ viewForm name form+
src/Trasa/Form/Lucid.hs view
@@ -6,34 +6,22 @@ import Data.Text (Text) import Ditto.Core hiding (view) import Ditto.Lucid-import Ditto.Result+import Ditto.Types import Lucid import Trasa.Form import Trasa.Server import Trasa.Url-import qualified Data.ByteString as BS -queryParamReformGET :: (MonadIO m, Show b, Applicative f) - => Text- -> Form (TrasaT m) QueryParam err (HtmlT f ()) b - -> TrasaT m (Result err b, HtmlT f ())-queryParamReformGET action = reformQP (formGenGET' action) "reform"--simpleReformGET :: (MonadIO m, Show b, Applicative f) +formGET :: (MonadIO m, Applicative f) => Text- -> Form (TrasaT m) Text err (HtmlT f ()) b + -> Form (TrasaFormT m) QueryParam err (HtmlT f ()) b -> TrasaT m (Result err b, HtmlT f ())-simpleReformGET action form = reform (formGenGET' action) "reform" form+formGET action = reform (formGenGET action) "ditto" -queryParamReformPOST :: (MonadIO m, Show b, Applicative f) +formPOST :: (MonadIO m, Applicative f) => Text- -> BS.ByteString- -> Form (TrasaT m) QueryParam err (HtmlT f ()) b + -> Maybe (FormData b)+ -> Form (TrasaFormT m) QueryParam err (HtmlT f ()) b -> TrasaT m (Result err b, HtmlT f ())-queryParamReformPOST action reqBody form = reformPost (formGenPOST' action) "reform" reqBody form--formGenGET' :: Applicative f => Text -> [(Text, Text)] -> HtmlT f b -> HtmlT f b-formGenGET' url = formGenGET url+formPOST action formData = reformPost (formGenPOST action) "ditto" formData -formGenPOST' :: Applicative f => Text -> [(Text, Text)] -> HtmlT f b -> HtmlT f b-formGenPOST' url = formGenPOST url
trasa-form.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: trasa-form-version: 0.3.2.0+version: 0.4 synopsis: generate forms using lucid, ditto and trasa description: Formlets library for trasa using ditto as its backend. Although trasa already has machinery for creating@@ -33,8 +33,8 @@ , lucid , mtl , quantification- , ditto >= 0.3.1 && < 0.4- , ditto-lucid >= 0.3.1 && < 0.4+ , ditto >= 0.4 && < 0.5+ , ditto-lucid >= 0.4 && < 0.5 , text , trasa , trasa-server >= 0.5.3@@ -46,20 +46,22 @@ -- ghc-options: -Wall -- main-is: Main.hs -- build-depends: --- base ^>=4.12.0.0--- , bytestring--- , lucid--- , quantification--- , ditto >= 0.2 && < 0.3--- , ditto-lucid >= 0.2 && < 0.3--- , text--- , trasa == 0.4.*--- , trasa-extra--- , trasa-form--- , trasa-server--- , wai--- , wai-extra == 3.0.27 --- , mtl--- , warp+-- base ^>=4.12.0.0+-- , bytestring+-- , ditto >= 0.4 && < 0.5+-- , ditto-lucid >= 0.4 && < 0.5+-- , http-api-data+-- , lucid+-- , mtl+-- , path-pieces+-- , quantification+-- , text+-- , trasa == 0.4.*+-- , trasa-extra+-- , trasa-form+-- , trasa-server+-- , wai+-- , wai-extra == 3.0.27 +-- , warp -- hs-source-dirs: app -- default-language: Haskell2010