Skip to content
Browse files

first barely working version

  • Loading branch information...
0 parents commit bcf149c68ed6928eea74890881cf88eb42c9689b @mzero committed Oct 2, 2010
Showing with 158 additions and 0 deletions.
  1. +10 −0 Index.hs
  2. +30 −0 LICENSE
  3. +2 −0 Setup.hs
  4. BIN Template.hi
  5. +8 −0 Template.hs
  6. +23 −0 barley.cabal
  7. +82 −0 barley.hs
  8. +3 −0 public/scaffold.css
10 Index.hs
@@ -0,0 +1,10 @@
+module Template where
+
+import Text.Html
+
+page =
+ thehtml (
+ header (
+ thelink ! [href "public/scaffold.css", rel "stylesheet", thetype "text/css"] noHtml
+ ) +++
+ h1 (toHtml "Welcome aboard!"))
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2010, Johan Tibell
+
+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.
+
+ * Neither the name of Johan Tibell nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"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
+OWNER OR CONTRIBUTORS 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.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
BIN Template.hi
Binary file not shown.
8 Template.hs
@@ -0,0 +1,8 @@
+module Template where
+
+import Text.Html
+
+page = thehtml << [
+ h1 << "Hi!",
+ paragraph << "testing"
+ ]
23 barley.cabal
@@ -0,0 +1,23 @@
+Name: barley
+Version: 0.1
+License: BSD3
+License-file: LICENSE
+Author: Johan Tibell, Mark Lentczner
+Maintainer: johan.tibell@gmail.com
+Category: Web
+Build-type: Simple
+Cabal-version: >=1.2
+
+Executable barley
+ Main-is: barley.hs
+
+ Build-depends:
+ base < 4.3,
+ bytestring < 1.0,
+ directory < 1.1,
+ filepath < 1.2,
+ plugins,
+ snap-core,
+ snap-server,
+ html < 1.1.2,
+ transformers
82 barley.hs
@@ -0,0 +1,82 @@
+module Main (main) where
+
+import Control.Monad.IO.Class
+import qualified Data.ByteString.Char8 as C
+import Prelude hiding (init)
+import Snap.Http.Server
+import Snap.Types
+import System.Directory (getCurrentDirectory)
+import System.Environment
+import System.Exit
+import System.FilePath ((</>))
+import System.Plugins
+import Text.Html hiding ((</>), start)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["start"] -> start
+ ["init"] -> init
+ ["run"] -> run
+ [cmd] -> do putStrLn $ "unknown command: " ++ cmd
+ exitFailure
+ _ -> putStrLn "Usage: barley <command>" >> exitFailure
+
+-- | Create a project directory structure and run the web server.
+start :: IO ()
+start = init >> run
+
+-- | Create a project directory structure.
+init :: IO ()
+init = return ()
+
+-- | Run the web server.
+run :: IO ()
+run = do
+ let address = "*"
+ port = 8080
+ hostname = "myserver"
+ putStrLn $ "Running on http://localhost:" ++ show port ++ "/"
+ httpServe (C.pack address) port (C.pack hostname) Nothing Nothing
+ genericHandler
+
+-- | Compile a template and return the generate HTML as a String.
+compile :: FilePath -> IO String
+compile filename = do
+ status <- make filename []
+ html <- case status of
+ MakeSuccess _ objfile -> do
+ putStrLn objfile
+ loadStatus <- load_ objfile [] "page"
+ case loadStatus of
+ LoadSuccess _ page -> do
+ return $ (page :: Html)
+ LoadFailure errs -> do
+ errorHtml errs filename
+ MakeFailure errs -> do
+ errorHtml errs filename
+ return $ renderHtml html
+
+-- | Given a URL, render the corresponding template.
+genericHandler :: Snap ()
+genericHandler = do
+ -- TODO: Check if the URL points inside the templates directory.
+ -- TODO: Server public/index.html for /
+ uri <- rqURI `fmap` getRequest
+ cwd <- liftIO getCurrentDirectory
+ -- XXX: directory traversal
+ html <- liftIO $ compile (cwd </> tail (C.unpack uri))
+ writeBS (C.pack html)
+
+-- | Given a list of errors and a template, create an HTML page that
+-- displays the errors.
+errorHtml :: Errors -> FilePath -> IO Html
+errorHtml errs filename = do
+ content <- readFile filename
+ length content `seq` return ()
+ let html = thehtml << body << (thediv ! [theclass "errors"] << [
+ h2 << "Errors",
+ pre << unlines errs]) +++
+ pre (toHtml content)
+ return html
3 public/scaffold.css
@@ -0,0 +1,3 @@
+h1 {
+ font-size: 13pt;
+}

0 comments on commit bcf149c

Please sign in to comment.
Something went wrong with that request. Please try again.