web/Foundation.hs

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