Update recipe example to car dealership example

2024-11-23 09:54:24 +03:00 · 2022-09-18 11:12:51 +00:00 · 2022-09-18 11:12:51 +00:00 · 1d1695ff24
commit 1d1695ff24
parent 83756123e4
6 changed files with 306 additions and 89 deletions
--- a/examples/car-dealership/Main.hs
+++ b/examples/car-dealership/Main.hs
@ -0,0 +1,238 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+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)
+
+instance FromForm Car where
+
+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|
+            <h1>Welcome to the online car dealership!</h1>
+            <hr>
+            <h2>Query Cars</h2>
+            <form {renderFormAttrs QueryCarsRoute}>
+              <label for="make">Car Make: </label>
+              <select name="make" id="make" multiple>
+                <option value={toQueryParam Toyota}>Toyota</option>
+                <option value={toQueryParam Ford}>Ford</option>
+                <option value={toQueryParam Honda}>Honda</option>
+                <option value={toQueryParam Mercedes}>Mercedes</option>
+                <option value={toQueryParam BMW}>BMW</option>
+              </select>
+              <br>
+              <label for="year">Car Latest Year: </label>
+              <input type="range" id="year" name="year" min="1985" step="1" max="2022" value="2022" oninput="this.nextElementSibling.value = this.value">
+              <output>2022</output>
+              <br>
+              <label for="miles">Car Max Miles: </label>
+              <input type="range" id="miles" name="miles" min="0" step="50000" max="500000" value="500000" oninput="this.nextElementSibling.value = this.value">
+              <output>500000</output>
+              <br>
+              <label for="price">Car Max Price: </label>
+              <input type="range" id="price" name="price" min="0" step="1000" max="200000" value="200000" oninput="this.nextElementSibling.value = this.value">
+              <output>200000</output>
+              <br>
+              <input type="submit" value="Submit">
+            </form>
+            <hr>
+            <h2>Put Your Car Up For Sale</h2>
+            <form {renderFormAttrs PostCarsRoute}>
+              <label for="carMake">Car Make: </label>
+              <select name="carMake" id="carMake">
+                <option value={toQueryParam Toyota}>Toyota</option>
+                <option value={toQueryParam Ford}>Ford</option>
+                <option value={toQueryParam Honda}>Honda</option>
+                <option value={toQueryParam Mercedes}>Mercedes</option>
+                <option value={toQueryParam BMW}>BMW</option>
+              </select>
+              <br>
+              <label for="carYear">Car Year: </label>
+              <select name="carYear" id="carYear">
+                {Data.ByteString.concat $ Prelude.map makeYearOption [1985..2022]}
+              </select>
+              <br>
+              <label for="carMiles">Car Miles: </label>
+              <input type="range" id="carMiles" name="carMiles" min="0" step="50000" max="500000" value="200000" oninput="this.nextElementSibling.value = this.value">
+              <output>200000</output>
+              <br>
+              <label for="carPrice">Car Price: </label>
+              <input type="range" id="carPrice" name="carPrice" min="0" step="1000" max="200000" value="20000" oninput="this.nextElementSibling.value = this.value">
+              <output>20000</output>
+              <br>
+              <input type="submit" value="Submit">
+            </form>
+          |]
+    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|
+                <h1>No results match your query.</h1>
+                <a href="{renderURL HomeRoute}">Go back</a>
+              |]
+            else
+              [qq|
+                <table>
+                  <tr>
+                    <th>Make</th>
+                    <th>Year</th>
+                    <th>Miles</th>
+                    <th>Price</th>
+                  </tr>
+                  {Data.ByteString.concat $ Prelude.map makeCarTableRow carsThatMatchQuery}
+                </table>
+                <a href="{renderURL HomeRoute}">Go back</a>
+              |]
+
+    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|
+            <h1>
+              Your car is now up for sale!
+            </h1>
+            <a href="{renderURL HomeRoute}">Go back</a>
+          |]
+    return $ setHTML html $ ok
+  PostFailureRoute -> do
+    let html =
+          [qq|
+            <h1>
+              We can't put your car up for sale.
+              Make sure you entered valid data.
+            </h1>
+            <a href="{renderURL HomeRoute}">Go back</a>
+          |]
+    return $ setHTML html $ ok
+  _ -> Okapi.next
+
+main :: IO ()
+main = do
+  database <- newIORef []
+  run id $ route methodAndPathParser $ methodAndPathDispatcher database
+
+makeYearOption :: Int -> ByteString
+makeYearOption year = [qq|<option value={toQueryParam year}>{toQueryParam year}</option>|]
+
+makeCarTableRow :: Car -> ByteString
+makeCarTableRow Car{..} =
+  [qq|
+    <tr>
+      <td>{carMake}</td>
+      <td>{show carYear}</td>
+      <td>{show carMiles}</td>
+      <td>${show carPrice}</td>
+    </tr>
+  |]
+
+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
+  ]
--- a/examples/recipe/Main.hs
+++ b/examples/recipe/Main.hs
@ -1,83 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Main where
-
-import Data.Text
-import Okapi
-
-import Database.SQLite.Simple
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.ToField
-import Text.InterpolatedString.Perl6
-
-data Recipe = Recipe
-  { recipeName :: Text
-  , recipeIngredients :: [Text]
-  , recipeDetail :: Text
-  , recipeCookTime :: Int -- ^ Cook time of the recipe in minutes
-  }
-
-pattern HomeRoute = (GET, []) -- ^ @[""]@ represents the trailing slash e.g. www.example.com/
-
-pattern QueryRecipesRoute = (GET, ["recipes"])
-
-pattern QuerySuccessRoute :: Int -> (Method, Path)
-pattern QuerySuccessRoute rID = (GET, ["recipes", "query", PathParam rID])
-
-pattern QueryFailureRoute = (GET, ["recipes", "query", "failure"])
-
-pattern PostRecipesRoute = (POST, ["recipes"])
-
-pattern PostSuccessRoute = (GET, ["recipes", "post", "success"])
-
-pattern PostFailureRoute = (GET, ["recipes", "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
-
-methodAndPath :: MonadOkapi m => m (Method, Path)
-methodAndPath = do
-  m <- method
-  p <- path
-  return (m, p)
-
-main :: IO ()
-main = run id $ route methodAndPath $ \case
-  HomeRoute -> do
-    let html =
-          [qq|
-            <h1>Recipes Home</h1>
-            <hr>
-            <h2>Query Recipes</h2>
-            <form {renderFormAttrs QueryRecipesRoute}>
-              ...
-            </form>
-            <hr>
-            <h2>Create New Recipes</h2>
-            <form {renderFormAttrs PostRecipesRoute}>
-              ...
-            </form>
-          |]
-    return $ setHTML html $ ok
-  QueryRecipesRoute -> do
-    return $ setJSON True $ ok
-  QueryFailureRoute -> undefined
-  QuerySuccessRoute rID -> undefined
-  PostRecipesRoute -> do
-    return $ setJSON True $ ok
-  PostSuccessRoute -> undefined
-  PostFailureRoute -> undefined
-  _ -> next
--- a/examples/twitter-clone/Main.hs
+++ b/examples/twitter-clone/Main.hs
@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = undefined
--- a/okapi.cabal
+++ b/okapi.cabal
@ -135,12 +135,12 @@ executable calculator2-exe
    , websockets
  default-language: Haskell2010

-executable recipe-exe
+executable car-dealership-exe
  main-is: Main.hs
  other-modules:
      Paths_okapi
  hs-source-dirs:
-      examples/recipe
+      examples/car-dealership
  ghc-options: -threaded -rtsopts -with-rtsopts=-N
  build-depends:
      aeson >=1.4.7
@ -161,6 +161,7 @@ executable recipe-exe
    , network
    , okapi
    , parser-combinators
+    , random
    , sqlite-simple
    , text
    , transformers
@ -365,6 +366,44 @@ executable todo3-exe
    , websockets
  default-language: Haskell2010

+executable twitter-clone-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_okapi
+  hs-source-dirs:
+      examples/twitter-clone
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      aeson >=1.4.7
+    , attoparsec
+    , base >=4.7 && <5
+    , base64
+    , bytestring
+    , containers
+    , cookie
+    , cryptonite
+    , extra
+    , http-api-data
+    , http-types
+    , memory
+    , mmorph
+    , mtl
+    , network
+    , okapi
+    , parser-combinators
+    , rel8
+    , text
+    , transformers
+    , unagi-chan
+    , vault
+    , wai
+    , wai-extra
+    , wai-websockets
+    , warp
+    , warp-tls
+    , websockets
+  default-language: Haskell2010
+
 test-suite okapi-test
  type: exitcode-stdio-1.0
  main-is: Spec.hs
--- a/package.yaml
+++ b/package.yaml
@ -122,9 +122,9 @@ executables:
    - text
    - bytestring
    - interpolatedstring-perl6
-  recipe-exe:
+  car-dealership-exe:
    main:                Main.hs
-    source-dirs:         examples/recipe
+    source-dirs:         examples/car-dealership
    ghc-options:
    - -threaded
    - -rtsopts
@ -135,6 +135,8 @@ executables:
    - text
    - bytestring
    - interpolatedstring-perl6
+    - parser-combinators
+    - random
  # chess-exe:
  #   main:                Main.hs
  #   source-dirs:         examples/chess
@ -193,6 +195,16 @@ executables:
    - -with-rtsopts=-N
    dependencies:
    - okapi
+  twitter-clone-exe:
+    main:                Main.hs
+    source-dirs:         examples/twitter-clone
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - okapi
+    - rel8

 tests:
  okapi-test:
--- a/src/Okapi.hs
+++ b/src/Okapi.hs
@ -377,6 +377,9 @@ instance Reader.MonadReader r m => Reader.MonadReader r (OkapiT m) where
      mapOkapiT f okapiT = OkapiT . Except.ExceptT . State.StateT $ f . State.runStateT (Except.runExceptT $ unOkapiT okapiT)
  reader = Morph.lift . Reader.reader

+instance IO.MonadIO m => IO.MonadIO (OkapiT m) where
+  liftIO = Morph.lift . IO.liftIO 
+
 instance Morph.MonadTrans OkapiT where
  lift :: Monad m => m a -> OkapiT m a
  lift action = OkapiT . Except.ExceptT . State.StateT $ \s -> do
@ -1158,8 +1161,12 @@ renderRelURL (RelURL path query) = case (path, query) of
  (p, q) -> renderPath p <> "?" <> renderQuery q

 renderPath :: Path -> Text.Text
-renderPath [] = ""
-renderPath (pathSeg : path) = "/" <> pathSeg <> renderPath path
+renderPath [] = "/"
+renderPath (pathSeg : path) = "/" <> pathSeg <> loop path
+  where
+    loop :: Path -> Text.Text
+    loop [] = ""
+    loop (pathSeg : path) = "/" <> pathSeg <> loop path

 renderQuery :: Query -> Text.Text
 renderQuery [] = ""