Browse Source

fresh new yesod app

elm
commit
215858c723
  1. 4
      .dir-locals.el
  2. 3
      .ghci
  3. 14
      .gitignore
  4. 89
      Application.hs
  5. 163
      Foundation.hs
  6. 39
      Handler/Home.hs
  7. 29
      Import.hs
  8. 14
      Model.hs
  9. 76
      Settings.hs
  10. 14
      Settings/Development.hs
  11. 35
      Settings/StaticFiles.hs
  12. 67
      app/DevelMain.hs
  13. 8
      app/main.hs
  14. BIN
      config/favicon.ico
  15. 8
      config/keter.yaml
  16. 12
      config/models
  17. 1
      config/robots.txt
  18. 7
      config/routes
  19. 19
      config/settings.yml
  20. 20
      config/sqlite.yml
  21. 90
      deploy/Procfile
  22. 24
      devel.hs
  23. 1
      messages/en.msg
  24. 99
      soggoth.cabal
  25. 6167
      static/css/bootstrap.css
  26. 396
      static/css/normalize.css
  27. BIN
      static/img/glyphicons-halflings-white.png
  28. BIN
      static/img/glyphicons-halflings.png
  29. 48
      templates/default-layout-wrapper.hamlet
  30. 3
      templates/default-layout.hamlet
  31. 38
      templates/homepage.hamlet
  32. 1
      templates/homepage.julius
  33. 6
      templates/homepage.lucius
  34. 38
      tests/HomeTest.hs
  35. 26
      tests/TestImport.hs
  36. 23
      tests/main.hs

4
.dir-locals.el

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

3
.ghci

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

14
.gitignore

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

89
Application.hs

@ -0,0 +1,89 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( makeApplication
, getApplicationDev
, makeFoundation
) where
import Import
import Settings
import Yesod.Auth
import Yesod.Default.Config
import Yesod.Default.Main
import Yesod.Default.Handlers
import Network.Wai.Middleware.RequestLogger
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
)
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Database.Persist
import Database.Persist.Sql (runMigration)
import Network.HTTP.Client.Conduit (newManager)
import Control.Monad.Logger (runLoggingT)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Home
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "App" resourcesApp
-- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc)
makeApplication conf = do
foundation <- makeFoundation conf
-- Initialize the logging middleware
logWare <- mkRequestLogger def
{ outputFormat =
if development
then Detailed True
else Apache FromSocket
, destination = RequestLogger.Logger $ loggerSet $ appLogger foundation
}
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
return (logWare $ defaultMiddlewaresNoLogging app, logFunc)
-- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization.
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager
s <- staticSite
dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
Database.Persist.loadConfig >>=
Database.Persist.applyEnv
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
loggerSet' <- newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher
let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger
-- Perform database migration using our application's logging settings.
runLoggingT
(Database.Persist.runPool dbconf (runMigration migrateAll) p)
(messageLoggerSource foundation logger)
return foundation
-- for yesod devel
getApplicationDev :: IO (Int, Application)
getApplicationDev =
defaultDevelApp loader (fmap fst . makeApplication)
where
loader = Yesod.Default.Config.loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}

163
Foundation.hs

@ -0,0 +1,163 @@
module Foundation where
import Prelude
import Yesod
import Yesod.Static
import Yesod.Auth
import Yesod.Auth.BrowserId
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
import Database.Persist.Sql (SqlPersistT)
import Settings.StaticFiles
import Settings (widgetFile, Extra (..))
import Model
import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile)
import Yesod.Core.Types (Logger)
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ settings :: AppConfig DefaultEnv Extra
, getStatic :: Static -- ^ Settings for static file serving.
, connPool :: Database.Persist.PersistConfigPool Settings.PersistConf -- ^ Database connection pool.
, httpManager :: Manager
, persistConfig :: Settings.PersistConf
, appLogger :: Logger
}
instance HasHttpManager App where
getHttpManager = httpManager
-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the linked documentation for an
-- explanation for this split.
mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod App where
approot = ApprootMaster $ appRoot . settings
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
pc <- widgetToPageContent $ do
$(combineStylesheets 'StaticR
[ css_normalize_css
, css_bootstrap_css
])
$(widgetFile "default-layout")
giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticRoot setting in Settings.hs
urlRenderOverride y (StaticR s) =
Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
urlRenderOverride _ _ = Nothing
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent =
addStaticContentExternal minifym genFileName Settings.staticDir (StaticR . flip StaticRoute [])
where
-- Generate a unique filename based on the content itself
genFileName lbs
| development = "autogen-" ++ base64md5 lbs
| otherwise = base64md5 lbs
-- Place Javascript at bottom of the body tag so the rest of the page loads first
jsLoader _ = BottomOfBody
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLog _ _source level =
development || level == LevelWarn || level == LevelError
makeLogger = return . appLogger
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlPersistT
runDB = defaultRunDB persistConfig connPool
instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner connPool
instance YesodAuth App where
type AuthId App = UserId
-- Where to send a user after successful login
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest _ = HomeR
getAuthId creds = runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds
case x of
Just (Entity uid _) -> return $ Just uid
Nothing -> do
fmap Just $ insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [authBrowserId def]
authHttpManager = httpManager
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
-- | Get the 'Extra' value, used to hold data from the settings.yml file.
getExtra :: Handler Extra
getExtra = fmap (appExtra . settings) getYesod
-- Note: previous versions of the scaffolding included a deliver function to
-- send emails. Unfortunately, there are too many different options for us to
-- give a reasonable default. Instead, the information is available on the
-- wiki:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email

39
Handler/Home.hs

@ -0,0 +1,39 @@
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Home where
import Import
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe (FileInfo, Text)
handlerName = "getHomeR" :: Text
defaultLayout $ do
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
defaultLayout $ do
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form (FileInfo, Text)
sampleForm = renderDivs $ (,)
<$> fileAFormReq "Choose a file"
<*> areq textField "What's on the file?" Nothing

29
Import.hs

@ -0,0 +1,29 @@
module Import
( module Import
) where
import Prelude as Import hiding (head, init, last,
readFile, tail, writeFile)
import Yesod as Import hiding (Route (..))
import Control.Applicative as Import (pure, (<$>), (<*>))
import Data.Text as Import (Text)
import Foundation as Import
import Model as Import
import Settings as Import
import Settings.Development as Import
import Settings.StaticFiles as Import
#if __GLASGOW_HASKELL__ >= 704
import Data.Monoid as Import
(Monoid (mappend, mempty, mconcat),
(<>))
#else
import Data.Monoid as Import
(Monoid (mappend, mempty, mconcat))
infixr 5 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif

14
Model.hs

@ -0,0 +1,14 @@
module Model where
import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Prelude
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlOnlySettings, mkMigrate "migrateAll"]
$(persistFileWith lowerCaseSettings "config/models")

76
Settings.hs

@ -0,0 +1,76 @@
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod
-- by overriding methods in the Yesod typeclass. That instance is
-- 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
-- | 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"
-- | 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.
--
-- For more information on modifying behavior, see:
--
-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
{ wfsHamletSettings = defaultHamletSettings
{ hamletNewlines = AlwaysNewlines
}
}
-- 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)
widgetFileSettings
data Extra = Extra
{ extraCopyright :: Text
, extraAnalytics :: Maybe Text -- ^ Google Analytics
} deriving Show
parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra
<$> o .: "copyright"
<*> o .:? "analytics"

14
Settings/Development.hs

@ -0,0 +1,14 @@
module Settings.Development where
import Prelude
development :: Bool
development =
#if DEVELOPMENT
True
#else
False
#endif
production :: Bool
production = not development

35
Settings/StaticFiles.hs

@ -0,0 +1,35 @@
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
-- | 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

67
app/DevelMain.hs

@ -0,0 +1,67 @@
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- 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 >= 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 add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
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 tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
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)
(putMVar done ()))

8
app/main.hs

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

BIN
config/favicon.ico

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.3 KiB

8
config/keter.yaml

@ -0,0 +1,8 @@
exec: ../dist/build/soggoth/soggoth
args:
- production
host: <<HOST-NOT-SET>>
# Use the following to automatically copy your bundle upon creation via `yesod
# keter`. Uses `scp` internally, so you can set it to a remote destination
# copy-to: user@host:/opt/keter/incoming

12
config/models

@ -0,0 +1,12 @@
User
ident Text
password Text Maybe
UniqueUser ident
deriving Typeable
Email
email Text
user UserId Maybe
verkey Text Maybe
UniqueEmail email
-- By default this file is used in Model.hs (which is imported by Foundation.hs)

1
config/robots.txt

@ -0,0 +1 @@
User-agent: *

7
config/routes

@ -0,0 +1,7 @@
/static StaticR Static getStatic
/auth AuthR Auth getAuth
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST

19
config/settings.yml

@ -0,0 +1,19 @@
Default: &defaults
host: "*4" # any IPv4 host
port: 3000
approot: "http://localhost:3000"
copyright: Insert copyright statement here
#analytics: UA-YOURCODE
Development:
<<: *defaults
Testing:
<<: *defaults
Staging:
<<: *defaults
Production:
#approot: "http://www.example.com"
<<: *defaults

20
config/sqlite.yml

@ -0,0 +1,20 @@
Default: &defaults
database: soggoth.sqlite3
poolsize: 10
Development:
<<: *defaults
Testing:
database: soggoth_test.sqlite3
<<: *defaults
Staging:
database: soggoth_staging.sqlite3
poolsize: 100
<<: *defaults
Production:
database: soggoth_production.sqlite3
poolsize: 100
<<: *defaults

90
deploy/Procfile

@ -0,0 +1,90 @@
# 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": "soggoth", "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/soggoth/soggoth
# git commit -m deploy
#
# * push to Heroku
#
# git push heroku deploy:master
# Heroku configuration that runs your app
web: ./dist/build/soggoth/soggoth production -p $PORT

24
devel.hs

@ -0,0 +1,24 @@
{-# LANGUAGE PackageImports #-}
import "soggoth" 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)
main :: IO ()
main = do
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

1
messages/en.msg

@ -0,0 +1 @@
Hello: Hello

99
soggoth.cabal

@ -0,0 +1,99 @@
name: soggoth
version: 0.0.0
cabal-version: >= 1.8
build-type: Simple
Flag dev
Description: Turn on development settings, like auto-reload templates.
Default: False
Flag library-only
Description: Build for use with "yesod devel"
Default: False
library
exposed-modules: Application
Foundation
Import
Model
Settings
Settings.StaticFiles
Settings.Development
Handler.Home
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT
ghc-options: -Wall -O0
else
ghc-options: -Wall -O2
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
MultiParamTypeClasses
TypeFamilies
GADTs
GeneralizedNewtypeDeriving
FlexibleContexts
EmptyDataDecls
NoMonomorphismRestriction
DeriveDataTypeable
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
, persistent >= 1.3 && < 1.4
, persistent-sqlite >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
, template-haskell
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 3.0 && < 3.1
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 3.0 && < 3.1
, data-default
, aeson >= 0.6 && < 0.9
, conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.2 && < 2.3
, wai-logger >= 2.2 && < 2.3
executable soggoth
if flag(library-only)
Buildable: False
main-is: main.hs
hs-source-dirs: app
build-depends: base
, soggoth
, yesod
ghc-options: -threaded -O2
test-suite test
type: exitcode-stdio-1.0
main-is: main.hs
hs-source-dirs: tests
ghc-options: -Wall
build-depends: base
, soggoth
, yesod-test >= 1.2 && < 1.3
, yesod-core
, yesod
, persistent
, persistent-sqlite
, resourcet
, monad-logger
, transformers
, hspec

6167
static/css/bootstrap.css

File diff suppressed because it is too large

396
static/css/normalize.css

@ -0,0 +1,396 @@
/*! normalize.css v2.1.2 | MIT License | git.io/normalize */
/* ==========================================================================
HTML5 display definitions
========================================================================== */
/**
* Correct `block` display not defined in IE 8/9.
*/
article,
aside,
details,
figcaption,
figure,
footer,
header,
hgroup,
main,
nav,
section,
summary {
display: block;
}
/**
* Correct `inline-block` display not defined in IE 8/9.
*/
audio,
canvas,
video {
display: inline-block;
}
/**
* Prevent modern browsers from displaying `audio` without controls.
* Remove excess height in iOS 5 devices.
*/
audio:not([controls]) {
display: none;
height: 0;
}
/**
* Address styling not present in IE 8/9.
*/
[hidden] {
display: none;
}
/* ==========================================================================
Base
========================================================================== */
/**
* 1. Set default font family to sans-serif.
* 2. Prevent iOS text size adjust after orientation change, without disabling
* user zoom.
*/
html {
font-family: sans-serif; /* 1 */
-ms-text-size-adjust: 100%; /* 2 */
-webkit-text-size-adjust: 100%; /* 2 */
}
/**
* Remove default margin.
*/
body {
margin: 0;
}
/* ==========================================================================
Links
========================================================================== */
/**
* Address `outline` inconsistency between Chrome and other browsers.
*/
a:focus {
outline: thin dotted;
}
/**
* Improve readability when focused and also mouse hovered in all browsers.
*/
a:active,
a:hover {
outline: 0;
}
/* ==========================================================================
Typography
========================================================================== */
/**
* Address variable `h1` font-size and margin within `section` and `article`
* contexts in Firefox 4+, Safari 5, and Chrome.
*/
h1 {
font-size: 2em;
margin: 0.67em 0;
}
/**
* Address styling not present in IE 8/9, Safari 5, and Chrome.
*/
abbr[title] {
border-bottom: 1px dotted;
}
/**
* Address style set to `bolder` in Firefox 4+, Safari 5, and Chrome.
*/
b,
strong {
font-weight: bold;
}
/**
* Address styling not present in Safari 5 and Chrome.
*/
dfn {
font-style: italic;
}
/**
* Address differences between Firefox and other browsers.
*/
hr {
-moz-box-sizing: content-box;
box-sizing: content-box;
height: 0;
}
/**
* Address styling not present in IE 8/9.
*/
mark {
background: #ff0;
color: #000;
}
/**
* Correct font family set oddly in Safari 5 and Chrome.
*/
code,
kbd,
pre,
samp {
font-family: monospace, serif;
font-size: 1em;
}
/**
* Improve readability of pre-formatted text in all browsers.
*/
pre {
white-space: pre-wrap;
}
/**
* Set consistent quote types.
*/
q {
quotes: "\201C" "\201D" "\2018" "\2019";
}
/**
* Address inconsistent and variable font size in all browsers.
*/
small {
font-size: 80%;
}
/**
* Prevent `sub` and `sup` affecting `line-height` in all browsers.
*/
sub,
sup {
font-size: 75%;
line-height: 0;
position: relative;
vertical-align: baseline;
}
sup {
top: -0.5em;
}
sub {
bottom: -0.25em;
}
/* ==========================================================================
Embedded content
========================================================================== */
/**
* Remove border when inside `a` element in IE 8/9.
*/
img {
border: 0;
}
/**
* Correct overflow displayed oddly in IE 9.
*/
svg:not(:root) {
overflow: hidden;
}
/* ==========================================================================
Figures
========================================================================== */
/**
* Address margin not present in IE 8/9 and Safari 5.
*/
figure {
margin: 0;
}
/* ==========================================================================
Forms
========================================================================== */
/**
* Define consistent border, margin, and padding.
*/
fieldset {
border: 1px solid #c0c0c0;
margin: 0 2px;
padding: 0.35em 0.625em 0.75em;
}
/**
* 1. Correct `color` not being inherited in IE 8/9.
* 2. Remove padding so people aren't caught out if they zero out fieldsets.
*/
legend {
border: 0; /* 1 */
padding: 0; /* 2 */
}
/**
* 1. Correct font family not being inherited in all browsers.
* 2. Correct font size not being inherited in all browsers.
* 3. Address margins set differently in Firefox 4+, Safari 5, and Chrome.
*/
button,
input,
select,
textarea {
font-family: inherit; /* 1 */
font-size: 100%; /* 2 */
margin: 0; /* 3 */
}
/**
* Address Firefox 4+ setting `line-height` on `input` using `!important` in
* the UA stylesheet.
*/
button,
input {
line-height: normal;
}
/**
* Address inconsistent `text-transform` inheritance for `button` and `select`.
* All other form control elements do not inherit `text-transform` values.
* Correct `button` style inheritance in Chrome, Safari 5+, and IE 8+.
* Correct `select` style inheritance in Firefox 4+ and Opera.
*/
button,
select {
text-transform: none;
}
/**
* 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio`
* and `video` controls.
* 2. Correct inability to style clickable `input` types in iOS.
* 3. Improve usability and consistency of cursor style between image-type
* `input` and others.
*/
button,
html input[type="button"], /* 1 */
input[type="reset"],
input[type="submit"] {
-webkit-appearance: button; /* 2 */
cursor: pointer; /* 3 */
}
/**
* Re-set default cursor for disabled elements.
*/
button[disabled],
html input[disabled] {
cursor: default;
}
/**
* 1. Address box sizing set to `content-box` in IE 8/9.
* 2. Remove excess padding in IE 8/9.
*/
input[type="checkbox"],
input[type="radio"] {
box-sizing: border-box; /* 1 */
padding: 0; /* 2 */
}
/**
* 1. Address `appearance` set to `searchfield` in Safari 5 and Chrome.
* 2. Address `box-sizing` set to `border-box` in Safari 5 and Chrome
* (include `-moz` to future-proof).
*/
input[type="search"] {
-webkit-appearance: textfield; /* 1 */
-moz-box-sizing: content-box;
-webkit-box-sizing: content-box; /* 2 */
box-sizing: content-box;
}
/**
* Remove inner padding and search cancel button in Safari 5 and Chrome
* on OS X.
*/
input[type="search"]::-webkit-search-cancel-button,
input[type="search"]::-webkit-search-decoration {
-webkit-appearance: none;
}
/**
* Remove inner padding and border in Firefox 4+.
*/
button::-moz-focus-inner,
input::-moz-focus-inner {
border: 0;
padding: 0;
}
/**
* 1. Remove default vertical scrollbar in IE 8/9.
* 2. Improve readability and alignment in all browsers.
*/
textarea {
overflow: auto; /* 1 */
vertical-align: top; /* 2 */
}
/* ==========================================================================
Tables
========================================================================== */
/**
* Remove most spacing between table cells.
*/
table {
border-collapse: collapse;
border-spacing: 0;
}

BIN
static/img/glyphicons-halflings-white.png

Binary file not shown.

After

Width:  |  Height:  |  Size: 8.6 KiB

BIN
static/img/glyphicons-halflings.png

Binary file not shown.

After

Width:  |  Height:  |  Size: 12 KiB

48
templates/default-layout-wrapper.hamlet

@ -0,0 +1,48 @@
$newline never
\<!doctype html>
\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
\<!--[if IE 7]> <html class="no-js ie7 oldie" lang="en"> <![endif]-->
\<!--[if IE 8]> <html class="no-js ie8 oldie" lang="en"> <![endif]-->
\<!--[if gt IE 8]><!-->
<html class="no-js" lang="en"> <!--<![endif]-->
<head>
<meta charset="UTF-8">
<title>#{pageTitle pc}
<meta name="description" content="">
<meta name="author" content="">
<meta name="viewport" content="width=device-width,initial-scale=1">
^{pageHead pc}
\<!--[if lt IE 9]>
\<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script>
\<![endif]-->
<script>
document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js');
<body>
<div class="container">
<header>
<div id="main" role="main">
^{pageBody pc}
<footer>
#{extraCopyright $ appExtra $ settings master}
$maybe analytics <- extraAnalytics $ appExtra $ settings master
<script>
if(!window.location.href.match(/localhost/)){
window._gaq = [['_setAccount','#{analytics}'],['_trackPageview'],['_trackPageLoadTime']];
(function() {
\ var ga = document.createElement('script'); ga.type = 'text/javascript'; ga.async = true;
\ ga.src = ('https:' == document.location.protocol ? 'https://ssl' : 'http://www') + '.google-analytics.com/ga.js';
\ var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(ga, s);
})();
}
\<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6. chromium.org/developers/how-tos/chrome-frame-getting-started -->
\<!--[if lt IE 7 ]>
<script src="//ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js">
<script>
window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})})
\<![endif]-->

3
templates/default-layout.hamlet

@ -0,0 +1,3 @@
$maybe msg <- mmsg
<div #message>#{msg}
^{widget}

38
templates/homepage.hamlet

@ -0,0 +1,38 @@
<h1>_{MsgHello}
<ol>
<li>Now that you have a working project you should use the #
\<a href="http://www.yesodweb.com/book/">Yesod book</a> to learn more. #
You can also use this scaffolded site to explore some basic concepts.
<li> This page was generated by the #{handlerName} handler in #
\<em>Handler/Home.hs</em>.
<li> The #{handlerName} handler is set to generate your site's home screen in Routes file #
<em>config/routes
<li> The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
most of them are brought together by the <em>defaultLayout</em> function which #
is defined in the <em>Foundation.hs</em> module, and used by <em>#{handlerName}</em>. #
All the files for templates and wigdets are in <em>templates</em>.
<li>
A Widget's Html, Css and Javascript are separated in three files with the #
\<em>.hamlet</em>, <em>.lucius</em> and <em>.julius</em> extensions.
<li ##{aDomId}>If you had javascript enabled then you wouldn't be seeing this.
<li #form>
This is an example trivial Form. Read the #
\<a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
on the yesod book to learn more about them.
$maybe (info,con) <- submission
<div .message>
Your file's type was <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
<form method=post action=@{HomeR}#form enctype=#{formEnctype}>
^{formWidget}
<input type="submit" value="Send it!">
<li> And last but not least, Testing. In <em>tests/main.hs</em> you will find a #
test suite that performs tests on this page. #
You can run your tests by doing: <pre>yesod test</pre>

1
templates/homepage.julius

@ -0,0 +1 @@
document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";

6
templates/homepage.lucius

@ -0,0 +1,6 @@
h1 {
text-align: center
}
h2##{aDomId} {
color: #990
}

38
tests/HomeTest.hs

@ -0,0 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
module HomeTest
( homeSpecs
) where
import TestImport
import qualified Data.List as L
homeSpecs :: Spec
homeSpecs =
ydescribe "These are some example tests" $ do
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" "tests/main.hs" "text/plain" -- talk about self-reference
byLabel "What's on the file?" "Some Content"
statusIs 200
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.
yit "leaves the user table empty" $ do
get HomeR
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEqual "user table empty" 0 $ L.length users

26
tests/TestImport.hs

@ -0,0 +1,26 @@
{-# LANGUAGE OverloadedStrings #-}
module TestImport
( module Yesod.Test
, module Model
, module Foundation
, module Database.Persist
, runDB
, Spec
, Example
) where
import Yesod.Test
import Database.Persist hiding (get)
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool)
import Control.Monad.IO.Class (liftIO)
import Foundation
import Model
type Spec = YesodSpec App
type Example = YesodExample App
runDB :: SqlPersistM a -> Example a
runDB query = do
pool <- fmap connPool getTestYesod
liftIO $ runSqlPersistMPool query pool

23
tests/main.hs

@ -0,0 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Import
import Yesod.Default.Config
import Yesod.Test
import Test.Hspec (hspec)
import Application (makeFoundation)
import HomeTest
main :: IO ()
main = do
conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing)
{ csParseExtra = parseExtra
}
foundation <- makeFoundation conf
hspec $ do
yesodSpec foundation $ do
homeSpecs
Loading…
Cancel
Save