Finally put pfifcontractors into gitHEADmaster

1 files changed, 197 insertions, 0 deletions

diff --git a/Foundation.hs b/Foundation.hs
new file mode 100644
index 0000000..e8a14fa
--- /dev/null
+++ b/Foundation.hs
@@ -0,0 +1,197 @@
+module Foundation
+    ( App (..)
+    , Route (..)
+    , AppMessage (..)
+    , resourcesApp
+    , Handler
+    , Widget
+    , Form
+    , maybeAuth
+    , requireAuth
+    , module Settings
+    , module Model
+    ) where
+
+import Prelude
+import Yesod
+import Yesod.Static
+import Yesod.Auth
+import Yesod.Auth.HashDB (authHashDB, HashDBUser(..), getAuthIdHashDB, setPassword)
+import Yesod.Default.Config
+import Yesod.Default.Util (addStaticContentExternal)
+import Yesod.Logger (Logger, logMsg, formatLogText)
+import Control.Monad (join)
+import Data.Maybe (isJust, fromJust)
+import Data.Time.Clock (getCurrentTime)
+import Data.Traversable (traverse)
+import Network.HTTP.Conduit (Manager)
+import qualified Settings
+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
+    , getLogger :: Logger
+    , 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
+
+    messageLogger y loc level msg =
+      formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)
+
+    -- 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
+
+    -- isAuthorized MeR _ = return AuthenticationRequired
+    isAuthorized _ _ = return Authorized
+
+-- 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 = getAuthIdHashDB AuthR (Just . UniqueUser)
+
+    authPlugins _ = [authHashDB (Just . UniqueUser)]
+
+    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
+
+
+instance HashDBUser (UserGeneric backend) where
+    userPasswordHash = Just . userPassword
+    userPasswordSalt = Just . userSalt
+    setSaltAndPasswordHash s h u = u { userSalt     = s
+                                     , userPassword = h
+                                     }
+
+-- 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
+
+{-
+    getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
+    setVerifyKey eid key = runDB $ update eid [EmailVerkey =. Just key]
+    verifyAccount eid = runDB $ do
+        me <- get eid
+        case me of
+            Nothing -> return Nothing
+            Just e -> do
+	        now <- liftIO $ getCurrentTime
+                update eid [EmailVerkey =. Nothing, EmailLastverified =. Just now]
+                return $ emailUser e
+    getPassword = runDB . fmap (join . fmap userPassword) . get
+    setPassword uid pass = runDB $ update uid [UserPassword =. Just pass]
+    getEmailCreds email = runDB $ do
+        me <- getBy $ UniqueEmail email
+        mu <- fmap join . traverse get $ (emailUser . entityVal =<< me)
+        case mu of
+            Nothing -> return Nothing
+            Just u -> return $ Just EmailCreds
+                { emailCredsId = entityKey . fromJust $ me
+                , emailCredsAuthId = emailUser . entityVal =<< me
+                , emailCredsStatus = isJust $ userPassword u
+                , emailCredsVerkey = emailVerkey . entityVal . fromJust $ me
+                }
+    getEmail = runDB . fmap (fmap emailEmail) . get
+-}