diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/.DS_Store | bin | 0 -> 6148 bytes | |||
-rw-r--r-- | src/Blog.hs | 33 | ||||
-rw-r--r-- | src/Server.hs | 98 |
3 files changed, 131 insertions, 0 deletions
diff --git a/src/.DS_Store b/src/.DS_Store new file mode 100644 index 000000000000..db284a629a24 --- /dev/null +++ b/src/.DS_Store Binary files differdiff --git a/src/Blog.hs b/src/Blog.hs new file mode 100644 index 000000000000..2a62bb768072 --- /dev/null +++ b/src/Blog.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module Blog where + +import Text.Blaze (toValue, preEscapedString) +import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) +import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +blogTemplate :: String -> String -> String -> Html +blogTemplate t h o = H.docTypeHtml $ do + H.head $ do + H.title $ (toHtml t) + H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href "/rss" + H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/blogstyle.css" ! A.media "all" + H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8" +{- H.style ! A.type_ "text/css" ! A.title "iOS iMessage" ! A.media "screen and (max-device-width: 1024px)" $ "#cosx{display:none;} #cios{display:block;}" -} + H.body $ do + H.div ! A.class_ "mainshell" $ H.div ! A.class_ "gradBox" $ H.div ! A.class_ "header" $ do + H.a ! A.href "/" ! A.style "text-decoration:none;color:black;font-size:x-large;font-weight:bold;" $ + (toHtml t) + H.br + H.span ! A.id "cosx" ! A.style "display:block;" $ H.b $ contactInfo "imessage:tazjin@me.com" + H.span ! A.id "cios" ! A.style "display:none;" $ H.b $ contactInfo "sms:tazjin@me.com" + where + contactInfo (imu :: String) = do + toHtml h + H.a ! A.href "mailto:hej@tazj.in" $ "Mail" + ", " + H.a ! A.href "http://twitter.com/#!/tazjin" ! A.target "_blank" $ "Twitter" + toHtml o + H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage" + "." \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 000000000000..aa41a2173d6e --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-} + +module Main where + +import Control.Monad (msum, mzero) +import Data.Data (Data, Typeable) +import Data.Monoid (mempty) +import Data.ByteString.Char8 (ByteString) +import Data.Text hiding (map, length, zip, head) +import Data.Time +import Database.CouchDB +import Happstack.Server +import Text.Blaze (toValue, preEscapedString) +import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) +import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.JSON.Generic + +import Blog + +tmpPolicy :: BodyPolicy +tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000) + +data BlogLang = EN | DE + +data Comment = Comment{ + cauthor :: String, + ctext :: String, + cdate :: Integer +} deriving (Show, Data, Typeable) + +data Entry = Entry{ + _id :: String, + year :: Int, + month :: Int, + day :: Int, + lang :: String, + title :: String, + author :: String, + text :: String, + mtext :: String, + comments :: [Comment] +} deriving (Show, Data, Typeable) + +instance Show BlogLang where + show EN = "en" + show DE = "de" + +--TazBlog version +version = ("2.2b" :: String) + +main :: IO() +main = do + putStrLn ("TazBlog " ++ version ++ " in Haskell starting") + simpleHTTP nullConf tazBlog + +tazBlog :: ServerPart Response +tazBlog = do + msum [ dir "en" $ blogHandler EN + , dir "de" $ blogHandler DE + , do nullDir; + ok $ showIndex DE + , do dir " " $ nullDir; + seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ()) + , dir "res" $ serveDirectory DisableBrowsing [] "../res" + , serveDirectory DisableBrowsing [] "../res" + ] + +blogHandler :: BlogLang -> ServerPart Response +blogHandler lang = + msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ + \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang year month day id_ + ] + +showEntry :: BlogLang -> Int -> Int -> Int -> String -> ServerPart Response +showEntry EN y m d i = undefined +showEntry DE y m d i = undefined + +showIndex :: BlogLang -> Response +showIndex lang = toResponse $ renderBlogHeader lang + +renderBlogHeader :: BlogLang -> Html +renderBlogHeader DE = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " +renderBlogHeader EN = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " + +-- http://tazj.in/2012/02/10.155234 + +-- CouchDB View Setup +latestDEView = "function(doc){ if(doc.lang == \"de\"){ emit([doc.year, doc.month, doc.day, doc.id_], doc); } }" +latestENView = "function(doc){ if(doc.lang == \"en\"){ emit([doc.year, doc.month, doc.day, doc.id_]], doc); } }" + +latestDE = ViewMap "latestDE" latestDEView +latestEN = ViewMap "latestEN" latestENView + +setupBlogViews :: IO () -- taking *reservations* DB name as parameter because we'll have multiple stores +setupBlogViews = runCouchDB' $ + newView "tazblog" "entries" [latestDE, latestEN] |