Foundation.hs

module Foundation where

import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding   as TE
import           Database.Persist.Sql (ConnectionPool, runSqlPool)
import           Import.NoFoundation
import           Text.Hamlet          (hamletFile)
import           Text.Jasmine         (minifym)
-- import           Yesod.Auth.Message   (AuthMessage (InvalidLogin))
import           Yesod.Core.Types     (Logger)
import qualified Yesod.Core.Unsafe    as Unsafe
import           Yesod.Default.Util   (addStaticContentExternal)

import           Yesod.Auth.Email

import           Betty.Auth
import           Betty.Helpers
import           Betty.Signup
import           Betty.Token
import           Betty.Vendor
import           Betty.Version

-- | 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
    }

-- 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 following documentation
-- for an explanation for this split:
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
--
-- This function also generates the following type synonyms:
-- type Handler = HandlerT App IO
-- type Widget = WidgetT App IO ()
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 = ApprootRequest $ \app req ->
        case appRoot $ appSettings app of
            Nothing -> getApprootText guessApproot app req
            Just root -> root

    -- 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"

    -- Yesod Middleware allows you to run code before and after each handler function.
    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
    -- The defaultCsrfMiddleware:
    --   a) Sets a cookie with a CSRF token in it.
    --   b) Validates that incoming write requests include that token in either a header or POST parameter.
    -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.

    -- TODO: defaultCsrfMiddleware is acting up again; disabling for
    -- now.
    yesodMiddleware = defaultCsrfMiddleware . defaultYesodMiddleware

    defaultLayout widget = do
        master <- getYesod
        mmsg <- getMessage

        ma <- maybeAuth

        -- 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_normalize_css
                , css_bootstrap_css
                , faCss
                ])
            $(widgetFile "default-layout")
        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

    -- The page to be redirected to when authentication is required.
    authRoute _ = Just $ AuthR LoginR

    -- Routes not requiring authentication.
    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

#ifndef DEVELOPMENT
    -- TODO: what to do about static/tmp and static/autogen?
    urlRenderOverride master (StaticR s) = do
        let staticRoot = appStaticRoot $ appSettings master
        case staticRoot of
            Nothing  -> Nothing
            Just r -> Just $ uncurry (joinPath master r) $ renderRoute s
    urlRenderOverride _ _ = Nothing
#endif

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

    authenticate creds = runDB $ do
        x <- getBy $ UniqueUser $ credsIdent creds
        case x of
            Just (Entity uid _) -> return $ Authenticated uid
            Nothing -> Authenticated <$> insert User
                { userEmail    = credsIdent creds
                , userPassword = Nothing
                , userVerkey   = Nothing
                , userVerified = False
                }

    -- You can add other plugins like BrowserID, email or OAuth here
    authPlugins _ = [authEmailBetty]

    authHttpManager = getHttpManager

    -- `authLayout` is exactly like `defaultLayout`, but we also use
    -- some jQuery code in `auth-layout` to remove the signup/login
    -- links from navbar, which is redundant in this context.
    authLayout widget =
        defaultLayout $ do
            widget
            $(widgetFile "auth.layout")

    -- Overriding `maybeAuthId` so that we can handle tokens
    -- presesnted in request headers.
    maybeAuthId = do
        mid <- defaultMaybeAuthId
        case mid of
            Nothing -> do
                $(logDebug) "Looking for auth token"
                uid <- maybeAuthToken
                case uid of
                    Nothing  -> return Nothing
                    Just tid -> return $ Just tid
            Just _ -> do
                $(logDebug) "Authorized -- not looking for token"
                return mid

    -- Default is to print the message "You are now logged in"
    -- (`NowLoggedIn` from `Yesod.Auth.Message`).  That is kind of
    -- redundant here.
    onLogin = return ()

instance YesodAuthPersist App

------------------------------------------------------------------------

-- Yesod.Auth.Email customizations here.

instance YesodAuthEmail App where
    type AuthEmailId App = UserId

    addUnverified email verkey =
        runDB $ insert $ User email Nothing (Just verkey) False

    sendVerifyEmail = sendVerificationEmail

    getVerifyKey = runDB . fmap (join . fmap userVerkey) . get

    setVerifyKey uid key = runDB $ update uid [ UserVerkey =. Just key ]

    verifyAccount uid = runDB $ do
        m <- get uid
        case m 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  = email
                                         }

    getEmail = runDB . fmap (fmap userEmail) . get

    afterPasswordRoute _  = ProfileStartR
    registerHandler       = localRegisterHandler
    forgotPasswordHandler = localForgotPasswordHandler

    -- TODO: these are reminders to myself to customize these handlers.
    -- setPasswordHandler = error "setPasswordHandler is not implementated"

------------------------------------------------------------------------

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

-- Useful when writing code that is re-usable outside of the Handler context.
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod applications.
instance HasHttpManager App where
    getHttpManager = appHttpManager

unsafeHandler :: App -> Foundation.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