summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Application.hs182
-rw-r--r--Foundation.hs129
-rw-r--r--Handler/CartItem.hs1
-rw-r--r--Handler/Common.hs16
-rw-r--r--Handler/ImageDelete.hs7
-rw-r--r--Handler/ImageList.hs11
-rw-r--r--Handler/ShopAdmin.hs1
-rw-r--r--Import.hs46
-rw-r--r--Model.hs8
-rw-r--r--Settings.hs189
-rw-r--r--Settings/Development.hs14
-rw-r--r--Settings/StaticFiles.hs31
-rw-r--r--Shop/Image/Fields.hs2
-rw-r--r--Shop/Image/Functions.hs24
-rw-r--r--app/DevelMain.hs4
-rw-r--r--app/devel.hs6
-rw-r--r--app/main.hs9
-rw-r--r--app/tasks.hs55
-rw-r--r--config/keter.yml10
-rw-r--r--config/routes2
-rw-r--r--config/settings.yml46
-rw-r--r--config/test-settings.yml2
-rw-r--r--deploy/Procfile90
-rw-r--r--devel.hs32
-rw-r--r--mokupona.cabal60
-rw-r--r--templates/default-layout-wrapper.hamlet4
-rw-r--r--test/Handler/CommonSpec.hs17
-rw-r--r--test/Handler/HomeSpec.hs44
-rw-r--r--test/Spec.hs20
-rw-r--r--test/TestImport.hs42
30 files changed, 527 insertions, 577 deletions
diff --git a/Application.hs b/Application.hs
index 4be56b3..66064f9 100644
--- a/Application.hs
+++ b/Application.hs
@@ -1,31 +1,30 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
- ( makeApplication
- , getApplicationDev
+ ( getApplicationDev
+ , appMain
+ , develMain
, makeFoundation
) where
+import Control.Monad.Logger (liftLoc, runLoggingT)
+import Database.Persist.Sqlite (createSqlitePool, runSqlPool,
+ sqlDatabase, sqlPoolSize)
import Import
-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 Database.Persist.Sqlite (createSqlitePool, sqlDatabase, sqlPoolSize)
-import Network.HTTP.Client.Conduit (newManager)
-import Control.Monad.Logger (runLoggingT)
-import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
-import Network.Wai.Logger (clockDateCacher)
-import Data.Default (def)
-import Yesod.Core.Types (loggerSet, Logger (Logger))
+import Language.Haskell.TH.Syntax (qLocation)
+import Network.Wai.Handler.Warp (Settings, defaultSettings,
+ defaultShouldDisplayException,
+ runSettings, setHost,
+ setOnException, setPort)
+import Network.Wai.Middleware.RequestLogger (Destination (Logger),
+ IPAddrSource (..),
+ OutputFormat (..), destination,
+ mkRequestLogger, outputFormat)
+import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
+ toLogStr)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
+import Handler.Common
import Handler.Home
import Handler.Shop
import Handler.ShopList
@@ -48,68 +47,103 @@ import Handler.LoginPanel
-- 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
+-- | This function allocates resources (such as a database connection pool),
+-- performs initialization and return a foundation datatype value. 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
+makeFoundation :: AppSettings -> IO App
+makeFoundation appSettings = do
+ -- Some basic initializations: HTTP connection manager, logger, and static
+ -- subsite.
+ appHttpManager <- newManager
+ appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
+ appStatic <-
+ (if appMutableStatic appSettings then staticDevel else static)
+ (appStaticDir appSettings)
- -- Initialize the logging middleware
+ -- We need a log function to create a connection pool. We need a connection
+ -- pool to create our foundation. And we need our foundation to get a
+ -- logging function. To get out of this loop, we initially create a
+ -- temporary foundation without a real connection pool, get a log function
+ -- from there, and then create the real foundation.
+ let mkFoundation appConnPool = App {..}
+ tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
+ logFunc = messageLoggerSource tempFoundation appLogger
+
+ -- Create the database connection pool
+ pool <- flip runLoggingT logFunc $ createSqlitePool
+ (sqlDatabase $ appDatabaseConf appSettings)
+ (sqlPoolSize $ appDatabaseConf appSettings)
+
+ -- Perform database migration using our application's logging settings.
+ runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
+
+ -- Return the foundation
+ return $ mkFoundation pool
+
+-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
+-- applyng some additional middlewares.
+makeApplication :: App -> IO Application
+makeApplication foundation = do
logWare <- mkRequestLogger def
{ outputFormat =
- if development
+ if appDetailedRequestLogging $ appSettings foundation
then Detailed True
- else Apache FromSocket
- , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation
+ else Apache
+ (if appIpFromHeader $ appSettings foundation
+ then FromFallback
+ else FromSocket)
+ , destination = 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/sqlite.yml" (appEnv conf)
- Database.Persist.loadConfig >>=
- Database.Persist.applyEnv
-
- loggerSet' <- newStdoutLoggerSet defaultBufSize
- (getter, _) <- clockDateCacher
-
- let logger = Yesod.Core.Types.Logger loggerSet' getter
- mkFoundation p = App
- { settings = conf
- , getStatic = s
- , connPool = p
- , httpManager = manager
- , persistConfig = dbconf
- , appLogger = logger
- }
- tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
- logFunc = messageLoggerSource tempFoundation logger
+ appPlain <- toWaiAppPlain foundation
+ return $ logWare $ defaultMiddlewaresNoLogging appPlain
- p <- flip runLoggingT logFunc
- $ createSqlitePool (sqlDatabase dbconf) (sqlPoolSize dbconf)
- let foundation = mkFoundation p
+-- | Warp settings for the given foundation value.
+warpSettings :: App -> Settings
+warpSettings foundation =
+ setPort (appPort $ appSettings foundation)
+ $ setHost (appHost $ appSettings foundation)
+ $ setOnException (\_req e ->
+ when (defaultShouldDisplayException e) $ messageLoggerSource
+ foundation
+ (appLogger foundation)
+ $(qLocation >>= liftLoc)
+ "yesod"
+ LevelError
+ (toLogStr $ "Exception from Warp: " ++ show e))
+ defaultSettings
- -- Perform database migration using our application's logging settings.
- flip runLoggingT logFunc
- (Database.Persist.runPool dbconf (runMigration migrateAll) p)
-
- 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
- }
+-- | For yesod devel, return the Warp settings and WAI Application.
+getApplicationDev :: IO (Settings, Application)
+getApplicationDev = do
+ settings <- loadAppSettings [configSettingsYml] [] useEnv
+ foundation <- makeFoundation settings
+ app <- makeApplication foundation
+ wsettings <- getDevSettings $ warpSettings foundation
+ return (wsettings, app)
+
+-- | main function for use by yesod devel
+develMain :: IO ()
+develMain = develMainHelper getApplicationDev
+
+-- | The @main@ function for an executable running this site.
+appMain :: IO ()
+appMain = do
+ -- Get the settings from all relevant sources
+ settings <- loadAppSettingsArgs
+ -- fall back to compile-time values, set to [] to require values at runtime
+ [configSettingsYmlValue]
+
+ -- allow environment variables to override
+ useEnv
+
+ -- Generate the foundation from the settings
+ foundation <- makeFoundation settings
+
+ -- Generate a WAI Application from the foundation
+ app <- makeApplication foundation
+
+ -- Run the application with Warp
+ runSettings (warpSettings foundation) app
diff --git a/Foundation.hs b/Foundation.hs
index 0318f0c..1e3c0fe 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -1,32 +1,21 @@
{-# LANGUAGE NoCPP #-}
module Foundation where
-import Prelude
-import Yesod
-import Yesod.Static
-import Yesod.Auth
-import Yesod.Auth.Email
+import ClassyPrelude.Yesod
+import Database.Persist.Sql (ConnectionPool, runSqlPool)
import qualified Yesod.Auth.Message as AuthMsg
-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 (SqlBackend)
-import Settings.StaticFiles
-import Settings (widgetFile, Extra (..))
import Model
-import Text.Jasmine (minifym)
+import Settings
+import Settings.StaticFiles
import Text.Hamlet (hamletFile)
+import Text.Jasmine (minifym)
+import Yesod.Auth
+import Yesod.Auth.Email
import Yesod.Core.Types (Logger)
+import Yesod.Default.Util (addStaticContentExternal)
import Network.Mail.Mime
import Text.Shakespeare.Text (stext)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import Data.Maybe (isJust)
-import Control.Monad (join)
-import Data.Text
-import Data.Time (getCurrentTime)
import Text.Cassius (PixelSize (..))
import Shop.Unit.Types (Unit (..))
import Shop.Amount.Types (Amount (..))
@@ -34,21 +23,20 @@ import Shop.Quantity.Types (Quantity (..), toAmount)
import Yesod.Form.Bootstrap3
import qualified Database.Esqueleto as E
--- | The site argument for your application. This can be a good place to
+-- | The foundation datatype 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
+ { appSettings :: AppSettings
+ , appStatic :: Static -- ^ Settings for static file serving.
+ , appConnPool :: ConnectionPool -- ^ Database connection pool.
+ , appHttpManager :: Manager
+ , appLogger :: Logger
}
instance HasHttpManager App where
- getHttpManager = httpManager
+ getHttpManager = appHttpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
@@ -136,7 +124,7 @@ cartAmount userid = do
E.&&. si E.^. CartItemItem E.==. i E.^. ItemId
)
return (i, si)
- return $ Prelude.foldr addCart (Amount 0) cart
+ return $ foldr addCart (Amount 0) cart
where
addCart (ei, esi) = (+) $ quantityItemPrice (entityVal ei) (entityVal esi)
@@ -157,30 +145,30 @@ getCartId userid = runDB (getBy $ UniqueCustomer userid)
-- explanation for this split.
mkYesodData "App" $(parseRoutesFile "config/routes")
+-- | A convenient synonym for creating forms.
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
+ -- Controls the base of generated URLs. For more information on modifying,
+ -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
+ approot = ApprootMaster $ appRoot . appSettings
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
- 120 -- timeout in minutes
+ 120 -- timeout in minutes
"config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
- thumbnailHeight <- fmap
- (PixelSize . toRational . extraThumbnailHeight) getExtra
- thumbnailWidth <- fmap
- (PixelSize . toRational . extraThumbnailWidth) getExtra
- cartThumbnailHeight <- fmap
- (PixelSize . toRational . extraCartThumbnailHeight) getExtra
- cartThumbnailWidth <- fmap
- (PixelSize . toRational . extraCartThumbnailWidth) getExtra
+ let thumbnailHeight = PixelSize $ toRational $ appThumbnailHeight $ appSettings master
+ thumbnailWidth = PixelSize $ toRational $ appThumbnailWidth $ appSettings master
+ cartThumbnailHeight = PixelSize $ toRational $ appCartThumbnailHeight $ appSettings master
+ cartThumbnailWidth = PixelSize $ toRational $ appCartThumbnailWidth $ appSettings master
+
mauth <- maybeAuth
let wauth = do
@@ -240,12 +228,6 @@ instance Yesod App where
$(widgetFile "default-layout")
withUrlRenderer $(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 LoginPanelR
@@ -273,7 +255,6 @@ instance Yesod App where
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
@@ -281,31 +262,38 @@ instance Yesod App where
-- 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 [])
+ addStaticContent ext mime content = do
+ master <- getYesod
+ let staticDir = appStaticDir $ appSettings master
+ addStaticContentExternal
+ minifym
+ genFileName
+ staticDir
+ (StaticR . flip StaticRoute [])
+ ext
+ mime
+ content
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
+ genFileName lbs = "autogen-" ++ base64md5 lbs
-- 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
+ shouldLog app _source level =
+ appShouldLogAll (appSettings app)
+ || level == LevelWarn
+ || level == LevelError
makeLogger = return . appLogger
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlBackend
- runDB = defaultRunDB persistConfig connPool
-
+ runDB action = do
+ master <- getYesod
+ runSqlPool action $ appConnPool master
instance YesodPersistRunner App where
- getDBRunner = defaultGetDBRunner connPool
+ getDBRunner = defaultGetDBRunner appConnPool
instance YesodAuth App where
type AuthId App = UserId
@@ -314,13 +302,18 @@ instance YesodAuth App where
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest _ = HomeR
+ -- Override the above two destinations when a Referer: header is present
+ redirectToReferer _ = True
-- getAuthId creds = runDB $ do
- -- x <- getBy $ UniqueEmail $ credsIdent creds
+ -- x <- getBy $ UniqueUser $ credsIdent creds
-- case x of
-- Just (Entity uid _) -> return $ Just uid
-- Nothing -> do
- -- fmap Just $ insert $ User (credsIdent creds) Nothing Nothing Nothing False
+ -- fmap Just $ insert User
+ -- { userIdent = credsIdent creds
+ -- , userPassword = Nothing
+ -- }
-- Need to find the UserId for the given email address.
getAuthId creds = do
date <- liftIO getCurrentTime
@@ -333,7 +326,7 @@ instance YesodAuth App where
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authEmail]
- authHttpManager = httpManager
+ authHttpManager = getHttpManager
onLogin = setMessageILevel "alert-info" MsgNowLoggedIn
@@ -346,16 +339,14 @@ instance YesodAuthPersist App
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:
+-- Note: Some functionality previously present in the scaffolding has been
+-- moved to documentation in the Wiki. Following are some hopefully helpful
+-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
+-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
+-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
+
instance YesodAuthEmail App where
type AuthEmailId App = UserId
diff --git a/Handler/CartItem.hs b/Handler/CartItem.hs
index 9ed0c50..d7b1ee9 100644
--- a/Handler/CartItem.hs
+++ b/Handler/CartItem.hs
@@ -1,7 +1,6 @@
module Handler.CartItem where
import Import
-import Control.Monad (mplus, void)
import Shop.Quantity.Fields (cartField)
import Shop.Quantity.Types (Quantity (..))
diff --git a/Handler/Common.hs b/Handler/Common.hs
new file mode 100644
index 0000000..eadd206
--- /dev/null
+++ b/Handler/Common.hs
@@ -0,0 +1,16 @@
+-- | Common handler functions.
+module Handler.Common where
+
+import Data.FileEmbed (embedFile)
+import Import
+
+-- These handlers embed files in the executable at compile time to avoid a
+-- runtime dependency, and for efficiency.
+
+getFaviconR :: Handler TypedContent
+getFaviconR = return $ TypedContent "image/x-icon"
+ $ toContent $(embedFile "config/favicon.ico")
+
+getRobotsR :: Handler TypedContent
+getRobotsR = return $ TypedContent typePlain
+ $ toContent $(embedFile "config/robots.txt")
diff --git a/Handler/ImageDelete.hs b/Handler/ImageDelete.hs
index 1cc525b..72155fc 100644
--- a/Handler/ImageDelete.hs
+++ b/Handler/ImageDelete.hs
@@ -2,7 +2,6 @@ module Handler.ImageDelete where
import Import
import Shop.Image.Functions (imageExists, removeImage)
-import Control.Monad (when)
getImageDeleteR :: UserId -> ImageId -> Handler Html
getImageDeleteR userId imageId = do
@@ -14,9 +13,9 @@ getImageDeleteR userId imageId = do
postImageDeleteR :: UserId -> ImageId -> Handler Html
postImageDeleteR userId imageId = do
image <- runDB $ get404 imageId
- let filename = imageFilename image
+ let filename' = imageFilename image
runDB $ delete imageId
- fileExists <- imageExists filename
- when fileExists $ removeImage filename
+ fileExists <- imageExists filename'
+ when fileExists $ removeImage filename'
setMessageILevel "alert-danger" MsgImageDeleteSuccess
redirectUltDest $ ImageListR userId
diff --git a/Handler/ImageList.hs b/Handler/ImageList.hs
index 99bd775..0ae6f41 100644
--- a/Handler/ImageList.hs
+++ b/Handler/ImageList.hs
@@ -2,8 +2,6 @@ module Handler.ImageList where
import Import
import Shop.Image.Functions (writeToServer)
-import Control.Monad (when, void)
-import Data.Maybe (isJust)
data FormImage = FormImage
{ fiFile :: FileInfo
@@ -34,10 +32,11 @@ addImage userId = do
((res, _), _) <- runFormPost imageForm
case res of
FormSuccess (FormImage file date) -> do
- twidth <- extraThumbnailWidth <$> getExtra
- theight <- extraThumbnailHeight <$> getExtra
- filename <- writeToServer file twidth theight
- void $ runDB $ insert $ Image filename date userId
+ master <- getYesod
+ let twidth = appThumbnailWidth $ appSettings master
+ theight = appThumbnailHeight $ appSettings master
+ filename' <- writeToServer file twidth theight
+ void $ runDB $ insert $ Image filename' date userId
setMessageILevel "alert-success" MsgImageAddSuccess
redirectUltDest $ ImageListR userId
_ -> defaultLayout $ do
diff --git a/Handler/ShopAdmin.hs b/Handler/ShopAdmin.hs
index 6025b4c..fae37cb 100644
--- a/Handler/ShopAdmin.hs
+++ b/Handler/ShopAdmin.hs
@@ -6,7 +6,6 @@ import Shop.Image.Functions (getImageId)
import Shop.Image.Fields (selectImageField, bootstrapFileField)
import Shop.Amount.Fields (amountField)
import Shop.Amount.Types (Amount (..))
-import Control.Monad (void)
import Shop.Quantity.Types (Quantity (..))
import Shop.Quantity.Fields (quantityField)
diff --git a/Import.hs b/Import.hs
index cb6a0f1..b745d52 100644
--- a/Import.hs
+++ b/Import.hs
@@ -2,36 +2,16 @@ 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, pack)
-
-import Foundation as Import
-import Model as Import
-import Settings as Import
-import Settings.Development as Import
-import Settings.StaticFiles as Import
-import Data.Time as Import ( UTCTime
- , getCurrentTime
- , NominalDiffTime
- , diffUTCTime
- , addUTCTime
- )
-import Yesod.Auth as Import (maybeAuth, maybeAuthId)
-import Yesod.Form.Bootstrap3 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
+import ClassyPrelude.Yesod as Import
+import Foundation as Import
+import Model as Import
+import Settings as Import
+import Settings.StaticFiles as Import
+import Yesod.Auth as Import
+import Yesod.Core.Types as Import (loggerSet)
+import Yesod.Default.Config2 as Import
+import Data.Time as Import ( NominalDiffTime
+ , diffUTCTime
+ , addUTCTime
+ )
+import Yesod.Form.Bootstrap3 as Import
diff --git a/Model.hs b/Model.hs
index 98a4d9a..f37d5a9 100644
--- a/Model.hs
+++ b/Model.hs
@@ -1,17 +1,11 @@
{-# LANGUAGE FlexibleInstances #-}
module Model where
-import Prelude
-import Yesod
-import Data.Text (Text)
+import ClassyPrelude.Yesod
import Database.Persist.Quasi
-import Data.Typeable (Typeable)
-import Data.Time (UTCTime)
import Shop.Unit.Types (Unit)
import Shop.Amount.Types (Amount)
import Shop.Quantity.Types (Quantity)
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad (mzero)
import Data.Aeson ((.:?))
-- You can define all of your database entities in the entities file.
diff --git a/Settings.hs b/Settings.hs
index 3f55538..e20261b 100644
--- a/Settings.hs
+++ b/Settings.hs
@@ -5,29 +5,92 @@
-- declared in the Foundation.hs file.
module Settings where
-import Prelude
-import Text.Shakespeare.Text (st)
-import Language.Haskell.TH.Syntax
-import Database.Persist.Sqlite (SqliteConf)
-import Yesod.Default.Config
-import Yesod.Default.Util
-import Data.Text (Text)
-import Data.Yaml
-import Control.Applicative
-import Settings.Development
-import Data.Default (def)
-import Text.Hamlet
-import Yesod.Core.Content (ContentType)
-
--- | Which Persistent backend this site is using.
-type PersistConf = SqliteConf
-
--- Static setting below. Changing these requires a recompile
-
--- | The location of static files on your system. This is a file system
--- path. The default value works properly with your scaffolded site.
-staticDir :: FilePath
-staticDir = "static"
+import ClassyPrelude.Yesod
+import Control.Exception (throw)
+import Data.Aeson (Result (..), fromJSON, withObject, (.!=),
+ (.:?))
+import Data.FileEmbed (embedFile)
+import Data.Yaml (decodeEither')
+import Database.Persist.Sqlite (SqliteConf)
+import Language.Haskell.TH.Syntax (Exp, Name, Q)
+import Network.Wai.Handler.Warp (HostPreference)
+import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
+import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
+ widgetFileReload)
+
+-- | Runtime settings to configure this application. These settings can be
+-- loaded from various sources: defaults, environment variables, config files,
+-- theoretically even a database.
+data AppSettings = AppSettings
+ { appStaticDir :: String
+ -- ^ Directory from which to serve static files.
+ , appDatabaseConf :: SqliteConf
+ -- ^ Configuration settings for accessing the database.
+ , appRoot :: Text
+ -- ^ Base for all generated URLs.
+ , appHost :: HostPreference
+ -- ^ Host/interface the server should bind to.
+ , appPort :: Int
+ -- ^ Port to listen on
+ , appIpFromHeader :: Bool
+ -- ^ Get the IP address from the header when logging. Useful when sitting
+ -- behind a reverse proxy.
+
+ , appDetailedRequestLogging :: Bool
+ -- ^ Use detailed request logging system
+ , appShouldLogAll :: Bool
+ -- ^ Should all log messages be displayed?
+ , appReloadTemplates :: Bool
+ -- ^ Use the reload version of templates
+ , appMutableStatic :: Bool
+ -- ^ Assume that files in the static dir may change after compilation
+ , appSkipCombining :: Bool
+ -- ^ Perform no stylesheet/script combining
+
+ -- Example app-specific configuration values.
+ , appCopyright :: Text
+ -- ^ Copyright text to appear in the footer of the page
+ , appAnalytics :: Maybe Text
+ -- ^ Google Analytics code
+ , appThumbnailHeight :: Int
+ , appThumbnailWidth :: Int
+ , appCartThumbnailHeight :: Int
+ , appCartThumbnailWidth :: Int
+ , appCartExpiration :: Integer
+ , appMediaPath :: String
+ }
+
+instance FromJSON AppSettings where
+ parseJSON = withObject "AppSettings" $ \o -> do
+ let defaultDev =
+#if DEVELOPMENT
+ True
+#else
+ False
+#endif
+ appStaticDir <- o .: "static-dir"
+ appDatabaseConf <- o .: "database"
+ appRoot <- o .: "approot"
+ appHost <- fromString <$> o .: "host"
+ appPort <- o .: "port"
+ appIpFromHeader <- o .: "ip-from-header"
+
+ appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
+ appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
+ appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
+ appMutableStatic <- o .:? "mutable-static" .!= defaultDev
+ appSkipCombining <- o .:? "skip-combining" .!= defaultDev
+
+ appCopyright <- o .: "copyright"
+ appAnalytics <- o .:? "analytics"
+ appThumbnailHeight <- o .: "thumbnail-height"
+ appThumbnailWidth <- o .: "thumbnail-width"
+ appCartThumbnailHeight <- o .: "cart-thumbnail-height"
+ appCartThumbnailWidth <- o .: "cart-thumbnail-width"
+ appCartExpiration <- o .: "cart-expiration"
+ appMediaPath <- o .: "media-path"
+
+ return AppSettings {..}
imageExt :: Text
imageExt = "jpg"
@@ -35,22 +98,6 @@ imageExt = "jpg"
imageCT :: ContentType
imageCT = "image/jpeg"
--- | The base URL for your static files. As you can see by the default
--- value, this can simply be "static" appended to your application root.
--- A powerful optimization can be serving static files from a separate
--- domain name. This allows you to use a web server optimized for static
--- files, more easily set expires and cache values, and avoid possibly
--- costly transference of cookies on static files. For more information,
--- please see:
--- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain
---
--- If you change the resource pattern for StaticR in Foundation.hs, you will
--- have to make a corresponding change here.
---
--- To see how this value is used, see urlRenderOverride in Foundation.hs
-staticRoot :: AppConfig DefaultEnv x -> Text
-staticRoot conf = [st|#{appRoot conf}/static|]
-
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
@@ -59,37 +106,47 @@ staticRoot conf = [st|#{appRoot conf}/static|]
-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
- { wfsHamletSettings = defaultHamletSettings
- { hamletNewlines = AlwaysNewlines
- }
- }
+
+-- | How static files should be combined.
+combineSettings :: CombineSettings
+combineSettings = def
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
-widgetFile = (if development then widgetFileReload
- else widgetFileNoReload)
+widgetFile = (if appReloadTemplates compileTimeAppSettings
+ then widgetFileReload
+ else widgetFileNoReload)
widgetFileSettings
-data Extra = Extra
- { extraCopyright :: Text
- , extraAnalytics :: Maybe Text -- ^ Google Analytics
- , extraThumbnailHeight :: Int
- , extraThumbnailWidth :: Int
- , extraCartThumbnailHeight :: Int
- , extraCartThumbnailWidth :: Int
- , extraCartExpiration :: Integer
- , extraMediaPath :: FilePath
- } deriving Show
-
-parseExtra :: DefaultEnv -> Object -> Parser Extra
-parseExtra _ o = Extra
- <$> o .: "copyright"
- <*> o .:? "analytics"
- <*> o .: "thumbnail-height"
- <*> o .: "thumbnail-width"
- <*> o .: "cart-thumbnail-height"
- <*> o .: "cart-thumbnail-width"
- <*> o .: "cart-expiration"
- <*> o .: "media-path"
+-- | Raw bytes at compile time of @config/settings.yml@
+configSettingsYmlBS :: ByteString
+configSettingsYmlBS = $(embedFile configSettingsYml)
+
+-- | @config/settings.yml@, parsed to a @Value@.
+configSettingsYmlValue :: Value
+configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS
+
+-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
+compileTimeAppSettings :: AppSettings
+compileTimeAppSettings =
+ case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
+ Error e -> error e
+ Success settings -> settings
+
+-- The following two functions can be used to combine multiple CSS or JS files
+-- at compile time to decrease the number of http requests.
+-- Sample usage (inside a Widget):
+--
+-- > $(combineStylesheets 'StaticR [style1_css, style2_css])
+
+combineStylesheets :: Name -> [Route Static] -> Q Exp
+combineStylesheets = combineStylesheets'
+ (appSkipCombining compileTimeAppSettings)
+ combineSettings
+
+combineScripts :: Name -> [Route Static] -> Q Exp
+combineScripts = combineScripts'
+ (appSkipCombining compileTimeAppSettings)
+ combineSettings
diff --git a/Settings/Development.hs b/Settings/Development.hs
deleted file mode 100644
index 73613f0..0000000
--- a/Settings/Development.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Settings.Development where
-
-import Prelude
-
-development :: Bool
-development =
-#if DEVELOPMENT
- True
-#else
- False
-#endif
-
-production :: Bool
-production = not development
diff --git a/Settings/StaticFiles.hs b/Settings/StaticFiles.hs
index cb37905..9ee45fa 100644
--- a/Settings/StaticFiles.hs
+++ b/Settings/StaticFiles.hs
@@ -1,35 +1,10 @@
module Settings.StaticFiles where
-import Prelude (IO)
-import Yesod.Static
-import qualified Yesod.Static as Static
-import Settings (staticDir)
-import Settings.Development
-import Language.Haskell.TH (Q, Exp, Name)
-import Data.Default (def)
-
--- | use this to create your static file serving site
-staticSite :: IO Static.Static
-staticSite = if development then Static.staticDevel staticDir
- else Static.static staticDir
+import Settings (appStaticDir, compileTimeAppSettings)
+import Yesod.Static (staticFiles)
-- | This generates easy references to files in the static directory at compile time,
-- giving you compile-time verification that referenced files exist.
-- Warning: any files added to your static directory during run-time can't be
-- accessed this way. You'll have to use their FilePath or URL to access them.
-$(staticFiles Settings.staticDir)
-
-combineSettings :: CombineSettings
-combineSettings = def
-
--- The following two functions can be used to combine multiple CSS or JS files
--- at compile time to decrease the number of http requests.
--- Sample usage (inside a Widget):
---
--- > $(combineStylesheets 'StaticR [style1_css, style2_css])
-
-combineStylesheets :: Name -> [Route Static] -> Q Exp
-combineStylesheets = combineStylesheets' development combineSettings
-
-combineScripts :: Name -> [Route Static] -> Q Exp
-combineScripts = combineScripts' development combineSettings
+staticFiles (appStaticDir compileTimeAppSettings)
diff --git a/Shop/Image/Fields.hs b/Shop/Image/Fields.hs
index 65e6eb4..43f324d 100644
--- a/Shop/Image/Fields.hs
+++ b/Shop/Image/Fields.hs
@@ -2,9 +2,7 @@
module Shop.Image.Fields where
import Import
-import Data.Maybe (listToMaybe)
import Text.Julius (rawJS)
-import Control.Monad (unless)
selectImageField :: HandlerT App IO (OptionList ImageId)
-> Field (HandlerT App IO) ImageId
diff --git a/Shop/Image/Functions.hs b/Shop/Image/Functions.hs
index 69378a2..1ba08b6 100644
--- a/Shop/Image/Functions.hs
+++ b/Shop/Image/Functions.hs
@@ -11,16 +11,13 @@ import Filesystem.Path.CurrentOS ( encodeString
, decodeString
, fromText
, toText
- , (</>)
- , (<.>)
, FilePath
, dropExtensions
- , filename)
+ )
import System.Process ( readProcessWithExitCode )
import Filesystem ( removeFile, isFile )
import System.Exit ( ExitCode (..) )
import System.Random ( randomRIO )
-import Control.Monad ( replicateM )
import qualified Data.Text as T
writeToServer :: FileInfo -> Int -> Int -> Handler Text
@@ -28,7 +25,7 @@ writeToServer file twidth theight = do
path <- randomFileName
liftIO $ fileMove file $ encodeString path
let tpath = thumbnailFilePath path thumbext
- (errcode, _, stderr) <- liftIO $ imageResize path tpath twidth theight
+ (errcode, _, stderr') <- liftIO $ imageResize path tpath twidth theight
case errcode of
ExitSuccess ->
case (toText $ filename tpath) of
@@ -41,7 +38,7 @@ writeToServer file twidth theight = do
let err = "Error" `T.append` (pack $ show errno)
`T.append` " resizing image \""
`T.append` (pack $ encodeString path)
- `T.append` "\": " `T.append` pack stderr
+ `T.append` "\": " `T.append` pack stderr'
$logError err
error $ show err
where
@@ -49,7 +46,8 @@ writeToServer file twidth theight = do
imageFilePath :: Text -> Handler FilePath
imageFilePath f = do
- uploadDir <- extraMediaPath <$> getExtra
+ master <- getYesod
+ let uploadDir = appMediaPath $ appSettings master
return $ decodeString uploadDir </> fromText f
thumbnailFilePath :: FilePath -> Text -> FilePath
@@ -58,7 +56,7 @@ thumbnailFilePath filepath thumbext =
imageResize :: FilePath -> FilePath -> Int -> Int -> IO (ExitCode, String, String)
imageResize orig dest twidth theight = do
- res <- readProcessWithExitCode command options stdin
+ res <- readProcessWithExitCode command options stdin'
removeFile orig
return res
where
@@ -73,7 +71,7 @@ imageResize orig dest twidth theight = do
, encodeString orig
, encodeString dest
]
- stdin = ""
+ stdin' = ""
removeImage :: Text -> Handler ()
removeImage f = liftIO <$> removeFile =<< imageFilePath f
@@ -89,7 +87,8 @@ sendImage f = do
randomFileName :: Handler FilePath
randomFileName = do
base <- liftIO $ replicateM 32 (randomRIO ('a','z'))
- uploadDir <- extraMediaPath <$> getExtra
+ master <- getYesod
+ let uploadDir = appMediaPath $ appSettings master
return $ decodeString uploadDir </> decodeString base <.> imageExt
getImageId :: Maybe ImageId
@@ -100,8 +99,9 @@ getImageId :: Maybe ImageId
getImageId Nothing Nothing _ _ = return Nothing
getImageId (Just imageid) Nothing _ _ = return $ Just imageid
getImageId _ (Just fileinfo) userid date = do
- twidth <- fmap extraThumbnailWidth getExtra
- theight <- fmap extraThumbnailHeight getExtra
+ master <- getYesod
+ let twidth = appThumbnailWidth $ appSettings master
+ theight = appThumbnailHeight $ appSettings master
filename' <- writeToServer fileinfo twidth theight
imageid <- runDB $ insert $ Image filename' date userid
return $ Just imageid
diff --git a/app/DevelMain.hs b/app/DevelMain.hs
index 52d54f1..bf62187 100644
--- a/app/DevelMain.hs
+++ b/app/DevelMain.hs
@@ -63,6 +63,6 @@ update = do
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
- (port,app) <- getApplicationDev
- forkIO (finally (runSettings (setPort port defaultSettings) app)
+ (settings,app) <- getApplicationDev
+ forkIO (finally (runSettings settings app)
(putMVar done ()))
diff --git a/app/devel.hs b/app/devel.hs
new file mode 100644
index 0000000..dc2c24c
--- /dev/null
+++ b/app/devel.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PackageImports #-}
+import "mokupona" Application (develMain)
+import Prelude (IO)
+
+main :: IO ()
+main = develMain
diff --git a/app/main.hs b/app/main.hs
index 7c6327f..4ffa93d 100644
--- a/app/main.hs
+++ b/app/main.hs
@@ -1,8 +1,5 @@
-import Prelude (IO)
-import Yesod.Default.Config (fromArgs)
-import Yesod.Default.Main (defaultMainLog)
-import Settings (parseExtra)
-import Application (makeApplication)
+import Prelude (IO)
+import Application (appMain)
main :: IO ()
-main = defaultMainLog (fromArgs parseExtra) makeApplication
+main = appMain
diff --git a/app/tasks.hs b/app/tasks.hs
index b39d1ee..d323b64 100644
--- a/app/tasks.hs
+++ b/app/tasks.hs
@@ -1,11 +1,12 @@
-import Import
-import Yesod.Default.Config
+import Control.Monad.Logger (liftLoc, runLoggingT)
+-- import Control.Monad.Logger (runStdoutLoggingT)
+import Control.Monad.Trans.Resource (runResourceT)
+import Database.Persist.Sqlite (createSqlitePool, runSqlPool,
+ sqlDatabase, sqlPoolSize)
+import Import
+import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
+ toLogStr)
import qualified Database.Persist
-import Settings
-import Model
-import Control.Monad.Trans.Resource (runResourceT)
-import Control.Monad.Logger (runStdoutLoggingT)
-import Control.Monad (forM_)
import qualified Database.Esqueleto as E
runQueries now expiration = do
@@ -23,18 +24,38 @@ runQueries now expiration = do
Database.Persist.update (cartItemItem $ entityVal ci) [ItemStock +=. (cartItemQuantity $ entityVal ci)]
Database.Persist.delete $ entityKey ci
Database.Persist.delete $ entityKey cart
- $(logInfo) $ pack $ "Deleted cart: " ++ (show $ userEmail $ entityVal user)
+ $(logInfo) $ pack $ "Deleted cart: " Prelude.++ (show $ userEmail $ entityVal user)
return ()
main :: IO ()
main = do
- conf <- fromArgs parseExtra
+ -- Get the settings from all relevant sources
+ settings <- loadAppSettingsArgs
+ -- fall back to compile-time values, set to [] to require values at runtime
+ [configSettingsYmlValue]
+
+ -- allow environment variables to override
+ useEnv
+
+ -- Some basic initializations: HTTP connection manager, logger, and static
+ -- subsite.
+ appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
+
now <- getCurrentTime
- dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
- Database.Persist.loadConfig >>=
- Database.Persist.applyEnv
- p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
-
- -- TODO defaultMainLog
- let expiration = fromInteger $ extraCartExpiration $ appExtra $ conf
- runStdoutLoggingT $ runResourceT $ Database.Persist.runPool dbconf (runQueries now expiration) p
+
+ -- We need a log function to create a connection pool. We need a connection
+ -- pool to create our foundation. And we need our foundation to get a
+ -- logging function. To get out of this loop, we initially create a
+ -- temporary foundation without a real connection pool, get a log function
+ -- from there, and then create the real foundation.
+ let mkFoundation appConnPool = App {..}
+ tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
+ logFunc = messageLoggerSource tempFoundation appLogger
+
+ -- Create the database connection pool
+ pool <- flip runLoggingT logFunc $ createSqlitePool
+ (sqlDatabase $ appDatabaseConf settings)
+ (sqlPoolSize $ appDatabaseConf settings)
+
+ let expiration = fromInteger $ appCartExpiration $ settings
+ runLoggingT (runSqlPool (runQueries now expiration) pool) logFunc
diff --git a/config/keter.yml b/config/keter.yml
index 9e0bca7..0015c67 100644
--- a/config/keter.yml
+++ b/config/keter.yml
@@ -12,7 +12,7 @@ stanzas:
# Name of your executable. You are unlikely to need to change this.
# Note that all file paths are relative to the keter.yml file.
- exec: ../dist/build/PROJECTNAME/PROJECTNAME
+ exec: ../dist/build/mokupona/mokupona
# Command line options passed to your application.
args:
@@ -22,7 +22,7 @@ stanzas:
# You can specify one or more hostnames for your application to respond
# to. The primary hostname will be used for generating your application
# root.
- - www.PROJECTNAME.com
+ - www.mokupona.com
# Enable to force Keter to redirect to https
# Can be added to any stanza
@@ -31,7 +31,7 @@ stanzas:
# Static files.
- type: static-files
hosts:
- - static.PROJECTNAME.com
+ - static.mokupona.com
root: ../static
# Uncomment to turn on directory listings.
@@ -41,9 +41,9 @@ stanzas:
- type: redirect
hosts:
- - PROJECTNAME.com
+ - mokupona.com
actions:
- - host: www.PROJECTNAME.com
+ - host: www.mokupona.com
# secure: false
# port: 80
diff --git a/config/routes b/config/routes
index 704c92b..b1b35ac 100644
--- a/config/routes
+++ b/config/routes
@@ -1,4 +1,4 @@
-/static StaticR Static getStatic
+/static StaticR Static appStatic
/auth AuthR Auth getAuth
/favicon.ico FaviconR GET
diff --git a/config/settings.yml b/config/settings.yml
index 4048847..e8af51a 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -1,25 +1,29 @@
-Default: &defaults
- host: "*4" # any IPv4 host
- port: 3000
- approot: "http://localhost:3000"
- copyright: site design © 2013-2014 Félix Sipma
- thumbnail-height: 140
- thumbnail-width: 140
- cart-thumbnail-height: 70
- cart-thumbnail-width: 70
- cart-expiration: 1800
- media-path: "media"
- #analytics: UA-YOURCODE
+static-dir: "_env:STATIC_DIR:static"
+host: "_env:HOST:*4" # any IPv4 host
+port: "_env:PORT:3000"
+approot: "_env:APPROOT:http://localhost:3000"
+ip-from-header: "_env:IP_FROM_HEADER:false"
-Development:
- <<: *defaults
+thumbnail-height: 140
+thumbnail-width: 140
+cart-thumbnail-height: 70
+cart-thumbnail-width: 70
+cart-expiration: 1800
+media-path: "media"
-Testing:
- <<: *defaults
+# Optional values with the following production defaults.
+# In development, they default to the inverse.
+#
+# development: false
+# detailed-logging: false
+# should-log-all: false
+# reload-templates: false
+# mutable-static: false
+# skip-combining: false
-Staging:
- <<: *defaults
+database:
+ database: "_env:SQLITE_DATABASE:mokupona.sqlite3"
+ poolsize: "_env:SQLITE_POOLSIZE:10"
-Production:
- #approot: "http://www.example.com"
- <<: *defaults
+copyright: site design © 2013-2014 Félix Sipma
+#analytics: UA-YOURCODE
diff --git a/config/test-settings.yml b/config/test-settings.yml
new file mode 100644
index 0000000..8ff94d4
--- /dev/null
+++ b/config/test-settings.yml
@@ -0,0 +1,2 @@
+database:
+ database: mokupona_test.sqlite3
diff --git a/deploy/Procfile b/deploy/Procfile
deleted file mode 100644
index e4231c1..0000000
--- a/deploy/Procfile
+++ /dev/null
@@ -1,90 +0,0 @@
-# Free deployment to Heroku.
-#
-# !! Warning: You must use a 64 bit machine to compile !!
-#
-# This could mean using a virtual machine. Give your VM as much memory as you can to speed up linking.
-#
-# Basic Yesod setup:
-#
-# * Move this file out of the deploy directory and into your root directory
-#
-# mv deploy/Procfile ./
-#
-# * Create an empty package.json
-# echo '{ "name": "mokupona", "version": "0.0.1", "dependencies": {} }' >> package.json
-#
-# Postgresql Yesod setup:
-#
-# * add dependencies on the "heroku", "aeson" and "unordered-containers" packages in your cabal file
-#
-# * add code in Application.hs to use the heroku package and load the connection parameters.
-# The below works for Postgresql.
-#
-# import Data.HashMap.Strict as H
-# import Data.Aeson.Types as AT
-# #ifndef DEVELOPMENT
-# import qualified Web.Heroku
-# #endif
-#
-#
-#
-# makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App
-# makeFoundation conf setLogger = do
-# manager <- newManager def
-# s <- staticSite
-# hconfig <- loadHerokuConfig
-# dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
-# (Database.Persist.Store.loadConfig . combineMappings hconfig) >>=
-# Database.Persist.Store.applyEnv
-# p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
-# Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
-# return $ App conf setLogger s p manager dbconf
-#
-# #ifndef DEVELOPMENT
-# canonicalizeKey :: (Text, val) -> (Text, val)
-# canonicalizeKey ("dbname", val) = ("database", val)
-# canonicalizeKey pair = pair
-#
-# toMapping :: [(Text, Text)] -> AT.Value
-# toMapping xs = AT.Object $ M.fromList $ map (\(key, val) -> (key, AT.String val)) xs
-# #endif
-#
-# combineMappings :: AT.Value -> AT.Value -> AT.Value
-# combineMappings (AT.Object m1) (AT.Object m2) = AT.Object $ m1 `M.union` m2
-# combineMappings _ _ = error "Data.Object is not a Mapping."
-#
-# loadHerokuConfig :: IO AT.Value
-# loadHerokuConfig = do
-# #ifdef DEVELOPMENT
-# return $ AT.Object M.empty
-# #else
-# Web.Heroku.dbConnParams >>= return . toMapping . map canonicalizeKey
-# #endif
-
-
-
-# Heroku setup:
-# Find the Heroku guide. Roughly:
-#
-# * sign up for a heroku account and register your ssh key
-# * create a new application on the *cedar* stack
-#
-# * make your Yesod project the git repository for that application
-# * create a deploy branch
-#
-# git checkout -b deploy
-#
-# Repeat these steps to deploy:
-# * add your web executable binary (referenced below) to the git repository
-#
-# git checkout deploy
-# git add ./dist/build/mokupona/mokupona
-# git commit -m deploy
-#
-# * push to Heroku
-#
-# git push heroku deploy:master
-
-
-# Heroku configuration that runs your app
-web: ./dist/build/mokupona/mokupona production -p $PORT
diff --git a/devel.hs b/devel.hs
deleted file mode 100644
index df61e3a..0000000
--- a/devel.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PackageImports #-}
-import "mokupona" Application (getApplicationDev)
-import Network.Wai.Handler.Warp
- (runSettings, defaultSettings, setPort)
-import Control.Concurrent (forkIO)
-import System.Directory (doesFileExist, removeFile)
-import System.Exit (exitSuccess)
-import Control.Concurrent (threadDelay)
-
-#ifndef mingw32_HOST_OS
-import System.Posix.Signals (installHandler, sigINT, Handler(Catch))
-#endif
-
-main :: IO ()
-main = do
-#ifndef mingw32_HOST_OS
- _ <- installHandler sigINT (Catch $ return ()) Nothing
-#endif
- putStrLn "Starting devel application"
- (port, app) <- getApplicationDev
- forkIO $ runSettings (setPort port defaultSettings) app
- loop
-
-loop :: IO ()
-loop = do
- threadDelay 100000
- e <- doesFileExist "yesod-devel/devel-terminate"
- if e then terminateDevel else loop
-
-terminateDevel :: IO ()
-terminateDevel = exitSuccess
diff --git a/mokupona.cabal b/mokupona.cabal
index 43ef571..60f879b 100644
--- a/mokupona.cabal
+++ b/mokupona.cabal
@@ -18,7 +18,7 @@ library
Model
Settings
Settings.StaticFiles
- Settings.Development
+ Handler.Common
Handler.Home
Handler.Shop
Handler.ShopList
@@ -64,18 +64,22 @@ library
DeriveDataTypeable
ViewPatterns
TupleSections
+ RecordWildCards
build-depends: base >= 4 && < 5
- , yesod >= 1.4.0 && < 1.5
+ , yesod >= 1.4.1 && < 1.5
, yesod-core >= 1.4.0 && < 1.5
, yesod-auth >= 1.4.0 && < 1.5
- , yesod-static >= 1.4.0 && < 1.5
+ , yesod-static >= 1.4.0.3 && < 1.5
, yesod-form >= 1.4.0 && < 1.5
+ , classy-prelude >= 0.10.2
+ , classy-prelude-conduit >= 0.10.2
+ , classy-prelude-yesod >= 0.10.2
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
- , persistent >= 2.1 && < 3
- , persistent-sqlite >= 2.1 && < 3
- , persistent-template >= 2.1 && < 3
+ , persistent >= 2.1 && < 2.2
+ , persistent-sqlite >= 2.1.1 && < 2.2
+ , persistent-template >= 2.1 && < 2.2
, template-haskell
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
@@ -91,30 +95,29 @@ library
, monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.2 && < 2.3
, wai-logger >= 2.2 && < 2.3
+ , file-embed
+ , safe
+ , unordered-containers
+ , containers
+ , vector
+ , time
, mime-mail >= 0.4.4.1
, blaze-markup >= 0.5.1.5
, blaze-html >= 0.6.1.1
, system-filepath >= 0.4.10
, system-fileio >= 0.3.12
- , time >= 1.4.0.1
, process >= 1.1.0.2
, random >= 1.0.1.1
, esqueleto >= 1.4.1
, foreign-store >= 0.1
- -- see https://github.com/yesodweb/yesod/issues/814
- if !os(windows)
- build-depends: unix
-
executable mokupona
if flag(library-only)
Buildable: False
main-is: main.hs
hs-source-dirs: app
- build-depends: base
- , mokupona
- , yesod
+ build-depends: base, mokupona
ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N
@@ -122,19 +125,24 @@ executable mokupona-tasks
if flag(library-only)
Buildable: False
+ main-is: tasks.hs
+ hs-source-dirs: app
+
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
- main-is: tasks.hs
- hs-source-dirs: app
- build-depends: base
- , mokupona
- , yesod
- , monad-logger
- , persistent
- , esqueleto
- , resourcet
- , text
+ RecordWildCards
+
+ build-depends: base >= 4 && < 5
+ , yesod >= 1.4.1 && < 1.5
+ , monad-logger >= 0.3 && < 0.4
+ , persistent >= 2.1 && < 2.2
+ , persistent-sqlite >= 2.1.1 && < 2.2
+ , fast-logger >= 2.2 && < 2.3
+ , text >= 0.11 && < 2.0
+ , esqueleto >= 1.4.1
+ , mokupona
+ , resourcet
ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N
@@ -162,7 +170,7 @@ test-suite test
build-depends: base
, mokupona
- , yesod-test >= 1.4 && < 1.5
+ , yesod-test >= 1.4.2 && < 1.5
, yesod-core
, yesod
, persistent
@@ -171,3 +179,5 @@ test-suite test
, monad-logger
, transformers
, hspec
+ , classy-prelude
+ , classy-prelude-yesod
diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet
index 79c43aa..8eb0605 100644
--- a/templates/default-layout-wrapper.hamlet
+++ b/templates/default-layout-wrapper.hamlet
@@ -26,9 +26,9 @@ $newline never
^{pageBody pc}
<div class="container">
<div class="footer">
- #{extraCopyright $ appExtra $ settings master}
+ #{appCopyright $ appSettings master}
- $maybe analytics <- extraAnalytics $ appExtra $ settings master
+ $maybe analytics <- appAnalytics $ appSettings master
<script>
if(!window.location.href.match(/localhost/)){
window._gaq = [['_setAccount','#{analytics}'],['_trackPageview'],['_trackPageLoadTime']];
diff --git a/test/Handler/CommonSpec.hs b/test/Handler/CommonSpec.hs
new file mode 100644
index 0000000..e1920fb
--- /dev/null
+++ b/test/Handler/CommonSpec.hs
@@ -0,0 +1,17 @@
+module Handler.CommonSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+ describe "robots.txt" $ do
+ it "gives a 200" $ do
+ get RobotsR
+ statusIs 200
+ it "has correct User-agent" $ do
+ get RobotsR
+ bodyContains "User-agent: *"
+ describe "favicon.ico" $ do
+ it "gives a 200" $ do
+ get FaviconR
+ statusIs 200
diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs
index fd042d1..2b6abbe 100644
--- a/test/Handler/HomeSpec.hs
+++ b/test/Handler/HomeSpec.hs
@@ -1,26 +1,32 @@
-module Handler.HomeSpec
- ( spec
- ) where
+module Handler.HomeSpec (spec) where
import TestImport
spec :: Spec
- ydescribe "These are some example tests" $ do
+spec = withApp $ do
+ it "loads the index and checks it looks right" $ do
+ get HomeR
+ statusIs 200
+ htmlAllContain "h1" "Welcome to Yesod"
- yit "loads the index and checks it looks right" $ do
- get HomeR
- statusIs 200
- htmlAllContain "h1" "Hello"
+ request $ do
+ setMethod "POST"
+ setUrl HomeR
+ addNonce
+ fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
+ byLabel "What's on the file?" "Some Content"
- request $ do
- setMethod "POST"
- setUrl HomeR
- addNonce
- fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
- byLabel "What's on the file?" "Some Content"
+ statusIs 200
+ -- more debugging printBody
+ htmlCount ".message" 1
+ htmlAllContain ".message" "Some Content"
+ htmlAllContain ".message" "text/plain"
- statusIs 200
- -- more debugging printBody
- htmlCount ".message" 1
- htmlAllContain ".message" "Some Content"
- htmlAllContain ".message" "text/plain"
+ -- This is a simple example of using a database access in a test. The
+ -- test will succeed for a fresh scaffolded site with an empty database,
+ -- but will fail on an existing database with a non-empty user table.
+ it "leaves the user table empty" $ do
+ get HomeR
+ statusIs 200
+ users <- runDB $ selectList ([] :: [Filter User]) []
+ assertEqual "user table empty" 0 $ length users
diff --git a/test/Spec.hs b/test/Spec.hs
index d179e28..a824f8c 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,19 +1 @@
-module Main where
-
-import Import
-import Yesod.Default.Config
-import Yesod.Test
-import Test.Hspec (hspec)
-import Application (makeFoundation)
-
-import qualified Handler.HomeSpec
-
-main :: IO ()
-main = do
- conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing)
- { csParseExtra = parseExtra
- }
- foundation <- makeFoundation conf
- hspec $ do
- yesodSpec foundation $ do
- Handler.HomeSpec.spec
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/test/TestImport.hs b/test/TestImport.hs
index aafaf47..bd647a6 100644
--- a/test/TestImport.hs
+++ b/test/TestImport.hs
@@ -1,27 +1,27 @@
module TestImport
- ( module Yesod.Test
- , module Model
- , module Foundation
- , module Database.Persist
- , module Prelude
- , runDB
- , Spec
- , Example
+ ( module TestImport
+ , module X
) where
-import Yesod.Test
-import Database.Persist hiding (get)
-import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool)
-import Control.Monad.IO.Class (liftIO)
-import Prelude
+import Application (makeFoundation)
+import ClassyPrelude as X
+import Database.Persist as X hiding (get)
+import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool)
+import Foundation as X
+import Model as X
+import Test.Hspec as X
+import Yesod.Default.Config2 (ignoreEnv, loadAppSettings)
+import Yesod.Test as X
-import Foundation
-import Model
-
-type Spec = YesodSpec App
-type Example = YesodExample App
-
-runDB :: SqlPersistM a -> Example a
+runDB :: SqlPersistM a -> YesodExample App a
runDB query = do
- pool <- fmap connPool getTestYesod
+ pool <- fmap appConnPool getTestYesod
liftIO $ runSqlPersistMPool query pool
+
+withApp :: SpecWith App -> Spec
+withApp = before $ do
+ settings <- loadAppSettings
+ ["config/test-settings.yml", "config/settings.yml"]
+ []
+ ignoreEnv
+ makeFoundation settings