web/Foundation.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 module Foundation where
   3
   4 import Import.NoFoundation
   5 import Database.Persist.Sql (ConnectionPool, runSqlPool)
   6 import Text.Hamlet          (hamletFile)
   7 import Text.Jasmine         (minifym)
   8 import Yesod.Auth.BrowserId (authBrowserId)
   9 import Yesod.Default.Util   (addStaticContentExternal)
  10 import Yesod.Core.Types     (Logger)
  11 import qualified Yesod.Core.Unsafe as Unsafe
  12
  13 -- | The foundation datatype for your application. This can be a good place to
  14 -- keep settings and values requiring initialization before your application
  15 -- starts running, such as database connections. Every handler will have
  16 -- access to the data present here.
  17 data App = App
  18     { appSettings    :: AppSettings
  19     , appStatic      :: Static -- ^ Settings for static file serving.
  20     , appConnPool    :: ConnectionPool -- ^ Database connection pool.
  21     , appHttpManager :: Manager
  22     , appLogger      :: Logger
  23     }
  24
  25 instance HasHttpManager App where
  26     getHttpManager = appHttpManager
  27
  28 -- This is where we define all of the routes in our application. For a full
  29 -- explanation of the syntax, please see:
  30 -- http://www.yesodweb.com/book/routing-and-handlers
  31 --
  32 -- Note that this is really half the story; in Application.hs, mkYesodDispatch
  33 -- generates the rest of the code. Please see the linked documentation for an
  34 -- explanation for this split.
  35 mkYesodData "App" $(parseRoutesFile "config/routes")
  36
  37 -- | A convenient synonym for creating forms.
  38 type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
  39
  40 -- Please see the documentation for the Yesod typeclass. There are a number
  41 -- of settings which can be configured by overriding methods here.
  42 instance Yesod App where
  43     -- Controls the base of generated URLs. For more information on modifying,
  44     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
  45     approot = ApprootMaster $ appRoot . appSettings
  46
  47     -- Store session data on the client in encrypted cookies,
  48     -- default session idle timeout is 120 minutes
  49     makeSessionBackend _ = Just <$> defaultClientSessionBackend
  50         120    -- timeout in minutes
  51         "config/client_session_key.aes"
  52
  53     defaultLayout widget = do
  54         master <- getYesod
  55         mmsg <- getMessage
  56
  57         -- We break up the default layout into two components:
  58         -- default-layout is the contents of the body tag, and
  59         -- default-layout-wrapper is the entire page. Since the final
  60         -- value passed to hamletToRepHtml cannot be a widget, this allows
  61         -- you to use normal widget features in default-layout.
  62
  63         pc <- widgetToPageContent $ do
  64             addStylesheet $ StaticR css_bootstrap_css
  65             $(widgetFile "default-layout")
  66         withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
  67
  68     -- The page to be redirected to when authentication is required.
  69     authRoute _ = Just $ AuthR LoginR
  70
  71     -- Routes not requiring authentication.
  72     isAuthorized (AuthR _) _ = return Authorized
  73     isAuthorized FaviconR _ = return Authorized
  74     isAuthorized RobotsR _ = return Authorized
  75     -- Default to Authorized for now.
  76     isAuthorized _ _ = return Authorized
  77
  78     -- This function creates static content files in the static folder
  79     -- and names them based on a hash of their content. This allows
  80     -- expiration dates to be set far in the future without worry of
  81     -- users receiving stale content.
  82     addStaticContent ext mime content = do
  83         master <- getYesod
  84         let staticDir = appStaticDir $ appSettings master
  85         addStaticContentExternal
  86             minifym
  87             genFileName
  88             staticDir
  89             (StaticR . flip StaticRoute [])
  90             ext
  91             mime
  92             content
  93       where
  94         -- Generate a unique filename based on the content itself
  95         genFileName lbs = "autogen-" ++ base64md5 lbs
  96
  97     -- What messages should be logged. The following includes all messages when
  98     -- in development, and warnings and errors in production.
  99     shouldLog app _source level =
 100         appShouldLogAll (appSettings app)
 101             || level == LevelWarn
 102             || level == LevelError
 103
 104     makeLogger = return . appLogger
 105
 106 -- How to run database actions.
 107 instance YesodPersist App where
 108     type YesodPersistBackend App = SqlBackend
 109     runDB action = do
 110         master <- getYesod
 111         runSqlPool action $ appConnPool master
 112 instance YesodPersistRunner App where
 113     getDBRunner = defaultGetDBRunner appConnPool
 114
 115 instance YesodAuth App where
 116     type AuthId App = UserId
 117
 118     -- Where to send a user after successful login
 119     loginDest _ = HomeR
 120     -- Where to send a user after logout
 121     logoutDest _ = HomeR
 122     -- Override the above two destinations when a Referer: header is present
 123     redirectToReferer _ = True
 124
 125     getAuthId creds = runDB $ do
 126         x <- getBy $ UniqueUser $ credsIdent creds
 127         case x of
 128             Just (Entity uid _) -> return $ Just uid
 129             Nothing -> Just <$> insert User
 130                 { userIdent = credsIdent creds
 131                 , userPassword = Nothing
 132                 }
 133
 134     -- You can add other plugins like BrowserID, email or OAuth here
 135     authPlugins _ = [authBrowserId def]
 136
 137     authHttpManager = getHttpManager
 138
 139 instance YesodAuthPersist App
 140
 141 -- This instance is required to use forms. You can modify renderMessage to
 142 -- achieve customized and internationalized form validation messages.
 143 instance RenderMessage App FormMessage where
 144     renderMessage _ _ = defaultFormMessage
 145
 146 unsafeHandler :: App -> Handler a -> IO a
 147 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 148
 149 -- Note: Some functionality previously present in the scaffolding has been
 150 -- moved to documentation in the Wiki. Following are some hopefully helpful
 151 -- links:
 152 --
 153 -- https://github.com/yesodweb/yesod/wiki/Sending-email
 154 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
 155 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding