Permalink
Browse files

Initial web stuff

  • Loading branch information...
1 parent d79c4ed commit 7d63785e29cf9ad8b6fb990a68533de5d3462429 @singpolyma committed Mar 20, 2013
Showing with 123 additions and 0 deletions.
  1. +5 −0 .gitignore
  2. +40 −0 Application.hs
  3. +18 −0 Main.hs
  4. +15 −0 Makefile
  5. +12 −0 Records.hs
  6. +1 −0 routes
  7. +32 −0 view/report.mustache
View
5 .gitignore
@@ -3,6 +3,11 @@
*.swp*
*.orig
*.rej
+Main
+MustacheTemplates.hs
+PathPieces.hs
+Routes.hs
+dev.db
tests/suite
dist/*
report.html
View
40 Application.hs
@@ -0,0 +1,40 @@
+module Application where
+
+import Network.Wai (Request(..), Response(..), Application)
+import Network.HTTP.Types (ok200, notFound404, seeOther303, badRequest400, notAcceptable406, Status, ResponseHeaders)
+import Network.Wai.Util (string, stringHeaders)
+import Web.PathPieces (PathPiece(..))
+import Data.Base58Address (RippleAddress)
+import Control.Error (readMay)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
+import qualified Data.Text as T
+import qualified Data.Text.Lazy.Builder as TL
+
+import Records
+import MustacheTemplates
+
+-- Orphan instances, do not import this module!
+
+instance PathPiece RippleAddress where
+ fromPathPiece = readMay . T.unpack
+ toPathPiece = T.pack . show
+
+htmlEscape :: String -> String
+htmlEscape = concatMap escChar
+ where
+ escChar '&' = "&"
+ escChar '"' = """
+ escChar '<' = "&lt;"
+ escChar '>' = "&gt;"
+ escChar c = [c]
+
+responseTextBuilder :: Status -> ResponseHeaders -> TL.Builder -> Response
+responseTextBuilder s h = ResponseBuilder s h . Blaze.fromLazyText . TL.toLazyText
+
+on404 :: Application
+on404 _ = string notFound404 [] "Not Found"
+
+reportFor :: RippleAddress -> Application
+reportFor adr req = return $ responseTextBuilder ok200 headers (viewReport htmlEscape $ Report adr)
+ where
+ Just headers = stringHeaders [("Content-Type", "text/html; charset=utf8")]
View
18 Main.hs
@@ -0,0 +1,18 @@
+module Main (main) where
+
+import Network.Wai.Handler.Warp (run)
+import Network.Wai.Middleware.RequestLogger (logStdoutDev)
+import Network.Wai.Middleware.Autohead (autohead)
+import Network.Wai.Middleware.Jsonp (jsonp)
+import Network.Wai.Middleware.AcceptOverride (acceptOverride)
+
+import Network.Wai.Dispatch
+import Routes
+import Application
+
+main :: IO ()
+main = do
+ putStrLn "Running..."
+ run 3000 $
+ logStdoutDev $ autohead $ acceptOverride $ jsonp $ -- Middleware
+ dispatch on404 $ routes -- Do routing
View
15 Makefile
@@ -0,0 +1,15 @@
+Main: Main.hs Application.hs Routes.hs MustacheTemplates.hs
+ ghc -Wall -fno-warn-name-shadowing Main.hs
+
+Routes.hs: routes
+ routeGenerator -r -m Application -n 0 $< > $@
+
+PathHelpers.hs: routes
+ routeGenerator -p -n 0 $< > $@
+
+MustacheTemplates.hs: Records.hs view/report.mustache
+ mustache2hs -m Records.hs view/report.mustache Report > $@
+
+clean:
+ find -name '*.o' -o -name '*.hi' | xargs $(RM)
+ $(RM) -r dist dist-ghc Main Routes.hs PathHelpers.hs MustacheTemplates.hs
View
12 Records.hs
@@ -0,0 +1,12 @@
+module Records where
+
+import Data.Base58Address (RippleAddress)
+import qualified Data.Text.Buildable as TL
+import qualified Data.Text.Format.Types as TL
+
+instance TL.Buildable RippleAddress where
+ build adr = TL.build (TL.Shown adr)
+
+data Report = Report {
+ address :: RippleAddress
+ }
View
1 routes
@@ -0,0 +1 @@
+GET /for/: => reportFor
View
32 view/report.mustache
@@ -0,0 +1,32 @@
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
+ <title>Ripple Union Credit Report for {{address}}</title>
+
+ <style type="text/css">
+ html, body {
+ background-color: #abcdef;
+ font-family: "Liberation Sans", sans-serif;
+ }
+
+ body {
+ margin-left: 10%;
+ margin-right: 10%;
+ margin-top: 2em;
+ }
+
+ h1 * {
+ vertical-align: middle;
+ }
+
+ h1 img {
+ padding-right: 5em;
+ }
+ </style>
+ </head>
+
+ <body>
+ <h1><img src="logo.png" alt="Ripple Union" /> Credit Report for {{address}}</h1>
+ </body>
+</html>

0 comments on commit 7d63785

Please sign in to comment.