diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# 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 = do - label "Int Field 1" "int1" - int1 <- inputInt readInt "int1" 0 - label "Bool Field 1" "bool1" - bool1 <- inputYesNo "bool1" - label "Int Field 2" "in2" - int2 <- inputInt readInt "int2" int1 - buttonSubmit (const (Right T.empty)) "" "" ("Submit" :: Text) - pure (Foo int1 bool1 int2) - --- 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) - diff --git a/src/Trasa/Form.hs b/src/Trasa/Form.hs --- a/src/Trasa/Form.hs +++ b/src/Trasa/Form.hs @@ -1,6 +1,7 @@ {-# language ConstraintKinds #-} {-# language OverloadedStrings #-} {-# language TypeFamilies #-} +{-# language MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -31,6 +32,13 @@ 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 + where + encQP QueryParamFlag = "" + encQP (QueryParamSingle x) = x + encQP (QueryParamList xs) = tshow xs liftParser :: (Text -> Either Text a) -> (QueryParam -> Either Text a) liftParser f q = case q of diff --git a/trasa-form.cabal b/trasa-form.cabal --- a/trasa-form.cabal +++ b/trasa-form.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: trasa-form -version: 0.2.0.0 +version: 0.3.1.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 @@ -26,15 +26,15 @@ -- other-extensions: ghc-options: -Wall build-depends: - base + base < 5 , http-api-data , cookie , http-types , lucid , mtl , quantification - , ditto >= 0.2 && < 0.3 - , ditto-lucid >= 0.2 && < 0.3 + , ditto >= 0.3.1 && < 0.4 + , ditto-lucid >= 0.3.1 && < 0.4 , text , trasa , trasa-server >= 0.5.3 @@ -42,24 +42,24 @@ , 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.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 - hs-source-dirs: app - 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.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 +-- hs-source-dirs: app +-- default-language: Haskell2010