yammat/Handler/Common.hs

254 lines
8.6 KiB
Haskell
Raw Normal View History

2015-08-09 19:16:33 +00:00
-- yammat - Yet Another MateMAT
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-04-04 04:46:33 +00:00
-- | Common handler functions.
module Handler.Common where
import Data.FileEmbed (embedFile)
2015-10-22 21:57:27 +00:00
import Yesod.Form.Bootstrap3
2015-04-04 04:46:33 +00:00
import qualified Data.Text as T
2016-01-21 21:19:41 +00:00
import qualified Data.Text.Lazy as TL
2015-07-21 07:14:38 +00:00
import qualified Data.List as L
2015-04-04 04:46:33 +00:00
import qualified Data.Text.Lazy.Encoding as E
import qualified Data.Text.Read as R
2015-07-21 07:14:38 +00:00
import Data.Maybe
import qualified Data.Char as C
2015-04-04 04:46:33 +00:00
import Yesod.Form.Functions
import Text.Shakespeare.Text
import Network.Mail.Mime
import Import
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
2017-06-03 00:37:22 +00:00
getFaviconR = do
cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $ TypedContent "image/x-icon"
$ toContent $(embedFile "config/favicon.ico")
2015-04-04 04:46:33 +00:00
getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain
2015-09-14 22:49:13 +00:00
$ toContent $(embedFile "config/robots.txt")
2015-04-04 04:46:33 +00:00
2016-01-21 21:19:41 +00:00
msgToBSSubmit :: AppMessage -> BootstrapSubmit AppMessage
2015-10-22 21:57:27 +00:00
msgToBSSubmit t = BootstrapSubmit
{ bsValue = t
, bsClasses = "btn-default"
, bsAttrs = []
}
2015-07-21 07:14:38 +00:00
removeItem :: Eq a => a -> [a] -> [a]
removeItem _ [] = []
removeItem x (y:ys)
2015-09-14 22:49:13 +00:00
| x == y = removeItem x ys
2015-07-21 07:14:38 +00:00
| otherwise = y : (removeItem x ys)
2015-04-04 04:46:33 +00:00
updateCashier :: Int -> Text -> Handler ()
updateCashier amount desc = do
2015-04-10 12:50:44 +00:00
mCashier <- runDB $ selectFirst [] [Desc CashierId]
2015-09-14 22:49:13 +00:00
trans <- liftIO $ (return . Transaction desc amount) =<< getCurrentTime
2015-04-04 04:46:33 +00:00
case mCashier of
Just entCash -> do
runDB $ update (entityKey entCash) [CashierBalance +=. amount]
runDB $ insert_ trans
Nothing -> do
currentTime <- liftIO getCurrentTime
runDB $ insert_ $ Cashier amount currentTime
2015-04-04 04:46:33 +00:00
runDB $ insert_ trans
getCashierBalance :: Handler Int
getCashierBalance = do
2015-04-10 12:50:44 +00:00
mCashier <- runDB $ selectFirst [] [Desc CashierId]
2015-04-04 04:46:33 +00:00
case mCashier of
2015-09-14 22:49:13 +00:00
Just cashier ->
2015-04-04 04:46:33 +00:00
return $ cashierBalance $ entityVal cashier
2015-09-14 22:49:13 +00:00
Nothing ->
return 0
2015-04-04 04:46:33 +00:00
currencyField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a
currencyField = Field
{ fieldParse = parseHelper $ \rawVals ->
case R.double (prependZero rawVals) of
2015-10-12 14:34:03 +00:00
Right (a, "") -> Right $ floor $ (100 * a) + 0.5
2015-04-04 04:46:33 +00:00
_ -> Left $ MsgInvalidNumber rawVals
, fieldView = \theId name attr val req -> toWidget [hamlet|$newline never
<input id=#{theId} name=#{name} *{attr} type="number" step=0.01 min=0 :req:required="required" value=#{showVal val}>
2015-04-04 04:46:33 +00:00
|]
, fieldEnctype = UrlEncoded
}
where
showVal = either id (pack . showA)
showA x = show ((fromIntegral x :: Double) / 100)
2015-05-03 16:01:30 +00:00
volumeField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a
volumeField = Field
{ fieldParse = parseHelper $ \rawVals ->
case R.double (prependZero rawVals) of
Right (a, "") -> Right $ floor $ 1000 * a
_ -> Left $ MsgInvalidNumber rawVals
, fieldView = \theId name attr val req -> toWidget [hamlet|$newline never
<input id=#{theId} name=#{name} *{attr} type="number" step=0.01 min=0 :req:required="required" value=#{showVal val}>
|]
, fieldEnctype = UrlEncoded
}
where
showVal = either id (pack . showA)
showA x = show ((fromIntegral x :: Double) / 1000)
2016-01-21 21:19:41 +00:00
barcodeField :: (RenderMessage (HandlerSite m) FormMessage, Monad m) => Field m [Text]
2015-07-21 07:14:38 +00:00
barcodeField = Field
{ fieldParse = parseHelper $ Right . removeItem "" . L.nub . T.splitOn ", "
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|$newline never
<input type="text" id="#{theId}" name="#{name}" :isReq:required="" *{attrs} value="#{either id (T.intercalate ", ") val}">
|]
, fieldEnctype = UrlEncoded
}
handleBarcodes :: Either UserId BeverageId -> [Text] -> Handler ()
handleBarcodes (Left uId) nbs = do
raws <- runDB $ selectList [BarcodeUser ==. Just uId] []
2015-09-14 22:49:13 +00:00
let obs = map (barcodeCode . entityVal) raws
let toDel = obs L.\\ nbs
let toAdd = nbs L.\\ obs
mapM_ (\b -> runDB $ insert_ $ Barcode
b
True
(Just uId)
Nothing
) toAdd
ents <- mapM (runDB . getBy . UniqueBarcode) toDel
mapM_ (runDB . delete . entityKey . fromJust) ents
2015-07-21 07:14:38 +00:00
handleBarcodes (Right bId) nbs = do
raws <- runDB $ selectList [BarcodeBev ==. Just bId] []
2015-09-14 22:49:13 +00:00
let obs = map (barcodeCode . entityVal) raws
let toDel = obs L.\\ nbs
let toAdd = nbs L.\\ obs
mapM_ (\b -> runDB $ insert_ $ Barcode
b
False
Nothing
(Just bId)
) toAdd
ents <- mapM (runDB . getBy . UniqueBarcode) toDel
mapM_ (runDB . delete . entityKey . fromJust) ents
2015-07-21 07:14:38 +00:00
handleGetParam :: Maybe Text -> Either UserId BeverageId -> Handler ()
handleGetParam Nothing _ =
return ()
handleGetParam (Just b) eub = do
f <- return $ T.filter C.isAlphaNum b
2015-09-14 22:49:13 +00:00
if T.length f > 0 && b /= ", "
then do
e <- runDB $ getBy $ UniqueBarcode f
2015-09-14 22:49:13 +00:00
if isNothing e
then do
_ <- case eub of
Left uId -> do
-- should usernames containing, among other, spaces cause problems, replace b for f here
runDB $ insert_ $ Barcode b True (Just uId) Nothing
Right bId -> do
-- and here
runDB $ insert_ $ Barcode b False Nothing (Just bId)
setMessageI MsgBarcodeAdded
2015-09-14 22:49:13 +00:00
else
setMessageI MsgBarcodeDuplicate
2015-09-14 22:49:13 +00:00
else
setMessageI MsgProvideBarcode
2015-07-21 07:14:38 +00:00
2015-04-04 04:46:33 +00:00
amountField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a
amountField = Field
{ fieldParse = parseHelper $ \s ->
case R.decimal s of
Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s
, fieldView = \theId name attr val req -> toWidget [hamlet|$newline never
2015-10-22 21:57:27 +00:00
<input #crement id=#{theId} name=#{name} *{attr} type="number" step=1 min=0 :req:required="required" value="#{showVal val}">
2015-04-04 04:46:33 +00:00
|]
, fieldEnctype = UrlEncoded
}
where
showVal = either id (pack . showI)
showI x = show (fromIntegral x :: Integer)
checkAlert :: BeverageId -> Int -> Handler ()
checkAlert bId oldamount = do
2015-04-04 04:46:33 +00:00
bev <- runDB $ getJust bId
let alert = beverageAlertAmount bev
when (beverageAmount bev < alert && oldamount > alert) $ do
master <- getYesod
let tos = appEmail $ appSettings master
mapM_ (\to ->
liftIO $ sendMail master to "Niedriger Bestand"
2015-04-04 04:46:33 +00:00
[stext|
2015-04-07 20:03:21 +00:00
Hallo,
2015-04-04 04:46:33 +00:00
2015-04-07 20:03:21 +00:00
Der Bestand an #{beverageIdent bev} ist unterhalb der Warnschwelle von #{beverageAlertAmount bev}.
Der momentane Bestand ist bei #{beverageAmount bev} Artikeln.
2015-04-04 04:46:33 +00:00
2015-04-07 20:03:21 +00:00
Viele Grüße,
2015-04-04 04:46:33 +00:00
Dein Matemat
2015-04-04 04:46:33 +00:00
|]
) tos
2015-04-04 04:46:33 +00:00
sendMail :: MonadIO m => App -> Text -> Text -> TL.Text -> m ()
sendMail master to subject body = liftIO $ do
let sendmailLocation = appSendmailLocation $ appSettings master
fromMail = appFromMail $ appSettings master
renderSendMailCustom sendmailLocation []
2015-04-04 04:46:33 +00:00
Mail
{ mailFrom = Address Nothing "noreply"
, mailTo = [Address Nothing to]
, mailCc = []
, mailBcc = []
2015-04-24 14:44:43 +00:00
, mailHeaders = [("Subject", subject),
("List-Id", "\"Matemat\" <"<> (fromString fromMail) <>">")]
2015-04-04 04:46:33 +00:00
, mailParts =[[Part
{ partType = "text/plain; charset=utf-8"
, partEncoding = None
, partHeaders = []
2020-06-05 16:28:46 +00:00
, partContent = PartContent $ E.encodeUtf8 body
2021-03-07 18:27:44 +00:00
, partDisposition = DefaultDisposition
2015-04-04 04:46:33 +00:00
}]]
}
2015-04-24 10:28:45 +00:00
formatIntVolume :: Int -> Text
2015-09-14 22:49:13 +00:00
formatIntVolume x = formatFloat (fromIntegral x / 1000)
2016-05-23 18:35:14 +00:00
--------------------------------------------------------------------------------
-- common case patterns
--------------------------------------------------------------------------------
isUser :: UserId -> Route App -> Handler User
isUser uId route = do
mUser <- runDB $ get uId
case mUser of
Nothing -> do
setMessageI MsgUserUnknown
redirectWith status404 route
2016-05-23 18:35:14 +00:00
Just user ->
return user
isBeverage :: BeverageId -> Route App -> Handler Beverage
isBeverage bId route = do
mBev <- runDB $ get bId
case mBev of
Nothing -> do
setMessageI MsgItemUnknown
redirectWith status404 route
2016-05-23 18:35:14 +00:00
Just bev ->
return bev