diff options
Diffstat (limited to 'src/Server.hs')
| -rw-r--r-- | src/Server.hs | 89 |
1 files changed, 46 insertions, 43 deletions
diff --git a/src/Server.hs b/src/Server.hs index aa41a2173d6e..eefc9b1e7ad8 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -2,76 +2,79 @@ 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 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 Text.JSON.Generic -import Blog +import Blog tmpPolicy :: BodyPolicy tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000) -data BlogLang = EN | DE data Comment = Comment{ - cauthor :: String, - ctext :: String, - cdate :: Integer + 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] + _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" + 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 + 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" - ] + 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_ - ] + msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry + \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang year month day id_ + , do nullDir + ok $ showIndex lang + ] showEntry :: BlogLang -> Int -> Int -> Int -> String -> ServerPart Response showEntry EN y m d i = undefined @@ -81,8 +84,8 @@ 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 " +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 -- http://tazj.in/2012/02/10.155234 @@ -93,6 +96,6 @@ latestENView = "function(doc){ if(doc.lang == \"en\"){ emit([doc.year, doc.month latestDE = ViewMap "latestDE" latestDEView latestEN = ViewMap "latestEN" latestENView -setupBlogViews :: IO () -- taking *reservations* DB name as parameter because we'll have multiple stores +setupBlogViews :: IO () setupBlogViews = runCouchDB' $ newView "tazblog" "entries" [latestDE, latestEN] |