198 lines
8.2 KiB
Haskell
198 lines
8.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Foundation where
|
|
|
|
import Import.NoFoundation
|
|
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
|
import Text.Hamlet (hamletFile)
|
|
import Text.Jasmine (minifym)
|
|
--import Yesod.Auth.BrowserId (authBrowserId)
|
|
import Yesod.Default.Util (addStaticContentExternal)
|
|
import Yesod.Core.Types (Logger)
|
|
import qualified Yesod.Core.Unsafe as Unsafe
|
|
--import Yesod.Auth.HashDB (authHashDB)
|
|
import Yesod.Auth.OAuth2.EveOnline (oauth2Eve,WidgetType(..))
|
|
import Data.Time.Format (parseTimeM)
|
|
|
|
-- | 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
|
|
|
|
-- 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)
|
|
|
|
-- 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 = ApprootMaster $ appRoot . appSettings
|
|
|
|
-- 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"
|
|
|
|
defaultLayout widget = do
|
|
master <- getYesod
|
|
mmsg <- getMessage
|
|
|
|
-- 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
|
|
addStylesheet $ StaticR css_bootstrap_css
|
|
addStylesheet $ StaticR css_neat_css
|
|
addScript $ StaticR js_jquery_js
|
|
addScript $ StaticR js_bootstrap_js
|
|
$(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
|
|
|
|
-- 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 master -> HandlerT master IO (AuthenticationResult master)
|
|
authenticate creds =
|
|
runDB $ do
|
|
x <- getBy $ UniqueUser $ credsIdent creds
|
|
now <- liftIO getCurrentTime
|
|
-- extra is charName tokenType and expires
|
|
liftIO $ print extra
|
|
case x of
|
|
Just (Entity uid _) -> do
|
|
update uid [UserLastLogin =. now]
|
|
return $ Authenticated uid
|
|
Nothing -> case fromExtra of
|
|
Just (expiry,token,name,cid) -> Authenticated <$> insert User
|
|
{ userIdent = credsIdent creds
|
|
, userName = name
|
|
, userCharId = cid
|
|
, userPassword = Nothing
|
|
, userLastLogin = now
|
|
, userTokenExpires = expiry
|
|
, userAccessToken = token
|
|
, userWalletTimeout = now
|
|
, userStandingsTimeout = now
|
|
, userSkillTimeout = now
|
|
, userAcc = 0
|
|
, userBr = 0
|
|
}
|
|
Nothing -> return $ ServerError "Problems extracting Access-Token"
|
|
where
|
|
extra = credsExtra creds
|
|
fromExtra = do
|
|
expires <- getFromExtra "expires" extra
|
|
token <- getFromExtra "accessToken" extra
|
|
name <- getFromExtra "charName" extra
|
|
cid <- getFromExtra "charId" extra >>= readMay
|
|
expiry <- parseTimeM True defaultTimeLocale "%FT%X" (unpack expires) :: Maybe UTCTime
|
|
-- %F = YYYY-MM-DD
|
|
-- %X = HH-MM-SS
|
|
return (expiry,token,name,cid)
|
|
getFromExtra :: Text -> [(Text,Text)] -> Maybe Text
|
|
getFromExtra s = fmap snd . listToMaybe . filter ((==) s . fst)
|
|
|
|
-- You can add other plugins like BrowserID, email or OAuth here
|
|
authPlugins _ = [ --authBrowserId def
|
|
--, authHashDB (Just . UniqueUser)
|
|
oauth2Eve "346ee0ad8f974e30be6bf422f40d891b" "kXnZd7f3pmRCvePiBPQcTL2aRcgBHSgPRxc6VNYT" BigBlack
|
|
]
|
|
|
|
authHttpManager = getHttpManager
|
|
|
|
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
|
|
|
|
unsafeHandler :: App -> 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
|