Removed old tests and yesod CLI
This commit is contained in:
Michael Snoyman
parent
9dbf6971ad
commit
57e4bef957
@ -1,70 +0,0 @@
|
||||
{-# 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
|
||||
@ -1,25 +0,0 @@
|
||||
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.
|
||||
@ -1,5 +0,0 @@
|
||||
approot: http://localhost:3000/
|
||||
static-root: http://localhost:3000/static/
|
||||
static-dir: static
|
||||
template-dir: templates
|
||||
port: 3000
|
||||
@ -1,10 +0,0 @@
|
||||
html {
|
||||
background: #ccc;
|
||||
}
|
||||
body {
|
||||
width: 760px;
|
||||
margin: 10px auto;
|
||||
padding: 10px;
|
||||
border: 1px solid #333;
|
||||
background: #fff;
|
||||
}
|
||||
@ -1,7 +0,0 @@
|
||||
\$layout(
|
||||
title={Homepage};
|
||||
content={
|
||||
<h1>Homepage</h1>
|
||||
<p>You probably want to put your own content here.</p>
|
||||
}
|
||||
)\$
|
||||
@ -1,11 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<title>\$title\$</title>
|
||||
<link rel="stylesheet" href="\$staticroot\$style.css">
|
||||
\$extrahead\$
|
||||
</head>
|
||||
<body>
|
||||
\$content\$
|
||||
</body>
|
||||
</html>
|
||||
@ -1,21 +0,0 @@
|
||||
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
76
CLI/yesod.hs
@ -1,76 +0,0 @@
|
||||
{-# 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."
|
||||
@ -1,59 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
module Test.Errors (testSuite) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Auth
|
||||
import Test.Framework (testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
|
||||
data Errors
|
||||
instance Yesod Errors where
|
||||
resources = [$mkResources|
|
||||
/denied:
|
||||
Get: denied
|
||||
/needs-ident:
|
||||
Get: needsIdent
|
||||
/has-args:
|
||||
Get: hasArgs
|
||||
|]
|
||||
instance YesodApproot Errors where
|
||||
approot _ = "IGNORED/"
|
||||
instance YesodAuth Errors
|
||||
|
||||
denied :: Handler Errors ()
|
||||
denied = permissionDenied
|
||||
|
||||
needsIdent :: Handler Errors (Html, HtmlObject)
|
||||
needsIdent = do
|
||||
i <- authIdentifier
|
||||
return (cs "", cs i)
|
||||
|
||||
hasArgs :: Handler Errors (Html, HtmlObject)
|
||||
hasArgs = do
|
||||
{- FIXME wait for new request API
|
||||
(a, b) <- runRequest $ (,) <$> getParam "firstParam"
|
||||
<*> getParam "secondParam"
|
||||
-}
|
||||
let (a, b) = ("foo", "bar")
|
||||
return (cs "", cs [a :: String, b])
|
||||
|
||||
caseErrorMessages :: Assertion
|
||||
caseErrorMessages = do return ()
|
||||
{- FIXME
|
||||
app <- toWaiApp Errors
|
||||
res <- app $ def { pathInfo = B8.pack "/denied/" }
|
||||
assertBool "/denied/" $ "Permission denied" `isInfixOf` show res
|
||||
res' <- app $ def { pathInfo = B8.pack "/needs-ident/" }
|
||||
assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res'
|
||||
-}
|
||||
{- FIXME this test is not yet ready
|
||||
res3 <- app $ def { pathInfo = "/has-args/" }
|
||||
assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3
|
||||
-}
|
||||
|
||||
testSuite :: Test
|
||||
testSuite = testGroup "Test.Errors"
|
||||
[ testCase "errorMessages" caseErrorMessages
|
||||
]
|
||||
@ -1,99 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Test.QuasiResource (testSuite) where
|
||||
|
||||
import Yesod
|
||||
import Test.Framework (testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
import Data.List
|
||||
import Network.Wai (Method (..))
|
||||
|
||||
data MyYesod = MyYesod
|
||||
|
||||
instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler"
|
||||
|
||||
addHead' :: HtmlObject -> (Html, HtmlObject)
|
||||
addHead' x = (cs "", x)
|
||||
|
||||
addHead :: Monad m => HtmlObject -> m (Html, HtmlObject)
|
||||
addHead = return . addHead'
|
||||
|
||||
getStatic :: Method -> [String] -> Handler MyYesod (Html, HtmlObject)
|
||||
getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p]
|
||||
pageIndex :: Handler MyYesod (Html, HtmlObject)
|
||||
pageIndex = addHead $ toHtmlObject ["pageIndex"]
|
||||
pageAdd :: Handler MyYesod ChooseRep
|
||||
pageAdd = return $ chooseRep $ addHead' $ toHtmlObject ["pageAdd"]
|
||||
pageDetail :: String -> Handler MyYesod ChooseRep
|
||||
pageDetail s = return $ chooseRep $ addHead' $ toHtmlObject ["pageDetail", s]
|
||||
pageDelete :: String -> Handler MyYesod (Html, HtmlObject)
|
||||
pageDelete s = addHead $ toHtmlObject ["pageDelete", s]
|
||||
pageUpdate :: String -> Handler MyYesod ChooseRep
|
||||
pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s]
|
||||
userInfo :: Integer -> Handler MyYesod (Html, HtmlObject)
|
||||
userInfo i = addHead $ toHtmlObject ["userInfo", show i]
|
||||
userVariable :: Integer -> String -> Handler MyYesod (Html, HtmlObject)
|
||||
userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s]
|
||||
userPage :: Integer -> [String] -> Handler MyYesod (Html, HtmlObject)
|
||||
userPage i p = addHead $ toHtmlObject ["userPage", show i, show p]
|
||||
|
||||
instance Show (Method -> Handler MyYesod ChooseRep) where
|
||||
show _ = "verb -> handler"
|
||||
instance Show (Resource -> Method -> Handler MyYesod ChooseRep) where
|
||||
show _ = "resource -> verb -> handler"
|
||||
handler :: Resource -> Method -> Handler MyYesod ChooseRep
|
||||
handler = [$mkResources|
|
||||
/static/*filepath/: getStatic
|
||||
/page/:
|
||||
GET: pageIndex
|
||||
PUT: pageAdd
|
||||
/page/$page/:
|
||||
GET: pageDetail
|
||||
DELETE: pageDelete
|
||||
POST: pageUpdate
|
||||
/user/#id/:
|
||||
GET: userInfo
|
||||
/user/#id/profile/$variable/:
|
||||
GET: userVariable
|
||||
/user/#id/page/*page/:
|
||||
GET: userPage
|
||||
|]
|
||||
|
||||
ph :: [String] -> Handler MyYesod ChooseRep -> Assertion
|
||||
ph ss h = do
|
||||
let eh = return . chooseRep . addHead' . toHtmlObject . show
|
||||
rr = error "No raw request"
|
||||
y = MyYesod
|
||||
cts = [TypeHtml]
|
||||
res <- runHandler h eh rr y cts
|
||||
res' <- myShow res
|
||||
mapM_ (helper res') ss
|
||||
where
|
||||
helper haystack needle =
|
||||
assertBool (show ("needle", needle, ss, haystack))
|
||||
$ needle `isInfixOf` haystack
|
||||
|
||||
myShow :: Response -> IO String
|
||||
myShow (Response sc hs ct c) = runContent c >>= \c' -> return $ unlines
|
||||
[ show sc
|
||||
, unlines $ map show hs
|
||||
, show ct
|
||||
, show c'
|
||||
]
|
||||
|
||||
caseQuasi :: Assertion
|
||||
caseQuasi = do
|
||||
ph ["200", "foo"] $ handler ["static", "foo", "bar", "baz"] GET
|
||||
ph ["404"] $ handler ["foo", "bar", "baz"] GET
|
||||
ph ["200", "pageIndex"] $ handler ["page"] GET
|
||||
ph ["404"] $ handler ["user"] GET
|
||||
ph ["404"] $ handler ["user", "five"] GET
|
||||
ph ["200", "userInfo", "5"] $ handler ["user", "5"] GET
|
||||
ph ["200", "userVar"] $ handler ["user", "5", "profile", "email"] GET
|
||||
|
||||
testSuite :: Test
|
||||
testSuite = testGroup "Test.QuasiResource"
|
||||
[ testCase "quasi" caseQuasi
|
||||
]
|
||||
@ -1 +0,0 @@
|
||||
foo:$o.foo$, bar:$o.bar$
|
||||
@ -1,10 +0,0 @@
|
||||
/static/*filepath/: getStatic
|
||||
/page/:
|
||||
GET: pageIndex
|
||||
PUT: pageAdd
|
||||
/page/$page/:
|
||||
GET: pageDetail
|
||||
DELETE: pageDelete
|
||||
POST: pageUpdate
|
||||
/user/#id/:
|
||||
GET: userInfo
|
||||
@ -1,15 +1,10 @@
|
||||
import Test.Framework (defaultMain)
|
||||
|
||||
-- FIXME import qualified Test.Errors
|
||||
-- FIXME import qualified Test.QuasiResource
|
||||
import qualified Web.Mime
|
||||
import qualified Yesod.Json
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[
|
||||
Web.Mime.testSuite
|
||||
[ Web.Mime.testSuite
|
||||
, Yesod.Json.testSuite
|
||||
-- FIXME , Test.Errors.testSuite
|
||||
-- FIXME, Test.QuasiResource.testSuite
|
||||
]
|
||||
|
||||
18
yesod.cabal
18
yesod.cabal
@ -5,19 +5,11 @@ license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: A library for creating RESTful web applications.
|
||||
description: This package stradles the line between framework and simply a controller. It provides minimal support for model and view, mostly focusing on making a controller which adheres strictly to RESTful principles.
|
||||
category: Web
|
||||
stability: unstable
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/code.html
|
||||
extra-source-files: CLI/skel/App.hs,
|
||||
CLI/skel/static/style.css,
|
||||
CLI/skel/settings.yaml,
|
||||
CLI/skel/LICENSE,
|
||||
CLI/skel/webapp.cabal,
|
||||
CLI/skel/templates/layout.st,
|
||||
CLI/skel/templates/homepage.st
|
||||
homepage: http://docs.yesodweb.com/yesod/
|
||||
|
||||
flag transformers_02
|
||||
description: transformers = 0.2.*
|
||||
@ -65,12 +57,6 @@ library
|
||||
Web.Mime
|
||||
ghc-options: -Wall
|
||||
|
||||
executable yesod
|
||||
ghc-options: -Wall
|
||||
build-depends: file-embed >= 0.0.3 && < 0.1,
|
||||
HStringTemplate >= 0.6.2 && < 0.7
|
||||
main-is: CLI/yesod.hs
|
||||
|
||||
executable runtests
|
||||
if flag(buildtests)
|
||||
Buildable: True
|
||||
|
||||
Loading…
Reference in New Issue
Block a user