Fisrt commit

.dir-locals.el

@@ -0,0 +1,4 @@
+((haskell-mode . ((haskell-indent-spaces . 4)
+                  (haskell-process-use-ghci . t)))
+ (hamlet-mode . ((hamlet/basic-offset . 4)
+                 (haskell-process-use-ghci . t))))

.ghci

@@ -0,0 +1,3 @@
+:set -i.:config:dist/build/autogen
+:set -DDEVELOPMENT
+:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable

.gitignore

@@ -0,0 +1,14 @@
+dist*
+static/tmp/
+static/combined/
+config/client_session_key.aes
+*.hi
+*.o
+*.sqlite3
+.hsenv*
+cabal-dev/
+yesod-devel/
+.cabal-sandbox
+cabal.sandbox.config
+.DS_Store
+*.swp

Application.hs

@@ -0,0 +1,101 @@
+{-# 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
+    ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
+    )
+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
+import qualified Database.Persist
+import Database.Persist.Sql (runMigration)
+import Network.HTTP.Client.Conduit (newManager)
+import Control.Monad.Logger (runLoggingT)
+import Control.Concurrent (forkIO, threadDelay)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
+import Network.Wai.Logger (clockDateCacher)
+import Data.Default (def)
+import Yesod.Core.Types (loggerSet, Logger (Logger))
+
+-- 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, LogFunc)
+makeApplication conf = do
+    foundation <- makeFoundation conf
+
+    -- Initialize the logging middleware
+    logWare <- mkRequestLogger def
+        { outputFormat =
+            if development
+                then Detailed True
+                else Apache FromSocket
+        , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation
+        }
+
+    -- Create the WAI application and apply middlewares
+    app <- toWaiAppPlain foundation
+    let logFunc = messageLoggerSource foundation (appLogger foundation)
+    return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
+
+-- | Loads up any necessary settings, creates your foundation datatype, and
+-- performs some initialization.
+makeFoundation :: AppConfig DefaultEnv Extra -> IO App
+makeFoundation conf = do
+    manager <- newManager
+    s <- staticSite
+    dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
+              Database.Persist.loadConfig >>=
+              Database.Persist.applyEnv
+    p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
+
+    loggerSet' <- newStdoutLoggerSet defaultBufSize
+    (getter, updater) <- clockDateCacher
+
+    -- If the Yesod logger (as opposed to the request logger middleware) is
+    -- used less than once a second on average, you may prefer to omit this
+    -- thread and use "(updater >> getter)" in place of "getter" below.  That
+    -- would update the cache every time it is used, instead of every second.
+    let updateLoop = do
+            threadDelay 1000000
+            updater
+            flushLogStr loggerSet'
+            updateLoop
+    _ <- forkIO updateLoop
+
+    let logger = Yesod.Core.Types.Logger loggerSet' getter
+        foundation = App conf s p manager dbconf logger
+
+    -- Perform database migration using our application's logging settings.
+    runLoggingT
+        (Database.Persist.runPool dbconf (runMigration migrateAll) p)
+        (messageLoggerSource foundation logger)
+
+    return foundation
+
+-- for yesod devel
+getApplicationDev :: IO (Int, Application)
+getApplicationDev =
+    defaultDevelApp loader (fmap fst . makeApplication)
+  where
+    loader = Yesod.Default.Config.loadConfig (configSettings Development)
+        { csParseExtra = parseExtra
+        }

Foundation.hs

@@ -0,0 +1,156 @@
+module Foundation where
+
+import Prelude
+import Yesod
+import Yesod.Static
+import Yesod.Auth
+import Yesod.Auth.BrowserId
+import Yesod.Default.Config
+import Yesod.Default.Util (addStaticContentExternal)
+import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
+import qualified Settings
+import Settings.Development (development)
+import qualified Database.Persist
+import Database.Persist.Sql (SqlPersistT)
+import Settings.StaticFiles
+import Settings (widgetFile, Extra (..))
+import Model
+import Text.Jasmine (minifym)
+import Text.Hamlet (hamletFile)
+import Yesod.Core.Types (Logger)
+
+-- | 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.PersistConfigPool Settings.PersistConf -- ^ Database connection pool.
+    , httpManager :: Manager
+    , persistConfig :: Settings.PersistConf
+    , appLogger :: Logger
+    }
+
+instance HasHttpManager App where
+    getHttpManager = httpManager
+
+-- 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/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")
+
+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
+    approot = ApprootMaster $ appRoot . settings
+
+    -- Store session data on the client in encrypted cookies,
+    -- default session idle timeout is 120 minutes
+    makeSessionBackend _ = fmap 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
+            $(combineStylesheets 'StaticR
+                [ css_normalize_css
+                , css_bootstrap_css
+                ])
+            $(widgetFile "default-layout")
+        giveUrlRenderer $(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 genFileName Settings.staticDir (StaticR . flip StaticRoute [])
+      where
+        -- Generate a unique filename based on the content itself
+        genFileName lbs
+            | development = "autogen-" ++ base64md5 lbs
+            | otherwise   = base64md5 lbs
+
+    -- 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
+
+    makeLogger = return . appLogger
+
+-- How to run database actions.
+instance YesodPersist App where
+    type YesodPersistBackend App = SqlPersistT
+    runDB = defaultRunDB persistConfig connPool
+instance YesodPersistRunner App where
+    getDBRunner = defaultGetDBRunner connPool
+
+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
+                    { userIdent = credsIdent creds
+                    , userPassword = Nothing
+                    }
+
+    -- You can add other plugins like BrowserID, email or OAuth here
+    authPlugins _ = [authBrowserId def]
+
+    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

Handler/Home.hs

@@ -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 Html
+getHomeR = do
+    (formWidget, formEnctype) <- generateFormPost sampleForm
+    let submission = Nothing :: Maybe (FileInfo, Text)
+        handlerName = "getHomeR" :: Text
+    defaultLayout $ do
+        aDomId <- newIdent
+        setTitle "Welcome To Yesod!"
+        $(widgetFile "homepage")
+
+postHomeR :: Handler Html
+postHomeR = do
+    ((result, formWidget), formEnctype) <- runFormPost sampleForm
+    let handlerName = "postHomeR" :: Text
+        submission = case result of
+            FormSuccess res -> Just res
+            _ -> Nothing
+
+    defaultLayout $ do
+        aDomId <- 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

Import.hs

@@ -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

Model.hs

@@ -0,0 +1,13 @@
+module Model where
+
+import Yesod
+import Data.Text (Text)
+import Database.Persist.Quasi
+import Data.Typeable (Typeable)
+
+-- 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 sqlOnlySettings, mkMigrate "migrateAll"]
+    $(persistFileWith lowerCaseSettings "config/models")