{-# LANGUAGE NoCPP #-} module Foundation where import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) import qualified Yesod.Auth.Message as AuthMsg import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) import Yesod.Core.Types (Logger) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Auth.Email import Network.Mail.Mime import Text.Shakespeare.Text (stext) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Cassius (PixelSize (..)) import Model.Unit (Unit (..)) import Model.Amount (Amount (..)) import qualified Database.Esqueleto as E import qualified Yesod.Core.Unsafe as Unsafe -- | 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 { appNavbar :: WidgetT App IO () , appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appHttpManager :: Manager , appLogger :: Logger } instance HasHttpManager App where getHttpManager = appHttpManager -- Set up i18n messages. See the message folder. mkMessage "App" "messages" "en" getUnitMsg :: (MonadHandler m, RenderMessage (HandlerSite m) AppMessage) => Unit -> m Text getUnitMsg unit = do mr <- getMessageRender return $ mr $ unitToMsg unit where unitToMsg :: Unit -> AppMessage unitToMsg Unit = MsgUnitUnit unitToMsg Gram = MsgUnitGram unitToMsg Litre = MsgUnitLitre setMessageILevel :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => Text -> msg -> m () setMessageILevel level msg = do mr <- getMessageRender let msgr = mr msg setMessage $ [shamlet|

#{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