Failwind.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Text.Blaze ((!))
import Text.Blaze.Html.Renderer.Text qualified as Html
import Text.Blaze.Html5 qualified as Html
import Text.Blaze.Html5.Attributes qualified as Html
  ( action,
    class_,
    enctype,
    for,
    method,
    name,
    onclick,
    src,
    type_,
  )
import Web.Scotty qualified as Scotty

main :: IO ()
main = Scotty.scotty 3000 $ do
  Scotty.get endpoints.home (renderPage homePage)
  Scotty.get endpoints.login (renderPage loginPage)
  Scotty.post endpoints.login loginHandler
  Scotty.get endpoints.welcome (renderPage welcomePage)
  Scotty.get endpoints.invalidLogin (renderPage invalidLoginPage)

data Login = Login
  { username :: !Text,
    password :: !Text
  }
  deriving (Show)

data Endpoints a = Endpoints
  { login :: a,
    home :: a,
    invalidLogin :: a,
    welcome :: a
  }

endpoints :: IsString a => Endpoints a
endpoints =
  Endpoints
    { login = "/login",
      home = "/",
      invalidLogin = "/invalid-login",
      welcome = "/welcome"
    }

loginPage :: Html.Html
loginPage = index $ do
  Html.h1 ! Html.class_ "mb-4 text-4xl font-extrabold leading-none tracking-tight text-gray-900 md:text-5xl lg:text-6xl dark:text-white" $ Html.toHtml @Text "Login"
  Html.div
    $ Html.button
      ! Html.class_ "font-medium text-blue-600 dark:text-blue-500 hover:underline"
      ! Html.onclick ("location.href='" <> endpoints.home <> "'")
    $ Html.toHtml @Text "home"
  Html.form ! Html.method "POST" ! Html.action endpoints.login ! Html.enctype "application/json" ! Html.class_ "bg-white shadow-md rounded px-8 pt-6 pb-8 mb-4" $ do
    -- username input
    Html.div ! Html.class_ "mb-4" $ do
      Html.label ! Html.for "username" ! Html.name "username" ! Html.class_ "block text-gray-700 text-sm font-bold mb-2" $ (Html.toHtml @Text "Username")
      Html.input ! Html.type_ "text" ! Html.name "username" ! Html.class_ "shadow appearance-none border rounded w-full py-2 px-3 text-gray-700 leading-tight focus:outline-none focus:shadow-outline"
    -- password input
    Html.div ! Html.class_ "mb-6" $ do
      Html.label ! Html.for "password" ! Html.name "password" ! Html.class_ "block text-gray-700 text-sm font-bold mb-2" $ (Html.toHtml @Text "Password")
      Html.input ! Html.type_ "text" ! Html.name "password" ! Html.class_ "shadow appearance-none border rounded w-full py-2 px-3 text-gray-700 leading-tight focus:outline-none focus:shadow-outline"
    Html.div ! Html.class_ "flex items-center justify-between" $
      Html.input ! Html.type_ "submit" ! Html.class_ "bg-blue-500 hover:bg-blue-700 text-white font-bold py-2 px-4 rounded focus:outline-none focus:shadow-outline"

homePage :: Html.Html
homePage = index $ do
  Html.h1 ! Html.class_ "mb-4 text-4xl font-extrabold leading-none tracking-tight text-gray-900 md:text-5xl lg:text-6xl dark:text-white" $ Html.toHtml @Text "Home"
  -- login button
  Html.button
    ! Html.class_ "font-medium text-blue-600 dark:text-blue-500 hover:underline"
    ! Html.onclick ("location.href='" <> endpoints.login <> "'")
    $ Html.toHtml @Text "login"

invalidLoginPage :: Html.Html
invalidLoginPage = index $ do
  Html.h1 ! Html.class_ "mb-4 text-4xl font-extrabold leading-none tracking-tight text-gray-900 md:text-5xl lg:text-6xl dark:text-white" $ Html.toHtml @Text "Invalid Login"

welcomePage :: Html.Html
welcomePage = index $ do
  Html.h1 ! Html.class_ "mb-4 text-4xl font-extrabold leading-none tracking-tight text-gray-900 md:text-5xl lg:text-6xl dark:text-white" $ Html.toHtml @Text "Welcome!"

index :: Html.Html -> Html.Html
index html = Html.docTypeHtml $ do
  Html.head $ do
    Html.script ! Html.src "https://cdn.tailwindcss.com" $ Html.toHtml @Text ""
    Html.title (Html.toMarkup @Text "Github Login")
  Html.body $
    Html.div ! Html.class_ "main" $
      html

renderPage :: Html.Html -> Scotty.ActionM ()
renderPage = Scotty.html <<< Html.renderHtml

-- Handlers
loginHandler :: Scotty.ActionM ()
loginHandler = do
  username <- Scotty.formParam @Text "username"
  password <- Scotty.formParam @Text "password"
  let login = Login {username, password}
  let user = getUser login.username login.password
  case user of
    Nothing -> Scotty.redirect endpoints.invalidLogin
    Just _user -> Scotty.redirect endpoints.welcome

getUser :: Text -> Text -> Maybe User
getUser username password =
  find @[]
    (\user -> user.username == username && user.password == password)
    database.users

database :: Database
database =
  Database
    { users = [User {username = "test", password = "password"}]
    }

data Database = Database
  { users :: ![User]
  }

data User = User
  { username :: !Text,
    password :: !Text
  }