summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Application.hs1
-rw-r--r--Form/Fields/Point.hs8
-rw-r--r--Form/Shop.hs5
-rw-r--r--Handler/Shop.hs11
-rw-r--r--Handler/ShopEdit.hs6
-rw-r--r--Handler/ShopList.hs4
-rw-r--r--Handler/ShopPlaceList.hs17
-rw-r--r--Model.hs14
-rw-r--r--Widget/Shop.hs2
-rw-r--r--config/models1
-rw-r--r--config/routes1
-rw-r--r--mokupona.cabal1
-rw-r--r--static/images/mp-marker-icon-shop.pngbin0 -> 1701 bytes
-rw-r--r--templates/shop.cassius2
-rw-r--r--templates/shop.hamlet2
-rw-r--r--templates/shop.julius40
16 files changed, 101 insertions, 14 deletions
diff --git a/Application.hs b/Application.hs
index 635668c..91959d4 100644
--- a/Application.hs
+++ b/Application.hs
@@ -54,6 +54,7 @@ import Handler.Delivery
import Handler.DeliveryPlace
import Handler.ShopDelivery
import Handler.ShopDeliveryAdmin
+import Handler.ShopPlaceList
import Widget.Navbar
diff --git a/Form/Fields/Point.hs b/Form/Fields/Point.hs
index a7bda98..89dd103 100644
--- a/Form/Fields/Point.hs
+++ b/Form/Fields/Point.hs
@@ -20,7 +20,7 @@ $newline never
toWidget [julius|
L.Icon.Default.imagePath = '@{StaticR $ StaticRoute ["images"] []}';
-var initLoc#{rawJS theId} = document.getElementById(#{toJSON theId}).value || #{toLeaflet $ appMapDefaultPoint $ appSettings master};
+var initLoc#{rawJS theId} = L.latLng(document.getElementById(#{toJSON theId}).value) || #{toLeaflet $ appMapDefaultPoint $ appSettings master};
var map#{rawJS theId} = L.map("map#{rawJS theId}").setView(initLoc#{rawJS theId}, #{toJSON $ appMapDefaultZoom $ appSettings master});
@@ -53,7 +53,7 @@ function updateLocationDiv (lat, lon) {
, fieldEnctype = UrlEncoded
}
where
- showVal = either id (pack . show)
+ showVal = either id (pack . showPoint)
parsePoint [] _ = return $ Right Nothing
parsePoint (text:_) _ = return $ case readMayPoint $ unpack text of
@@ -113,3 +113,7 @@ parserDouble = rd <$> integer <++> decimal <++> exponent'
readMaybePoint :: String -> Maybe Point
readMaybePoint _ = Nothing
+
+showPoint :: Point -> String
+showPoint (Point lat lon Nothing) = show lat ++ ", " ++ show lon
+showPoint (Point lat lon (Just ele)) = show lat ++ ", " ++ show lon ++ ", " ++ show ele
diff --git a/Form/Shop.hs b/Form/Shop.hs
index bf8bf08..d324a07 100644
--- a/Form/Shop.hs
+++ b/Form/Shop.hs
@@ -2,12 +2,15 @@ module Form.Shop where
import Import
import Form.Fields.Image (selectImageField, bootstrapFileField)
+import Model.Point (Point)
+import Form.Fields.Point (pointField)
data FormShop = FormShop
{ fsIdent :: Text
, fsUserId :: UserId
, fiImageFromList :: Maybe ImageId
, fiImageNew :: Maybe FileInfo
+ , fsLocation :: Point
, fsDate :: UTCTime
}
@@ -21,6 +24,7 @@ shopFormUser userid mshop = renderBootstrap3 formLayout $ FormShop
<*> aopt (selectImageField images) (bfs MsgShopImage)
(shopImage <$> mshop)
<*> aopt bootstrapFileField (fieldSettingsLabel MsgShopImage) Nothing
+ <*> areq pointField (bfs MsgPlaceLocation) (shopLocation <$> mshop)
<*> lift (liftIO getCurrentTime)
where
images = do
@@ -50,6 +54,7 @@ shopFormAdmin meuser mshop = renderBootstrap3 formLayout $ FormShop
<*> aopt (selectImageField images) (bfs MsgShopImage)
(shopImage <$> mshop)
<*> aopt bootstrapFileField (fieldSettingsLabel MsgShopImage) Nothing
+ <*> areq pointField (bfs MsgPlaceLocation) (shopLocation <$> mshop)
<*> lift (liftIO getCurrentTime)
where
vendors = maybe vendorsEdit vendorsAdd meuser
diff --git a/Handler/Shop.hs b/Handler/Shop.hs
index 0f30f93..8f5aae6 100644
--- a/Handler/Shop.hs
+++ b/Handler/Shop.hs
@@ -1,7 +1,9 @@
module Handler.Shop where
import Import
-import Widget.Shop (shopPlaceDeliveryListWidget)
+import Widget.Shop (shopPlaceDeliveryListWidget)
+import Text.Julius (rawJS)
+import Model.Point (toLeaflet)
import qualified Database.Esqueleto as E
shopPlaceDeliveryList :: ShopId -> Handler [(Entity Place, [(Entity ShopDelivery, Entity Delivery)])]
@@ -34,11 +36,16 @@ getShopR shopid = do
user <- runDB $ get404 $ shopVendor shop
selectRep $ do
provideRep $ defaultLayout $ do
+ mapid <- newIdent
+ master <- getYesod
setUltDestCurrent
setTitle $ toHtml $ shopIdent shop
- $(widgetFile "shop")
addScript $ StaticR js_leaflet_js
addStylesheet $ StaticR css_leaflet_css
+ addScript $ StaticR js_leaflet_markercluster_js
+ addStylesheet $ StaticR css_MarkerCluster_css
+ addStylesheet $ StaticR css_MarkerCluster_Default_css
$(widgetFile "leaflet")
+ $(widgetFile "shop")
mapM_ shopPlaceDeliveryListWidget placedeliveries
provideJson (Entity shopid shop)
diff --git a/Handler/ShopEdit.hs b/Handler/ShopEdit.hs
index caec833..2f30b1d 100644
--- a/Handler/ShopEdit.hs
+++ b/Handler/ShopEdit.hs
@@ -13,6 +13,8 @@ getShopEditR shopid = maybeAuth >>= maybe
shop <- runDB $ get404 shopid
defaultLayout $ do
setTitleI $ MsgShopEditTitle $ shopIdent shop
+ addScript $ StaticR js_leaflet_js
+ addStylesheet $ StaticR css_leaflet_css
(shopWidget, enctype) <- handlerToWidget $ generateFormPost $ shopEditForm euser $ Just shop
$(widgetFile "shop-edit")
@@ -25,7 +27,7 @@ postShopEditR shopid = maybeAuth >>= maybe
oldshop <- runDB $ get404 shopid
((res, _), _) <- runFormPost $ shopEditForm euser $ Just oldshop
case res of
- FormSuccess (FormShop ident userid mimageid mfile date)
+ FormSuccess (FormShop ident userid mimageid mfile point date)
| ident == shopIdent oldshop -> replaceShop
| otherwise -> runDB (getBy $ UniqueShop ident)
>>= maybe replaceShop (const editShopAux)
@@ -36,7 +38,7 @@ postShopEditR shopid = maybeAuth >>= maybe
replaceShop = do
mimageid' <- getImageId mimageid mfile userid date
runDB $ replace shopid
- $ Shop ident userid mimageid' (shopCreated oldshop) date
+ $ Shop ident userid mimageid' point (shopCreated oldshop) date
setMessageILevel "alert-success"
$ MsgShopEditSuccess ident
redirectUltDest $ ShopAdminR shopid
diff --git a/Handler/ShopList.hs b/Handler/ShopList.hs
index ec7b1d3..fdff64b 100644
--- a/Handler/ShopList.hs
+++ b/Handler/ShopList.hs
@@ -22,13 +22,13 @@ postShopListHelper :: Entity User -> Handler TypedContent
postShopListHelper euser = do
((res, _), _) <- runFormPost $ shopAddForm euser
case res of
- FormSuccess (FormShop ident userid mimageid mfile date) ->
+ FormSuccess (FormShop ident userid mimageid mfile point date) ->
runDB (getBy $ UniqueShop ident)
>>= maybe addShop (const duplicateShop)
where
addShop = do
mimageid' <- getImageId mimageid mfile userid date
- shopid <- runDB $ insert $ Shop ident userid mimageid' date date
+ shopid <- runDB $ insert $ Shop ident userid mimageid' point date date
setMessageILevel "alert-success"
$ MsgShopAddSuccess ident
redirect $ ShopAdminR shopid
diff --git a/Handler/ShopPlaceList.hs b/Handler/ShopPlaceList.hs
new file mode 100644
index 0000000..5825578
--- /dev/null
+++ b/Handler/ShopPlaceList.hs
@@ -0,0 +1,17 @@
+module Handler.ShopPlaceList where
+
+import Import
+import qualified Database.Esqueleto as E
+
+getShopPlaceListR :: ShopId -> Handler TypedContent
+getShopPlaceListR shopid = do
+ places <- runDB $
+ E.selectDistinct $
+ E.from $ \(sd, d, p) -> do
+ E.where_ ( sd E.^. ShopDeliveryShop E.==. E.val shopid
+ E.&&. sd E.^. ShopDeliveryDelivery E.==. d E.^. DeliveryId
+ E.&&. d E.^. DeliveryPlace E.==. p E.^. PlaceId
+ )
+ E.orderBy [ E.desc (p E.^. PlaceIdent) ]
+ return p
+ selectRep $ provideJson places
diff --git a/Model.hs b/Model.hs
index 0339c59..ac38890 100644
--- a/Model.hs
+++ b/Model.hs
@@ -18,12 +18,13 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"]
instance ToJSON (Entity Shop) where
toJSON (Entity sid s) = object
- [ "id" .= (String $ toPathPiece sid)
- , "ident" .= (String $ shopIdent s)
- , "vendor" .= (String $ toPathPiece $ shopVendor s)
- , "image" .= maybe Null (String . toPathPiece) (shopImage s)
- , "created" .= shopCreated s
- , "updated" .= shopUpdated s
+ [ "id" .= (String $ toPathPiece sid)
+ , "ident" .= (String $ shopIdent s)
+ , "vendor" .= (String $ toPathPiece $ shopVendor s)
+ , "image" .= maybe Null (String . toPathPiece) (shopImage s)
+ , "location" .= [ toJSON $ pntLon $ shopLocation s, toJSON $ pntLat $ shopLocation s ]
+ , "created" .= shopCreated s
+ , "updated" .= shopUpdated s
]
instance FromJSON Shop where
@@ -31,6 +32,7 @@ instance FromJSON Shop where
<$> o .: "ident"
<*> o .: "vendor"
<*> o .:? "image"
+ <*> o .: "location"
<*> o .: "created"
<*> o .: "updated"
diff --git a/Widget/Shop.hs b/Widget/Shop.hs
index 8bc3ae1..cc4e144 100644
--- a/Widget/Shop.hs
+++ b/Widget/Shop.hs
@@ -9,6 +9,8 @@ shopAddWidget :: Entity User -> Widget
shopAddWidget euser = do
(shopWidget, enctype) <-
handlerToWidget $ generateFormPost $ shopAddForm euser
+ addScript $ StaticR js_leaflet_js
+ addStylesheet $ StaticR css_leaflet_css
$(widgetFile "shop-add")
shopPlaceDeliveryListWidget :: (Entity Place, [(Entity ShopDelivery, Entity Delivery)]) -> Widget
diff --git a/config/models b/config/models
index dbc40c7..9ed6b83 100644
--- a/config/models
+++ b/config/models
@@ -10,6 +10,7 @@ Shop
ident Text
vendor UserId
image ImageId Maybe
+ location Point
created UTCTime
updated UTCTime
UniqueShop ident
diff --git a/config/routes b/config/routes
index 6d3ba95..ca770c8 100644
--- a/config/routes
+++ b/config/routes
@@ -28,3 +28,4 @@
/shop/#ShopId/shopdelivery ShopShopDeliveryR POST
/shopdelivery/#ShopDeliveryId ShopDeliveryR GET
/shopdelivery/#ShopDeliveryId/admin ShopDeliveryAdminR GET POST
+/shop/#ShopId/place ShopPlaceListR GET
diff --git a/mokupona.cabal b/mokupona.cabal
index 18ff257..067ac87 100644
--- a/mokupona.cabal
+++ b/mokupona.cabal
@@ -59,6 +59,7 @@ library
Handler.ShopDelivery
Handler.ShopDeliveryAdmin
Handler.ItemFormCart
+ Handler.ShopPlaceList
Shop.Image.Functions
Form.Cart
Form.Delivery
diff --git a/static/images/mp-marker-icon-shop.png b/static/images/mp-marker-icon-shop.png
new file mode 100644
index 0000000..6b1295a
--- /dev/null
+++ b/static/images/mp-marker-icon-shop.png
Binary files differ
diff --git a/templates/shop.cassius b/templates/shop.cassius
new file mode 100644
index 0000000..65ca7b1
--- /dev/null
+++ b/templates/shop.cassius
@@ -0,0 +1,2 @@
+##{mapid}
+ height: 200px
diff --git a/templates/shop.hamlet b/templates/shop.hamlet
index 109af35..84b8973 100644
--- a/templates/shop.hamlet
+++ b/templates/shop.hamlet
@@ -18,3 +18,5 @@
<div .btn .btn-danger>
<span .glyphicon .glyphicon-cog>#
\ _{MsgShopAdmin}
+ <div .panel-body>
+ <div ##{mapid}>
diff --git a/templates/shop.julius b/templates/shop.julius
new file mode 100644
index 0000000..6208f92
--- /dev/null
+++ b/templates/shop.julius
@@ -0,0 +1,40 @@
+var map#{rawJS mapid} = L.map(#{toJSON mapid}).setView(#{toLeaflet $ shopLocation shop}, #{toJSON $ appMapDefaultZoom $ appSettings master});
+
+var clusterlayer#{rawJS mapid} = new L.MarkerClusterGroup();
+
+function importFeature (feature, layer) {
+ layer.bindPopup(feature.properties.ident);
+};
+
+function placePointToLayer (feature, latlng) {
+ return L.marker(latlng, {});
+};
+
+$.getJSON("@{ShopPlaceListR shopid}", function(data) {
+ var geojsonlayer#{rawJS mapid} = L.geoJson(data, {
+ pointToLayer: placePointToLayer,
+ onEachFeature: importFeature
+ });
+ clusterlayer#{rawJS mapid}.addLayer(geojsonlayer#{rawJS mapid});
+ map#{rawJS mapid}.addLayer(clusterlayer#{rawJS mapid})
+});
+
+// add an OpenStreetMap tile layer
+L.tileLayer(#{toJSON $ appMapTileUrl $ appSettings master}, {
+ attribution: #{toJSON $ appMapAttribution $ appSettings master},
+ minZoom: 2,
+ maxZoom: 20
+}).addTo(map#{rawJS mapid});
+
+var shopIcon#{rawJS mapid} = new L.Icon.Default({
+ iconUrl: '@{StaticR images_mp_marker_icon_shop_png}'
+});
+
+// add a marker in the given location, attach some popup content to it and open the popup
+L.marker(#{toLeaflet $ shopLocation shop}, {
+ icon: shopIcon#{rawJS mapid},
+ zIndexOffset: 1000
+})
+.addTo(map#{rawJS mapid})
+.bindPopup(#{toJSON $ shopIdent shop})
+.openPopup();