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 #-}
module Application
( makeApplication
, getApplicationDev
( getApplicationDev
, makeFoundation
, develMain
, appMain
) where
import Import
import Settings
-- import Yesod.Auth
import Yesod.Default.Config
import Yesod.Static
import Yesod.Default.Config2
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 Control.Monad
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import Network.Wai.Logger (clockDateCacher)
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.
-- Don't forget to add new modules to your cabal file!
@ -54,68 +66,103 @@ import Handler.RootFeed
-- 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)
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
-- | 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
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
-- | 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
loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, updater) <- clockDateCacher
-- | 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)
-- 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
-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev
let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger
-- | 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]
-- Perform database migration using our application's logging settings.
runLoggingT
(Database.Persist.runPool dbconf (runMigration migrateAll) p)
(messageLoggerSource foundation logger)
-- allow environment variables to override
useEnv
return foundation
-- Generate the foundation from the settings
foundation <- makeFoundation settings
-- for yesod devel
getApplicationDev :: IO (Int, Application)
getApplicationDev =
defaultDevelApp loader (fmap fst . makeApplication)
where
loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app

69
Foundation.hs
View file

@ -3,23 +3,22 @@ module Foundation where
import Prelude
import Yesod
import Yesod.Static
-- import Yesod.Auth
-- import Yesod.Auth.BrowserId
import Yesod.Default.Config
import Yesod.Default.Config2
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 Database.Persist.Sql -- (ConnectionPool, runSqlPool)
import Settings.StaticFiles
import Settings (widgetFile, Extra (..))
import Settings
import Model
import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile)
import Yesod.Core.Types (Logger)
import Yesod.Core.Types
-- costom imports
import Data.Text
import Data.Maybe
import Helper
-- | 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
-- 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
{ 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"
@ -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
-- of settings which can be configured by overriding methods here.
instance Yesod App where
approot = ApprootMaster $ appRoot . settings
approot = ApprootMaster $ appRoot . appSettings
-- change maximum content length
maximumContentLength _ _ = Just $ 1024 ^ 5
@ -84,7 +82,7 @@ instance Yesod App where
return $ userSlug user
Nothing -> do
return ("" :: Text)
block <- fmap extraSignupBlocked getExtra
block <- return $ appSignupBlocked $ appSettings master
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
@ -98,13 +96,13 @@ instance Yesod App where
, css_bootstrap_css
])
$(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
-- 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
-- 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
@ -113,30 +111,41 @@ 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
genFileName lbs = "autogen-" ++ 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
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 = SqlPersistT
runDB = defaultRunDB persistConfig connPool
type YesodPersistBackend App = SqlBackend
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
@ -167,8 +176,8 @@ 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
-- 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

6
Handler/Signup.hs
View file

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

21
Helper.hs
View file

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

4
Model.hs
View file

@ -1,6 +1,6 @@
module Model where
import Yesod
import ClassyPrelude.Yesod
import Yesod.Markdown (Markdown)
import Data.Text (Text)
import Database.Persist.Quasi
@ -13,7 +13,7 @@ import Data.ByteString
import Data.Bool
import Data.Int
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 find more information on persistent and how to declare entities

156
Settings.hs
View file

@ -5,44 +5,84 @@
-- declared in the Foundation.hs file.
module Settings where
import Prelude
import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
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 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 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)
-- | Which Persistent backend this site is using.
type PersistConf = SqliteConf
-- | 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.
-- 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
-- path. The default value works properly with your scaffolded site.
staticDir :: FilePath
staticDir = "static"
-- Example app-specific configuration values.
, appCopyright :: Text
-- ^ Copyright text to appear in the footer of the page
, 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
-- 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|]
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"
appSignupBlocked <- o .: "signupBlocked"
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
@ -52,27 +92,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
widgetFile = (if appReloadTemplates compileTimeAppSettings
then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
data Extra = Extra
{ extraCopyright :: Text
-- , extraAnalytics :: Maybe Text -- ^ Google Analytics
, extraSignupBlocked :: Bool
} deriving Show
-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
configSettingsYmlBS = $(embedFile configSettingsYml)
parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra
<$> o .: "copyright"
-- <*> o .:? "analytics"
<*> o .: "signupBlocked"
-- | @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

38
Settings/StaticFiles.hs
View file

@ -1,35 +1,35 @@
module Settings.StaticFiles where
import Prelude (IO)
import Yesod.Static
import Yesod.Static (staticFiles)
import qualified Yesod.Static as Static
import Settings (staticDir)
import Settings (appStaticDir, compileTimeAppSettings)
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
-- staticSite :: IO Static.Static
-- staticSite = if development then Static.staticDevel staticDir
-- else Static.static staticDir
-- | 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)
staticFiles (appStaticDir compileTimeAppSettings)
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):
-- combineSettings :: CombineSettings
-- combineSettings = def
--
-- > $(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
-- -- 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

48
app/DevelMain.hs
View file

@ -4,17 +4,21 @@
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- 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)
--
-- If you don't use cabal repl, you will need
-- to run the following in GHCi or to add it to
-- your .ghci file.
-- to add settings to your .ghci file.
--
-- :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
module DevelMain where
@ -28,32 +32,36 @@ import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tid_1
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- newEmptyMVar
_done_0 <- newStore done
done <- storeAction doneStore newEmptyMVar
tid <- start done
tidRef <- newIORef tid
_tid_1 <- newStore tidRef
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
Just tidStore -> do
tidRef <- readStore tidStore
tid <- readIORef tidRef
done <- readStore (Store done_0)
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
takeMVar done
newTid <- start done
writeIORef tidRef newTid
where tid_1 = 1
done_0 = 0
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
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 :: 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 ()))

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

7
app/main.hs
View file

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

6
config/models
View file

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

2
config/routes
View file

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

40
config/settings.yml
View file

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

11
eidolon.cabal
View file

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

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

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