×
\#{msgr}
|]
isAdmin :: User -> Bool
isAdmin user = userEmail user == "gueux@capeo"
authShopVendor :: ShopId -> User -> HandlerT App IO AuthResult
authShopVendor shopId user
| isAdmin user = return Authorized
| otherwise = do
shop <- runDB $ get404 shopId
suser <- runDB $ get404 $ shopVendor shop
authEqual suser user
authShop :: ShopId -> HandlerT App IO AuthResult
authShop shopId = maybeAuth
>>= maybe (return AuthenticationRequired)
(authShopVendor shopId . entityVal)
authShopDelivery :: ShopDeliveryId -> HandlerT App IO AuthResult
authShopDelivery shopdeliveryid = maybeAuth
>>= maybe (return AuthenticationRequired)
authShopDeliveryAux
where
authShopDeliveryAux euser = do
shopdelivery <- runDB $ get404 shopdeliveryid
authShopVendor (shopDeliveryShop shopdelivery) $ entityVal euser
authEqual :: Eq a => a -> a -> HandlerT App IO AuthResult
authEqual a b
| a == b = return Authorized
| otherwise = unauthorizedI MsgNotAuthorized
authUserAux :: UserId -> Entity User -> HandlerT App IO AuthResult
authUserAux userId euser
| isAdmin user = return Authorized
| otherwise = authEqual userId key
where
Entity key user = euser
authUser :: UserId -> HandlerT App IO AuthResult
authUser userId = maybeAuth
>>= maybe (return AuthenticationRequired) (authUserAux userId)
authAuthentified :: HandlerT App IO AuthResult
authAuthentified = maybeAuthId
>>= maybe (return AuthenticationRequired) (const $ return Authorized)
authNotAuthentified :: HandlerT App IO AuthResult
authNotAuthentified = maybeAuthId
>>= maybe (return Authorized) (const $ unauthorizedI MsgLogoutFirst)
formLayout :: BootstrapFormLayout
formLayout = BootstrapHorizontalForm {
bflLabelOffset = ColSm 0
, bflLabelSize = ColSm 2
, bflInputOffset = ColSm 0
, bflInputSize = ColSm 8
}
quantityPrice :: Amount -> Quantity -> Amount
quantityPrice unitprice = (*) unitprice . toAmount
quantityItemPrice :: Item -> CartItem -> Amount
quantityItemPrice i = quantityPrice (itemPrice i) . cartItemQuantity
cartAmount' :: UserId -> HandlerT App IO Amount
cartAmount' userid = do
cart <- runDB $
E.select $
E.from $ \(i, si) -> do
E.where_ ( si E.^. CartItemCustomer E.==. E.val userid
E.&&. si E.^. CartItemItem E.==. i E.^. ItemId
)
return (i, si)
return $ foldr addCart (Amount 0) cart
where
addCart (ei, esi) = (+) $ quantityItemPrice (entityVal ei) (entityVal esi)
getCartId :: UserId -> HandlerT App IO CartId
getCartId userid = runDB (getBy $ UniqueCustomer userid)
>>= maybe (insertCart userid) (return . entityKey)
where
insertCart userid' = do
date <- liftIO getCurrentTime
runDB $ insert $ Cart userid' date date (Amount 0)
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the linked documentation for an
-- explanation for this split.
mkYesodData "App" $(parseRoutesFile "config/routes")
-- | A convenient synonym for creating forms.
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod App where
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
approot = ApprootMaster $ appRoot . appSettings
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
mr <- getMessageRender
let thumbnailHeight = PixelSize $ toRational $ appThumbnailHeight $ appSettings master
thumbnailWidth = PixelSize $ toRational $ appThumbnailWidth $ appSettings master
cartThumbnailHeight = PixelSize $ toRational $ appCartThumbnailHeight $ appSettings master
cartThumbnailWidth = PixelSize $ toRational $ appCartThumbnailWidth $ appSettings master
navbar = appNavbar master
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
pc <- widgetToPageContent $ do
$(combineStylesheets 'StaticR
[ css_bootstrap_css
])
$(combineScripts 'StaticR
[ js_jquery_min_js
, js_bootstrap_min_js
])
navbar
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- The page to be redirected to when authentication is required.
authRoute _ = Just LoginPanelR
-- Authorizations for various routes
isAuthorized HomeR _ = return Authorized
isAuthorized (ShopR _) _ = return Authorized
isAuthorized ShopListR True = authAuthentified
isAuthorized ShopListR False = return Authorized
isAuthorized (ShopAdminR shopid) _ = authShop shopid
isAuthorized (ShopEditR shopid) writeBool = isAuthorized (ShopAdminR shopid) writeBool
isAuthorized (ShopDeleteR shopid) writeBool = isAuthorized (ShopEditR shopid) writeBool
isAuthorized (ItemEditR itemId) writeBool = do
item <- runDB $ get404 itemId
shopdelivery <- runDB $ get404 $ itemShopdelivery item
isAuthorized (ShopAdminR $ shopDeliveryShop shopdelivery) writeBool
isAuthorized (ItemDeleteR itemid) writeBool = isAuthorized (ItemEditR itemid) writeBool
isAuthorized (ImageR _) _ = return Authorized
isAuthorized (ImageListR userid) _ = authUser userid
isAuthorized (ImageDeleteR userid _) writeBool = isAuthorized (ImageListR userid) writeBool
isAuthorized CartR _ = authAuthentified
isAuthorized (CartItemR _) _ = authAuthentified
isAuthorized (CartItemEditR _) _ = authAuthentified
isAuthorized (CartItemDeleteR _) _ = authAuthentified
isAuthorized LoginPanelR _ = authNotAuthentified
isAuthorized PlaceListR True = authAuthentified
isAuthorized PlaceListR False = return Authorized
isAuthorized (PlaceR _) _ = return Authorized
isAuthorized DeliveryListR True = authAuthentified
isAuthorized DeliveryListR False = return Authorized
isAuthorized (DeliveryR _) _ = return Authorized
isAuthorized (DeliveryPlaceR _) _ = authAuthentified
isAuthorized (ShopShopDeliveryR shopid) _ = authShop shopid
isAuthorized (ShopDeliveryR _) _ = return Authorized
isAuthorized (ShopDeliveryAdminR shopdeliveryid) _ = authShopDelivery shopdeliveryid
isAuthorized (ShopPlaceListR _) _ = return Authorized
isAuthorized (UserR userid) _ = authUser userid
isAuthorized (StaticR _) _ = return Authorized
isAuthorized (AuthR LogoutR) _ = authAuthentified
isAuthorized (AuthR LoginR) _ = authNotAuthentified
isAuthorized (AuthR (PluginR "email" ["register"])) _ = authNotAuthentified
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLog app _source level =
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger = return . appLogger
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlBackend
runDB action = do
master <- getYesod
runSqlPool action $ appConnPool master
instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner appConnPool
instance YesodAuth App where
type AuthId App = UserId
-- Where to send a user after successful login
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest _ = HomeR
-- Override the above two destinations when a Referer: header is present
redirectToReferer _ = True
-- getAuthId creds = runDB $ do
-- x <- getBy $ UniqueUser $ credsIdent creds
-- case x of
-- Just (Entity uid _) -> return $ Just uid
-- Nothing -> Just <$> insert User
-- { userIdent = credsIdent creds
-- , userPassword = Nothing
-- }
-- Need to find the UserId for the given email address.
getAuthId creds = do
date <- liftIO getCurrentTime
x <- runDB $ insertBy $ User (credsIdent creds) Nothing Nothing False date
return $ Just $
case x of
Left (Entity userid _) -> userid -- newly added user
Right userid -> userid -- existing user
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authEmail]
authHttpManager = getHttpManager
onLogin = setMessageILevel "alert-info" MsgNowLoggedIn
onLogout = setMessageILevel "alert-info" MsgNowLoggedOut
instance YesodAuthPersist App
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
instance YesodAuthEmail App where
type AuthEmailId App = UserId
addUnverified email verkey = do
date <- liftIO getCurrentTime
runDB $ insert $ User email Nothing (Just verkey) False date
sendVerifyEmail email _ verurl = do
messageRender <- getMessageRender
let plainPart' = plainPart [stext|#{messageRender MsgVerifyEmailIntro}
#{verurl}
#{messageRender MsgVerifyEmailOutro}
|]
let htmlPart' = Part {
partType = "text/html; charset=utf-8"
, partEncoding = None
, partFilename = Nothing
, partHeaders = []
, partContent = renderHtml
[shamlet|
#{messageRender MsgVerifyEmailIntro}
#{verurl}
#{messageRender MsgVerifyEmailOutro}
|]
}
liftIO $ renderSendMail (emptyMail $ Address Nothing "noreply")
{ mailTo = [Address Nothing email]
, mailHeaders =
[ ("Subject", messageRender MsgVerifyEmailSubject)
]
, mailParts = [[plainPart', htmlPart']]
}
getVerifyKey = runDB . fmap (join . fmap userVerkey) . get
setVerifyKey uid key = runDB $ update uid [UserVerkey =. Just key]
verifyAccount uid = runDB $ do
mu <- get uid
case mu of
Nothing -> return Nothing
Just _ -> do
update uid [UserVerified =. True]
return $ Just uid
getPassword = runDB . fmap (join . fmap userPassword) . get
setPassword uid pass = runDB $ update uid [UserPassword =. Just pass]
getEmailCreds email = runDB $ do
mu <- getBy $ UniqueUser email
case mu of
Nothing -> return Nothing
Just (Entity uid u) -> return $ Just EmailCreds
{ emailCredsId = uid
, emailCredsAuthId = Just uid
, emailCredsStatus = isJust $ userPassword u
, emailCredsVerkey = userVerkey u
, emailCredsEmail = userEmail u
}
getEmail = runDB . fmap (fmap userEmail) . get
afterPasswordRoute _ = HomeR
registerHandler = do
email <- newIdent
lift $ authLayout $ do
setTitleI AuthMsg.RegisterLong
$(widgetFile "register")
confirmationEmailSentResponse identifier = do
mr <- getMessageRender
selectRep $ do
provideJsonMessage (mr msg)
provideRep $ authLayout $ do
setTitleI AuthMsg.ConfirmationEmailSentTitle
setMessageILevel "alert-info" msg
redirectUltDest HomeR
where
msg = AuthMsg.ConfirmationEmailSent identifier