Foundation.hs example

Foundation.hs

module Foundation where

import Yesod
import Yesod.Static
import Yesod.Auth
import Yesod.Auth.Email               as YAE
import Yesod.Auth.GoogleEmail2        as GE2
import Yesod.Auth.Facebook.ServerSide as YAF
import Yesod.Facebook
import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM2, join)
import Control.Monad.Trans.Maybe
import Data.Either
import Data.Maybe (isJust)
import Data.Text
import Text.Hamlet
import Text.Cassius
import Network.HTTP.Client.Conduit (Manager)
import Database.Persist.Postgresql (ConnectionPool, runSqlPool, SqlBackend)
import qualified Facebook as FB

import Model
import Settings

data App = App
    { appSettings :: AppSettings
    , connPool    :: ConnectionPool
    , getStatic   :: Static
    , httpManager :: Manager
    }

staticFiles "static"

mkYesodData "App" $(parseRoutesFile "config/routes")

instance Yesod App where
    approot = ApprootMaster $ appRoot . appSettings

    defaultLayout w = do
        p <- widgetToPageContent $ do
            addStylesheet $ StaticR css_style_css
            addStylesheet $ StaticR css_style_less
            w
        msgs <- getMessages
        withUrlRenderer $(hamletFile "templates/foundation/default-layout.hamlet")

    authRoute _ = Just $ AuthR LoginR
    
    isAuthorized (AuthR _)   _ = return Authorized
    isAuthorized (StaticR _) _ = return Authorized
    isAuthorized _ _ = return AuthenticationRequired
    
    makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
        (24 * 60)
        "config/client_session_key.aes"

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

instance YesodPersist App where
    type YesodPersistBackend App = SqlBackend
    runDB f = getYesod >>= runSqlPool f . connPool

-- GoogleAuth
clientId :: Text
clientId = "clientId"

clientSecret :: Text
clientSecret = "clientSecret"

-- FacebookAuth
facebookCreds :: FB.Credentials
facebookCreds = FB.Credentials "AppName" "AppId" "AppSecret"

instance YesodAuthPersist App

instance YesodAuth App where
    type AuthId App = UserId

    -- 3rd party auth URLs
    -- Google   - GE2.forwardUrl
    -- Facebook - YAF.facebookLogin
    loginHandler = lift $ authLayout $ do
        setTitle "Login - AtomicThink"
        $(whamletFile "templates/foundation/login.hamlet")

    authPlugins _ =
        [ authEmail
        , authGoogleEmailSaveToken clientId clientSecret
        , authFacebook ["public_profile", "email"]
        ]

    authenticate (Creds pl me _) = do
        manager <- getsYesod httpManager
        Just (email, name) <- case pl of
            "fb" -> do
                accessToken <- YAF.getUserAccessToken
                user        <- runYesodFbT $ FB.getUser (FB.Id "me") [("fields", "email,name")] accessToken
                return . return . liftM2 (,) ((maybe (Left . FB.userId $ user) Right) . FB.userEmail) FB.userName $ user
            "googleemail2" -> runMaybeT $ do
                accessToken <- MaybeT GE2.getUserAccessToken
                person      <- MaybeT $ getPerson manager accessToken
                return . liftM2 (,) (Right . const me) personDisplayName $ person
            _ -> return $ return (Right me, Nothing)
        result <- runDB . insertBy $ User Nothing (pack . show $ email) name Nothing Nothing $ name /= Nothing
        return . Authenticated $ either entityKey id result

    authHttpManager = httpManager

instance YesodAuthEmail App where
    type AuthEmailId App = UserId
    
    registerHandler = undefined
    emailLoginHandler toParent = do
        setTitle "Login - AtomicThink"
        $(whamletFile "templates/foundation/login.hamlet")
    
    afterPasswordRoute _ = HomeR
    
    addUnverified email verkey =
        runDB . insert $ User Nothing email Nothing Nothing (Just verkey) False
    
    getVerifyKey =
        fmap _userVerifyKey . runDB . get404
    setVerifyKey uid verkey =
        runDB $ update uid [UserVerifyKey =. Just verkey]
    verifyAccount uid =
        runDB $ get uid >>= \case
            Nothing -> return Nothing
            Just _  -> update uid [UserVerified =. True]
                >> (return $ Just uid)
    
    getPassword =
        fmap _userPassword . runDB . get404
    setPassword uid password =
        runDB $ update uid [UserPassword =. Just password]
    
    getEmail =
        fmap (return . _userEmail) . runDB . get404
    getEmailCreds email =
        (runDB . getBy $ UniqueUserEmail email) >>= \case
            Nothing -> return Nothing
            Just (Entity uid user) -> return $ Just (EmailCreds
                { emailCredsId = uid
                , emailCredsAuthId = Just uid
                , emailCredsStatus = isJust $ _userPassword user
                , emailCredsVerkey = _userVerifyKey user
                , emailCredsEmail = email
                } :: EmailCreds App)
    
    sendVerifyEmail = undefined

instance YesodFacebook App where
    fbCredentials _ = facebookCreds
    fbHttpManager = httpManager