Skip to content

Instantly share code, notes, and snippets.

@ptkato
Created January 22, 2021 17:30
Show Gist options
  • Save ptkato/7ec227ae5b133cb3e8fa30ee33b75da3 to your computer and use it in GitHub Desktop.
Save ptkato/7ec227ae5b133cb3e8fa30ee33b75da3 to your computer and use it in GitHub Desktop.
Foundation.hs example
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment