Removed unneeded files
This commit is contained in:
Michael Snoyman
parent
9f7223ea5e
commit
888336029f
90
ChangeLog.md
90
ChangeLog.md
@ -1,90 +0,0 @@
|
|||||||
### Yesod 0.5.0 (August 29, 2010)
|
|
||||||
|
|
||||||
* Forms no longer have special types for special views; instead, there is a
|
|
||||||
toFormField attribute when declaring entities to specify a form rendering
|
|
||||||
function.
|
|
||||||
|
|
||||||
* URL settings for jQuery and Nic are now in their own typeclasses. This will
|
|
||||||
be the approach used in the future when adding more widgets and forms that
|
|
||||||
require Javascript libraries.
|
|
||||||
|
|
||||||
* You can explicitly specify the id and name attributes to be used in forms if
|
|
||||||
you like. When omitted, a unique name is automatically generated.
|
|
||||||
|
|
||||||
* The isAuthorized function now takes a function specifying whether the
|
|
||||||
request is a write request. This should make it simpler to develop read/write
|
|
||||||
authorization systems. Bonus points: if you use HTTP request methods properly,
|
|
||||||
the isWriteRequest function will automatically determine whether a request is
|
|
||||||
a read or write request.
|
|
||||||
|
|
||||||
* You can now specify splitPath and joinPath functions yourself. Previously,
|
|
||||||
the built-in versions had very specific URL rules, such as enforcing a
|
|
||||||
trailing slash. If you want something more flexible, you can override these
|
|
||||||
functions.
|
|
||||||
|
|
||||||
* addStaticContent is used to serve CSS and Javascript code from widgets from
|
|
||||||
external files. This allows caching to take place as you'd normally like.
|
|
||||||
|
|
||||||
* Static files served from the static subsite can have a hash string added to
|
|
||||||
the query string; this is done automatically when using the getStaticFiles
|
|
||||||
function. This allows you to set your expires headers far in the future.
|
|
||||||
|
|
||||||
* A new Yesod.Mail module provides datatypes and functions for creating
|
|
||||||
multipart MIME email messages and sending them via the sendmail executable.
|
|
||||||
Since these functions generate lazy bytestrings, you can use any delivery
|
|
||||||
mechanism you want.
|
|
||||||
|
|
||||||
* Change the type of defaultLayout to use Widgets instead of PageContent. This
|
|
||||||
makes it easier to avoid double-including scripts and stylesheets.
|
|
||||||
|
|
||||||
* Major reworking of the Auth subsite to make it easier to use.
|
|
||||||
|
|
||||||
* Update of the site scaffolder to include much more functionality. Also
|
|
||||||
removed the Handler type alias from the library, as the scaffolder now
|
|
||||||
provides that.
|
|
||||||
|
|
||||||
### New in Yesod 0.4.0
|
|
||||||
|
|
||||||
A big thanks on this release to Simon Michael, who pointed out a number of
|
|
||||||
places where the docs were unclear, the API was unintuitive, or the names were
|
|
||||||
inconsistent.
|
|
||||||
|
|
||||||
* Widgets. These allow you to create composable pieces of a webpage that
|
|
||||||
keep track of their own Javascript and CSS. It includes a function for
|
|
||||||
obtaining unique identifiers to avoid name collisions, and does automatic
|
|
||||||
dependency combining; in other words, if you have two widgets that depend on
|
|
||||||
jQuery, the combined widget will only include it once.
|
|
||||||
|
|
||||||
* Combined the Yesod.Form and Yesod.Formable module into a single, consistent,
|
|
||||||
widget-based API. It includes basic input functions as well as fancier
|
|
||||||
Javascript-driven functions; for example, there is a plain day entry field,
|
|
||||||
and a day entry field which automatically loads the jQuery UI date picker.
|
|
||||||
|
|
||||||
* Added the yesod executable which performs basic scaffolding.
|
|
||||||
|
|
||||||
* Cleaned up a bunch of API function names for consistency. For example,
|
|
||||||
Yesod.Request now has a logical lookupGetName, lookupPostName, etc naming
|
|
||||||
scheme.
|
|
||||||
|
|
||||||
* Changed the type of basicHandler to require less typing, and added
|
|
||||||
basicHandler' which allows you to modify the line output to STDOUT (or skip it
|
|
||||||
altogether).
|
|
||||||
|
|
||||||
* Switched the Handler monad from ContT to MEitherT (provided by the neither
|
|
||||||
package). ContT does not have a valid MonadCatchIO instance, which is used for
|
|
||||||
the sqlite persitent backend.
|
|
||||||
|
|
||||||
* Facebook support in the Auth helper.
|
|
||||||
|
|
||||||
* Ensure that HTTP request methods are given in ALL CAPS.
|
|
||||||
|
|
||||||
* Cleaned up signatures of many methods in the Yesod typeclass. In particular,
|
|
||||||
due to changes in web-routes-quasi, many of those functions can now live in
|
|
||||||
the Handler monad, making it easier to use standard functions on them.
|
|
||||||
|
|
||||||
* The static file helper now has extensible file-extension-to-mimetype
|
|
||||||
mappings.
|
|
||||||
|
|
||||||
* Added the sendResponse function for handler short-circuiting.
|
|
||||||
|
|
||||||
* Renamed Routes to Route.
|
|
||||||
41
CodeGen.hs
41
CodeGen.hs
@ -1,41 +0,0 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
-- | A code generation template haskell. Everything is taken as literal text,
|
|
||||||
-- with ~var~ variable interpolation.
|
|
||||||
module CodeGen (codegen) where
|
|
||||||
|
|
||||||
import Language.Haskell.TH.Syntax
|
|
||||||
import Text.ParserCombinators.Parsec
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import qualified Data.Text.Lazy as LT
|
|
||||||
import qualified Data.Text.Lazy.Encoding as LT
|
|
||||||
|
|
||||||
data Token = VarToken String | LitToken String | EmptyToken
|
|
||||||
|
|
||||||
codegen :: FilePath -> Q Exp
|
|
||||||
codegen fp = do
|
|
||||||
s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg"
|
|
||||||
let s = init $ LT.unpack $ LT.decodeUtf8 s'
|
|
||||||
case parse (many parseToken) s s of
|
|
||||||
Left e -> error $ show e
|
|
||||||
Right tokens' -> do
|
|
||||||
let tokens'' = map toExp tokens'
|
|
||||||
concat' <- [|concat|]
|
|
||||||
return $ concat' `AppE` ListE tokens''
|
|
||||||
|
|
||||||
toExp :: Token -> Exp
|
|
||||||
toExp (LitToken s) = LitE $ StringL s
|
|
||||||
toExp (VarToken s) = VarE $ mkName s
|
|
||||||
toExp EmptyToken = LitE $ StringL ""
|
|
||||||
|
|
||||||
parseToken :: Parser Token
|
|
||||||
parseToken =
|
|
||||||
parseVar <|> parseLit
|
|
||||||
where
|
|
||||||
parseVar = do
|
|
||||||
_ <- char '~'
|
|
||||||
s <- many alphaNum
|
|
||||||
_ <- char '~'
|
|
||||||
return $ if null s then EmptyToken else VarToken s
|
|
||||||
parseLit = do
|
|
||||||
s <- many1 $ noneOf "~"
|
|
||||||
return $ LitToken s
|
|
||||||
108
blog.hs
108
blog.hs
@ -1,108 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-}
|
|
||||||
import Yesod
|
|
||||||
import Yesod.Helpers.Auth
|
|
||||||
import Yesod.Helpers.Crud
|
|
||||||
import Database.Persist.Sqlite
|
|
||||||
import Data.Time (Day)
|
|
||||||
|
|
||||||
share2 mkPersist mkIsForm [$persist|
|
|
||||||
Entry
|
|
||||||
title String "label=Entry title" "tooltip=Make it something cool"
|
|
||||||
posted JqueryDay Desc
|
|
||||||
content NicHtml
|
|
||||||
deriving
|
|
||||||
|]
|
|
||||||
instance Item Entry where
|
|
||||||
itemTitle = entryTitle
|
|
||||||
|
|
||||||
getAuth = const $ Auth
|
|
||||||
{ authIsOpenIdEnabled = False
|
|
||||||
, authRpxnowApiKey = Nothing
|
|
||||||
, authEmailSettings = Nothing
|
|
||||||
-- | client id, secret and requested permissions
|
|
||||||
, authFacebook = Just (clientId, secret, ["email"])
|
|
||||||
}
|
|
||||||
where
|
|
||||||
clientId = "134280699924829"
|
|
||||||
secret = "a7685e10c8977f5435e599aaf1d232eb"
|
|
||||||
|
|
||||||
data Blog = Blog Connection
|
|
||||||
type EntryCrud = Crud Blog Entry
|
|
||||||
mkYesod "Blog" [$parseRoutes|
|
|
||||||
/ RootR GET
|
|
||||||
/entry/#EntryId EntryR GET
|
|
||||||
/admin AdminR EntryCrud defaultCrud
|
|
||||||
/auth AuthR Auth getAuth
|
|
||||||
|]
|
|
||||||
instance Yesod Blog where
|
|
||||||
approot _ = "http://localhost:3000"
|
|
||||||
defaultLayout p = do
|
|
||||||
mcreds <- maybeCreds
|
|
||||||
admin <- maybeAuthorized $ AdminR CrudListR
|
|
||||||
hamletToContent [$hamlet|
|
|
||||||
!!!
|
|
||||||
%html
|
|
||||||
%head
|
|
||||||
%title $pageTitle.p$
|
|
||||||
^pageHead.p^
|
|
||||||
%style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666}
|
|
||||||
%body
|
|
||||||
%p
|
|
||||||
%a!href=@RootR@ Homepage
|
|
||||||
$maybe admin a
|
|
||||||
\ | $
|
|
||||||
%a!href=@a@ Admin
|
|
||||||
\ | $
|
|
||||||
$maybe mcreds c
|
|
||||||
Welcome $
|
|
||||||
$maybe credsDisplayName.c dn
|
|
||||||
$dn$
|
|
||||||
$nothing
|
|
||||||
$credsIdent.c$
|
|
||||||
\ $
|
|
||||||
%a!href=@AuthR.Logout@ Logout
|
|
||||||
$nothing
|
|
||||||
%a!href=@AuthR.StartFacebookR@ Facebook Connect
|
|
||||||
^pageBody.p^
|
|
||||||
%p
|
|
||||||
Powered by Yesod Web Framework
|
|
||||||
|]
|
|
||||||
isAuthorized AdminR{} = do
|
|
||||||
mc <- maybeCreds
|
|
||||||
let x = (mc >>= credsEmail) == Just "michael@snoyman.com"
|
|
||||||
return $ if x then Nothing else Just "Permission denied"
|
|
||||||
isAuthorized _ = return Nothing
|
|
||||||
instance YesodAuth Blog where
|
|
||||||
defaultDest _ = RootR
|
|
||||||
defaultLoginRoute _ = RootR
|
|
||||||
instance YesodPersist Blog where
|
|
||||||
type YesodDB Blog = SqliteReader
|
|
||||||
runDB db = do
|
|
||||||
Blog conn <- getYesod
|
|
||||||
runSqlite db conn
|
|
||||||
|
|
||||||
getRootR = do
|
|
||||||
entries <- runDB $ select [] [EntryPostedDesc]
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string "Blog tutorial homepage"
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 All Entries
|
|
||||||
%ul
|
|
||||||
$forall entries entry
|
|
||||||
%li
|
|
||||||
%a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
|
|
||||||
|]
|
|
||||||
|
|
||||||
getEntryR :: EntryId -> Handler Blog RepHtml
|
|
||||||
getEntryR eid = do
|
|
||||||
entry <- runDB (get eid) >>= maybe notFound return
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string $ entryTitle entry
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 $entryTitle.entry$
|
|
||||||
%h2 $show.unJqueryDay.entryPosted.entry$
|
|
||||||
#content $unNicHtml.entryContent.entry$
|
|
||||||
|]
|
|
||||||
main = withSqlite "blog.db3" $ \conn -> do
|
|
||||||
flip runSqlite conn $ initialize (undefined :: Entry)
|
|
||||||
toWaiApp (Blog conn) >>= basicHandler 3000
|
|
||||||
71
blog2.hs
71
blog2.hs
@ -1,71 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
import Yesod
|
|
||||||
import Yesod.Helpers.Crud
|
|
||||||
import Yesod.Form.Jquery
|
|
||||||
import Yesod.Form.Nic
|
|
||||||
import Database.Persist.Sqlite
|
|
||||||
import Database.Persist.TH
|
|
||||||
import Data.Time (Day)
|
|
||||||
|
|
||||||
share2 mkToForm mkPersist [$persist|
|
|
||||||
Entry
|
|
||||||
title String id=thetitle
|
|
||||||
day Day Desc toFormField=YesodJquery.jqueryDayField name=day
|
|
||||||
content Html' toFormField=YesodNic.nicHtmlField
|
|
||||||
deriving
|
|
||||||
|]
|
|
||||||
|
|
||||||
instance Item Entry where
|
|
||||||
itemTitle = entryTitle
|
|
||||||
|
|
||||||
data Blog = Blog { pool :: Pool Connection }
|
|
||||||
|
|
||||||
type EntryCrud = Crud Blog Entry
|
|
||||||
|
|
||||||
mkYesod "Blog" [$parseRoutes|
|
|
||||||
/ RootR GET
|
|
||||||
/entry/#EntryId EntryR GET
|
|
||||||
/admin AdminR EntryCrud defaultCrud
|
|
||||||
|]
|
|
||||||
|
|
||||||
instance Yesod Blog where
|
|
||||||
approot _ = "http://localhost:3000"
|
|
||||||
instance YesodJquery Blog
|
|
||||||
instance YesodNic Blog
|
|
||||||
|
|
||||||
instance YesodPersist Blog where
|
|
||||||
type YesodDB Blog = SqliteReader
|
|
||||||
runDB db = fmap pool getYesod>>= runSqlite db
|
|
||||||
|
|
||||||
getRootR = do
|
|
||||||
entries <- runDB $ selectList [] [EntryDayDesc] 0 0
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string "Yesod Blog Tutorial Homepage"
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 Archive
|
|
||||||
%ul
|
|
||||||
$forall entries entry
|
|
||||||
%li
|
|
||||||
%a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
|
|
||||||
%p
|
|
||||||
%a!href=@AdminR.CrudListR@ Admin
|
|
||||||
|]
|
|
||||||
|
|
||||||
getEntryR entryid = do
|
|
||||||
entry <- runDB $ get404 entryid
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string $ entryTitle entry
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 $entryTitle.entry$
|
|
||||||
%h2 $show.entryDay.entry$
|
|
||||||
$entryContent.entry$
|
|
||||||
|]
|
|
||||||
|
|
||||||
withBlog f = withSqlite ":memory:" 8 $ \p -> do
|
|
||||||
flip runSqlite p $ do
|
|
||||||
initialize (undefined :: Entry)
|
|
||||||
f $ Blog p
|
|
||||||
|
|
||||||
main = withBlog $ basicHandler 3000
|
|
||||||
40
freeform.hs
40
freeform.hs
@ -1,40 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}
|
|
||||||
import Yesod
|
|
||||||
import Control.Applicative
|
|
||||||
|
|
||||||
data FreeForm = FreeForm
|
|
||||||
mkYesod "FreeForm" [$parseRoutes|
|
|
||||||
/ RootR GET
|
|
||||||
|]
|
|
||||||
instance Yesod FreeForm where approot _ = ""
|
|
||||||
|
|
||||||
data Person = Person String Int String
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
getRootR = do
|
|
||||||
((merr, mperson, form), enctype) <- runFormMonadGet $ do
|
|
||||||
(name, namef) <- stringField "Name" Nothing
|
|
||||||
(age, agef) <- intField "Age" $ Just 25
|
|
||||||
(color, colorf) <- stringField "Color" Nothing
|
|
||||||
let (merr, mperson) =
|
|
||||||
case Person <$> name <*> age <*> color of
|
|
||||||
FormSuccess p -> (Nothing, Just p)
|
|
||||||
FormFailure e -> (Just e, Nothing)
|
|
||||||
FormMissing -> (Nothing, Nothing)
|
|
||||||
let form = [$hamlet|
|
|
||||||
Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^.
|
|
||||||
|]
|
|
||||||
return (merr, mperson, form)
|
|
||||||
defaultLayout [$hamlet|
|
|
||||||
$maybe merr err
|
|
||||||
%ul!style=color:red
|
|
||||||
$forall err e
|
|
||||||
%li $e$
|
|
||||||
$maybe mperson person
|
|
||||||
%p Last person: $show.person$
|
|
||||||
%form!method=get!action=@RootR@!enctype=$enctype$
|
|
||||||
%p ^form^
|
|
||||||
%input!type=submit!value=Submit
|
|
||||||
|]
|
|
||||||
|
|
||||||
main = basicHandler 3000 FreeForm
|
|
||||||
@ -1,2 +0,0 @@
|
|||||||
cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html'
|
|
||||||
scp -r dist/doc/html/yesod snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock/
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
|
|
||||||
import Yesod
|
|
||||||
data HelloWorld = HelloWorld
|
|
||||||
mkYesod "HelloWorld" [$parseRoutes|/ Home GET|]
|
|
||||||
instance Yesod HelloWorld where approot _ = ""
|
|
||||||
getHome = return $ RepPlain $ toContent "Hello World!"
|
|
||||||
main = basicHandler 3000 HelloWorld
|
|
||||||
14
mail.hs
14
mail.hs
@ -1,14 +0,0 @@
|
|||||||
import Yesod.Mail
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as L
|
|
||||||
import System.Environment
|
|
||||||
|
|
||||||
main = do
|
|
||||||
[dest] <- getArgs
|
|
||||||
let p1 = Part "text/html" None Inline $ L.pack "<h1>Hello World!!!</h1>"
|
|
||||||
lbs <- L.readFile "mail.hs"
|
|
||||||
let p2 = Part "text/plain" Base64 (Attachment "mail.hs") lbs
|
|
||||||
let mail = Mail
|
|
||||||
[("To", dest), ("Subject", "mail quine")]
|
|
||||||
"Plain stuff. Mime-clients should not show it."
|
|
||||||
[p1, p2]
|
|
||||||
renderSendMail mail
|
|
||||||
87
scaffold.hs
87
scaffold.hs
@ -1,87 +0,0 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
import CodeGen
|
|
||||||
import System.IO
|
|
||||||
import System.Directory
|
|
||||||
import qualified Data.ByteString.Char8 as S
|
|
||||||
import Language.Haskell.TH.Syntax
|
|
||||||
import Data.Time (getCurrentTime, utctDay, toGregorian)
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import qualified Data.Text.Lazy as LT
|
|
||||||
import qualified Data.Text.Lazy.Encoding as LT
|
|
||||||
|
|
||||||
qq :: String
|
|
||||||
#if GHC7
|
|
||||||
qq = ""
|
|
||||||
#else
|
|
||||||
qq = "$"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
putStr $(codegen "welcome")
|
|
||||||
hFlush stdout
|
|
||||||
name <- getLine
|
|
||||||
|
|
||||||
putStr $(codegen "project-name")
|
|
||||||
hFlush stdout
|
|
||||||
project <- getLine
|
|
||||||
|
|
||||||
putStr $(codegen "dir-name")
|
|
||||||
hFlush stdout
|
|
||||||
dirRaw <- getLine
|
|
||||||
let dir = if null dirRaw then project else dirRaw
|
|
||||||
|
|
||||||
putStr $(codegen "site-arg")
|
|
||||||
hFlush stdout
|
|
||||||
sitearg <- getLine
|
|
||||||
|
|
||||||
putStr $(codegen "database")
|
|
||||||
hFlush stdout
|
|
||||||
backendS <- getLine
|
|
||||||
let pconn1 = $(codegen "pconn1")
|
|
||||||
let pconn2 = $(codegen "pconn2")
|
|
||||||
let (lower, upper, connstr1, connstr2) =
|
|
||||||
case backendS of
|
|
||||||
"s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3")
|
|
||||||
"p" -> ("postgresql", "Postgresql", pconn1, pconn2)
|
|
||||||
_ -> error $ "Invalid backend: " ++ backendS
|
|
||||||
|
|
||||||
putStrLn "That's it! I'm creating your files now..."
|
|
||||||
|
|
||||||
let fst3 (x, _, _) = x
|
|
||||||
year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime
|
|
||||||
|
|
||||||
let writeFile' fp s = do
|
|
||||||
putStrLn $ "Generating " ++ fp
|
|
||||||
L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s
|
|
||||||
mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp
|
|
||||||
|
|
||||||
mkDir "Handler"
|
|
||||||
mkDir "hamlet"
|
|
||||||
mkDir "cassius"
|
|
||||||
mkDir "julius"
|
|
||||||
|
|
||||||
writeFile' "simple-server.hs" $(codegen "simple-server_hs")
|
|
||||||
writeFile' "fastcgi.hs" $(codegen "fastcgi_hs")
|
|
||||||
writeFile' "devel-server.hs" $(codegen "devel-server_hs")
|
|
||||||
writeFile' (project ++ ".cabal") $(codegen "cabal")
|
|
||||||
writeFile' "LICENSE" $(codegen "LICENSE")
|
|
||||||
writeFile' (sitearg ++ ".hs") $(codegen "sitearg_hs")
|
|
||||||
writeFile' "Controller.hs" $(codegen "Controller_hs")
|
|
||||||
writeFile' "Handler/Root.hs" $(codegen "Root_hs")
|
|
||||||
writeFile' "Model.hs" $(codegen "Model_hs")
|
|
||||||
writeFile' "Settings.hs" $(codegen "Settings_hs")
|
|
||||||
writeFile' "cassius/default-layout.cassius"
|
|
||||||
$(codegen "default-layout_cassius")
|
|
||||||
writeFile' "hamlet/default-layout.hamlet"
|
|
||||||
$(codegen "default-layout_hamlet")
|
|
||||||
writeFile' "hamlet/homepage.hamlet" $(codegen "homepage_hamlet")
|
|
||||||
writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius")
|
|
||||||
writeFile' "julius/homepage.julius" $(codegen "homepage_julius")
|
|
||||||
|
|
||||||
S.writeFile (dir ++ "/favicon.ico")
|
|
||||||
$(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do
|
|
||||||
pack <- [|S.pack|]
|
|
||||||
return $ pack `AppE` LitE (StringL $ S.unpack bs))
|
|
||||||
@ -1,40 +0,0 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
module Controller
|
|
||||||
( with~sitearg~
|
|
||||||
) where
|
|
||||||
|
|
||||||
import ~sitearg~
|
|
||||||
import Settings
|
|
||||||
import Yesod.Helpers.Static
|
|
||||||
import Yesod.Helpers.Auth
|
|
||||||
import Database.Persist.GenericSql
|
|
||||||
|
|
||||||
-- Import all relevant handler modules here.
|
|
||||||
import Handler.Root
|
|
||||||
|
|
||||||
-- This line actually creates our YesodSite instance. It is the second half
|
|
||||||
-- of the call to mkYesodData which occurs in ~sitearg~.hs. Please see
|
|
||||||
-- the comments there for more details.
|
|
||||||
mkYesodDispatch "~sitearg~" resources~sitearg~
|
|
||||||
|
|
||||||
-- Some default handlers that ship with the Yesod site template. You will
|
|
||||||
-- very rarely need to modify this.
|
|
||||||
getFaviconR :: Handler ()
|
|
||||||
getFaviconR = sendFile "image/x-icon" "favicon.ico"
|
|
||||||
|
|
||||||
getRobotsR :: Handler RepPlain
|
|
||||||
getRobotsR = return $ RepPlain $ toContent "User-agent: *"
|
|
||||||
|
|
||||||
-- 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.
|
|
||||||
with~sitearg~ :: (Application -> IO a) -> IO a
|
|
||||||
with~sitearg~ f = Settings.withConnectionPool $ \p -> do
|
|
||||||
runConnectionPool (runMigration migrateAll) p
|
|
||||||
let h = ~sitearg~ s p
|
|
||||||
toWaiApp h >>= f
|
|
||||||
where
|
|
||||||
s = fileLookupDir Settings.staticdir typeByExt
|
|
||||||
|
|
||||||
@ -1,26 +0,0 @@
|
|||||||
The following license covers this documentation, and the source code, except
|
|
||||||
where otherwise indicated.
|
|
||||||
|
|
||||||
Copyright ~year~, ~name~. All rights reserved.
|
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without
|
|
||||||
modification, are permitted provided that the following conditions are met:
|
|
||||||
|
|
||||||
* Redistributions of source code must retain the above copyright notice, this
|
|
||||||
list of conditions and the following disclaimer.
|
|
||||||
|
|
||||||
* Redistributions in binary form must reproduce the above copyright notice,
|
|
||||||
this list of conditions and the following disclaimer in the documentation
|
|
||||||
and/or other materials provided with the distribution.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
|
|
||||||
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
|
||||||
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
|
|
||||||
EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
||||||
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
||||||
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
|
|
||||||
OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
|
|
||||||
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
|
||||||
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
||||||
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
||||||
@ -1,22 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
|
|
||||||
module Model where
|
|
||||||
|
|
||||||
import Yesod
|
|
||||||
import Database.Persist.TH (share2)
|
|
||||||
import Database.Persist.GenericSql (mkMigrate)
|
|
||||||
|
|
||||||
-- You can define all of your database entities here. You can find more
|
|
||||||
-- information on persistent and how to declare entities at:
|
|
||||||
-- http://docs.yesodweb.com/book/persistent/
|
|
||||||
share2 mkPersist (mkMigrate "migrateAll") [~qq~persist|
|
|
||||||
User
|
|
||||||
ident String
|
|
||||||
password String Maybe Update
|
|
||||||
UniqueUser ident
|
|
||||||
Email
|
|
||||||
email String
|
|
||||||
user UserId Maybe Update
|
|
||||||
verkey String Maybe Update
|
|
||||||
UniqueEmail email
|
|
||||||
|]
|
|
||||||
|
|
||||||
@ -1,20 +0,0 @@
|
|||||||
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
|
|
||||||
module Handler.Root where
|
|
||||||
|
|
||||||
import ~sitearg~
|
|
||||||
|
|
||||||
-- This is a handler function for the GET request method on the RootR
|
|
||||||
-- resource pattern. All of your resource patterns are defined in
|
|
||||||
-- ~sitearg~.hs; look for the line beginning with mkYesodData.
|
|
||||||
--
|
|
||||||
-- 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.
|
|
||||||
getRootR :: Handler RepHtml
|
|
||||||
getRootR = do
|
|
||||||
mu <- maybeAuth
|
|
||||||
defaultLayout $ do
|
|
||||||
h2id <- newIdent
|
|
||||||
setTitle "~project~ homepage"
|
|
||||||
addWidget $(widgetFile "homepage")
|
|
||||||
|
|
||||||
@ -1,147 +0,0 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
-- | 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 ~sitearg~.hs file.
|
|
||||||
module Settings
|
|
||||||
( hamletFile
|
|
||||||
, cassiusFile
|
|
||||||
, juliusFile
|
|
||||||
, widgetFile
|
|
||||||
, connStr
|
|
||||||
, ConnectionPool
|
|
||||||
, withConnectionPool
|
|
||||||
, runConnectionPool
|
|
||||||
, approot
|
|
||||||
, staticroot
|
|
||||||
, staticdir
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Text.Hamlet as H
|
|
||||||
import qualified Text.Cassius as H
|
|
||||||
import qualified Text.Julius as H
|
|
||||||
import Language.Haskell.TH.Syntax
|
|
||||||
import Database.Persist.~upper~
|
|
||||||
import Yesod (MonadInvertIO, addWidget, addCassius, addJulius)
|
|
||||||
import Data.Monoid (mempty)
|
|
||||||
import System.Directory (doesFileExist)
|
|
||||||
|
|
||||||
-- | The base URL for your application. This will usually be different for
|
|
||||||
-- development and production. Yesod automatically constructs URLs for you,
|
|
||||||
-- so this value must be accurate to create valid links.
|
|
||||||
approot :: String
|
|
||||||
#ifdef PRODUCTION
|
|
||||||
-- You probably want to change this. If your domain name was "yesod.com",
|
|
||||||
-- you would probably want it to be:
|
|
||||||
-- > approot = "http://www.yesod.com"
|
|
||||||
-- Please note that there is no trailing slash.
|
|
||||||
approot = "http://localhost:3000"
|
|
||||||
#else
|
|
||||||
approot = "http://localhost:3000"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | 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 ~sitearg~.hs, you will
|
|
||||||
-- have to make a corresponding change here.
|
|
||||||
--
|
|
||||||
-- To see how this value is used, see urlRenderOverride in ~sitearg~.hs
|
|
||||||
staticroot :: String
|
|
||||||
staticroot = approot ++ "/static"
|
|
||||||
|
|
||||||
-- | The database connection string. The meaning of this string is backend-
|
|
||||||
-- specific.
|
|
||||||
connStr :: String
|
|
||||||
#ifdef PRODUCTION
|
|
||||||
connStr = "~connstr2~"
|
|
||||||
#else
|
|
||||||
connStr = "~connstr1~"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | Your application will keep a connection pool and take connections from
|
|
||||||
-- there as necessary instead of continually creating new connections. This
|
|
||||||
-- value gives the maximum number of connections to be open at a given time.
|
|
||||||
-- If your application requests a connection when all connections are in
|
|
||||||
-- use, that request will fail. Try to choose a number that will work well
|
|
||||||
-- with the system resources available to you while providing enough
|
|
||||||
-- connections for your expected load.
|
|
||||||
--
|
|
||||||
-- Also, connections are returned to the pool as quickly as possible by
|
|
||||||
-- Yesod to avoid resource exhaustion. A connection is only considered in
|
|
||||||
-- use while within a call to runDB.
|
|
||||||
connectionCount :: Int
|
|
||||||
connectionCount = 10
|
|
||||||
|
|
||||||
-- The rest of this file contains settings which rarely need changing by a
|
|
||||||
-- user.
|
|
||||||
|
|
||||||
-- The following three functions are used for calling HTML, CSS and
|
|
||||||
-- Javascript templates from your Haskell code. During development,
|
|
||||||
-- the "Debug" versions of these functions are used so that changes to
|
|
||||||
-- the templates are immediately reflected in an already running
|
|
||||||
-- application. When making a production compile, the non-debug version
|
|
||||||
-- is used for increased performance.
|
|
||||||
--
|
|
||||||
-- You can see an example of how to call these functions in Handler/Root.hs
|
|
||||||
--
|
|
||||||
-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer
|
|
||||||
-- used; to get the same auto-loading effect, it is recommended that you
|
|
||||||
-- use the devel server.
|
|
||||||
|
|
||||||
toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath
|
|
||||||
toHamletFile x = "hamlet/" ++ x ++ ".hamlet"
|
|
||||||
toCassiusFile x = "cassius/" ++ x ++ ".cassius"
|
|
||||||
toJuliusFile x = "julius/" ++ x ++ ".julius"
|
|
||||||
|
|
||||||
hamletFile :: FilePath -> Q Exp
|
|
||||||
hamletFile = H.hamletFile . toHamletFile
|
|
||||||
|
|
||||||
cassiusFile :: FilePath -> Q Exp
|
|
||||||
#ifdef PRODUCTION
|
|
||||||
cassiusFile = H.cassiusFile . toCassiusFile
|
|
||||||
#else
|
|
||||||
cassiusFile = H.cassiusFileDebug . toCassiusFile
|
|
||||||
#endif
|
|
||||||
|
|
||||||
juliusFile :: FilePath -> Q Exp
|
|
||||||
#ifdef PRODUCTION
|
|
||||||
juliusFile = H.juliusFile . toJuliusFile
|
|
||||||
#else
|
|
||||||
juliusFile = H.juliusFileDebug . toJuliusFile
|
|
||||||
#endif
|
|
||||||
|
|
||||||
widgetFile :: FilePath -> Q Exp
|
|
||||||
widgetFile x = do
|
|
||||||
let h = unlessExists toHamletFile hamletFile
|
|
||||||
let c = unlessExists toCassiusFile cassiusFile
|
|
||||||
let j = unlessExists toJuliusFile juliusFile
|
|
||||||
[|addWidget $h >> addCassius $c >> addJulius $j|]
|
|
||||||
where
|
|
||||||
unlessExists tofn f = do
|
|
||||||
e <- qRunIO $ doesFileExist $ tofn x
|
|
||||||
if e then f x else [|mempty|]
|
|
||||||
|
|
||||||
-- The next two functions are for allocating a connection pool and running
|
|
||||||
-- database actions using a pool, respectively. It is used internally
|
|
||||||
-- by the scaffolded application, and therefore you will rarely need to use
|
|
||||||
-- them yourself.
|
|
||||||
withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a
|
|
||||||
withConnectionPool = with~upper~Pool connStr connectionCount
|
|
||||||
|
|
||||||
runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a
|
|
||||||
runConnectionPool = runSqlPool
|
|
||||||
|
|
||||||
@ -1,58 +0,0 @@
|
|||||||
name: ~project~
|
|
||||||
version: 0.0.0
|
|
||||||
license: BSD3
|
|
||||||
license-file: LICENSE
|
|
||||||
author: ~name~
|
|
||||||
maintainer: ~name~
|
|
||||||
synopsis: The greatest Yesod web application ever.
|
|
||||||
description: I'm sure you can say something clever here if you try.
|
|
||||||
category: Web
|
|
||||||
stability: Experimental
|
|
||||||
cabal-version: >= 1.6
|
|
||||||
build-type: Simple
|
|
||||||
homepage: http://~project~.yesodweb.com/
|
|
||||||
|
|
||||||
Flag production
|
|
||||||
Description: Build the production executable.
|
|
||||||
Default: False
|
|
||||||
|
|
||||||
executable simple-server
|
|
||||||
if flag(production)
|
|
||||||
Buildable: False
|
|
||||||
main-is: simple-server.hs
|
|
||||||
build-depends: base >= 4 && < 5
|
|
||||||
, yesod >= 0.6 && < 0.7
|
|
||||||
, yesod-auth >= 0.2 && < 0.3
|
|
||||||
, mime-mail >= 0.0 && < 0.1
|
|
||||||
, wai-extra
|
|
||||||
, directory
|
|
||||||
, bytestring
|
|
||||||
, text
|
|
||||||
, persistent >= 0.3.1.1
|
|
||||||
, persistent-~lower~
|
|
||||||
, template-haskell
|
|
||||||
, hamlet
|
|
||||||
, web-routes
|
|
||||||
, hjsmin >= 0.0.4 && < 0.1
|
|
||||||
ghc-options: -Wall
|
|
||||||
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
|
||||||
|
|
||||||
executable devel-server
|
|
||||||
if flag(production)
|
|
||||||
Buildable: False
|
|
||||||
else
|
|
||||||
build-depends: wai-handler-devel >= 0.1.0 && < 0.2
|
|
||||||
main-is: devel-server.hs
|
|
||||||
ghc-options: -Wall -O2
|
|
||||||
|
|
||||||
executable fastcgi
|
|
||||||
if flag(production)
|
|
||||||
Buildable: True
|
|
||||||
build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3
|
|
||||||
else
|
|
||||||
Buildable: False
|
|
||||||
cpp-options: -DPRODUCTION
|
|
||||||
main-is: fastcgi.hs
|
|
||||||
ghc-options: -Wall -threaded
|
|
||||||
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
|
||||||
|
|
||||||
@ -1,6 +0,0 @@
|
|||||||
Yesod uses Persistent for its (you guessed it) persistence layer.
|
|
||||||
This tool will build in either SQLite or PostgreSQL support for you. If you
|
|
||||||
want to use a different backend, you'll have to make changes manually.
|
|
||||||
If you're not sure, stick with SQLite: it has no dependencies.
|
|
||||||
|
|
||||||
So, what'll it be? s for sqlite, p for postgresql:
|
|
||||||
@ -1,3 +0,0 @@
|
|||||||
body
|
|
||||||
font-family: sans-serif
|
|
||||||
|
|
||||||
@ -1,10 +0,0 @@
|
|||||||
!!!
|
|
||||||
%html
|
|
||||||
%head
|
|
||||||
%title $pageTitle.pc$
|
|
||||||
^pageHead.pc^
|
|
||||||
%body
|
|
||||||
$maybe mmsg msg
|
|
||||||
#message $msg$
|
|
||||||
^pageBody.pc^
|
|
||||||
|
|
||||||
@ -1,20 +0,0 @@
|
|||||||
import Network.Wai.Handler.DevelServer (run)
|
|
||||||
import Control.Concurrent (forkIO)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
mapM_ putStrLn
|
|
||||||
[ "Starting your server process. Code changes will be automatically"
|
|
||||||
, "loaded as you save your files. Type \"quit\" to exit."
|
|
||||||
, "You can view your app at http://localhost:3000/"
|
|
||||||
, ""
|
|
||||||
]
|
|
||||||
_ <- forkIO $ run 3000 "Controller" "with~sitearg~" ["hamlet"]
|
|
||||||
go
|
|
||||||
where
|
|
||||||
go = do
|
|
||||||
x <- getLine
|
|
||||||
case x of
|
|
||||||
'q':_ -> putStrLn "Quitting, goodbye!"
|
|
||||||
_ -> go
|
|
||||||
|
|
||||||
@ -1,5 +0,0 @@
|
|||||||
Now where would you like me to place your generated files? I'm smart enough
|
|
||||||
to create the directories, don't worry about that. If you leave this answer
|
|
||||||
blank, we'll place the files in ~project~.
|
|
||||||
|
|
||||||
Directory name:
|
|
||||||
@ -1,6 +0,0 @@
|
|||||||
import Controller
|
|
||||||
import Network.Wai.Handler.FastCGI (run)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = with~sitearg~ run
|
|
||||||
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 1.1 KiB |
@ -1,5 +0,0 @@
|
|||||||
h1
|
|
||||||
text-align: center
|
|
||||||
h2#$h2id$
|
|
||||||
color: #990
|
|
||||||
|
|
||||||
@ -1,13 +0,0 @@
|
|||||||
%h1 Hello
|
|
||||||
%h2#$h2id$ You do not have Javascript enabled.
|
|
||||||
$maybe mu u
|
|
||||||
%p
|
|
||||||
You are logged in as $userIdent.snd.u$. $
|
|
||||||
%a!href=@AuthR.LogoutR@ Logout
|
|
||||||
\.
|
|
||||||
$nothing
|
|
||||||
%p
|
|
||||||
You are not logged in. $
|
|
||||||
%a!href=@AuthR.LoginR@ Login now
|
|
||||||
\.
|
|
||||||
|
|
||||||
@ -1,4 +0,0 @@
|
|||||||
window.onload = function(){
|
|
||||||
document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>";
|
|
||||||
}
|
|
||||||
|
|
||||||
@ -1 +0,0 @@
|
|||||||
user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug
|
|
||||||
@ -1 +0,0 @@
|
|||||||
user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production
|
|
||||||
@ -1,4 +0,0 @@
|
|||||||
Welcome ~name~.
|
|
||||||
What do you want to call your project? We'll use this for the cabal name.
|
|
||||||
|
|
||||||
Project name:
|
|
||||||
@ -1,6 +0,0 @@
|
|||||||
import Controller
|
|
||||||
import Network.Wai.Handler.SimpleServer (run)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = putStrLn "Loaded" >> with~sitearg~ (run 3000)
|
|
||||||
|
|
||||||
@ -1,5 +0,0 @@
|
|||||||
Great, we'll be creating ~project~ today, and placing it in ~dir~.
|
|
||||||
What's going to be the name of your foundation datatype? This name must
|
|
||||||
start with a capital letter.
|
|
||||||
|
|
||||||
Foundation:
|
|
||||||
@ -1,221 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
|
||||||
module ~sitearg~
|
|
||||||
( ~sitearg~ (..)
|
|
||||||
, ~sitearg~Route (..)
|
|
||||||
, resources~sitearg~
|
|
||||||
, Handler
|
|
||||||
, Widget
|
|
||||||
, maybeAuth
|
|
||||||
, requireAuth
|
|
||||||
, module Yesod
|
|
||||||
, module Settings
|
|
||||||
, module Model
|
|
||||||
, StaticRoute (..)
|
|
||||||
, AuthRoute (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Yesod
|
|
||||||
import Yesod.Helpers.Static
|
|
||||||
import Yesod.Helpers.Auth
|
|
||||||
import Yesod.Helpers.Auth.OpenId
|
|
||||||
import Yesod.Helpers.Auth.Email
|
|
||||||
import qualified Settings
|
|
||||||
import System.Directory
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import Web.Routes.Site (Site (formatPathSegments))
|
|
||||||
import Database.Persist.GenericSql
|
|
||||||
import Settings (hamletFile, cassiusFile, juliusFile, widgetFile)
|
|
||||||
import Model
|
|
||||||
import Data.Maybe (isJust)
|
|
||||||
import Control.Monad (join, unless)
|
|
||||||
import Network.Mail.Mime
|
|
||||||
import qualified Data.Text.Lazy
|
|
||||||
import qualified Data.Text.Lazy.Encoding
|
|
||||||
import Text.Jasmine (minifym)
|
|
||||||
|
|
||||||
-- | 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 ~sitearg~ = ~sitearg~
|
|
||||||
{ getStatic :: Static -- ^ Settings for static file serving.
|
|
||||||
, connPool :: Settings.ConnectionPool -- ^ Database connection pool.
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | A useful synonym; most of the handler functions in your application
|
|
||||||
-- will need to be of this type.
|
|
||||||
type Handler = GHandler ~sitearg~ ~sitearg~
|
|
||||||
|
|
||||||
-- | A useful synonym; most of the widgets functions in your application
|
|
||||||
-- will need to be of this type.
|
|
||||||
type Widget = GWidget ~sitearg~ ~sitearg~
|
|
||||||
|
|
||||||
-- This is where we define all of the routes in our application. For a full
|
|
||||||
-- explanation of the syntax, please see:
|
|
||||||
-- http://docs.yesodweb.com/book/web-routes-quasi/
|
|
||||||
--
|
|
||||||
-- This function does three things:
|
|
||||||
--
|
|
||||||
-- * Creates the route datatype ~sitearg~Route. Every valid URL in your
|
|
||||||
-- application can be represented as a value of this type.
|
|
||||||
-- * Creates the associated type:
|
|
||||||
-- type instance Route ~sitearg~ = ~sitearg~Route
|
|
||||||
-- * Creates the value resources~sitearg~ which contains information on the
|
|
||||||
-- resources declared below. This is used in Controller.hs by the call to
|
|
||||||
-- mkYesodDispatch
|
|
||||||
--
|
|
||||||
-- What this function does *not* do is create a YesodSite instance for
|
|
||||||
-- ~sitearg~. Creating that instance requires all of the handler functions
|
|
||||||
-- for our application to be in scope. However, the handler functions
|
|
||||||
-- usually require access to the ~sitearg~Route datatype. Therefore, we
|
|
||||||
-- split these actions into two functions and place them in separate files.
|
|
||||||
mkYesodData "~sitearg~" [~qq~parseRoutes|
|
|
||||||
/static StaticR Static getStatic
|
|
||||||
/auth AuthR Auth getAuth
|
|
||||||
|
|
||||||
/favicon.ico FaviconR GET
|
|
||||||
/robots.txt RobotsR GET
|
|
||||||
|
|
||||||
/ RootR GET
|
|
||||||
|]
|
|
||||||
|
|
||||||
-- Please see the documentation for the Yesod typeclass. There are a number
|
|
||||||
-- of settings which can be configured by overriding methods here.
|
|
||||||
instance Yesod ~sitearg~ where
|
|
||||||
approot _ = Settings.approot
|
|
||||||
|
|
||||||
defaultLayout widget = do
|
|
||||||
mmsg <- getMessage
|
|
||||||
pc <- widgetToPageContent $ do
|
|
||||||
widget
|
|
||||||
addCassius $(Settings.cassiusFile "default-layout")
|
|
||||||
hamletToRepHtml $(Settings.hamletFile "default-layout")
|
|
||||||
|
|
||||||
-- This is done to provide an optimization for serving static files from
|
|
||||||
-- a separate domain. Please see the staticroot setting in Settings.hs
|
|
||||||
urlRenderOverride a (StaticR s) =
|
|
||||||
Just $ uncurry (joinPath a Settings.staticroot) $ format s
|
|
||||||
where
|
|
||||||
format = formatPathSegments ss
|
|
||||||
ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))
|
|
||||||
ss = getSubSite
|
|
||||||
urlRenderOverride _ _ = Nothing
|
|
||||||
|
|
||||||
-- The page to be redirected to when authentication is required.
|
|
||||||
authRoute _ = Just $ AuthR LoginR
|
|
||||||
|
|
||||||
-- This function creates static content files in the static folder
|
|
||||||
-- and names them based on a hash of their content. This allows
|
|
||||||
-- expiration dates to be set far in the future without worry of
|
|
||||||
-- users receiving stale content.
|
|
||||||
addStaticContent ext' _ content = do
|
|
||||||
let fn = base64md5 content ++ '.' : ext'
|
|
||||||
let content' =
|
|
||||||
if ext' == "js"
|
|
||||||
then case minifym content of
|
|
||||||
Left _ -> content
|
|
||||||
Right y -> y
|
|
||||||
else content
|
|
||||||
let statictmp = Settings.staticdir ++ "/tmp/"
|
|
||||||
liftIO $ createDirectoryIfMissing True statictmp
|
|
||||||
let fn' = statictmp ++ fn
|
|
||||||
exists <- liftIO $ doesFileExist fn'
|
|
||||||
unless exists $ liftIO $ L.writeFile fn' content'
|
|
||||||
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
|
||||||
|
|
||||||
-- How to run database actions.
|
|
||||||
instance YesodPersist ~sitearg~ where
|
|
||||||
type YesodDB ~sitearg~ = SqlPersist
|
|
||||||
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
|
|
||||||
|
|
||||||
instance YesodAuth ~sitearg~ where
|
|
||||||
type AuthId ~sitearg~ = UserId
|
|
||||||
|
|
||||||
-- Where to send a user after successful login
|
|
||||||
loginDest _ = RootR
|
|
||||||
-- Where to send a user after logout
|
|
||||||
logoutDest _ = RootR
|
|
||||||
|
|
||||||
getAuthId creds = runDB $ do
|
|
||||||
x <- getBy $ UniqueUser $ credsIdent creds
|
|
||||||
case x of
|
|
||||||
Just (uid, _) -> return $ Just uid
|
|
||||||
Nothing -> do
|
|
||||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
|
||||||
|
|
||||||
showAuthId _ = showIntegral
|
|
||||||
readAuthId _ = readIntegral
|
|
||||||
|
|
||||||
authPlugins = [ authOpenId
|
|
||||||
, authEmail
|
|
||||||
]
|
|
||||||
|
|
||||||
instance YesodAuthEmail ~sitearg~ where
|
|
||||||
type AuthEmailId ~sitearg~ = EmailId
|
|
||||||
|
|
||||||
showAuthEmailId _ = showIntegral
|
|
||||||
readAuthEmailId _ = readIntegral
|
|
||||||
|
|
||||||
addUnverified email verkey =
|
|
||||||
runDB $ insert $ Email email Nothing $ Just verkey
|
|
||||||
sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail
|
|
||||||
{ mailHeaders =
|
|
||||||
[ ("From", "noreply")
|
|
||||||
, ("To", email)
|
|
||||||
, ("Subject", "Verify your email address")
|
|
||||||
]
|
|
||||||
, mailParts = [[textPart, htmlPart]]
|
|
||||||
}
|
|
||||||
where
|
|
||||||
textPart = Part
|
|
||||||
{ partType = "text/plain; charset=utf-8"
|
|
||||||
, partEncoding = None
|
|
||||||
, partFilename = Nothing
|
|
||||||
, partContent = Data.Text.Lazy.Encoding.encodeUtf8
|
|
||||||
$ Data.Text.Lazy.pack $ unlines
|
|
||||||
[ "Please confirm your email address by clicking on the link below."
|
|
||||||
, ""
|
|
||||||
, verurl
|
|
||||||
, ""
|
|
||||||
, "Thank you"
|
|
||||||
]
|
|
||||||
}
|
|
||||||
htmlPart = Part
|
|
||||||
{ partType = "text/html; charset=utf-8"
|
|
||||||
, partEncoding = None
|
|
||||||
, partFilename = Nothing
|
|
||||||
, partContent = renderHtml [~qq~hamlet|
|
|
||||||
%p Please confirm your email address by clicking on the link below.
|
|
||||||
%p
|
|
||||||
%a!href=$verurl$ $verurl$
|
|
||||||
%p Thank you
|
|
||||||
|]
|
|
||||||
}
|
|
||||||
getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
|
|
||||||
setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key]
|
|
||||||
verifyAccount eid = runDB $ do
|
|
||||||
me <- get eid
|
|
||||||
case me of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just e -> do
|
|
||||||
let email = emailEmail e
|
|
||||||
case emailUser e of
|
|
||||||
Just uid -> return $ Just uid
|
|
||||||
Nothing -> do
|
|
||||||
uid <- insert $ User email Nothing
|
|
||||||
update eid [EmailUser $ Just uid, EmailVerkey Nothing]
|
|
||||||
return $ Just uid
|
|
||||||
getPassword = runDB . fmap (join . fmap userPassword) . get
|
|
||||||
setPassword uid pass = runDB $ update uid [UserPassword $ Just pass]
|
|
||||||
getEmailCreds email = runDB $ do
|
|
||||||
me <- getBy $ UniqueEmail email
|
|
||||||
case me of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just (eid, e) -> return $ Just EmailCreds
|
|
||||||
{ emailCredsId = eid
|
|
||||||
, emailCredsAuthId = emailUser e
|
|
||||||
, emailCredsStatus = isJust $ emailUser e
|
|
||||||
, emailCredsVerkey = emailVerkey e
|
|
||||||
}
|
|
||||||
getEmail = runDB . fmap (fmap emailEmail) . get
|
|
||||||
|
|
||||||
@ -1,6 +0,0 @@
|
|||||||
Welcome to the Yesod scaffolder.
|
|
||||||
I'm going to be creating a skeleton Yesod project for you.
|
|
||||||
|
|
||||||
What is your name? We're going to put this in the cabal and LICENSE files.
|
|
||||||
|
|
||||||
Your name:
|
|
||||||
Loading…
Reference in New Issue
Block a user