diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Panda.hs b/Panda.hs new file mode 100644 --- /dev/null +++ b/Panda.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fno-monomorphism-restriction #-} + +module Panda + ( + module Panda.Controller.Application, + panda + ) where + +import Panda.Controller.Application +import Kibro +import Kibro.DB.Sqlite3 + +panda = kibro (db "") pages diff --git a/Panda/Config/Global.hs b/Panda/Config/Global.hs new file mode 100644 --- /dev/null +++ b/Panda/Config/Global.hs @@ -0,0 +1,32 @@ +module Panda.Config.Global where + +import Data.Maybe +import Text.Pandoc.UTF8 +import Panda.Helper.Helper +import Prelude hiding ((.), (/), id) +import MPS + +db_id = "db" +flat_id = "." +blog_id = "blog" +config_id = "config" + +db_uri = db_id +flat_uri = db_uri / flat_id + +config_uri = flat_uri / config_id / "site.txt" +blog_uri = flat_uri / blog_id + +markup = markdown + + +-- unsafe, might need to restart server after changing app/config file + +user_config = readFile config_uri .purify .split' .map (split "\\s*=\\s*") .map tuple2 +config_for s = user_config.lookup s.fromJust .fromUTF8 + +blog_title = config_for "blog_title" +host_name = config_for "host_name" +author_email = config_for "author_email" + + diff --git a/Panda/Controller/Application.hs b/Panda/Controller/Application.hs new file mode 100644 --- /dev/null +++ b/Panda/Controller/Application.hs @@ -0,0 +1,58 @@ +{-# OPTIONS -fno-monomorphism-restriction #-} + +module Panda.Controller.Application (pages) where + +import Kibro +import Kibro.DB.Sqlite3 +import Control.Monad hiding (join) +import Control.Arrow ((>>>)) +import Data.List +import Network.URI +import Network.CGI +import Text.Pandoc.UTF8 + +import MPS +import Prelude hiding ((.), (/), id) + +import Panda.Helper.Helper +import Panda.Model.Blog as Blog +import Panda.View.Blog as BlogV +import Panda.View.Template as T +import Panda.View.Static as StaticV +import Panda.Config.Global + +blog_regex = "^/[0-9][0-9]-[0-9][0-9]-[0-9][0-9]" + +pages = + [ ("^/$", index ) + , ("^/([?].+$)?$", index ) + , ("^/rss.xml$", blog_feed ) + , (blog_regex, blog ) + , ("^/static/.", static ) + , ("^/bench_template", bench_template ) + , ("^/bench_io", bench_io ) + , ("^/debug", debug ) + ] + +index = do + blogs <- Blog.list.liftIO + p <- pager 10 $ blogs.length + blogs.BlogV.list p.output_html + +blog_feed = do + blogs <- Blog.list.liftIO + blogs.BlogV.rss.output + +blog = do + id <- uri <.> ("blog/" ++) + blog <- Blog.get id .liftIO + blog.BlogV.view.output_html + +static = do + id <- uri + (flat_uri / id) .readFile .liftIO <.> StaticV.view >>= output_html + +bench_template = T.page "bench me" .output_html +bench_io = readFile "src/Main.hs" .liftIO >>= output + +debug = uri >>= output diff --git a/Panda/Helper/Helper.hs b/Panda/Helper/Helper.hs new file mode 100644 --- /dev/null +++ b/Panda/Helper/Helper.hs @@ -0,0 +1,82 @@ +{-# OPTIONS -fno-monomorphism-restriction #-} + +module Panda.Helper.Helper where + +import Network.URI +import Network.CGI +import System.FilePath.Posix (()) +import Kibro +import Control.Arrow ((>>>), (&&&)) +import Text.XHtml.Strict +import Control.Monad hiding (join) + +import Panda.Type.Pager as Pager +import MPS +import Prelude hiding ((.), (/), id) + +(/) = () + +-- controller +uri = do + uri <- requestURI + uri.uriPath.urlDecode.tail.return + +markdown_link l s = ["[", s, "]", "(", l, ")"] .join' + +params = do + query_string <- requestURI <.> uriQuery + case query_string of + '?':s -> s.split "&" .map (split "=" >>> tuple2) .return + otherwise -> return [] + +param_with_default s d = do + ps <- params + return $ case ps.lookup s of + Nothing -> d + Just x -> x.read + +pager length total = liftM5 ( Pager length ) current has_next has_previous next previous where + current = param_with_default "page" 1 + has_next = current <.> ( (* length) >>> (< total.fromIntegral) ) + has_previous = current <.> (> 1) + next = current <.> (+ 1) + previous = current <.> (+ (-1) ) + + +for_current_page p xs = xs.drop ((p.Pager.current - 1) * p.Pager.length) .take (p.Pager.length) + + + + +-- view +id = identifier + +css_link l = itag "link" ! [rel "stylesheet", thetype "text/css", href ("/css/" ++ l ++ ".css") ] +js_link l = itag "script" ! [thetype "text/javascript", src ("/js/" ++ l ++ ".js" )] +svg s a w h = image ! [src ("/svg/" ++ s), height (h.show), width (w.show), alt a] + +meta_tag = meta ! [httpequiv "Content-Type", content "text/html; charset=utf-8"] + +div_id s = thediv ! [id s] +div_class s = thediv ! [theclass s] +space = hr ! [theclass "space"] + +sep_by _ [] = toHtml "" +sep_by _ [x] = toHtmlFromList [x] +sep_by x xs = ( init >>> map (+++ x) ) &&& last >>> splash (+++) $ xs + +output_html = output ... renderHtml + +ie s = + [ "" + ] .join' .primHtml + +rss_uri x = URI { + uriScheme = "http://", + uriAuthority = Nothing, + uriPath = x / "rss.xml", + uriQuery = "", + uriFragment = "" + } diff --git a/Panda/Model/Blog.hs b/Panda/Model/Blog.hs new file mode 100644 --- /dev/null +++ b/Panda/Model/Blog.hs @@ -0,0 +1,44 @@ +{-# OPTIONS -fno-monomorphism-restriction #-} + +module Panda.Model.Blog ( + get, list, title, body, uid, date, parse_date +) where + +import Kibro hiding (title, body) +import Network.URI +import Network.CGI +import Text.Pandoc.UTF8 +import Control.Arrow ((>>>)) +import Control.Monad hiding (join) +import System.Directory +import Data.List +import Data.Maybe + +import MPS hiding (date) +import Prelude hiding ((.), (/), id) + +import Panda.Helper.Helper +import Panda.Config.Global +import System.Locale +import System.Time.Parse + +data Blog = Blog + { uid :: String -- blog/08-09-04 blog title + , title :: String + , body :: String + } + deriving (Show, Eq) + +list = do + ids <- getDirectoryContents blog_uri <.> (\\ [".", ".."]) <.> rsort <.> map ("" / "blog" /) + mapM get ids + +get id = liftM (Blog id (get_title id) ) (get_body id) +get_title id = id.fromUTF8.words.tail.join " " +get_body id = (flat_uri / id) .readFile + +parse_date = parseCalendarTime defaultTimeLocale "%Y-%m-%d" +date x = case x.uid.fromUTF8.words.first.split "/".last.("20"++).parse_date of + Nothing -> parse_date "2000-1-1".fromJust + Just x -> x + diff --git a/Panda/Type/Pager.hs b/Panda/Type/Pager.hs new file mode 100644 --- /dev/null +++ b/Panda/Type/Pager.hs @@ -0,0 +1,11 @@ +module Panda.Type.Pager where + +data Pager = Pager { + length :: Int, + current :: Int, + has_next :: Bool, + has_previous :: Bool, + next :: Int, + previous :: Int + } + deriving (Eq, Show) diff --git a/Panda/View/Blog.hs b/Panda/View/Blog.hs new file mode 100644 --- /dev/null +++ b/Panda/View/Blog.hs @@ -0,0 +1,78 @@ +module Panda.View.Blog where + +import Kibro + +import MPS +import Prelude hiding ((.), (/), id) +import Control.Arrow ((>>>)) + +import Panda.Helper.Helper +import Panda.View.Template +import Panda.Model.Blog as Blog +import Panda.Config.Global as Config +import Panda.Type.Pager as Pager +import Network.URI +import Text.RSS +import System.Time +import System.Locale + +-- HTML +-- render single entry +entry x = [entry_title, entry_body, entry_mark] where + entry_title = div_class "span-24 last" << x.title_link + entry_body = div_class "span-23 last" << x.Blog.body.markup + entry_mark = div_class "span-4 last" << x.blog_date + +entry_uri x = "/" ++ Blog.uid x.urlEncode.split "/".tail.join "/" +title_link x = h2 << hotlink (entry_uri x) << x.Blog.title +blog_date x = p << formatted where + formatted = x.Blog.date.formatCalendarTime defaultTimeLocale "- %b %e %Y" + +-- entry view +view x = x.entry.page + +-- list view +list p = for_current_page p >>> map entry >>> sep_by hr >>> (+++ hr) >>> (+++ nav p) >>> page + +nav p = + [ div_class "span-2 append-20" << nav_previous p + , div_class "span-2 last" << nav_next p + ] + +nav_previous p = if p.Pager.has_previous + then h2 << hotlink ( "/" ++ "?page=" ++ p.Pager.previous.show ) << previous_sign + else spaceHtml + +nav_next p = if p.Pager.has_next + then h2 << hotlink ( "/" ++ "?page=" ++ p.Pager.next.show ) << next_sign + else spaceHtml + +next_sign = svg "treble_clef.svg.png" ">>>" 18 44 +previous_sign = svg "bass_clef.svg.png" "<<<" 18 20 + + + + +-- RSS +channel_rss_template = + [ Language "en-us" + ] + +item_rss_template x = + [ Title $ x.Blog.title + , Description $ x.Blog.body.markup.show + , Author $ Config.author_email + , Link $ x.item_uri + , PubDate $ x.Blog.date + ] + +item_uri x = URI + { uriScheme = "http://" + , uriAuthority = Nothing + , uriPath = Config.host_name ++ x.entry_uri + , uriQuery = "" + , uriFragment = "" + } + +rss xs = RSS Config.blog_title (rss_uri Config.host_name) Config.blog_title channel_rss_template (xs.take 20 .map item_rss_template) + .rssToXML.showXML diff --git a/Panda/View/Static.hs b/Panda/View/Static.hs new file mode 100644 --- /dev/null +++ b/Panda/View/Static.hs @@ -0,0 +1,10 @@ +module Panda.View.Static where + +import Kibro + +import Control.Arrow ((>>>)) + +import Panda.View.Template +import Panda.Config.Global + +view = markup >>> (+++ hr) >>> page diff --git a/Panda/View/Template.hs b/Panda/View/Template.hs new file mode 100644 --- /dev/null +++ b/Panda/View/Template.hs @@ -0,0 +1,55 @@ +module Panda.View.Template where + +import Kibro + +import MPS +import Prelude hiding ((.), (/), id, span) + +import Panda.Config.Global as Config +import Panda.Helper.Helper + + + +-- template entry point +page x = html_head +++ html_body x + + +-- meta +html_head = header << [meta_tag, title_tag, screen_css, ie_css] + +title_tag = thetitle << Config.blog_title +screen_css = css_link "blueprint/screen" +ie_css = ie $ css_link "blueprint/ie" + + +-- builder +html_body x = body << [body_header, hr, body_content x] + +container = div_class "container" +home_link = h6 << hotlink "/" << "Home" +about = h6 << hotlink "/static/about" << "About" +rss_link = hotlink "/rss.xml" << image ! [src "/image/feed.png", alt "feed link", height "18", width "18"] + +body_header = container << + div_class "span-24 last" << + [ div_class "span-3" << hotlink "/" << + image ! [src "/image/piano.jpg", alt "logo", height "75", width "75"] + , div_class "span-21 last" << + [ space + , div_class "span-17 last" << h1 << "C大调" + , div_class "span-4 last" << + [ space + , space + , div_class "span-2 " << about + , div_class "span-2 last" << rss_link + ] + , space + ] + ] + +body_content x = container << div_class "span-24 last" << x + + +-- no footer for now +-- body_footer = container << div_class "span-24 last" << about + diff --git a/Rakefile b/Rakefile new file mode 100644 --- /dev/null +++ b/Rakefile @@ -0,0 +1,33 @@ +require 'rake' +require 'rake/clean' + +Dir['tasks/**/*.rake'].each { |rake| load rake } + +CLEAN.include %w[ + **/*.o + **/*.hi + Main.exe* + **/*.pid + **/*.sock + **/*.fcgi +] + +desc "refresh" +task :r do + #{}`ghc --make src/Main.hs -o public/example.fcgi -threaded` + `kibro refresh` + `kibro stop` + kill :fcgi + kill :lighttpd + `kibro start` +end + +desc "kill" +task :kill do + kill :fcgi + kill :lighttpd +end + +def kill(that) + `ps -A | grep #{that} | awk '{print $1}' | xargs kill -9` +end diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/panda.cabal b/panda.cabal new file mode 100644 --- /dev/null +++ b/panda.cabal @@ -0,0 +1,25 @@ +Name: panda +Version: 0.0 +Build-type: Simple +Synopsis: Simple Static Blog Engine +Description: Simple Static Blog Engine +License: BSD3 +License-file: LICENSE +Author: Wang, Jinjing +Maintainer: Wang, Jinjing +Build-Depends: base +Cabal-version: >= 1.2 +data-files: Rakefile + +library + build-depends: base, cgi, network, pandoc >= 0.46, old-locale, old-time, directory, filepath, mps >= 0.0, parsedate >= 3000.0.0, rss >= 3000.1.0, xhtml >= 3000.2.0.0, kibro >= 0.0 + exposed-modules: Panda + Panda.Controller.Application + Panda.Config.Global + Panda.Helper.Helper + Panda.Model.Blog + Panda.Type.Pager + Panda.View.Blog + Panda.View.Static + Panda.View.Template +