Permalink
Browse files

PostgreSQL scaffolding

  • Loading branch information...
1 parent 1faa919 commit bea81e8471cb2ecb22b1da8e5f2ce28130ed218e @snoyberg snoyberg committed Nov 5, 2012
View
2 .ghci
@@ -0,0 +1,2 @@
+:set -i.:config:dist/build/autogen
+:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls
View
@@ -0,0 +1,6 @@
+dist/
+static/tmp/
+config/client_session_key.aes
+*.hi
+*.o
+*.sqlite3
View
@@ -0,0 +1,59 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Application
+ ( makeApplication
+ , getApplicationDev
+ , makeFoundation
+ ) where
+
+import Import
+import Settings
+import Yesod.Auth
+import Yesod.Default.Config
+import Yesod.Default.Main
+import Yesod.Default.Handlers
+import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
+import qualified Database.Persist.Store
+import Database.Persist.GenericSql (runMigration)
+import Network.HTTP.Conduit (newManager, def)
+
+-- Import all relevant handler modules here.
+-- Don't forget to add new modules to your cabal file!
+import Handler.Home
+
+-- This line actually creates our YesodDispatch instance. It is the second half
+-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
+-- comments there for more details.
+mkYesodDispatch "App" resourcesApp
+
+-- This function allocates resources (such as a database connection pool),
+-- performs initialization and creates a WAI application. This is also the
+-- place to put your migrate statements to have automatic database
+-- migrations handled by Yesod.
+makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication conf = do
+ foundation <- makeFoundation conf
+ app <- toWaiAppPlain foundation
+ return $ logWare app
+ where
+ logWare = if development then logStdoutDev
+ else logStdout
+
+makeFoundation :: AppConfig DefaultEnv Extra -> IO App
+makeFoundation conf = do
+ manager <- newManager def
+ s <- staticSite
+ dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
+ Database.Persist.Store.loadConfig >>=
+ Database.Persist.Store.applyEnv
+ p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
+ Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
+ return $ App conf s p manager dbconf
+
+-- for yesod devel
+getApplicationDev :: IO (Int, Application)
+getApplicationDev =
+ defaultDevelApp loader makeApplication
+ where
+ loader = loadConfig (configSettings Development)
+ { csParseExtra = parseExtra
+ }
View
@@ -0,0 +1,155 @@
+module Foundation where
+
+import Prelude
+import Yesod
+import Yesod.Static
+import Yesod.Auth
+import Yesod.Auth.BrowserId
+import Yesod.Auth.GoogleEmail
+import Yesod.Default.Config
+import Yesod.Default.Util (addStaticContentExternal)
+import Network.HTTP.Conduit (Manager)
+import qualified Settings
+import Settings.Development (development)
+import qualified Database.Persist.Store
+import Settings.StaticFiles
+import Database.Persist.GenericSql
+import Settings (widgetFile, Extra (..))
+import Model
+import Text.Jasmine (minifym)
+import Web.ClientSession (getKey)
+import Text.Hamlet (hamletFile)
+
+-- | The site argument 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
+ { settings :: AppConfig DefaultEnv Extra
+ , getStatic :: Static -- ^ Settings for static file serving.
+ , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
+ , httpManager :: Manager
+ , persistConfig :: Settings.PersistConfig
+ }
+
+-- Set up i18n messages. See the message folder.
+mkMessage "App" "messages" "en"
+
+-- 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/handler
+--
+-- This function does three things:
+--
+-- * Creates the route datatype AppRoute. Every valid URL in your
+-- application can be represented as a value of this type.
+-- * Creates the associated type:
+-- type instance Route App = AppRoute
+-- * Creates the value resourcesApp which contains information on the
+-- resources declared below. This is used in Handler.hs by the call to
+-- mkYesodDispatch
+--
+-- What this function does *not* do is create a YesodSite instance for
+-- App. Creating that instance requires all of the handler functions
+-- for our application to be in scope. However, the handler functions
+-- usually require access to the AppRoute datatype. Therefore, we
+-- split these actions into two functions and place them in separate files.
+mkYesodData "App" $(parseRoutesFile "config/routes")
+
+type Form x = Html -> MForm App App (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
+ approot = ApprootMaster $ appRoot . settings
+
+ -- Store session data on the client in encrypted cookies,
+ -- default session idle timeout is 120 minutes
+ makeSessionBackend _ = do
+ key <- getKey "config/client_session_key.aes"
+ return . Just $ clientSessionBackend key 120
+
+ 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
+ $(widgetFile "normalize")
+ addStylesheet $ StaticR css_bootstrap_css
+ $(widgetFile "default-layout")
+ hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+ -- This is done to provide an optimization for serving static files from
+ -- a separate domain. Please see the staticRoot setting in Settings.hs
+ urlRenderOverride y (StaticR s) =
+ Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
+ urlRenderOverride _ _ = Nothing
+
+ -- The page to be redirected to when authentication is required.
+ authRoute _ = Just $ AuthR LoginR
+
+ -- 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 = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
+
+ -- Place Javascript at bottom of the body tag so the rest of the page loads first
+ jsLoader _ = BottomOfBody
+
+ -- What messages should be logged. The following includes all messages when
+ -- in development, and warnings and errors in production.
+ shouldLog _ _source level =
+ development || level == LevelWarn || level == LevelError
+
+-- How to run database actions.
+instance YesodPersist App where
+ type YesodPersistBackend App = SqlPersist
+ runDB f = do
+ master <- getYesod
+ Database.Persist.Store.runPool
+ (persistConfig master)
+ f
+ (connPool master)
+
+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
+
+ getAuthId creds = runDB $ do
+ x <- getBy $ UniqueUser $ credsIdent creds
+ case x of
+ Just (Entity uid _) -> return $ Just uid
+ Nothing -> do
+ fmap Just $ insert $ User (credsIdent creds) Nothing
+
+ -- You can add other plugins like BrowserID, email or OAuth here
+ authPlugins _ = [authBrowserId, authGoogleEmail]
+
+ authHttpManager = httpManager
+
+-- 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
+
+-- | Get the 'Extra' value, used to hold data from the settings.yml file.
+getExtra :: Handler Extra
+getExtra = fmap (appExtra . settings) getYesod
+
+-- Note: previous versions of the scaffolding included a deliver function to
+-- send emails. Unfortunately, there are too many different options for us to
+-- give a reasonable default. Instead, the information is available on the
+-- wiki:
+--
+-- https://github.com/yesodweb/yesod/wiki/Sending-email
View
@@ -0,0 +1,39 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.Home where
+
+import Import
+
+-- This is a handler function for the GET request method on the HomeR
+-- resource pattern. All of your resource patterns are defined in
+-- config/routes
+--
+-- The majority of the code you will write in Yesod lives in these handler
+-- functions. You can spread them across multiple files if you are so
+-- inclined, or create a single monolithic file.
+getHomeR :: Handler RepHtml
+getHomeR = do
+ (formWidget, formEnctype) <- generateFormPost sampleForm
+ let submission = Nothing :: Maybe (FileInfo, Text)
+ handlerName = "getHomeR" :: Text
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "Welcome To Yesod!"
+ $(widgetFile "homepage")
+
+postHomeR :: Handler RepHtml
+postHomeR = do
+ ((result, formWidget), formEnctype) <- runFormPost sampleForm
+ let handlerName = "postHomeR" :: Text
+ submission = case result of
+ FormSuccess res -> Just res
+ _ -> Nothing
+
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "Welcome To Yesod!"
+ $(widgetFile "homepage")
+
+sampleForm :: Form (FileInfo, Text)
+sampleForm = renderDivs $ (,)
+ <$> fileAFormReq "Choose a file"
+ <*> areq textField "What's on the file?" Nothing
View
@@ -0,0 +1,29 @@
+module Import
+ ( module Import
+ ) where
+
+import Prelude as Import hiding (head, init, last,
+ readFile, tail, writeFile)
+import Yesod as Import hiding (Route (..))
+
+import Control.Applicative as Import (pure, (<$>), (<*>))
+import Data.Text as Import (Text)
+
+import Foundation as Import
+import Model as Import
+import Settings as Import
+import Settings.Development as Import
+import Settings.StaticFiles as Import
+
+#if __GLASGOW_HASKELL__ >= 704
+import Data.Monoid as Import
+ (Monoid (mappend, mempty, mconcat),
+ (<>))
+#else
+import Data.Monoid as Import
+ (Monoid (mappend, mempty, mconcat))
+
+infixr 5 <>
+(<>) :: Monoid m => m -> m -> m
+(<>) = mappend
+#endif
View
25 LICENSE
@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2012, DEVELOPERNAME. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
@@ -0,0 +1,14 @@
+module Model where
+
+import Prelude
+import Yesod
+import Data.Text (Text)
+import Database.Persist.Quasi
+
+
+-- You can define all of your database entities in the entities file.
+-- You can find more information on persistent and how to declare entities
+-- at:
+-- http://www.yesodweb.com/book/persistent/
+share [mkPersist sqlSettings, mkMigrate "migrateAll"]
+ $(persistFileWith lowerCaseSettings "config/models")
Oops, something went wrong.

0 comments on commit bea81e8

Please sign in to comment.