{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, RecordWildCards #-} module Main where import Control.Applicative ((<$>), (<*>), optional, pure) import Control.Exception (bracket) import Control.Monad (msum, mzero, when, unless) import Control.Monad.State (get, put) import Control.Monad.Reader (ask) import qualified Crypto.Hash.SHA512 as SHA import Data.Acid import Data.Acid.Advanced import Data.Acid.Local import qualified Data.ByteString.Base64 as B64 (encode) import Data.ByteString.Char8 (ByteString, pack) import Data.Data (Data, Typeable) import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Time import Data.SafeCopy (base, deriveSafeCopy) import Database.CouchDB import Happstack.Server import Network.CGI (liftIO) import Text.JSON.Generic import System.Environment(getEnv) import System.Locale (defaultTimeLocale) import Blog import Locales data SessionState = SessionState { sessions :: [(String, Integer)] } -- id/date deriving (Eq, Ord, Read, Show, Data, Typeable) initialSession :: SessionState initialSession = SessionState [] $(deriveSafeCopy 0 'base ''SessionState) data AccountState = AccountState { accounts :: [Account] } deriving (Read, Show, Data, Typeable) data Account = Account { account :: String , password :: ByteString } deriving (Read, Show, Data, Typeable) {-session handling functions-} addSession :: (String, Integer) -> Update SessionState [(String, Integer)] addSession newS = do s@SessionState{..} <- get let newSessions = newS : sessions put $ s{ sessions = newSessions } return newSessions querySessions :: Query SessionState [(String, Integer)] querySessions = sessions <$> ask $(makeAcidic ''SessionState ['addSession, 'querySessions]) $(makeAcidic ''AccountState []) {- various functions -} hashString :: String -> ByteString hashString = B64.encode . SHA.hash . pack {- Server -} tmpPolicy :: BodyPolicy tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000) main :: IO() main = do putStrLn ("TazBlog " ++ version ++ " in Haskell starting") tbDir <- getEnv "TAZBLOG" bracket (openLocalStateFrom (tbDir ++ "/State/SessionState") initialAccounts) (createCheckpointAndClose) (\sessionAcid -> bracket (openLocalStateFrom (tbDir ++ "/State/AccountState") ) (createCheckpointAndClose) (\accountAcid -> simpleHTTP nullConf $ tazBlog sessionAcid accountAcid)) initialAccounts :: AccountState initialAccounts = [] askAccount :: IO Account askAccount = do putStrLn "Enter name for the account:" n <- getLine putStrLn "Enter password for the account:" p <- getLine return $ Account n $ hashString p guardSession :: AcidState SessionState -> ServerPartT IO () guardSession acid = do sID <- lookCookieValue "session" sDate <- readCookieValue "sdate" cSessions <- query' acid QuerySessions cDate <- liftIO $ currentSeconds when (not $ elem (sID, sDate) cSessions) mzero when (32400 > (cDate - sDate)) mzero tazBlog :: AcidState SessionState -> ServerPart Response tazBlog acid = do msum [ dir (show DE) $ blogHandler DE , dir (show EN) $ blogHandler EN , do nullDir showIndex DE , do dir " " $ nullDir seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ()) , path $ \(id_ :: Int) -> getEntryLink id_ , path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_ , dir "res" $ serveDirectory DisableBrowsing [] "../res" , dir "notice" $ ok $ toResponse showSiteNotice , do dir "admin" $ guardSession acid adminHandler , dir "admin" $ ok $ toResponse $ adminTemplate adminLogin "Login" , dir "dologin" $ processLogin acid , serveDirectory DisableBrowsing [] "../res" ] blogHandler :: BlogLang -> ServerPart Response blogHandler lang = msum [ path $ \(year :: Int) -> path $ \(month :: Int) -> path $ --single entry \(day :: Int) -> path $ \(id_ :: String) -> showEntry lang id_ , path $ \(year :: Int ) -> path $ \(month :: Int) -> showMonth year month lang , do decodeBody tmpPolicy dir "postcomment" $ path $ \(id_ :: String) -> addComment id_ , do nullDir showIndex lang ] adminHandler :: ServerPart Response adminHandler = undefined formatOldLink :: Int -> Int -> String -> ServerPart Response formatOldLink y m id_ = flip seeOther (toResponse ()) $ concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_] showEntry :: BlogLang -> String -> ServerPart Response showEntry lang id_ = do entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc id_) let entry = maybeDoc entryJS ok $ tryEntry entry lang tryEntry :: Maybe Entry -> BlogLang -> Response tryEntry Nothing lang = toResponse $ showError NotFound lang tryEntry (Just entry) _ = toResponse $ blogTemplate eLang eTitle $ renderEntry entry where eTitle = T.pack $ ": " ++ title entry eLang = lang entry getEntryLink :: Int -> ServerPart Response getEntryLink id_ = do entryJS <- liftIO $ runCouchDB' $ getDoc (db "tazblog") (doc $ show id_) let entry = maybeDoc entryJS seeOther (makeLink entry) (toResponse()) where makeLink :: Maybe Entry -> String makeLink (Just e) = concat $ intersperse' "/" [show $ lang e, show $ year e, show $ month e, show $ day e, show id_] makeLink Nothing = "/" showIndex :: BlogLang -> ServerPart Response showIndex lang = do entries <- getLatest lang [("descending", showJSON True)] (page :: Maybe Int) <- optional $ lookRead "page" ok $ toResponse $ blogTemplate lang "" $ renderEntries False (eDrop page entries) (topText lang) (Just $ showLinks page lang) where eDrop :: Maybe Int -> [a] -> [a] eDrop (Just i) = drop ((i-1) * 6) eDrop Nothing = drop 0 showMonth :: Int -> Int -> BlogLang -> ServerPart Response showMonth y m lang = do entries <- getLatest lang $ ("descending", showJSON True) : makeQuery startkey endkey ok $ toResponse $ blogTemplate lang month $ renderEntries True entries month Nothing where month = getMonth lang y m startkey = JSArray [toJSON y, toJSON m] endkey = JSArray [toJSON y, toJSON m, JSObject (toJSObject [] )] addComment :: String -> ServerPart Response addComment id_ = do rda <- liftIO $ currentSeconds >>= return nComment <- Comment <$> look "cname" <*> look "ctext" <*> pure rda rev <- updateDBDoc (doc id_) $ insertComment nComment liftIO $ putStrLn $ show rev seeOther ("/" ++ id_) (toResponse()) processLogin :: AcidState SessionState -> ServerPart Response processLogin acid = do decodeBody tmpPolicy account <- look "account" password <- look "password" ok $ toResponse ("Shut up" :: String) -- http://tazj.in/2012/02/10.155234 currentSeconds :: IO Integer currentSeconds = do now <- getCurrentTime let s = read (formatTime defaultTimeLocale "%s" now) :: Integer return s {- CouchDB functions -} getLatest :: BlogLang -> [(String, JSValue)] -> ServerPart [Entry] getLatest lang arg = do queryResult <- queryDB view arg let entries = map (stripResult . fromJSON . snd) queryResult return entries where view = case lang of EN -> "latestEN" DE -> "latestDE" insertComment :: Comment -> JSValue -> IO JSValue insertComment c jEntry = return $ toJSON $ e { comments = c : (comments e)} where e = convertJSON jEntry :: Entry makeQuery :: JSON a => a -> a -> [(String, JSValue)] makeQuery qsk qek = [("startkey", (showJSON qsk)) ,("endkey", (showJSON qek))] queryDB :: JSON a => String -> [(String, JSValue)] -> ServerPart [(Doc, a)] queryDB view arg = liftIO . runCouchDB' $ queryView (db "tazblog") (doc "entries") (doc view) arg maybeDoc :: Data a => Maybe (Doc, Rev, JSValue) -> Maybe a maybeDoc (Just(_,_,v)) = Just( stripResult $ fromJSON v) maybeDoc Nothing = Nothing updateDBDoc :: JSON a => Doc -> (a -> IO a) -> ServerPart (Maybe Rev) updateDBDoc docn f = liftIO $ runCouchDB' $ getAndUpdateDoc (db "tazblog") docn f stripResult :: Result a -> a stripResult (Ok z) = z stripResult (Error s) = error $ "JSON error: " ++ s convertJSON :: Data a => JSValue -> a convertJSON = stripResult . fromJSON getMonthCount :: BlogLang -> Int -> Int -> ServerPart Int getMonthCount lang y m = do count <- queryDB (view lang) $ makeQuery startkey endkey return . stripCount $ map (stripResult . fromJSON . snd) count where startkey = JSArray [toJSON ("count" :: String), toJSON y, toJSON m] endkey = JSArray [toJSON ("count" :: String), toJSON y, toJSON m, JSObject (toJSObject [] )] stripCount :: [Int] -> Int stripCount [x] = x stripCount [] = 0 view DE = "countDE" view EN = "countEN" {- 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); } }" countDEView = "function(doc){ if(doc.lang == 'DE'){ emit(['count', doc.year, doc.month, doc.day, doc._id], 1); } }" countENView = "function(doc){ if(doc.lang == 'EN'){ emit(['count', doc.year, doc.month, doc.day, doc._id], 1); } }" countReduce = "function(keys, values, rereduce) { return sum(values); }" latestDE = ViewMap "latestDE" latestDEView latestEN = ViewMap "latestEN" latestENView countDE = ViewMapReduce "countDE" countDEView countReduce countEN = ViewMapReduce "countEN" countENView countReduce setupBlogViews :: IO () setupBlogViews = runCouchDB' $ newView "tazblog" "entries" [latestDE, latestEN, countDE, countEN]