405 lines
11 KiB
Haskell
405 lines
11 KiB
Haskell
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
|
|
import CodeGenQ
|
|
import System.IO
|
|
import System.Directory
|
|
import qualified Data.ByteString.Char8 as S
|
|
import Language.Haskell.TH.Syntax
|
|
|
|
writeFile' :: FilePath -> String -> IO ()
|
|
writeFile' fp s = do
|
|
putStrLn $ "Generating " ++ fp
|
|
writeFile fp s
|
|
|
|
main :: IO ()
|
|
main = do
|
|
putStr [$codegen|Welcome to the Yesod scaffolder.
|
|
I'm going to be creating a skeleton Yesod project for you.
|
|
Please make sure you are in the directory where you'd like the files created.
|
|
|
|
What is your name? We're going to put this in the cabal and LICENSE files.
|
|
|
|
Your name: |]
|
|
hFlush stdout
|
|
name <- getLine
|
|
|
|
putStr [$codegen|
|
|
Welcome ~name~.
|
|
What do you want to call your project? We'll use this for the cabal name and
|
|
executable filenames.
|
|
|
|
Project name: |]
|
|
hFlush stdout
|
|
project <- getLine
|
|
putStr [$codegen|
|
|
Great, we'll be creating ~project~ today. What's going to be the name of
|
|
your site argument datatype? This name must start with a capital letter;
|
|
I recommend picking something short, as this name gets typed a lot.
|
|
|
|
Site argument: |]
|
|
hFlush stdout
|
|
sitearg <- getLine
|
|
putStr [$codegen|
|
|
That's it! I'm creating your files now...
|
|
|]
|
|
|
|
createDirectoryIfMissing False "Handler"
|
|
createDirectoryIfMissing False "hamlet"
|
|
createDirectoryIfMissing False "cassius"
|
|
createDirectoryIfMissing False "julius"
|
|
|
|
writeFile' "simple-server.hs" [$codegen|
|
|
import Controller
|
|
import Network.Wai.Handler.SimpleServer (run)
|
|
|
|
main :: IO ()
|
|
main = with~sitearg~ $ run 3000
|
|
|]
|
|
|
|
writeFile' "fastcgi.hs" [$codegen|
|
|
import Controller
|
|
import Network.Wai.Handler.FastCGI (run)
|
|
|
|
main :: IO ()
|
|
main = with~sitearg~ run
|
|
|]
|
|
|
|
writeFile' (project ++ ".cabal") [$codegen|
|
|
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://www.yesodweb.com/~project~
|
|
|
|
Flag production
|
|
Description: Build the production executable.
|
|
Default: False
|
|
|
|
executable simple-server
|
|
if flag(production)
|
|
Buildable: False
|
|
cpp-options: -DDEBUG
|
|
main-is: simple-server.hs
|
|
build-depends: base >= 4 && < 5,
|
|
yesod >= 0.5 && < 0.6,
|
|
wai-extra,
|
|
directory,
|
|
bytestring,
|
|
persistent,
|
|
persistent-sqlite,
|
|
template-haskell,
|
|
hamlet
|
|
ghc-options: -Wall
|
|
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
|
|
|
executable fastcgi
|
|
if flag(production)
|
|
Buildable: True
|
|
else
|
|
Buildable: False
|
|
main-is: fastcgi.hs
|
|
build-depends: wai-handler-fastcgi
|
|
ghc-options: -Wall
|
|
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
|
|]
|
|
|
|
writeFile' "LICENSE" [$codegen|
|
|
The following license covers this documentation, and the source code, except
|
|
where otherwise indicated.
|
|
|
|
Copyright 2010, ~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.
|
|
|]
|
|
|
|
writeFile' (sitearg ++ ".hs") [$codegen|
|
|
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
|
module ~sitearg~
|
|
( ~sitearg~ (..)
|
|
, ~sitearg~Route (..)
|
|
, resources~sitearg~
|
|
, Handler
|
|
, module Yesod
|
|
, module Settings
|
|
, module Model
|
|
) where
|
|
|
|
import Yesod
|
|
import Yesod.Helpers.Static
|
|
import qualified Settings
|
|
import System.Directory
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Yesod.WebRoutes
|
|
import Database.Persist.GenericSql
|
|
import Settings (hamletFile, cassiusFile, juliusFile)
|
|
import Model
|
|
|
|
data ~sitearg~ = ~sitearg~
|
|
{ getStatic :: Static
|
|
, connPool :: Settings.ConnectionPool
|
|
}
|
|
|
|
type Handler = GHandler ~sitearg~ ~sitearg~
|
|
|
|
mkYesodData "~sitearg~" [$parseRoutes|
|
|
/ RootR GET POST
|
|
/static StaticR Static getStatic
|
|
/favicon.ico FaviconR GET
|
|
/robots.txt RobotsR GET
|
|
|~~]
|
|
|
|
instance Yesod ~sitearg~ where
|
|
approot _ = Settings.approot
|
|
defaultLayout widget = do
|
|
pc <- widgetToPageContent $ do
|
|
widget
|
|
addStyle $(Settings.cassiusFile "default-layout")
|
|
hamletToRepHtml $(Settings.hamletFile "default-layout")
|
|
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
|
|
addStaticContent ext' _ content = do
|
|
let fn = base64md5 content ++ '.' : ext'
|
|
let statictmp = Settings.staticdir ++ "/tmp/"
|
|
liftIO $ createDirectoryIfMissing True statictmp
|
|
liftIO $ L.writeFile (statictmp ++ fn) content
|
|
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
|
|
|
instance YesodPersist ~sitearg~ where
|
|
type YesodDB ~sitearg~ = SqlPersist
|
|
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
|
|
|]
|
|
|
|
writeFile' "Controller.hs" [$codegen|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Controller
|
|
( with~sitearg~
|
|
) where
|
|
|
|
import ~sitearg~
|
|
import Settings
|
|
import Yesod.Helpers.Static
|
|
import Database.Persist.GenericSql
|
|
|
|
import Handler.Root
|
|
|
|
mkYesodDispatch "~sitearg~" resources~sitearg~
|
|
|
|
getFaviconR :: Handler ()
|
|
getFaviconR = sendFile "image/x-icon" "favicon.ico"
|
|
|
|
getRobotsR :: Handler RepPlain
|
|
getRobotsR = return $ RepPlain $ toContent "User-agent: *"
|
|
|
|
with~sitearg~ :: (Application -> IO a) -> IO a
|
|
with~sitearg~ f = Settings.withConnectionPool $ \p -> do
|
|
flip runConnectionPool p $ runMigration $ do
|
|
migrate (undefined :: Message)
|
|
let h = ~sitearg~ s p
|
|
toWaiApp h >>= f
|
|
where
|
|
s = fileLookupDir Settings.staticdir typeByExt
|
|
|]
|
|
|
|
writeFile' "Handler/Root.hs" [$codegen|
|
|
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
|
|
module Handler.Root where
|
|
|
|
import ~sitearg~
|
|
import Control.Applicative
|
|
|
|
messageFormlet :: Formlet sub master Message
|
|
messageFormlet x = fieldsToTable
|
|
$ Message <$> textareaField "Message"
|
|
(fmap messageContent x)
|
|
|
|
getRootR :: Handler RepHtml
|
|
getRootR = do
|
|
messages <- runDB $ selectList [] [] 10 0
|
|
(_, wform, _) <- runFormGet $ messageFormlet Nothing
|
|
defaultLayout $ do
|
|
setTitle "~project~ homepage"
|
|
ident <- newIdent
|
|
form <- extractBody wform
|
|
addBody $(hamletFile "homepage")
|
|
addStyle $(cassiusFile "homepage")
|
|
addJavascript $(juliusFile "homepage")
|
|
|
|
postRootR :: Handler ()
|
|
postRootR = do
|
|
(res, _, _) <- runFormPost $ messageFormlet Nothing
|
|
case res of
|
|
FormSuccess message -> runDB (insert message) >> return ()
|
|
_ -> return ()
|
|
redirect RedirectTemporary RootR
|
|
|]
|
|
|
|
writeFile' "Model.hs" [$codegen|
|
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
|
|
module Model where
|
|
|
|
import Yesod
|
|
|
|
mkPersist [$persist|
|
|
Message
|
|
content Textarea
|
|
|~~]
|
|
|]
|
|
|
|
writeFile' "Settings.hs" [$codegen|
|
|
{-# LANGUAGE CPP #-}
|
|
module Settings
|
|
( hamletFile
|
|
, cassiusFile
|
|
, juliusFile
|
|
, 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.Sqlite
|
|
import Yesod (MonadCatchIO)
|
|
|
|
hamletFile :: FilePath -> Q Exp
|
|
#ifdef DEBUG
|
|
hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet"
|
|
#else
|
|
hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet"
|
|
#endif
|
|
|
|
cassiusFile :: FilePath -> Q Exp
|
|
#ifdef DEBUG
|
|
cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius"
|
|
#else
|
|
cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius"
|
|
#endif
|
|
|
|
juliusFile :: FilePath -> Q Exp
|
|
#ifdef DEBUG
|
|
juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius"
|
|
#else
|
|
juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius"
|
|
#endif
|
|
|
|
connStr :: String
|
|
#ifdef DEBUG
|
|
connStr = "debug.db3"
|
|
#else
|
|
connStr = "production.db3"
|
|
#endif
|
|
|
|
connectionCount :: Int
|
|
connectionCount = 10
|
|
|
|
withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
|
|
withConnectionPool = withSqlitePool connStr connectionCount
|
|
|
|
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
|
|
runConnectionPool = runSqlPool
|
|
|
|
approot :: String
|
|
#ifdef DEBUG
|
|
approot = "http://localhost:3000"
|
|
#else
|
|
approot = "http://localhost:3000"
|
|
#endif
|
|
|
|
staticroot :: String
|
|
staticroot = approot ++ "/static"
|
|
|
|
staticdir :: FilePath
|
|
staticdir = "static"
|
|
|]
|
|
|
|
writeFile' "cassius/default-layout.cassius" [$codegen|
|
|
body
|
|
font-family: sans-serif
|
|
|]
|
|
|
|
writeFile' "hamlet/default-layout.hamlet" [$codegen|
|
|
!!!
|
|
%html
|
|
%head
|
|
%title $pageTitle.pc$
|
|
^pageHead.pc^
|
|
%body
|
|
^pageBody.pc^
|
|
|]
|
|
|
|
writeFile' "hamlet/homepage.hamlet" [$codegen|
|
|
%h1 Hello
|
|
%p#$ident$ Welcome.
|
|
%h3 Messages
|
|
$if null.messages
|
|
%p No messages.
|
|
$else
|
|
%ul
|
|
$forall messages m
|
|
%li $messageContent.snd.m$
|
|
%h3 Add Message
|
|
%form!method=post!action=@RootR@
|
|
%table
|
|
^form^
|
|
%tr
|
|
%td!colspan=2
|
|
%input!type=submit!value="Add Message"
|
|
|]
|
|
|
|
writeFile' "cassius/homepage.cassius" [$codegen|
|
|
body
|
|
font-family: sans-serif
|
|
h1
|
|
text-align: center
|
|
|]
|
|
|
|
writeFile' "julius/homepage.julius" [$codegen|
|
|
window.onload = function(){
|
|
document.getElementById("%ident%").innerHTML = "<i>Added from JavaScript.</i>";
|
|
}
|
|
|]
|
|
|
|
S.writeFile "favicon.ico"
|
|
$(runIO (S.readFile "favicon.ico") >>= \bs -> do
|
|
pack <- [|S.pack|]
|
|
return $ pack `AppE` LitE (StringL $ S.unpack bs))
|