nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

transition to persistent > 2.0. still buggy

Browse source
This commit is contained in:
nek0 2014-12-23 05:01:53 +01:00
parent 465f331165
commit 4cf399413b
15 changed files with 374 additions and 221 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

167
Application.hs
View file

@ -1,29 +1,41 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application module Application
( makeApplication ( getApplicationDev
, getApplicationDev
, makeFoundation , makeFoundation
, develMain
, appMain
) where ) where
import Import import Import
import Settings import Settings
-- import Yesod.Auth import Yesod.Static
import Yesod.Default.Config import Yesod.Default.Config2
import Yesod.Default.Main import Yesod.Default.Main
import Yesod.Default.Handlers 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 qualified Database.Persist
import Database.Persist.Sql (runMigration) import Database.Persist.Sql (runMigration)
import Network.HTTP.Client.Conduit (newManager) import Network.HTTP.Client.Conduit (newManager)
import Control.Monad.Logger (runLoggingT)
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Monad
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr) import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher) import Network.Wai.Logger (clockDateCacher)
import Data.Default (def) import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger)) import Yesod.Core.Types (loggerSet)
import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.Sqlite (createSqlitePool, runSqlPool,
sqlDatabase, sqlPoolSize)
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. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
@ -54,68 +66,103 @@ import Handler.RootFeed
-- comments there for more details. -- comments there for more details.
mkYesodDispatch "App" resourcesApp mkYesodDispatch "App" resourcesApp
-- This function allocates resources (such as a database connection pool), -- | This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the -- performs initialization and return a foundation datatype value. This is also
-- place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc) makeFoundation :: AppSettings -> IO App
makeApplication conf = do makeFoundation appSettings = do
foundation <- makeFoundation conf -- 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 logWare <- mkRequestLogger def
{ outputFormat = { outputFormat =
if development if appDetailedRequestLogging $ appSettings foundation
then Detailed True then Detailed True
else Apache FromSocket else Apache
, destination = RequestLogger.Logger $ loggerSet $ appLogger foundation (if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
} }
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation appPlain <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation) return $ logWare $ defaultMiddlewaresNoLogging appPlain
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and -- | Warp settings for the given foundation value.
-- performs some initialization. warpSettings :: App -> Settings
makeFoundation :: AppConfig DefaultEnv Extra -> IO App warpSettings foundation =
makeFoundation conf = do setPort (appPort $ appSettings foundation)
manager <- newManager $ setHost (appHost $ appSettings foundation)
s <- staticSite $ setOnException (\_req e ->
dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf) when (defaultShouldDisplayException e) $ messageLoggerSource
Database.Persist.loadConfig >>= foundation
Database.Persist.applyEnv (appLogger foundation)
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) $(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
loggerSet' <- newStdoutLoggerSet defaultBufSize -- | For yesod devel, return the Warp settings and WAI Application.
(getter, updater) <- clockDateCacher getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
settings <- loadAppSettings [configSettingsYml] [] useEnv
foundation <- makeFoundation settings
app <- makeApplication foundation
wsettings <- getDevSettings $ warpSettings foundation
return (wsettings, app)
-- If the Yesod logger (as opposed to the request logger middleware) is -- | main function for use by yesod devel
-- used less than once a second on average, you may prefer to omit this develMain :: IO ()
-- thread and use "(updater >> getter)" in place of "getter" below. That develMain = develMainHelper getApplicationDev
-- 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 -- | The @main@ function for an executable running this site.
foundation = App conf s p manager dbconf logger 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]
-- Perform database migration using our application's logging settings. -- allow environment variables to override
runLoggingT useEnv
(Database.Persist.runPool dbconf (runMigration migrateAll) p)
(messageLoggerSource foundation logger)
return foundation -- Generate the foundation from the settings
foundation <- makeFoundation settings
-- for yesod devel -- Generate a WAI Application from the foundation
getApplicationDev :: IO (Int, Application) app <- makeApplication foundation
getApplicationDev =
defaultDevelApp loader (fmap fst . makeApplication) -- Run the application with Warp
where runSettings (warpSettings foundation) app
loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}

71
Foundation.hs
View file

@ -3,23 +3,22 @@ module Foundation where
import Prelude import Prelude
import Yesod import Yesod
import Yesod.Static import Yesod.Static
-- import Yesod.Auth import Yesod.Default.Config2
-- import Yesod.Auth.BrowserId
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager)) import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings import qualified Settings
import Settings.Development (development) import Settings.Development (development)
import qualified Database.Persist import qualified Database.Persist
import Database.Persist.Sql (SqlPersistT) import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
import Settings.StaticFiles import Settings.StaticFiles
import Settings (widgetFile, Extra (..)) import Settings
import Model import Model
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
import Yesod.Core.Types (Logger) import Yesod.Core.Types
-- costom imports -- costom imports
import Data.Text import Data.Text
import Data.Maybe
import Helper import Helper
-- | The site argument for your application. This can be a good place to -- | The site argument for your application. This can be a good place to
@ -27,16 +26,15 @@ import Helper
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data App = App data App = App
{ settings :: AppConfig DefaultEnv Extra { appSettings :: AppSettings
, getStatic :: Static -- ^ Settings for static file serving. , appStatic :: Static -- ^ Settings for static file serving.
, connPool :: Database.Persist.PersistConfigPool Settings.PersistConf -- ^ Database connection pool. , appConnPool :: ConnectionPool -- ^ Database connection pool.
, httpManager :: Manager , appHttpManager :: Manager
, persistConfig :: Settings.PersistConf , appLogger :: Logger
, appLogger :: Logger
} }
instance HasHttpManager App where instance HasHttpManager App where
getHttpManager = httpManager getHttpManager = appHttpManager
-- Set up i18n messages. See the message folder. -- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en" mkMessage "App" "messages" "en"
@ -55,7 +53,7 @@ type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod App where instance Yesod App where
approot = ApprootMaster $ appRoot . settings approot = ApprootMaster $ appRoot . appSettings
-- change maximum content length -- change maximum content length
maximumContentLength _ _ = Just $ 1024 ^ 5 maximumContentLength _ _ = Just $ 1024 ^ 5
@ -84,7 +82,7 @@ instance Yesod App where
return $ userSlug user return $ userSlug user
Nothing -> do Nothing -> do
return ("" :: Text) return ("" :: Text)
block <- fmap extraSignupBlocked getExtra block <- return $ appSignupBlocked $ appSettings master
-- We break up the default layout into two components: -- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and -- default-layout is the contents of the body tag, and
@ -98,13 +96,13 @@ instance Yesod App where
, css_bootstrap_css , css_bootstrap_css
]) ])
$(widgetFile "default-layout") $(widgetFile "default-layout")
giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- This is done to provide an optimization for serving static files from -- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticRoot setting in Settings.hs -- a separate domain. Please see the staticRoot setting in Settings.hs
urlRenderOverride y (StaticR s) = -- urlRenderOverride y (StaticR s) =
Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s -- Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
urlRenderOverride _ _ = Nothing -- urlRenderOverride _ _ = Nothing
-- The page to be redirected to when authentication is required. -- The page to be redirected to when authentication is required.
-- authRoute _ = Just $ AuthR LoginR -- authRoute _ = Just $ AuthR LoginR
@ -113,30 +111,41 @@ instance Yesod App where
-- and names them based on a hash of their content. This allows -- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of -- expiration dates to be set far in the future without worry of
-- users receiving stale content. -- users receiving stale content.
addStaticContent = addStaticContent ext mime content = do
addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute []) master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where where
-- Generate a unique filename based on the content itself -- Generate a unique filename based on the content itself
genFileName lbs genFileName lbs = "autogen-" ++ base64md5 lbs
| development = "autogen-" ++ base64md5 lbs
| otherwise = base64md5 lbs
-- Place Javascript at bottom of the body tag so the rest of the page loads first -- Place Javascript at bottom of the body tag so the rest of the page loads first
jsLoader _ = BottomOfBody jsLoader _ = BottomOfBody
-- What messages should be logged. The following includes all messages when -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.
shouldLog _ _source level = shouldLog app _source level =
development || level == LevelWarn || level == LevelError appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger = return . appLogger makeLogger = return . appLogger
-- How to run database actions. -- How to run database actions.
instance YesodPersist App where instance YesodPersist App where
type YesodPersistBackend App = SqlPersistT type YesodPersistBackend App = SqlBackend
runDB = defaultRunDB persistConfig connPool runDB action = do
master <- getYesod
runSqlPool action $ appConnPool master
instance YesodPersistRunner App where instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner connPool getDBRunner = defaultGetDBRunner appConnPool
-- instance YesodAuth App where -- instance YesodAuth App where
-- type AuthId App = UserId -- type AuthId App = UserId
@ -167,8 +176,8 @@ instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage renderMessage _ _ = defaultFormMessage
-- | Get the 'Extra' value, used to hold data from the settings.yml file. -- | Get the 'Extra' value, used to hold data from the settings.yml file.
getExtra :: Handler Extra -- getExtra :: Handler Extra
getExtra = fmap (appExtra . settings) getYesod -- getExtra = fmap (appExtra . settings) getYesod
-- Note: previous versions of the scaffolding included a deliver function to -- Note: previous versions of the scaffolding included a deliver function to
-- send emails. Unfortunately, there are too many different options for us to -- send emails. Unfortunately, there are too many different options for us to

6
Handler/Signup.hs
View file

@ -8,7 +8,8 @@ import Data.Maybe
getSignupR :: Handler Html getSignupR :: Handler Html
getSignupR = do getSignupR = do
block <- fmap extraSignupBlocked I.getExtra master <- getYesod
block <- return $ appSignupBlocked $ appSettings master
case block of case block of
False -> do False -> do
defaultLayout $ do defaultLayout $ do
@ -20,7 +21,8 @@ getSignupR = do
postSignupR :: Handler Html postSignupR :: Handler Html
postSignupR = do postSignupR = do
block <- fmap I.extraSignupBlocked I.getExtra master <- getYesod
block <- return $ appSignupBlocked $ appSettings master
case block of case block of
False -> do False -> do
mUserName <- lookupPostParam "username" mUserName <- lookupPostParam "username"

21
Helper.hs
View file

@ -48,14 +48,22 @@ import Text.Blaze.Html.Renderer.Utf8
getUserIdFromText :: T.Text -> UserId getUserIdFromText :: T.Text -> UserId
getUserIdFromText tempUserId = getUserIdFromText tempUserId =
Key $ PersistInt64 $ fromIntegral $ read $ T.unpack tempUserId case key of
Left a ->
extractKey :: KeyBackend backend entity -> T.Text error $ T.unpack a
extractKey = extractKey' . unKey Right k ->
k
where where
extractKey' (PersistInt64 k) = T.pack $ show k key = keyFromValues $ pInt64 : []
pInt64 = PersistInt64 $ fromIntegral $ read $ T.unpack tempUserId
extractKey :: PersistEntity record => Key record -> T.Text
extractKey = extractKey' . keyToValues
where
extractKey' [PersistInt64 k] = T.pack $ show k
extractKey' _ = "" extractKey' _ = ""
fromHex :: String -> BL.ByteString
fromHex = BL.pack . hexToWords fromHex = BL.pack . hexToWords
where hexToWords (c:c':text) = where hexToWords (c:c':text) =
let hex = [c, c'] let hex = [c, c']
@ -112,6 +120,7 @@ userField users = Field
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
getUsersFromResult :: Eq b => [(T.Text, b)] -> [b] -> T.Text
getUsersFromResult users res = T.intercalate " " $ map (\x -> fromMaybe "" $ reverseLookup x users) res getUsersFromResult users res = T.intercalate " " $ map (\x -> fromMaybe "" $ reverseLookup x users) res
sendMail :: MonadIO m => T.Text -> T.Text -> Html -> m () sendMail :: MonadIO m => T.Text -> T.Text -> Html -> m ()
@ -166,7 +175,7 @@ localTimeToZonedTime :: TimeZone -> LocalTime -> ZonedTime
localTimeToZonedTime tz = localTimeToZonedTime tz =
utcToZonedTime tz . localTimeToUTC tz utcToZonedTime tz . localTimeToUTC tz
--rfc822 :: LocalTime -> String rfc822 :: FormatTime t => t -> String
rfc822 = formatTime defaultTimeLocale rfc822DateFormat rfc822 = formatTime defaultTimeLocale rfc822DateFormat
mediumStaticImageRoute :: Medium -> Route Static mediumStaticImageRoute :: Medium -> Route Static

4
Model.hs
View file

@ -1,6 +1,6 @@
module Model where module Model where
import Yesod import ClassyPrelude.Yesod
import Yesod.Markdown (Markdown) import Yesod.Markdown (Markdown)
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Quasi import Database.Persist.Quasi
@ -13,7 +13,7 @@ import Data.ByteString
import Data.Bool import Data.Bool
import Data.Int import Data.Int
import Text.Show (Show) import Text.Show (Show)
import System.FilePath (FilePath) import qualified System.FilePath as FP
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities

160
Settings.hs
View file

@ -5,44 +5,84 @@
-- declared in the Foundation.hs file. -- declared in the Foundation.hs file.
module Settings where module Settings where
import Prelude import ClassyPrelude.Yesod
import Text.Shakespeare.Text (st) import Control.Exception (throw)
import Language.Haskell.TH.Syntax import Data.Aeson (Result (..), fromJSON, withObject, (.!=),
import Database.Persist.Sqlite (SqliteConf) (.:?))
import Yesod.Default.Config import Data.FileEmbed (embedFile)
import Yesod.Default.Util import Data.Yaml (decodeEither')
import Data.Text (Text) import Database.Persist.Sqlite (SqliteConf)
import Data.Yaml import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Control.Applicative import Network.Wai.Handler.Warp (HostPreference)
import Settings.Development import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Data.Default (def) import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
import Text.Hamlet widgetFileReload)
-- | Which Persistent backend this site is using. -- | Runtime settings to configure this application. These settings can be
type PersistConf = SqliteConf -- 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.
-- Static setting below. Changing these requires a recompile , 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
-- | The location of static files on your system. This is a file system -- Example app-specific configuration values.
-- path. The default value works properly with your scaffolded site. , appCopyright :: Text
staticDir :: FilePath -- ^ Copyright text to appear in the footer of the page
staticDir = "static" , appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appSignupBlocked :: Bool
-- ^ block signup site
}
-- | The base URL for your static files. As you can see by the default instance FromJSON AppSettings where
-- value, this can simply be "static" appended to your application root. parseJSON = withObject "AppSettings" $ \o -> do
-- A powerful optimization can be serving static files from a separate let defaultDev =
-- domain name. This allows you to use a web server optimized for static #if DEVELOPMENT
-- files, more easily set expires and cache values, and avoid possibly True
-- costly transference of cookies on static files. For more information, #else
-- please see: False
-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain #endif
-- appStaticDir <- o .: "static-dir"
-- If you change the resource pattern for StaticR in Foundation.hs, you will appDatabaseConf <- o .: "database"
-- have to make a corresponding change here. appRoot <- o .: "approot"
-- appHost <- fromString <$> o .: "host"
-- To see how this value is used, see urlRenderOverride in Foundation.hs appPort <- o .: "port"
staticRoot :: AppConfig DefaultEnv x -> Text appIpFromHeader <- o .: "ip-from-header"
staticRoot conf = [st|#{appRoot conf}/static|]
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"
appSignupBlocked <- o .: "signupBlocked"
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and -- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings. -- default Hamlet settings.
@ -52,27 +92,47 @@ staticRoot conf = [st|#{appRoot conf}/static|]
-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
widgetFileSettings :: WidgetFileSettings widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def 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 -- The rest of this file contains settings which rarely need changing by a
-- user. -- user.
widgetFile :: String -> Q Exp widgetFile :: String -> Q Exp
widgetFile = (if development then widgetFileReload widgetFile = (if appReloadTemplates compileTimeAppSettings
else widgetFileNoReload) then widgetFileReload
else widgetFileNoReload)
widgetFileSettings widgetFileSettings
data Extra = Extra -- | Raw bytes at compile time of @config/settings.yml@
{ extraCopyright :: Text configSettingsYmlBS :: ByteString
-- , extraAnalytics :: Maybe Text -- ^ Google Analytics configSettingsYmlBS = $(embedFile configSettingsYml)
, extraSignupBlocked :: Bool
} deriving Show
parseExtra :: DefaultEnv -> Object -> Parser Extra -- | @config/settings.yml@, parsed to a @Value@.
parseExtra _ o = Extra configSettingsYmlValue :: Value
<$> o .: "copyright" configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS
-- <*> o .:? "analytics"
<*> o .: "signupBlocked" -- | 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

40
Settings/StaticFiles.hs
View file

@ -1,35 +1,35 @@
module Settings.StaticFiles where module Settings.StaticFiles where
import Prelude (IO) import Prelude (IO)
import Yesod.Static import Yesod.Static (staticFiles)
import qualified Yesod.Static as Static import qualified Yesod.Static as Static
import Settings (staticDir) import Settings (appStaticDir, compileTimeAppSettings)
import Settings.Development import Settings.Development
import Language.Haskell.TH (Q, Exp, Name) import Language.Haskell.TH (Q, Exp, Name)
import Data.Default (def) import Data.Default (def)
-- | use this to create your static file serving site -- | use this to create your static file serving site
staticSite :: IO Static.Static -- staticSite :: IO Static.Static
staticSite = if development then Static.staticDevel staticDir -- staticSite = if development then Static.staticDevel staticDir
else Static.static staticDir -- else Static.static staticDir
-- | This generates easy references to files in the static directory at compile time, -- | This generates easy references to files in the static directory at compile time,
-- giving you compile-time verification that referenced files exist. -- giving you compile-time verification that referenced files exist.
-- Warning: any files added to your static directory during run-time can't be -- 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. -- accessed this way. You'll have to use their FilePath or URL to access them.
$(staticFiles Settings.staticDir) staticFiles (appStaticDir compileTimeAppSettings)
combineSettings :: CombineSettings -- combineSettings :: CombineSettings
combineSettings = def -- combineSettings = def
--
-- The following two functions can be used to combine multiple CSS or JS files -- -- The following two functions can be used to combine multiple CSS or JS files
-- at compile time to decrease the number of http requests. -- -- at compile time to decrease the number of http requests.
-- Sample usage (inside a Widget): -- -- Sample usage (inside a Widget):
-- -- --
-- > $(combineStylesheets 'StaticR [style1_css, style2_css]) -- -- > $(combineStylesheets 'StaticR [style1_css, style2_css])
--
combineStylesheets :: Name -> [Route Static] -> Q Exp -- combineStylesheets :: Name -> [Route Static] -> Q Exp
combineStylesheets = combineStylesheets' development combineSettings -- combineStylesheets = combineStylesheets' development combineSettings
--
combineScripts :: Name -> [Route Static] -> Q Exp -- combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings -- combineScripts = combineScripts' development combineSettings

50
app/DevelMain.hs
View file

@ -4,17 +4,21 @@
-- --
-- cabal repl --ghc-options="-O0 -fobject-code" -- cabal repl --ghc-options="-O0 -fobject-code"
-- --
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file -- You will need to add these packages to your .cabal file
-- * foreign-store (very light-weight) -- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file) -- * warp (you already depend on this, it just isn't in your .cabal file)
-- --
-- If you don't use cabal repl, you will need -- If you don't use cabal repl, you will need
-- to run the following in GHCi or to add it to -- to add settings to your .ghci file.
-- your .ghci file.
-- --
-- :set -DDEVELOPMENT -- :set -DDEVELOPMENT
-- --
-- There is more information about this approach, -- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where module DevelMain where
@ -28,32 +32,36 @@ import Foreign.Store
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
-- | Start or restart the server. -- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO () update :: IO ()
update = do update = do
mtidStore <- lookupStore tid_1 mtidStore <- lookupStore tidStoreNum
case mtidStore of case mtidStore of
-- no server running
Nothing -> do Nothing -> do
done <- newEmptyMVar done <- storeAction doneStore newEmptyMVar
_done_0 <- newStore done
tid <- start done tid <- start done
tidRef <- newIORef tid _ <- storeAction (Store tidStoreNum) (newIORef tid)
_tid_1 <- newStore tidRef
return () return ()
Just tidStore -> do -- server is already running
tidRef <- readStore tidStore Just tidStore ->
tid <- readIORef tidRef -- shut the server down with killThread and wait for the done signal
done <- readStore (Store done_0) modifyStoredIORef tidStore $ \tid -> do
killThread tid killThread tid
takeMVar done withStore doneStore takeMVar >> readStore doneStore >>= start
newTid <- start done where
writeIORef tidRef newTid doneStore = Store 0
where tid_1 = 1 tidStoreNum = 1
done_0 = 0
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread. -- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed. start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId -> IO ThreadId
start done = do start done = do
(port,app) <- getApplicationDev (settings,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app) forkIO (finally (runSettings settings app)
(putMVar done ())) (putMVar done ()))

6
app/devel.hs Normal file
View file

@ -0,0 +1,6 @@
{-# LANGUAGE PackageImports #-}
import "eidolon" Application (develMain)
import Prelude (IO)
main :: IO ()
main = develMain

9
app/main.hs
View file

@ -1,8 +1,5 @@
import Prelude (IO) import Prelude (IO)
import Yesod.Default.Config (fromArgs) import Application (appMain)
import Yesod.Default.Main (defaultMainLog)
import Settings (parseExtra)
import Application (makeApplication)
main :: IO () main :: IO ()
main = defaultMainLog (fromArgs parseExtra) makeApplication main = appMain

6
config/models
View file

@ -21,12 +21,12 @@ Album
owner UserId owner UserId
shares [UserId] shares [UserId]
content [MediumId] content [MediumId]
samplePic FilePath Maybe samplePic FP.FilePath Maybe
deriving Eq Show deriving Eq Show
Medium Medium
title Text title Text
path FilePath path FP.FilePath
thumb FilePath thumb FP.FilePath
mime Text mime Text
time UTCTime time UTCTime
owner UserId owner UserId

2
config/routes
View file

@ -1,4 +1,4 @@
/static StaticR Static getStatic /static StaticR Static appStatic
/favicon.ico FaviconR GET /favicon.ico FaviconR GET
/robots.txt RobotsR GET /robots.txt RobotsR GET

40
config/settings.yml
View file

@ -1,20 +1,28 @@
Default: &defaults # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
host: "*4" # any IPv4 host # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
port: 3000
approot: "http://localhost:3000"
copyright: Insert copyright statement here
#enter only True or False
signupBlocked: False
Development: static-dir: "_env:STATIC_DIR:static"
<<: *defaults 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"
Testing: # Optional values with the following production defaults.
<<: *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: database:
<<: *defaults database: "_env:SQLITE_DATABASE:eidolon.sqlite3"
poolsize: "_env:SQLITE_POOLSIZE:10"
Production: copyright: Insert copyright statement here
#approot: "http://www.example.com" #analytics: UA-YOURCODE
<<: *defaults
# block signup process
signupBlocked: "_env:SIGNUP_BLOCK:false"

11
eidolon.cabal
View file

@ -61,16 +61,18 @@ library
EmptyDataDecls EmptyDataDecls
NoMonomorphismRestriction NoMonomorphismRestriction
DeriveDataTypeable DeriveDataTypeable
RecordWildCards
ViewPatterns
build-depends: base >= 4 build-depends: base >= 4
, yesod >= 1.2.5 , yesod >= 1.4.0
, yesod-core >= 1.2.12 , yesod-core >= 1.2.12
, yesod-auth >= 1.3 , yesod-auth >= 1.3
, yesod-static >= 1.2 , yesod-static >= 1.2
, yesod-form >= 1.3 , yesod-form >= 1.3
, bytestring >= 0.9 , bytestring >= 0.9
, text >= 0.11 , text >= 0.11
, persistent >= 1.3 && < 2.0.0 , persistent >= 1.3
, persistent-sqlite >= 1.3 , persistent-sqlite >= 1.3
, persistent-template >= 1.3 , persistent-template >= 1.3
, template-haskell , template-haskell
@ -88,6 +90,11 @@ library
, monad-logger >= 0.3 , monad-logger >= 0.3
, fast-logger >= 2.1.4 , fast-logger >= 2.1.4
, wai-logger >= 2.1 , wai-logger >= 2.1
-- transition to persisten 2.0
, classy-prelude
, classy-prelude-conduit
, classy-prelude-yesod
, file-embed
-- custom dependencies -- custom dependencies
, random , random
, mime-mail , mime-mail

2
templates/default-layout-wrapper.hamlet
View file

@ -18,4 +18,4 @@ $doctype 5
<main id="main" role="main"> <main id="main" role="main">
^{pageBody pc} ^{pageBody pc}
<footer> <footer>
#{extraCopyright $ appExtra $ settings master} #{appCopyright $ appSettings master}