haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added yesod executable (with init)

Browse Source
This commit is contained in:
Snoyman 2010-03-07 16:51:58 -08:00
parent 9e77f4fab5
commit ef2e84668a
13 changed files with 267 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
CLI/skel/App.hs Normal file
View File

@ -0,0 +1,70 @@
{-# LANGUAGE QuasiQuotes #-}
import Yesod
import Yesod.Helpers.Static
import qualified Data.Object.Yaml
import qualified Safe.Failure
data $Datatype$ = $Datatype$
{ settings :: Settings
, templateGroup :: TemplateGroup
}
data Settings = Settings
{ sApproot :: String
, staticRoot :: String
, staticDir :: String
, templateDir :: String
, portNumber :: Int
}
settingsFile :: FilePath
settingsFile = "settings.yaml"
loadSettings :: IO Settings
loadSettings = do
m <- Data.Object.Yaml.decodeFile settingsFile >>= fromMapping
ar <- lookupScalar "approot" m
sr <- lookupScalar "static-root" m
sd <- lookupScalar "static-dir" m
td <- lookupScalar "template-dir" m
pn <- lookupScalar "port" m >>= Safe.Failure.read
return \$ Settings ar sr sd td pn
load$Datatype$ :: IO $Datatype$
load$Datatype$ = do
s <- loadSettings
tg <- loadTemplateGroup \$ templateDir s
return \$ $Datatype$ s tg
main :: IO ()
main = do
datatype <- load$Datatype$
app <- toWaiApp datatype
basicHandler (portNumber \$ settings datatype) app
instance Yesod $Datatype$ where
resources = [\$mkResources|
/:
GET: homepageH
/static/*: serveStatic'
|]
applyLayout = defaultApplyLayout
instance YesodApproot $Datatype$ where
approot = sApproot . settings
instance YesodTemplate $Datatype$ where
getTemplateGroup = templateGroup
defaultTemplateAttribs y _ = return
. setHtmlAttrib "approot" (approot y)
. setHtmlAttrib "staticroot" (staticRoot \$ settings y)
homepageH :: Handler $Datatype$ RepHtml
homepageH = templateHtml "homepage" return
serveStatic' :: Method -> [String]
-> Handler $Datatype$ [(ContentType, Content)]
serveStatic' method pieces = do
y <- getYesod
let sd = staticDir \$ settings y
serveStatic (fileLookupDir sd) method pieces

25
CLI/skel/LICENSE Normal file
View File

@ -0,0 +1,25 @@
The following license covers this documentation, and the source code, except
where otherwise indicated.
Copyright $year$, $author$. 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.

5
CLI/skel/settings.yaml Normal file
View File

@ -0,0 +1,5 @@
approot: http://localhost:3000/
static-root: http://localhost:3000/static/
static-dir: static
template-dir: templates
port: 3000

10
CLI/skel/static/style.css Normal file
View File

@ -0,0 +1,10 @@
html {
background: #ccc;
}
body {
width: 760px;
margin: 10px auto;
padding: 10px;
border: 1px solid #333;
background: #fff;
}

7
CLI/skel/templates/homepage.st Normal file
View File

@ -0,0 +1,7 @@
\$layout(
title={Homepage};
content={
<h1>Homepage</h1>
<p>You probably want to put your own content here.</p>
}
)\$

11
CLI/skel/templates/layout.st Normal file
View File

@ -0,0 +1,11 @@
<!DOCTYPE html>
<html>
<head>
<title>\$title\$</title>
<link rel="stylesheet" href="\$staticroot\$style.css">
\$extrahead\$
</head>
<body>
\$content\$
</body>
</html>

21
CLI/skel/webapp.cabal Normal file
View File

@ -0,0 +1,21 @@
name: $project$
version: 0.0.0
license: BSD3
license-file: LICENSE
author: $author$ $email$
maintainer: $author$ $email$
synopsis: A web application based on Yesod.
description: The default web application. You might want to change this.
category: Web
stability: Stable
cabal-version: >= 1.2
build-type: Simple
homepage: $homepage$
executable $project$
build-depends: base >= 4 && < 5,
yesod >= 0.0.0 && < 0.1,
safe-failure >= 0.4.0 && < 0.5,
data-object-yaml >= 0.2.0.1 && < 0.3
main-is: $Datatype$.hs
ghc-options: -Wall

76
CLI/yesod.hs Normal file
View File

@ -0,0 +1,76 @@
{-# LANGUAGE TemplateHaskell #-}
import Data.FileEmbed
import Text.StringTemplate
import Data.ByteString.Char8 (ByteString, unpack)
import System.Directory
import System.Environment
import System.IO
import Data.Char
skel :: [(FilePath, ByteString)]
skel = $(embedDir "CLI/skel")
yesodInit :: FilePath -> [(String, String)] -> IO ()
yesodInit topDir a = do
mapM_ (\x -> createDirectoryIfMissing True $ topDir ++ x)
["static", "templates"]
mapM_ go skel
where
go (fp, bs) = do
let temp = newSTMP $ unpack bs
writeFile (topDir ++ fp) $ toString $ setManyAttrib a temp
main :: IO ()
main = do
args <- getArgs
case args of
["init"] -> yesodInit'
_ -> usage
usage :: IO ()
usage = putStrLn "Currently, the only support operation is \"init\"."
prompt :: String -> (String -> Bool) -> IO String
prompt s t = do
putStr s
hFlush stdout
x <- getLine
if t x
then return x
else do
putStrLn "That was not valid input."
prompt s t
yesodInit' :: IO ()
yesodInit' = do
putStrLn "Let's get started created a Yesod web application."
dest <-
prompt
"In which directory would you like to put the application? "
(not . null)
dt <-
prompt
"Give a data type name (first letter capital): "
(\x -> not (null x) && isUpper (head x))
pr <- prompt
"Name of project (cabal file): "
(not . null)
au <- prompt
"Author (cabal file): "
(not . null)
em <- prompt
"Author email (cabal file): "
(not . null)
ho <- prompt
"Homepage (cabal file): "
(not . null)
yesodInit (dest ++ "/")
[ ("Datatype", dt)
, ("project", pr)
, ("author", au)
, ("email", em)
, ("homepage", ho)
]
renameFile (dest ++ "/webapp.cabal") (dest ++ "/" ++ pr ++ ".cabal")
renameFile (dest ++ "/App.hs") (dest ++ "/" ++ dt ++ ".hs")
putStrLn "Your project has been initialized."

3
Yesod.hs
View File

@ -25,6 +25,7 @@ module Yesod
, module Yesod.Template
, module Web.Mime
, Application
, Method (..)
) where
#if TEST
@ -45,5 +46,5 @@ import Yesod.Form
import Yesod.Yesod
import Yesod.Definitions
import Yesod.Handler
import Network.Wai (Application)
import Network.Wai (Application, Method (..))
import Yesod.Template

1
Yesod/Helpers/Static.hs
View File

@ -27,7 +27,6 @@ import Control.Monad
import Yesod
import Data.List (intercalate)
import Network.Wai (Method (GET))
type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))

18
Yesod/Template.hs
View File

@ -6,6 +6,7 @@ module Yesod.Template
, Template
, TemplateGroup
, loadTemplateGroup
, defaultApplyLayout
-- * HTML templates
, HtmlTemplate (..)
, templateHtml
@ -43,6 +44,23 @@ instance Exception NoSuchTemplate
loadTemplateGroup :: FilePath -> IO TemplateGroup
loadTemplateGroup = directoryGroupRecursiveLazy
defaultApplyLayout :: YesodTemplate y
=> y
-> Request
-> String -- ^ title
-> Html -- ^ body
-> Content
defaultApplyLayout y req t b =
case getStringTemplate "layout" $ getTemplateGroup y of
Nothing -> cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)
Just temp ->
ioTextToContent
$ fmap (render . unHtmlTemplate)
$ defaultTemplateAttribs y req
$ setHtmlAttrib "title" t
$ setHtmlAttrib "content" b
$ HtmlTemplate temp
type TemplateName = String
newtype HtmlTemplate = HtmlTemplate { unHtmlTemplate :: Template }

17
Yesod/Yesod.hs
View File

@ -6,6 +6,7 @@ module Yesod.Yesod
, applyLayoutJson
, getApproot
, toWaiApp
, basicHandler
) where
import Data.Object.Html
@ -26,6 +27,10 @@ import Network.Wai.Middleware.ClientSession
import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.MethodOverride
import qualified Network.Wai.Handler.SimpleServer as SS
import qualified Network.Wai.Handler.CGI as CGI
import System.Environment (getEnvironment)
class Yesod a where
-- | Please use the Quasi-Quoter, you\'ll be happier. For more information,
-- see the examples/fact.lhs sample.
@ -139,3 +144,15 @@ httpAccept = map contentTypeFromBS
. fromMaybe B.empty
. lookup W.Accept
. W.requestHeaders
-- | Runs an application with CGI if CGI variables are present (namely
-- PATH_INFO); otherwise uses SimpleServer.
basicHandler :: Int -- ^ port number
-> W.Application -> IO ()
basicHandler port app = do
vars <- getEnvironment
case lookup "PATH_INFO" vars of
Nothing -> do
putStrLn $ "http://localhost:" ++ show port ++ "/"
SS.run port app
Just _ -> CGI.run app

5
yesod.cabal
View File

@ -70,6 +70,11 @@ library
Web.Mime
ghc-options: -Wall -Werror
executable yesod
ghc-options: -Wall
build-depends: file-embed >= 0.0.3 && < 0.1
main-is: CLI/yesod.hs
executable runtests
if flag(buildtests)
Buildable: True