trasa-form-0.1.0.0: app/Main.hs

{-# 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)