yammat/Foundation.hs

288 lines
10 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
module Foundation where
2017-01-21 17:02:29 +00:00
import Import.NoFoundation hiding (tail)
2015-04-04 04:46:33 +00:00
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger)
2015-04-05 09:05:06 +00:00
--snip
2017-06-03 00:37:22 +00:00
import Yesod.Auth.Hardcoded
import Yesod.Auth.Message
2015-04-05 09:05:06 +00:00
import qualified Data.Text as T
import Network.Wai as Wai
import Network.Wai.Request (appearsSecure)
2015-04-09 22:40:58 +00:00
import Data.List (tail)
import Data.List.Split
import Text.Printf
2015-10-11 18:07:12 +00:00
2015-04-09 22:40:58 +00:00
prependZero :: Text -> Text
2015-09-14 22:49:13 +00:00
prependZero t0
| T.null t1 = t1
| T.head t1 == '.' = '0' `T.cons` t1
| "-." `T.isPrefixOf` t1 = "-0." `T.append` T.drop 2 t1
| otherwise = t1
where t1 = T.dropWhile (' ' ==) t0
2015-04-09 22:40:58 +00:00
formatFloat :: Double -> Text
2015-04-12 15:20:43 +00:00
formatFloat d = T.pack (pre ++ t ++ c)
2015-04-09 22:40:58 +00:00
where
t = reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = "," ++ tail (snd sp)
2015-09-14 22:49:13 +00:00
sp = break (== '.') (printf "%.2f" (abs d))
pre = if d < 0
then "-"
else ""
2015-04-09 22:40:58 +00:00
-- T.pack . (splitEvery 3) . (printf "%,2f")
formatIntCurrency :: Int -> Text
2015-09-14 22:49:13 +00:00
formatIntCurrency x = formatFloat $ fromIntegral x / 100
2015-04-04 04:46:33 +00:00
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appHttpManager :: Manager
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = appHttpManager
2015-04-09 22:40:58 +00:00
mkMessage "App" "messages" "de"
renderMessage' :: (RenderMessage (HandlerSite m) message, MonadHandler m) => message -> m Text
2015-04-09 22:40:58 +00:00
renderMessage' e = do
m <- getYesod
l <- languages
return $ renderMessage m l e
2015-04-04 04:46:33 +00:00
-- 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)
2015-04-05 09:05:06 +00:00
approotRequest :: App -> Wai.Request -> T.Text
approotRequest master req =
case requestHeaderHost req of
Just a -> prefix `T.append` decodeUtf8 a
Nothing -> appRoot $ appSettings master
where
prefix =
if appearsSecure req
2015-09-14 22:49:13 +00:00
then "https://"
else "http://"
2015-04-05 09:05:06 +00:00
2015-04-04 04:46:33 +00:00
-- 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
2015-04-05 09:05:06 +00:00
--approot = ApprootMaster $ appRoot . appSettings
approot = ApprootRequest approotRequest
2015-04-04 04:46:33 +00:00
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
2015-09-14 22:49:13 +00:00
makeSessionBackend _ = Just <$> defaultClientSessionBackend
2015-04-04 04:46:33 +00:00
120 -- timeout in minutes
"config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
2017-06-03 00:37:22 +00:00
musername <- maybeAuthId
2015-04-04 04:46:33 +00:00
-- 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.
2015-09-17 19:54:04 +00:00
copyrightWidget <- widgetToPageContent $
$(widgetFile "copyright")
2015-04-04 04:46:33 +00:00
pc <- widgetToPageContent $ do
2017-01-30 22:04:06 +00:00
mapM_ addStylesheet $ map StaticR
2015-10-22 21:57:27 +00:00
[ css_bootstrap_min_css
2015-04-04 04:46:33 +00:00
, css_main_css
2017-01-30 22:07:04 +00:00
]
2017-01-30 22:04:06 +00:00
mapM_ addScript $ map StaticR
2015-04-13 12:09:47 +00:00
[ js_crementing_js
2017-02-12 10:58:54 +00:00
-- , js_barcode_js
2017-01-30 22:07:04 +00:00
]
2015-04-04 04:46:33 +00:00
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
2015-10-11 18:07:12 +00:00
2015-04-04 04:46:33 +00:00
-- The page to be redirected to when authentication is required.
-- authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authentication.
2017-06-03 00:37:22 +00:00
isAuthorized (AuthR _) _ = return Authorized
2015-04-04 04:46:33 +00:00
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
2017-06-03 00:37:22 +00:00
-- Routes requiring authentication
isAuthorized RestockR _ = isAdmin
isAuthorized (UpstockR _) _ = isAdmin
isAuthorized NewArticleR _ = isAdmin
isAuthorized JournalR _ = isAdmin
isAuthorized (JournalPageR _) _ = isAdmin
isAuthorized PayoutR _ = isAdmin
isAuthorized SummaryR _ = isAdmin
isAuthorized SummaryJsonR _ = isAdmin
isAuthorized (ModifyR _) _ = isAdmin
isAuthorized (DeleteBeverageR _) _ = isAdmin
isAuthorized CashCheckR _ = isAdmin
isAuthorized UploadInventoryJsonR _ = isAdmin
isAuthorized InventoryJsonR _ = isAdmin
isAuthorized AvatarR _ = isAdmin
isAuthorized (ModifyAvatarR _) _ = isAdmin
isAuthorized (AvatarDeleteR _) _ = isAdmin
isAuthorized SupplierR _ = isAdmin
isAuthorized NewSupplierR _ = isAdmin
isAuthorized (SupplierActionsR _) _ = isAdmin
isAuthorized (ModifySupplierR _) _ = isAdmin
isAuthorized (SupplierDigestR _) _ = isAdmin
isAuthorized (DeleteSupplierR _) _ = isAdmin
2015-04-04 04:46:33 +00:00
-- 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.
2018-08-10 18:12:48 +00:00
-- shouldLog app _source level =
-- appShouldLogAll (appSettings app)
-- || level == LevelWarn
-- || level == LevelError
2015-04-04 04:46:33 +00:00
makeLogger = return . appLogger
2017-06-03 00:37:22 +00:00
isAdmin :: YesodAuth master => HandlerT master IO AuthResult
isAdmin = do
mu <- maybeAuthId
return $ case mu of
Nothing -> AuthenticationRequired
Just _ -> Authorized
2015-04-04 04:46:33 +00:00
-- 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
2017-06-03 00:37:22 +00:00
instance YesodAuth App where
type AuthId App = Text
-- 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 = return . Just . credsIdent
-- getAuthId creds = runDB $ do
-- x <- getBy $ UniqueUser $ credsIdent creds
-- case x of
-- Just (Entity uid _) -> return $ Just uid
-- Nothing -> do
-- fmap Just $ insert User
-- { userIdent = credsIdent creds
-- , userPassword = Nothing
-- }
authenticate Creds{..} = do
settings <- getsYesod appSettings
maybe (return $ Authenticated "nobody") (\login ->
if loginName login == credsIdent
then return (Authenticated credsIdent)
else return (UserError InvalidLogin)
) (appAdminCreds settings)
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authHardcoded]
2018-08-10 18:22:04 +00:00
-- authHttpManager = getHttpManager
2017-06-03 00:37:22 +00:00
maybeAuthId = do
settings <- getsYesod appSettings
maybe (return $ Just "nobody")
(const $ lookupSession credsKey)
(appAdminCreds settings)
instance YesodAuthHardcoded App where
validatePassword u p = do
settings <- getsYesod appSettings
maybe (return True) (\login ->
return (u == loginName login && p == loginPass login)
) (appAdminCreds settings)
doesUserNameExist u = do
settings <- getsYesod appSettings
let name = fromMaybe "nobody" $ loginName <$> appAdminCreds settings
return (u == name)
2015-04-04 04:46:33 +00:00
-- 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
-- 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
2015-04-09 22:40:58 +00:00