diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 250 |
1 files changed, 49 insertions, 201 deletions
diff --git a/src/Main.hs b/src/Main.hs index 7990b8811ac2..58de3221837e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, - TypeFamilies, RecordWildCards #-} + TypeFamilies, RecordWildCards, BangPatterns #-} module Main where @@ -21,51 +21,15 @@ 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 Happstack.Server hiding (Session) import Network.CGI (liftIO) -import Text.JSON.Generic import System.Environment(getEnv) import System.Locale (defaultTimeLocale) import Blog +import BlogDB hiding (addComment) 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 @@ -75,48 +39,18 @@ main :: IO() main = do putStrLn ("TazBlog " ++ version ++ " in Haskell starting") tbDir <- getEnv "TAZBLOG" - bracket (openLocalStateFrom (tbDir ++ "/State/SessionState") initialAccounts) + bracket (openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState) (createCheckpointAndClose) - (\sessionAcid -> bracket (openLocalStateFrom (tbDir ++ "/State/AccountState") ) - (createCheckpointAndClose) - (\accountAcid -> simpleHTTP nullConf $ - tazBlog sessionAcid accountAcid)) - - + (\acid -> simpleHTTP nullConf $ tazBlog acid) - - -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 :: AcidState Blog -> ServerPart Response tazBlog acid = do - msum [ dir (show DE) $ blogHandler DE - , dir (show EN) $ blogHandler EN + msum [ dir (show DE) $ blogHandler acid DE + , dir (show EN) $ blogHandler acid EN , do nullDir - showIndex DE + showIndex acid 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 @@ -127,18 +61,29 @@ tazBlog acid = do , 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 +blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response +blogHandler acid lang = + msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId , do decodeBody tmpPolicy - dir "postcomment" $ path $ \(id_ :: String) -> addComment id_ + dir "postcomment" $ path $ + \(eId :: Integer) -> addComment acid $ EntryId eId , do nullDir - showIndex lang + showIndex acid lang ] +guardSession :: AcidState Blog -> ServerPartT IO () +guardSession acid = do + (sId :: Text) <- readCookieValue "session" + (Just Session{..}) <- query' acid (GetSession $ SessionID sId) + (uName :: Text) <- readCookieValue "sUser" + now <- liftIO $ getCurrentTime + unless (and [uName == username user, sessionTimeDiff now sdate]) + mzero + where + sessionTimeDiff :: UTCTime -> UTCTime -> Bool + sessionTimeDiff now sdate = (diffUTCTime now sdate) > 43200 + adminHandler :: ServerPart Response adminHandler = undefined @@ -147,32 +92,21 @@ 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 +showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response +showEntry acid lang eId = do + entry <- query' acid (GetEntry eId) 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 + eTitle = T.append ": " (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)] +showIndex :: AcidState Blog -> BlogLang -> ServerPart Response +showIndex acid lang = do + entries <- query' acid (LatestEntries lang) (page :: Maybe Int) <- optional $ lookRead "page" ok $ toResponse $ blogTemplate lang "" $ renderEntries False (eDrop page entries) (topText lang) (Just $ showLinks page lang) @@ -180,110 +114,24 @@ showIndex lang = do 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()) +addComment :: AcidState Blog -> EntryId -> ServerPart Response +addComment acid eId = do + now <- liftIO $ getCurrentTime >>= return + nComment <- Comment <$> lookText' "cname" + <*> lookText' "ctext" + <*> pure now + update' acid (AddComment eId nComment) + seeOther ("/" ++ show eId) (toResponse()) -processLogin :: AcidState SessionState -> ServerPart Response +processLogin :: AcidState Blog -> ServerPart Response processLogin acid = do decodeBody tmpPolicy - account <- look "account" + account <- lookText' "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 + login <- query' acid (CheckUser (Username account) password) + if' login + (addSessionCookie account) + (ok $ toResponse $ ("Fail?" :: Text)) 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] - - - + addSessionCookie = undefined \ No newline at end of file |