diff options
| -rw-r--r-- | src/Blog.hs | 86 | ||||
| -rw-r--r-- | src/Server.hs | 61 | ||||
| -rw-r--r-- | tools/convertdb/convertdb.go | 15 |
3 files changed, 91 insertions, 71 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 983bae2366bb..bb74cbb16bef 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-} module Blog where +--import Control.Monad(when) +import Data.Data (Data, Typeable) import Data.Monoid (mempty) import Text.Blaze (toValue, preEscapedString) import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) @@ -10,30 +12,37 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A +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 :: BlogLang, + title :: String, + author :: String, + text :: String, + mtext :: String, + comments :: [Comment] +} deriving (Show, Data, Typeable) -repoURL = ("" :: String) +data BlogError = NoEntries | NotFound | DBError -{- -</div> -<div style=\"text-align:right;\"> -Proudly made with -<a href=\"http://golang.org\">Google Go</a> and without PHP, Java, Perl, MySQL and Python. -<br>Idee zum simplen Blog von -<a href=\"http://blog.fefe.de\" target=\"_blank\">Fefe</a> -<br>Version 2.1.3 -<a href=\"/impressum\">Impressum</a> -</div> -</div> -</div> -<div class=\"centerbox\"><img src=\"http://getpunchd.com/img/june/idiots.png\" alt=\"\"></div> -</body> -</html>" +data BlogLang = EN | DE deriving (Data, Typeable) --} +instance Show BlogLang where + show EN = "en" + show DE = "de" -blogTemplate :: String -> String -> String -> String -> String -> Html -- -> Html -blogTemplate title ctext1 ortext lang version = H.docTypeHtml $ do --add body +repoURL = ("https://bitbucket.org/tazjin/tazblog-haskell" :: String) + +blogTemplate :: String -> String -> String -> String -> BlogLang -> Html -> Html +blogTemplate title ctext1 ortext version lang body = H.docTypeHtml $ do --add body H.head $ do H.title $ (toHtml title) H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href "/rss" @@ -49,7 +58,7 @@ blogTemplate title ctext1 ortext lang version = H.docTypeHtml $ do --add body 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" H.div ! A.class_ "myclear" $ mempty - emptyTest lang + body showFooter lang version H.div ! A.class_ "centerbox" $ H.img ! A.src "http://getpunchd.com/img/june/idiots.png" ! A.alt "" @@ -63,16 +72,32 @@ blogTemplate title ctext1 ortext lang version = H.docTypeHtml $ do --add body H.a ! A.href (toValue imu) ! A.target "_blank" $ "iMessage" "." -emptyTest :: String -> Html +renderEntry :: Entry -> Html +renderEntry entry = H.div ! A.class_ "innerBox" $ do + H.div ! A.class_ "innerBoxTop" $ toHtml $ title entry + H.div ! A.class_ "innerBoxMiddle" $ do + H.article $ H.ul $ H.li $ do + preEscapedString $ text entry + preEscapedString $ mtext entry + H.div ! A.class_ "innerBoxComments" $ do + H.div ! A.name "cHead" ! A.style "font-size:large;font-weight:bold;" $ toHtml cHead + H.ul $ H.li $ toHtml noC + where + getTexts :: BlogLang -> (String, String) + getTexts EN = ("Comments:", " No comments yet") + getTexts DE = ("Kommentare:", " Keine Kommentare") + (cHead,noC) = getTexts (lang entry) + +emptyTest :: BlogLang -> Html emptyTest lang = H.div ! A.class_ "innerBox" $ do H.div ! A.class_ "innerBoxTop" $ "Test" H.div ! A.class_ "innerBoxMiddle" $ getTestText lang H.div ! A.class_ "myclear" $ mempty where - getTestText "de" = toHtml ("Das ist doch schonmal was." :: String) - getTestText "en" = toHtml ("This is starting to look like something." :: String) + getTestText DE = toHtml ("Das ist doch schonmal was." :: String) + getTestText EN = toHtml ("This is starting to look like something." :: String) -showFooter :: String -> String -> Html +showFooter :: BlogLang -> String -> Html showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do toHtml ("Proudly made with " :: String) H.a ! A.href "http://haskell.org" $ "Haskell" @@ -84,6 +109,11 @@ showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do preEscapedString " " H.a ! A.href "/notice" $ toHtml $ noticeText l where - noticeText :: String -> String - noticeText "en" = "site notice" - noticeText "de" = "Impressum" + noticeText :: BlogLang -> String + noticeText EN = "site notice" + noticeText DE = "Impressum" + + +-- Error pages +showError :: BlogError -> Html +showError _ = undefined diff --git a/src/Server.hs b/src/Server.hs index eefc9b1e7ad8..310c2ea1220c 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 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 Network.CGI (liftIO) 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) @@ -23,31 +23,6 @@ tmpPolicy :: BodyPolicy tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000) -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 :: BlogLang, - title :: String, - author :: String, - text :: String, - mtext :: String, - comments :: [Comment] -} deriving (Show, Data, Typeable) - -data BlogLang = EN | DE deriving (Data, Typeable) - -instance Show BlogLang where - show EN = "en" - show DE = "de" - --TazBlog version version = ("2.2b" :: String) @@ -71,24 +46,44 @@ tazBlog = do blogHandler :: BlogLang -> ServerPart Response blogHandler lang = msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry - \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang year month day id_ + \(day :: Int) -> path $ \(id_ :: String) -> showEntry year month day id_ , do nullDir ok $ showIndex lang ] -showEntry :: BlogLang -> Int -> Int -> Int -> String -> ServerPart Response -showEntry EN y m d i = undefined -showEntry DE y m d i = undefined +showEntry :: Int -> Int -> Int -> String -> ServerPart Response +showEntry y m d i = do + entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc i) + let entry = maybeDoc entryJS + ok $ tryEntry entry + +tryEntry :: Maybe Entry -> Response +tryEntry Nothing = toResponse $ showError NotFound +tryEntry (Just entry) = toResponse $ renderBlog eLang $ renderEntry entry + where + eLang = lang entry showIndex :: BlogLang -> Response showIndex lang = toResponse $ renderBlogHeader lang +renderBlog :: BlogLang -> Html -> Html +renderBlog DE body = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " version DE body +renderBlog EN body = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " version EN body + renderBlogHeader :: BlogLang -> Html -renderBlogHeader DE = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " "de" version -renderBlogHeader EN = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " "en" version +renderBlogHeader DE = blogTemplate "Tazjins Blog" "Wer mich kontaktieren will: " " oder " version DE (emptyTest DE) +renderBlogHeader EN = blogTemplate "Tazjin's Blog" "Get in touch with me: " " or " version EN (emptyTest EN) -- http://tazj.in/2012/02/10.155234 +-- CouchDB functions +maybeDoc :: Data a => Maybe (Doc, Rev, JSValue) -> Maybe a +maybeDoc (Just(_,_,v)) = Just( stripResult $ fromJSON v) +maybeDoc Nothing = Nothing + +stripResult :: Result a -> a +stripResult (Ok z) = z +stripResult (Error s) = error $ "JSON error: " ++ s -- 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); } }" diff --git a/tools/convertdb/convertdb.go b/tools/convertdb/convertdb.go index adef31910bf1..f7b94176b422 100644 --- a/tools/convertdb/convertdb.go +++ b/tools/convertdb/convertdb.go @@ -26,7 +26,7 @@ type OldEntry struct { Comments []OldComment } -//new +//old type Comment struct { Author string `json:"cauthor"` Text string `json:"ctext"` @@ -37,7 +37,7 @@ type Entry struct { Id string `json:"_id"` Year int `json:"year"` Month int `json:"month"` - Day int + Day int `json:"day"` Lang string `json:"lang"` Title string `json:"title"` Author string `json:"author"` @@ -100,17 +100,12 @@ func convertEntry(oEntry OldEntry, p string) Entry{ nEntry.Mtext = oEntry.Mtext nEntry.Text = oEntry.Text nEntry.Comments = nComments - nEntry.Lang = "de" + nEntry.Lang = "DE" return nEntry } -//http://tazj.in/2012/02/10.155234 -func parseEntryTime(year, month, day int, ids string) string { - x := fmt.Sprintf() -} - -func parseDumbTime(Year, Month, Day int, ) int64 { +func parseDumbTime(ct string) int64 { x, err := time.Parse("[Am 02.01.2006 um 15:04 Uhr]", ct) if err != nil { fmt.Println(err.String()) @@ -118,4 +113,4 @@ func parseDumbTime(Year, Month, Day int, ) int64 { } return x.Seconds() -} +} \ No newline at end of file |