trasa-form (empty) → 0.1.0.0
raw patch · 7 files changed
+504/−0 lines, 7 filesdep +basedep +bytestringdep +cookiesetup-changed
Dependencies added: base, bytestring, cookie, ditto, ditto-lucid, http-api-data, http-types, lucid, mtl, quantification, text, trasa, trasa-extra, trasa-form, trasa-server, unordered-containers, wai, wai-extra, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +211/−0
- src/Trasa/Form.hs +152/−0
- src/Trasa/Form/Lucid.hs +39/−0
- trasa-form.cabal +65/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for trasa-form++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, goolord++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of goolord nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,211 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeOperators #-}+{-# language TypeFamilies #-}+{-# language PolyKinds #-}++module Main where++import Data.ByteString.Lazy (ByteString)+import Data.Functor.Identity+import Data.Kind (Type)+import Data.Text (Text)+import Ditto (Result(..))+import Ditto.Core +import Ditto.Lucid+import Ditto.Lucid.Named+import Lucid+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import Trasa.Core+import Trasa.Extra+import Trasa.Form+import Trasa.Form.Lucid+import Trasa.Server+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Read as TR+import qualified Text.Read+import qualified Trasa.Method as Method++tshow :: Show a => a -> Text+tshow = T.pack . show++readInt :: Text -> Either Text Int+readInt input = case (TR.signed TR.decimal) input of+ Left err -> Left $ T.pack err+ Right (i, _) -> Right i++data Foo = Foo Int Bool Int+ deriving Show++-- Our route data type. We define this ourselves.+data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where+ HelloWorld :: Route + '[ByteString] -- ^ now the path captures the first piece as a ByeString+ '[('Optional ByteString)] -- ^ there is an optional query parameter, decoded as a ByteString+ 'Bodyless -- ^ the route does not have a request body+ ByteString -- ^ the response body will be `ByteString`+ FormTest :: Route+ '[]+ '[]+ 'Bodyless+ (Html ())+ FormTestPost :: Route+ '[]+ '[]+ ('Body B.ByteString)+ (Html ())++bodyAny :: BodyCodec B.ByteString+bodyAny = BodyCodec+ (pure "*/*")+ (BL.fromStrict)+ (Right . BL.toStrict)++bodyText :: BodyCodec ByteString+bodyText = BodyCodec + (pure "text/html; charset=utf-8") -- ^ NonEmpty list of the HTTP media type names.+ id -- ^ encode from ByteString to ByteString+ Right -- ^ decode from ByteString to (Either Text ByteString)++bodyHtml :: BodyCodec (Html a)+bodyHtml = BodyCodec (pure "text/html;charset=utf-8") renderBS (const (Left "can not decode html"))++bytestring :: CaptureCodec ByteString+bytestring = CaptureCodec (TE.decodeUtf8 . BL.toStrict) (Just . BL.fromStrict . TE.encodeUtf8)++text :: CaptureCodec Text+text = CaptureCodec id Just++showReadCodec :: Show a => Read a => CaptureCodec a+showReadCodec = CaptureCodec tshow (Text.Read.readMaybe . T.unpack)++int :: CaptureCodec Int+int = showReadCodec++-- | metadata about our routes: value level functions and data for constructing+-- and decoding paths+meta :: Route captures queries request response -> MetaCodec captures queries request response+meta route = case route of+ HelloWorld -> Meta + (capture bytestring ./ end) -- ^ match "/hello"+ (optional "b" bytestring .& qend) -- ^ no query parameters+ bodyless -- ^ no request body+ (resp (one bodyText)) -- ^ response body is one BodyCodec: our bodyText function above+ Method.get -- ^ http method: GET+ FormTest -> Meta+ (match "test" ./ end)+ (qend)+ bodyless+ (resp (one bodyHtml))+ Method.get+ FormTestPost -> Meta+ (match "test" ./ match "post" ./ end)+ (qend)+ (body (one bodyAny))+ (resp (one bodyHtml))+ Method.post++-- | this function defines how we handle routes with our web server:+-- what actions we perform based on the route and its captures & queries+routes+ :: forall captures queries request response.+ Route captures queries request response -- ^ our route GADT, polymorphic over its type variables+ -> Rec Identity captures -- ^ an extensible record of the captures for this route+ -> Rec Parameter queries -- ^ an extensible record of the captures for this route+ -> RequestBody Identity request -- ^ the request body+ -> TrasaT IO response -- ^ our response+routes route captures queries reqBody = case route of+ HelloWorld -> go helloWorld+ FormTest -> go formTest+ FormTestPost -> go formTestPost+ where+ -- | this helper function uses the `handler` function to unwrap the `Arguments` type family.+ go :: Arguments captures queries request (TrasaT IO response) -> TrasaT IO response+ go f = handler captures queries reqBody f++helloWorld :: ByteString -> Maybe ByteString -> TrasaT IO ByteString+helloWorld a (Just b) = pure $ a <> ", " <> b <> "!"+helloWorld a Nothing = pure a++type family QueryArguments (querys :: [Param]) (result :: Type) :: Type where+ QueryArguments '[] r = r+ QueryArguments (q ': qs) r = ParamBase q -> QueryArguments qs r++-- formArgs :: Monad f => Rec Parameter qrys -> QueryArguments qrys (f (Rec Parameter qrys))+-- formArgs queries args = do+-- pure RecNil++formFoo :: TrasaSimpleForm Foo+formFoo = childErrorList ++> ( Foo + <$> label "Int Field 1" "int1" + ++> setAttr [class_ "input"] (inputInt readInt "int1" 0)+ <*> label "Bool Field 1" "bool1"+ ++> inputYesNo "bool1"+ <*> label "Int Field 2" "in2" + ++> inputInt readInt "int2" 0+ <* buttonSubmit (const (Right T.empty)) "" "" ("Submit" :: Text)+ )++prepare :: Route captures query request response -> Arguments captures query request (Prepared Route response)+prepare = prepareWith meta++instance IsRoute Route where+ metaF = meta++formTest :: TrasaT IO (Html ())+formTest = do+ (res, html) <- simpleReformGET (encodeRoute $ conceal (prepare FormTest)) formFoo+ defaultLayout $ do+ case res of+ Ok x -> do+ toHtml $ show x+ br_ []+ Error xs -> do+ toHtml $ show xs+ br_ []+ html++formTestPost :: B.ByteString -> TrasaT IO (Html ())+formTestPost _ = do+ pure $ pure ()++defaultLayout :: Html () -> TrasaT IO (Html ())+defaultLayout children = do+ pure $ html_ $ do+ head_ $ do+ link_ [rel_ "stylesheet", href_ "https://unpkg.com/sakura.css/css/sakura.css", type_ "text/css"]+ body_ $ do+ children++-- | We define a list of all the routes for our server for wai+allRoutes :: [Constructed Route]+allRoutes = [Constructed HelloWorld, Constructed FormTest, Constructed FormTestPost]++-- | Another implimentaiton detail: this creates the data structure used to do routing+router :: Router Route+router = routerWith (mapMeta captureDecoding captureDecoding id id . meta) allRoutes++-- | `wai` application+application :: Application+application = serveWith+ (metaCodecToMetaServer . meta) -- ^ implimentaiton detail: this just marshals some types+ routes -- ^ routes function defined above+ router -- ^ router function defined above++main :: IO ()+main = run 8080 (logStdoutDev application)++inputYesNo :: String -> TrasaSimpleForm Bool+inputYesNo s = mapView + (\x -> label_ [for_ (T.pack s)] $ x *> "Enabled")+ (inputCheckbox False s)+
+ src/Trasa/Form.hs view
@@ -0,0 +1,152 @@+{-# language ConstraintKinds #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Trasa.Form + ( reform+ , reformQP+ , reformPost+ , liftParser+ , TrasaForm+ , TrasaSimpleForm+ , FormError(..)+ )+ where++import Control.Monad.Except+import Control.Monad.Reader+import Data.Text (Text)+import Ditto.Backend+import Ditto.Core hiding (view)+import Ditto.Result+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 Text where+ type ErrorInputType Text = Text+ commonFormError = T.pack . (commonFormErrorStr T.unpack)++liftParser :: (Text -> Either Text a) -> (QueryParam -> Either Text 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"++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++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+ -> 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'+ 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+ QueryString queryString <- trasaQueryString <$> ask+ let val = HM.lookup (tshow formId) queryString+ case val of+ Nothing -> pure Missing+ Just x -> pure (Found x)++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+ -> 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'+ 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
+ src/Trasa/Form/Lucid.hs view
@@ -0,0 +1,39 @@+{-# language OverloadedStrings #-}++module Trasa.Form.Lucid where++import Control.Monad.Except+import Data.Text (Text)+import Ditto.Core hiding (view)+import Ditto.Lucid+import Ditto.Result+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) + => Text+ -> Form (TrasaT m) Text err (HtmlT f ()) b + -> TrasaT m (Result err b, HtmlT f ())+simpleReformGET action form = reform (formGenGET' action) "reform" form++queryParamReformPOST :: (MonadIO m, Show b, Applicative f) + => Text+ -> BS.ByteString+ -> Form (TrasaT 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++formGenPOST' :: Applicative f => Text -> [(Text, Text)] -> HtmlT f b -> HtmlT f b+formGenPOST' url = formGenPOST url
+ trasa-form.cabal view
@@ -0,0 +1,65 @@+cabal-version: 2.0+name: trasa-form+version: 0.1.0.0+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+ typesafe forms, this library with ditto allow a more+ composable approach to form generation/validation.+license: BSD3+license-file: LICENSE+author: goolord+maintainer: zacharyachurchill@gmail.com+category: Web+build-type: Simple+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/goolord/ditto.git++library+ exposed-modules:+ Trasa.Form+ Trasa.Form.Lucid+ -- other-modules:+ -- other-extensions:+ ghc-options: -Wall+ build-depends: + base+ , http-api-data+ , cookie+ , http-types+ , lucid+ , mtl+ , quantification+ , ditto >= 0.1.2.0 && < 0.2+ , ditto-lucid >= 0.1.2.0 && < 0.2+ , text+ , trasa+ , trasa-server >= 0.5.3+ , unordered-containers+ , bytestring+ hs-source-dirs: src+ default-language: Haskell2010+executable test-server+ ghc-options: -Wall+ main-is: Main.hs+ build-depends: + base ^>=4.12.0.0+ , bytestring+ , lucid+ , quantification+ , ditto >= 0.1.2.0 && < 0.2+ , ditto-lucid >= 0.1.2.0 && < 0.2+ , text+ , trasa == 0.4.*+ , trasa-extra+ , trasa-form+ , trasa-server+ , wai+ , wai-extra == 3.0.27 + , mtl+ , warp+ hs-source-dirs: app+ default-language: Haskell2010