{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} module Main where import Data.Text import Okapi import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.IORef import Data.Map import GHC.Generics import Data.List.NonEmpty import Database.SQLite.Simple import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import Text.InterpolatedString.Perl6 import Control.Monad.Combinators import Web.Internal.HttpApiData import Web.Internal.FormUrlEncoded import Data.ByteString import System.Random data Make = Toyota | Ford | Honda | Mercedes | BMW deriving (Eq, Show) instance ToHttpApiData Make where toQueryParam = \case Toyota -> "toyota" Ford -> "ford" Honda -> "honda" Mercedes -> "mercedes" BMW -> "bmw" instance FromHttpApiData Make where parseQueryParam = \case "toyota" -> Right Toyota "ford" -> Right Ford "honda" -> Right Honda "mercedes" -> Right Mercedes "bmw" -> Right BMW _ -> Left "Couldn't parse car make" data Car = Car { carMake :: Make , carYear :: Int , carMiles :: Int , carPrice :: Float } deriving (Eq, Show, Generic, FromForm) pattern HomeRoute = (GET, []) pattern QueryCarsRoute = (GET, ["cars"]) pattern PostCarsRoute = (POST, ["cars"]) pattern PostSuccessRoute = (GET, ["cars", "post", "success"]) pattern PostFailureRoute = (GET, ["cars", "post", "failure"]) renderURL :: (Method, Path) -> Text renderURL (_, p) = renderPath p renderFormAttrs :: (Method, Path) -> Text renderFormAttrs (m, p) = renderAction p <> " " <> renderMethod m where renderAction p = "action=\"" <> renderPath p <> "\"" renderMethod = \case POST -> "method=\"" <> "post" <> "\"" _ -> "method=\"" <> "get" <> "\"" -- ^ method="get" is the default method for forms methodAndPathParser :: MonadOkapi m => m (Method, Path) methodAndPathParser = do m <- method p <- path return (m, p) methodAndPathDispatcher :: (MonadOkapi m, MonadIO m) => IORef [Car] -> (Method, Path) -> m Response methodAndPathDispatcher database = \case HomeRoute -> do let html = [qq|

Welcome to the online car dealership!


Query Cars


2022
500000
200000

Put Your Car Up For Sale



200000
20000
|] return $ setHTML html $ ok QueryCarsRoute -> do maybeMakes <- optional $ queryList @Make "make" latestYear <- queryParam @Int "year" maxMiles <- queryParam @Int "miles" maxPrice <- queryParam @Float "price" carsThatMatchQuery <- liftIO $ do let makes = case maybeMakes of Nothing -> [] Just (m :| ms) -> m : ms availableCars <- readIORef database return $ filterCars makes maxMiles maxPrice availableCars let html = if Prelude.null carsThatMatchQuery then [qq|

No results match your query.

Go back |] else [qq| {Data.ByteString.concat $ Prelude.map makeCarTableRow carsThatMatchQuery}
Make Year Miles Price
Go back |] return $ setHTML html $ ok PostCarsRoute -> do maybeCarForSale <- optional $ bodyForm @Car case maybeCarForSale of Nothing -> return $ redirect 302 $ renderURL PostFailureRoute Just carForSale -> do liftIO $ modifyIORef database (carForSale :) return $ redirect 302 $ renderURL PostSuccessRoute PostSuccessRoute -> do let html = [qq|

Your car is now up for sale!

Go back |] return $ setHTML html $ ok PostFailureRoute -> do let html = [qq|

We can't put your car up for sale. Make sure you entered valid data.

Go back |] return $ setHTML html $ ok _ -> Okapi.next main :: IO () main = do database <- newIORef [] run id $ route methodAndPathParser $ methodAndPathDispatcher database makeYearOption :: Int -> ByteString makeYearOption year = [qq||] makeCarTableRow :: Car -> ByteString makeCarTableRow Car{..} = [qq| {carMake} {show carYear} {show carMiles} ${show carPrice} |] filterCars :: [Make] -> Int -> Float -> [Car] -> [Car] filterCars makes maxMiles maxPrice cars = [ car | car <- cars , carMiles car <= maxMiles , carPrice car <= maxPrice , if Prelude.null makes then True else carMake car `Prelude.elem` makes ]