yammat/Handler/Common.hs

138 lines
4.4 KiB
Haskell

-- | Common handler functions.
module Handler.Common where
import Data.FileEmbed (embedFile)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as E
import qualified Data.Text.Read as R
import Data.List (tail)
import Data.List.Split
import Yesod.Form.Functions
import Text.Shakespeare.Text
import Network.Mail.Mime
import Text.Printf
import Import
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
getFaviconR = return $ TypedContent "image/x-icon"
$ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "config/robots.txt")
updateCashier :: Int -> Text -> Handler ()
updateCashier amount desc = do
mCashier <- runDB $ selectFirst [] [Desc CashierCreated]
trans <- liftIO $ (\time -> return $ Transaction desc amount time) =<< getCurrentTime
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
runDB $ insert_ trans
getCashierBalance :: Handler Int
getCashierBalance = do
mCashier <- runDB $ selectFirst [] [Desc CashierCreated]
case mCashier of
Just cashier -> do
return $ cashierBalance $ entityVal cashier
Nothing -> do
return 0
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
Right (a, "") -> Right $ floor $ 100 * 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="" value=#{showVal val}>
|]
, fieldEnctype = UrlEncoded
}
where
showVal = either id (pack . showA)
showA x = show ((fromIntegral x :: Double) / 100)
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
<input id=#{theId} name="#{name}" *{attr} type="number" step=1 min=0 :req:required="" value="#{showVal val}">
|]
, fieldEnctype = UrlEncoded
}
where
showVal = either id (pack . showI)
showI x = show (fromIntegral x :: Integer)
checkAlert :: BeverageId -> Handler ()
checkAlert bId = do
bev <- runDB $ getJust bId
case beverageAmount bev < beverageAlertAmount bev of
True -> do
master <- getYesod
to <- return $ appEmail $ appSettings master
sendMail to "Niedriger Bestand"
[stext|
Hallo,
Der Bestand an #{beverageIdent bev} ist unterhalb der Warnschwelle von #{beverageAlertAmount bev}.
Der momentane Bestand ist bei #{beverageAmount bev} Artikeln.
Viele Grüße,
der Matemat
|]
False -> return () -- do nothing
--sendMail :: MonadIO m => Text -> Text -> Text -> m ()
sendMail to subject body =
liftIO $ renderSendMail
Mail
{ mailFrom = Address Nothing "noreply"
, mailTo = [Address Nothing to]
, mailCc = []
, mailBcc = []
, mailHeaders = [("Subject", subject)]
, mailParts =[[Part
{ partType = "text/plain; charset=utf-8"
, partEncoding = None
, partFilename = Nothing
, partHeaders = []
, partContent = E.encodeUtf8 body
}]]
}
prependZero :: Text -> Text
prependZero t0 = if T.null t1
then t1
else if T.head t1 == '.'
then '0' `T.cons` t1
else if "-." `T.isPrefixOf` t1
then "-0." `T.append` (T.drop 2 t1)
else t1
where t1 = T.dropWhile ((==) ' ') t0
formatFloat :: Double -> Text
formatFloat d = T.pack (t ++ c)
where
t = reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = "," ++ tail (snd sp)
sp = (break (== '.') (printf "%.2f" d))
-- T.pack . (splitEvery 3) . (printf "%,2f")
formatIntCurrency :: Int -> Text
formatIntCurrency x = formatFloat $ ((fromIntegral x) / 100)