summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Application.hs1
-rw-r--r--Handler/ItemEdit.hs6
-rw-r--r--Handler/Order.hs146
-rw-r--r--Handler/Shop.hs14
-rw-r--r--Handler/ShopAdmin.hs6
-rw-r--r--Model.hs1
-rw-r--r--Money/Fields.hs20
-rw-r--r--Money/Types.hs37
-rw-r--r--config/models8
-rw-r--r--config/routes1
-rw-r--r--messages/en.msg5
-rw-r--r--mokupona.cabal3
-rw-r--r--templates/order-add.hamlet7
-rw-r--r--templates/shop-admin.hamlet5
-rw-r--r--templates/shop.cassius3
-rw-r--r--templates/shop.hamlet41
-rw-r--r--templates/shop.julius26
17 files changed, 313 insertions, 17 deletions
diff --git a/Application.hs b/Application.hs
index 96a3b59..1f82e8c 100644
--- a/Application.hs
+++ b/Application.hs
@@ -38,6 +38,7 @@ import Handler.ItemDelete
import Handler.Image
import Handler.ImageList
import Handler.ImageDelete
+import Handler.Order
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
diff --git a/Handler/ItemEdit.hs b/Handler/ItemEdit.hs
index c7a3336..cd6c072 100644
--- a/Handler/ItemEdit.hs
+++ b/Handler/ItemEdit.hs
@@ -3,14 +3,16 @@ module Handler.ItemEdit where
import Import
import Image.Field
import Unit
+import Money.Fields
+import Money.Types
-itemEditForm :: Maybe Item -> ShopId -> Html -> MForm Handler (FormResult (Text, ShopId, Int, Unit, Double, Int, Maybe ImageId), Widget)
+itemEditForm :: Maybe Item -> ShopId -> Html -> MForm Handler (FormResult (Text, ShopId, Int, Unit, Amount, Int, Maybe ImageId), Widget)
itemEditForm mitem shopid = renderBootstrap $ (,,,,,,)
<$> areq textField (fieldSettingsLabel MsgItemIdent) (itemIdent <$> mitem)
<*> pure shopid
<*> areq intField (fieldSettingsLabel MsgItemQuantity) (itemQuantity <$> mitem)
<*> areq (selectFieldList units) (fieldSettingsLabel MsgItemUnit) (itemUnit <$> mitem)
- <*> areq doubleField (fieldSettingsLabel MsgItemPrice) (itemPrice <$> mitem)
+ <*> areq amountField (fieldSettingsLabel MsgItemPrice) (itemPrice <$> mitem)
<*> areq intField (fieldSettingsLabel MsgItemStock) (itemStock <$> mitem)
<*> aopt (selectImageField images) (fieldSettingsLabel MsgItemImage) (itemImage <$> mitem)
where
diff --git a/Handler/Order.hs b/Handler/Order.hs
new file mode 100644
index 0000000..c189ec4
--- /dev/null
+++ b/Handler/Order.hs
@@ -0,0 +1,146 @@
+module Handler.Order where
+
+import Import
+import qualified Data.Text.Read
+import Control.Monad (liftM)
+
+quantityIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i
+quantityIntField = Field
+ { fieldParse = parseHelper $ \s ->
+ case Data.Text.Read.signed Data.Text.Read.decimal s of
+ Right (a, "") -> Right a
+ _ -> Left $ MsgInvalidInteger s
+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
+<div class="input-group">
+ <span class="input-group-btn">
+ <button type="button" class="btn btn-success increase-button">
+ <span class="glyphicon glyphicon-plus">
+ <input class="increase-decrease-input form-control" id="#{theId}" name="#{name}" *{attrs} type="text" step=1 :isReq:required="" value="#{showVal val}">
+ <span class="input-group-btn">
+ <button type="button" class="btn btn-danger decrease-button">
+ <span class="glyphicon glyphicon-minus">
+|]
+ , fieldEnctype = UrlEncoded
+ }
+ where
+ showVal = either id (pack . showI)
+ showI x = show (fromIntegral x :: Integer)
+
+-- | Render a form using Bootstrap-friendly shamlet syntax.
+--
+-- Sample Hamlet:
+--
+-- > <form .form-horizontal method=post action=@{ActionR} enctype=#{formEnctype}>
+-- > <fieldset>
+-- > <legend>_{MsgLegend}
+-- > $case result
+-- > $of FormFailure reasons
+-- > $forall reason <- reasons
+-- > <div .alert .alert-error>#{reason}
+-- > $of _
+-- > ^{formWidget}
+-- > <div .form-actions>
+-- > <input .btn .primary type=submit value=_{MsgSubmit}>
+renderOrderBootstrap :: ItemId -> FormRender (HandlerT App IO) a
+renderOrderBootstrap itemid aform fragment = do
+ (res, views') <- aFormToForm aform
+ let views = views' []
+ has (Just _) = True
+ has Nothing = False
+ let widget = do
+ mr <- getMessageRender
+ item <- handlerToWidget $ runDB $ get404 itemid
+ [whamlet|
+$newline never
+\#{fragment}
+<div class="form-group col-md-2 col-sd-3 col-xs-5 order-image">
+ $maybe imageid <- itemImage item
+ <img class="img-thumbnail" alt="#{itemIdent item}" src="@{ImageR imageid}" />
+ $nothing
+ <div class="img-thumbnail">
+ <span class="glyphicon glyphicon-camera">
+<div class="row">
+ <div class="form-group col-md-2 col-sd-2 col-xs-3 item-title">
+ #{itemIdent item}
+ <div class="form-group col-lg-2 col-md-2 col-sd-2 col-xs-4 order-quantity">
+ $forall view <- views
+ <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>
+ <label .control-label for=#{fvId view}>#{fvLabel view}
+ <div .controls .input>
+ ^{fvInput view}
+ $maybe tt <- fvTooltip view
+ <span .help-block>#{tt}
+ $maybe err <- fvErrors view
+ <span .help-block>#{err}
+ <div class="form-group col-md-2 col-sd-2 col-xs-3 order-price">
+ <span class="order-price-price">
+ #{itemPrice item}
+ <span class="order-price-currency">
+ #{mr MsgCurrency}
+ <span class="order-unit-quantity">
+ \ (#{itemQuantity item}#{itemUnit item})
+ <div class="form-group col-md-2 col-sd-2 col-xs-2 order-stock">
+ #{itemStock item}
+ <div class="order-button col-lg-2 col-md-2 col-sd-2 col-xs-3">
+ <button type=submit class="btn btn-lg btn-warning">
+ <span class="glyphicon glyphicon-shopping-cart">
+ \ #{mr MsgOrderItem}
+|]
+ return (res, widget)
+
+orderItemForm :: ItemId -> UserId -> Html -> MForm Handler (FormResult ShoppingCartItem, Widget)
+orderItemForm itemid userid = renderOrderBootstrap itemid $ ShoppingCartItem
+ <$> pure itemid
+ <*> areq quantityField (fieldSettingsLabel MsgItemQuantity) (Just 1)
+ <*> pure userid
+ <*> lift (liftIO getCurrentTime)
+ where
+ quantityField = checkM isAvailable quantityIntField
+ isAvailable q = liftM (testQuantity q) $ runDB $ get404 itemid
+ testQuantity q item
+ | q > itemStock item = Left $ MsgAvailableQuantityInsufficient $ itemStock item
+ | 0 < q && q <= itemStock item = Right q
+ | otherwise = Left MsgInvalidQuantity
+
+getOrderR :: ItemId -> Handler Html
+getOrderR itemid = do
+ item <- runDB $ get404 itemid
+ mauth <- maybeAuth
+ defaultLayout $
+ case mauth of
+ Nothing -> permissionDeniedI MsgNotAuthorized
+ Just euser -> do
+ (orderWidget, enctype) <- handlerToWidget $ generateFormPost $ orderItemForm itemid key
+ $(widgetFile "order-add")
+ where
+ Entity key _ = euser
+
+postOrderR :: ItemId -> Handler Html
+postOrderR itemid = do
+ mauth <- maybeAuth
+ case mauth of
+ Nothing -> permissionDeniedI MsgNotAuthorized
+ Just euser -> do
+ ((res, _), _) <- runFormPost $ orderItemForm itemid key
+ case res of
+ FormSuccess (ShoppingCartItem _ quantity userid date) -> do
+ morderitem <- runDB $ selectFirst [ShoppingCartItemItem ==. itemid, ShoppingCartItemCustomer ==. userid] []
+ item <- runDB $ get404 itemid
+ runDB $ update itemid [ItemStock -=. quantity]
+ case morderitem of
+ Nothing -> do
+ _ <- runDB $ insert $ ShoppingCartItem itemid quantity userid date
+ setMessageILevel "alert-success" $ MsgShoppingCartItemAddSuccess $ itemIdent item
+ Just eorderitem -> do
+ runDB $ update keyorderitem [ShoppingCartItemQuantity +=. quantity]
+ setMessageILevel "alert-success" $ MsgShoppingCartItemUpdateSuccess $ itemIdent item
+ where
+ Entity keyorderitem _ = eorderitem
+ redirectUltDest ShopListR
+ _ -> do
+ setMessageILevel "alert-danger" MsgPleaseCorrect
+ setUltDestReferer
+ redirectUltDest ShopListR
+ where
+ Entity key _ = euser
diff --git a/Handler/Shop.hs b/Handler/Shop.hs
index a4dd4ce..da38039 100644
--- a/Handler/Shop.hs
+++ b/Handler/Shop.hs
@@ -1,6 +1,18 @@
module Handler.Shop where
import Import
+import Handler.Order
+
+multiForm :: [Entity Item] -> Maybe (Entity User) -> WidgetT App IO (Maybe [(Key Item, Widget, Enctype)])
+multiForm _ Nothing = return Nothing
+multiForm items (Just (Entity key _)) = Just <$> mapM (itemForm key) items
+
+itemForm :: UserId -> Entity Item -> WidgetT App IO (Key Item, Widget, Enctype)
+itemForm userid item = do
+ (orderWidget, enctype) <- handlerToWidget $ generateFormPost $ orderItemForm itemid userid
+ return (itemid, orderWidget, enctype)
+ where
+ Entity itemid _ = item
getShopR :: ShopId -> Handler Html
getShopR shopId = do
@@ -9,5 +21,7 @@ getShopR shopId = do
user <- runDB $ get404 $ shopVendor shop
mauth <- maybeAuth
defaultLayout $ do
+ setUltDestCurrent
+ mforms <- multiForm items mauth
setTitle $ toHtml $ shopIdent shop
$(widgetFile "shop")
diff --git a/Handler/ShopAdmin.hs b/Handler/ShopAdmin.hs
index 2d285fd..fb4b454 100644
--- a/Handler/ShopAdmin.hs
+++ b/Handler/ShopAdmin.hs
@@ -3,14 +3,16 @@ module Handler.ShopAdmin where
import Import
import Image.Upload
import Unit
+import Money.Fields
+import Money.Types
-itemAddForm :: Maybe Item -> ShopId -> Html -> MForm Handler (FormResult (Text, ShopId, Int, Unit, Double, Int, Maybe FileInfo, UTCTime), Widget)
+itemAddForm :: Maybe Item -> ShopId -> Html -> MForm Handler (FormResult (Text, ShopId, Int, Unit, Amount, Int, Maybe FileInfo, UTCTime), Widget)
itemAddForm mitem shopid = renderBootstrap $ (,,,,,,,)
<$> areq textField (fieldSettingsLabel MsgItemIdent) (itemIdent <$> mitem)
<*> pure shopid
<*> areq intField (fieldSettingsLabel MsgItemQuantity) (itemQuantity <$> mitem)
<*> areq (selectFieldList units) (fieldSettingsLabel MsgItemUnit) (itemUnit <$> mitem)
- <*> areq doubleField (fieldSettingsLabel MsgItemPrice) (itemPrice <$> mitem)
+ <*> areq amountField (fieldSettingsLabel MsgItemPrice) (itemPrice <$> mitem)
<*> areq intField (fieldSettingsLabel MsgItemStock) (itemStock <$> mitem)
<*> aopt fileField (fieldSettingsLabel MsgItemImage) Nothing
<*> lift (liftIO getCurrentTime)
diff --git a/Model.hs b/Model.hs
index fe4e5b6..9762e5e 100644
--- a/Model.hs
+++ b/Model.hs
@@ -7,6 +7,7 @@ import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Data.Time (UTCTime)
import Unit
+import Money.Types (Amount)
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
diff --git a/Money/Fields.hs b/Money/Fields.hs
new file mode 100644
index 0000000..5bb6f80
--- /dev/null
+++ b/Money/Fields.hs
@@ -0,0 +1,20 @@
+module Money.Fields where
+
+import Import
+import Money.Types
+import qualified Data.Text.Read
+
+amountField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Amount
+amountField = Field
+ { fieldParse = parseHelper $ \s ->
+ case Data.Text.Read.double s of
+ Right (a, "") -> Right $ Amount a
+ _ -> Left $ MsgInvalidNumber s
+
+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
+<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
+|]
+ , fieldEnctype = UrlEncoded
+ }
+ where showVal = either id (pack . show)
diff --git a/Money/Types.hs b/Money/Types.hs
new file mode 100644
index 0000000..25be7d8
--- /dev/null
+++ b/Money/Types.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Money.Types where
+
+import Prelude
+import Text.Printf
+import Database.Persist.TH
+import Text.Blaze (ToMarkup, toMarkup)
+import Text.Blaze.Internal (string)
+
+data Amount = Amount {
+ amount :: Double
+ } deriving Eq
+derivePersistField "Amount"
+
+instance Show Amount where
+ show (Amount x) = printf "%0.2f" x
+
+instance Read Amount where
+ readsPrec _ value =
+ let [(parsed, garbage)] = reads value :: [(Double, String)] in
+ [(Amount (roundAmount parsed), garbage)]
+ where
+ roundAmount :: Double -> Double
+ roundAmount v = fromIntegral (round $ v * 100) / 100
+
+
+instance ToMarkup Amount where
+ toMarkup = string . show
+
+instance Num Amount where
+ (Amount x) + (Amount y) = Amount $ x + y
+ (Amount x) - (Amount y) = Amount $ x - y
+ (Amount x) * (Amount y) = Amount $ x * y
+ negate (Amount x) = Amount $ negate x
+ abs (Amount x) = Amount $ abs x
+ signum (Amount x) = Amount $ signum x
+ fromInteger x = Amount $ fromInteger x
diff --git a/config/models b/config/models
index e5417aa..ef3f3f8 100644
--- a/config/models
+++ b/config/models
@@ -21,10 +21,16 @@ Item
shop ShopId
quantity Int default=1
unit Unit default=Unit
- price Double default=0
+ price Amount default=0
stock Int default=0
image ImageId Maybe
date UTCTime
--image String Maybe
UniqueShopItem shop ident
+ShoppingCartItem
+ item ItemId
+ quantity Int
+ customer UserId
+ date UTCTime
+ UniqueOrderItem customer item
-- By default this file is used in Model.hs (which is imported by Foundation.hs)
diff --git a/config/routes b/config/routes
index cf24e21..eb3a54e 100644
--- a/config/routes
+++ b/config/routes
@@ -15,3 +15,4 @@
/media/#ImageId ImageR GET
/media/user/#UserId ImageListR GET POST
/media/#UserId/#ImageId/delete ImageDeleteR GET POST
+/order/#ItemId OrderR GET POST
diff --git a/messages/en.msg b/messages/en.msg
index 6b62964..bf1f9fe 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -82,3 +82,8 @@ UnitUnit: Unit
UnitGram: Gram
UnitLitre: Litre
Currency: €
+OrderItem: Order
+ShoppingCartItemAddSuccess item@Text: Item #{showText item} successfully added to your shopping cart.
+ShoppingCartItemUpdateSuccess item@Text: Shopping cart succesfully updated: #{showText item}.
+AvailableQuantityInsufficient quantity@Int: Available quantity: #{show quantity}
+InvalidQuantity: Invalid quantity
diff --git a/mokupona.cabal b/mokupona.cabal
index e134108..2c48dc1 100644
--- a/mokupona.cabal
+++ b/mokupona.cabal
@@ -30,9 +30,12 @@ library
Handler.Image
Handler.ImageList
Handler.ImageDelete
+ Handler.Order
Image.Upload
Image.Field
Unit
+ Money.Types
+ Money.Fields
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT
diff --git a/templates/order-add.hamlet b/templates/order-add.hamlet
new file mode 100644
index 0000000..84578b9
--- /dev/null
+++ b/templates/order-add.hamlet
@@ -0,0 +1,7 @@
+<div class="panel panel-default">
+ <div class="panel-heading">
+ <h3 class="panel-title">_{MsgItemAdd}
+ <div class="panel-body">
+ <form method="post" role="form" class="form-inline" enctype=#{enctype}>
+ ^{orderWidget}
+ <button type=submit class="btn btn-primary">_{MsgItemAddSubmit}
diff --git a/templates/shop-admin.hamlet b/templates/shop-admin.hamlet
index f5e6a52..9f009d6 100644
--- a/templates/shop-admin.hamlet
+++ b/templates/shop-admin.hamlet
@@ -21,6 +21,7 @@
<table class="table">
<thead>
<tr>
+ <th>_{MsgItemImage}
<th>_{MsgItemIdent}
<th>_{MsgItemUnitQuantity}
<th>_{MsgItemPrice}
@@ -35,8 +36,8 @@
$nothing
<div class="img-thumbnail">
<span class="glyphicon glyphicon-camera">
- <div class="item-title">
- #{itemIdent item}
+ <td>
+ #{itemIdent item}
<td>
#{itemQuantity item}#{itemUnit item}
<td>
diff --git a/templates/shop.cassius b/templates/shop.cassius
new file mode 100644
index 0000000..4ac83c9
--- /dev/null
+++ b/templates/shop.cassius
@@ -0,0 +1,3 @@
+.order-quantity
+ min-width:160px
+ width:160px
diff --git a/templates/shop.hamlet b/templates/shop.hamlet
index 949fc7e..69d401b 100644
--- a/templates/shop.hamlet
+++ b/templates/shop.hamlet
@@ -16,13 +16,34 @@
#{shopIdent shop}
<small>
#{userEmail user}
- <div class="panel-body">
- <div class="row">
- $forall Entity _ item <- items
- <div class="col-md-2 col-sm-3 col-xs-4">
- <a href="#" class="btn img-popover" data-toggle="popover" title="#{itemIdent item}">
- $maybe imageid <- itemImage item
- <img class="img-thumbnail" alt="#{itemIdent item}" src="@{ImageR imageid}" />
- $nothing
- <div class="img-thumbnail">
- <span class="glyphicon glyphicon-camera">
+ $maybe forms <- mforms
+ <div class="panel-body">
+ $forall (itemid, orderWidget, enctype) <- forms
+ <form class="form-inline row" method=post action=@{OrderR itemid} enctype=#{enctype}>
+ ^{orderWidget}
+ $nothing
+ <table class="table">
+ <thead>
+ <tr>
+ <th>_{MsgItemImage}
+ <th>_{MsgItemIdent}
+ <th>_{MsgItemUnitQuantity}
+ <th>_{MsgItemPrice}
+ <th>_{MsgItemStock}
+ <tbody>
+ $forall Entity _ item <- items
+ <tr>
+ <td>
+ $maybe imageid <- itemImage item
+ <img class="img-thumbnail" alt="#{itemIdent item}" src="@{ImageR imageid}" />
+ $nothing
+ <div class="img-thumbnail">
+ <span class="glyphicon glyphicon-camera">
+ <td>
+ #{itemIdent item}
+ <td>
+ #{itemQuantity item}#{itemUnit item}
+ <td>
+ #{itemPrice item}_{MsgCurrency}
+ <td>
+ #{itemStock item}
diff --git a/templates/shop.julius b/templates/shop.julius
new file mode 100644
index 0000000..5066c95
--- /dev/null
+++ b/templates/shop.julius
@@ -0,0 +1,26 @@
+$(".increase-button").each(function(index){
+ $(this).on("click", function(){
+ var input = $(this).closest(':has(.increase-decrease-input)').find('.increase-decrease-input');
+ var stock = parseInt($(this).closest(':has(.order-stock)').find('.order-stock').html());
+ var newVal = parseInt(input.val()) + 1;
+ if (isNaN(newVal)) {
+ newVal = 1;
+ };
+ if (newVal <= stock) {
+ input.val(newVal);
+ };
+ });
+});
+
+$(".decrease-button").each(function(index){
+ $(this).on("click", function(){
+ var input = $(this).closest(':has(.increase-decrease-input)').find('.increase-decrease-input');
+ var newVal = parseInt(input.val()) - 1;
+ if (isNaN(newVal)) {
+ newVal = 1;
+ };
+ if (newVal > 0) {
+ input.val(newVal);
+ };
+ });
+});