diff options
| -rw-r--r-- | .stylish.haskell.yaml | 20 | ||||
| -rw-r--r-- | src/BlogDB.hs | 8 | ||||
| -rw-r--r-- | src/Main.hs | 219 | ||||
| -rw-r--r-- | src/Server.hs | 224 |
4 files changed, 250 insertions, 221 deletions
diff --git a/.stylish.haskell.yaml b/.stylish.haskell.yaml new file mode 100644 index 000000000000..cb432ce231ba --- /dev/null +++ b/.stylish.haskell.yaml @@ -0,0 +1,20 @@ +steps: + - imports: + align: group + - language_pragmas: + style: vertical + remove_redundant: true + - records: {} + - trailing_whitespace: {} +columns: 120 +language_extensions: + - DeriveDataTypeable + - FlexibleContexts + - GeneralizedNewtypeDeriving + - MultiParamTypeClasses + - OverloadedStrings + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskell + - TypeFamilies + - QuasiQuotes diff --git a/src/BlogDB.hs b/src/BlogDB.hs index e2787794c344..ca20aedb091d 100644 --- a/src/BlogDB.hs +++ b/src/BlogDB.hs @@ -15,7 +15,6 @@ import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.Text (Text, pack) import Data.Text.Lazy (toStrict) import Data.Time -import Happstack.Server (FromReqURI (..)) import System.Environment (getEnv) import qualified Crypto.Hash.SHA512 as SHA (hash) @@ -40,13 +39,6 @@ instance Show BlogLang where show DE = "de" show EN = "en" -instance FromReqURI BlogLang where - fromReqURI sub = - case map toLower sub of - "de" -> Just DE - "en" -> Just EN - _ -> Nothing - $(deriveSafeCopy 0 'base ''BlogLang) data Comment = Comment { diff --git a/src/Main.hs b/src/Main.hs index 2579d576964a..a50ca67ed17d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,34 +1,14 @@ module Main where -import Control.Applicative (optional, pure, (<$>), (<*>)) +import Control.Applicative (pure, (<$>), (<*>)) import Control.Exception (bracket) -import Control.Monad (liftM, msum, mzero, unless, when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -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, unpack) -import Data.Data (Data, Typeable) -import Data.Maybe (fromJust) -import Data.Monoid (mempty) -import Data.SafeCopy (base, deriveSafeCopy) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time -import Happstack.Server hiding (Session) -import Happstack.Server.Compression +import Data.Acid.Local (createCheckpointAndClose) import Options -import System.Locale (defaultTimeLocale) -import Blog -import BlogDB hiding (addComment, deleteComment, - updateEntry) -import Locales -import RSS +import BlogDB (initialBlogState) +import Locales (version) +import Server {- Server -} @@ -47,199 +27,12 @@ instance Options MainOptions where <*> simpleOption "res" "/usr/share/tazblog/res" "Resources folder location." -tmpPolicy :: BodyPolicy -tmpPolicy = defaultBodyPolicy "./tmp/" 0 200000 1000 - main :: IO() main = do putStrLn ("TazBlog " ++ version ++ " in Haskell starting") runCommand $ \opts args -> bracket (openLocalStateFrom (optState opts ++ "BlogState") initialBlogState) createCheckpointAndClose - (\acid -> simpleHTTP nullConf {port = optPort opts} $ tazBlog acid (optRes opts)) - -tazBlog :: AcidState Blog -> String -> ServerPart Response -tazBlog acid resDir = do - compr <- compressedResponseFilter - msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang - , nullDir >> showIndex acid EN - , dir " " $ nullDir >> - seeOther ("https://plus.google.com/115916629925754851590" :: Text) (toResponse ()) - , path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_ - , dir "res" $ serveDirectory DisableBrowsing [] "../res" - , dir "notice" $ ok $ toResponse showSiteNotice - {- :Admin handlers -} - , do dirs "admin/postentry" nullDir - guardSession acid - postEntry acid - , do dirs "admin/entrylist" $ dir (show DE) nullDir - guardSession acid - entryList acid DE - , do dirs "admin/entrylist" $ dir (show EN) nullDir - guardSession acid - entryList acid EN - , do guardSession acid - dirs "admin/edit" $ path $ \(eId :: Integer) -> editEntry acid eId - , do guardSession acid - dirs "admin/updateentry" $ nullDir >> updateEntry acid - , do guardSession acid - dirs "admin/cdelete" $ path $ \(eId :: Integer) -> path $ \(cId :: String) -> - deleteComment acid (EntryId eId) cId - , do dir "admin" nullDir - guardSession acid - ok $ toResponse $ adminIndex ("tazjin" :: Text) - , dir "admin" $ ok $ toResponse adminLogin - , dir "dologin" $ processLogin acid - , do dirs "static/blogv40.css" nullDir - setHeaderM "content-type" "text/css" - setHeaderM "cache-control" "max-age=630720000" - setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" - ok $ toResponse blogStyle - , do setHeaderM "cache-control" "max-age=630720000" - setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" - dir "static" $ serveDirectory DisableBrowsing [] resDir - , serveDirectory DisableBrowsing [] resDir - , notFound $ toResponse $ showError NotFound DE - ] - -blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response -blogHandler acid lang = - msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId - , nullDir >> showIndex acid lang - , dir "rss" $ nullDir >> showRSS acid lang - , dir "rss.xml" $ nullDir >> showRSS acid lang - , notFound $ toResponse $ showError NotFound lang - ] - -formatOldLink :: Int -> Int -> String -> ServerPart Response -formatOldLink y m id_ = - flip seeOther (toResponse ()) $ - concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_] - -showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response -showEntry acid lang eId = do - entry <- query' acid (GetEntry eId) - tryEntry entry lang - -tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response -tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang -tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry - where - eTitle = T.append ": " (title entry) - eLang = lang entry - -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) - where - eDrop :: Maybe Int -> [a] -> [a] - eDrop (Just i) = drop ((i-1) * 6) - eDrop Nothing = drop 0 - -showRSS :: AcidState Blog -> BlogLang -> ServerPart Response -showRSS acid lang = do - entries <- query' acid (LatestEntries lang) - feed <- liftIO $ renderFeed lang $ take 6 entries - setHeaderM "content-type" "text/xml" - ok $ toResponse feed - -{- ADMIN stuff -} - -postEntry :: AcidState Blog -> ServerPart Response -postEntry acid = do - decodeBody tmpPolicy - now <- liftIO getCurrentTime - let eId = timeToId now - lang <- look "lang" - nBtext <- lookText' "btext" - nMtext <- lookText' "mtext" - nEntry <- Entry <$> pure eId - <*> getLang lang - <*> readCookieValue "sUser" - <*> lookText' "title" - <*> pure nBtext - <*> pure nMtext - <*> pure now - <*> pure [] -- NYI - <*> pure [] - update' acid (InsertEntry nEntry) - seeOther ("/" ++ lang ++ "/" ++ show eId) (toResponse()) - where - timeToId :: UTCTime -> EntryId - timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t - getLang :: String -> ServerPart BlogLang - getLang "de" = return DE - getLang "en" = return EN - -entryList :: AcidState Blog -> BlogLang -> ServerPart Response -entryList acid lang = do - entries <- query' acid (LatestEntries lang) - ok $ toResponse $ adminEntryList entries - -editEntry :: AcidState Blog -> Integer -> ServerPart Response -editEntry acid i = do - (Just entry) <- query' acid (GetEntry eId) - ok $ toResponse $ editPage entry - where - eId = EntryId i - -updateEntry :: AcidState Blog -> ServerPart Response -- TODO: Clean this up -updateEntry acid = do - decodeBody tmpPolicy - (eId :: Integer) <- lookRead "eid" - (Just entry) <- query' acid (GetEntry $ EntryId eId) - nTitle <- lookText' "title" - nBtext <- lookText' "btext" - nMtext <- lookText' "mtext" - let nEntry = entry { title = nTitle - , btext = nBtext - , mtext = nMtext} - update' acid (UpdateEntry nEntry) - seeOther (concat $ intersperse' "/" [show $ lang entry, show eId]) - (toResponse ()) - -deleteComment :: AcidState Blog -> EntryId -> String -> ServerPart Response -deleteComment acid eId cId = do - nEntry <- update' acid (DeleteComment eId cDate) - ok $ toResponse $ commentDeleted eId - where - (cDate :: UTCTime) = fromJust $ parseTime defaultTimeLocale "%s%Q" cId - -guardSession :: AcidState Blog -> ServerPartT IO () -guardSession acid = do - (sId :: Text) <- readCookieValue "session" - (uName :: Text) <- readCookieValue "sUser" - now <- liftIO getCurrentTime - mS <- query' acid (GetSession $ SessionID sId) - case mS of - Nothing -> mzero - (Just Session{..}) -> unless ((uName == username user) && sessionTimeDiff now sdate) - mzero - where - sessionTimeDiff :: UTCTime -> UTCTime -> Bool - sessionTimeDiff now sdate = diffUTCTime now sdate < 43200 - + (\acid -> runBlog acid (optPort opts) (optRes opts)) -processLogin :: AcidState Blog -> ServerPart Response -processLogin acid = do - decodeBody tmpPolicy - account <- lookText' "account" - password <- look "password" - login <- query' acid (CheckUser (Username account) password) - if login - then createSession account - else ok $ toResponse adminLogin - where - createSession account = do - now <- liftIO getCurrentTime - let sId = hashString $ show now - addCookie (MaxAge 43200) (mkCookie "session" $ unpack sId) - addCookie (MaxAge 43200) (mkCookie "sUser" $ T.unpack account) - (Just user) <- query' acid (GetUser $ Username account) - let nSession = Session (T.pack $ unpack sId) user now - update' acid (AddSession nSession) - seeOther ("/admin?do=login" :: Text) (toResponse()) diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 000000000000..bc1f51298b1a --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,224 @@ +-- Server implementation based on Happstack + +module Server where + +import Control.Applicative (optional, pure, (<$>), (<*>)) +import Control.Monad (liftM, msum, mzero, unless, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Data.Acid +import Data.Acid.Advanced +import Data.ByteString.Char8 (ByteString, pack, unpack) +import Data.Char (toLower) +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Happstack.Server hiding (Session) +import Happstack.Server.Compression +import System.Locale (defaultTimeLocale) + +import Blog +import BlogDB hiding (addComment, deleteComment, updateEntry) +import Locales +import RSS + + +instance FromReqURI BlogLang where + fromReqURI sub = + case map toLower sub of + "de" -> Just DE + "en" -> Just EN + _ -> Nothing + +tmpPolicy :: BodyPolicy +tmpPolicy = defaultBodyPolicy "./tmp/" 0 200000 1000 + +runBlog :: AcidState Blog -> Int -> String -> IO () +runBlog acid port respath = + simpleHTTP nullConf {port = port} $ tazBlog acid respath + +tazBlog :: AcidState Blog -> String -> ServerPart Response +tazBlog acid resDir = do + compr <- compressedResponseFilter + msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang + , nullDir >> showIndex acid EN + , dir " " $ nullDir >> + seeOther ("https://plus.google.com/115916629925754851590" :: Text) (toResponse ()) + , path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_ + , dir "res" $ serveDirectory DisableBrowsing [] "../res" + , dir "notice" $ ok $ toResponse showSiteNotice + {- :Admin handlers -} + , do dirs "admin/postentry" nullDir + guardSession acid + postEntry acid + , do dirs "admin/entrylist" $ dir (show DE) nullDir + guardSession acid + entryList acid DE + , do dirs "admin/entrylist" $ dir (show EN) nullDir + guardSession acid + entryList acid EN + , do guardSession acid + dirs "admin/edit" $ path $ \(eId :: Integer) -> editEntry acid eId + , do guardSession acid + dirs "admin/updateentry" $ nullDir >> updateEntry acid + , do guardSession acid + dirs "admin/cdelete" $ path $ \(eId :: Integer) -> path $ \(cId :: String) -> + deleteComment acid (EntryId eId) cId + , do dir "admin" nullDir + guardSession acid + ok $ toResponse $ adminIndex ("tazjin" :: Text) + , dir "admin" $ ok $ toResponse adminLogin + , dir "dologin" $ processLogin acid + , do dirs "static/blogv40.css" nullDir + setHeaderM "content-type" "text/css" + setHeaderM "cache-control" "max-age=630720000" + setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" + ok $ toResponse blogStyle + , do setHeaderM "cache-control" "max-age=630720000" + setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" + dir "static" $ serveDirectory DisableBrowsing [] resDir + , serveDirectory DisableBrowsing [] resDir + , notFound $ toResponse $ showError NotFound DE + ] + +blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response +blogHandler acid lang = + msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId + , nullDir >> showIndex acid lang + , dir "rss" $ nullDir >> showRSS acid lang + , dir "rss.xml" $ nullDir >> showRSS acid lang + , notFound $ toResponse $ showError NotFound lang + ] + +formatOldLink :: Int -> Int -> String -> ServerPart Response +formatOldLink y m id_ = + flip seeOther (toResponse ()) $ + concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_] + +showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response +showEntry acid lang eId = do + entry <- query' acid (GetEntry eId) + tryEntry entry lang + +tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response +tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang +tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry + where + eTitle = T.append ": " (title entry) + eLang = lang entry + +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) + where + eDrop :: Maybe Int -> [a] -> [a] + eDrop (Just i) = drop ((i-1) * 6) + eDrop Nothing = drop 0 + +showRSS :: AcidState Blog -> BlogLang -> ServerPart Response +showRSS acid lang = do + entries <- query' acid (LatestEntries lang) + feed <- liftIO $ renderFeed lang $ take 6 entries + setHeaderM "content-type" "text/xml" + ok $ toResponse feed + +{- ADMIN stuff -} + +postEntry :: AcidState Blog -> ServerPart Response +postEntry acid = do + decodeBody tmpPolicy + now <- liftIO getCurrentTime + let eId = timeToId now + lang <- look "lang" + nBtext <- lookText' "btext" + nMtext <- lookText' "mtext" + nEntry <- Entry <$> pure eId + <*> getLang lang + <*> readCookieValue "sUser" + <*> lookText' "title" + <*> pure nBtext + <*> pure nMtext + <*> pure now + <*> pure [] -- NYI + <*> pure [] + update' acid (InsertEntry nEntry) + seeOther ("/" ++ lang ++ "/" ++ show eId) (toResponse()) + where + timeToId :: UTCTime -> EntryId + timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t + getLang :: String -> ServerPart BlogLang + getLang "de" = return DE + getLang "en" = return EN + +entryList :: AcidState Blog -> BlogLang -> ServerPart Response +entryList acid lang = do + entries <- query' acid (LatestEntries lang) + ok $ toResponse $ adminEntryList entries + +editEntry :: AcidState Blog -> Integer -> ServerPart Response +editEntry acid i = do + (Just entry) <- query' acid (GetEntry eId) + ok $ toResponse $ editPage entry + where + eId = EntryId i + +updateEntry :: AcidState Blog -> ServerPart Response -- TODO: Clean this up +updateEntry acid = do + decodeBody tmpPolicy + (eId :: Integer) <- lookRead "eid" + (Just entry) <- query' acid (GetEntry $ EntryId eId) + nTitle <- lookText' "title" + nBtext <- lookText' "btext" + nMtext <- lookText' "mtext" + let nEntry = entry { title = nTitle + , btext = nBtext + , mtext = nMtext} + update' acid (UpdateEntry nEntry) + seeOther (concat $ intersperse' "/" [show $ lang entry, show eId]) + (toResponse ()) + +deleteComment :: AcidState Blog -> EntryId -> String -> ServerPart Response +deleteComment acid eId cId = do + nEntry <- update' acid (DeleteComment eId cDate) + ok $ toResponse $ commentDeleted eId + where + (cDate :: UTCTime) = fromJust $ parseTime defaultTimeLocale "%s%Q" cId + +guardSession :: AcidState Blog -> ServerPartT IO () +guardSession acid = do + (sId :: Text) <- readCookieValue "session" + (uName :: Text) <- readCookieValue "sUser" + now <- liftIO getCurrentTime + mS <- query' acid (GetSession $ SessionID sId) + case mS of + Nothing -> mzero + (Just Session{..}) -> unless ((uName == username user) && sessionTimeDiff now sdate) + mzero + where + sessionTimeDiff :: UTCTime -> UTCTime -> Bool + sessionTimeDiff now sdate = diffUTCTime now sdate < 43200 + + +processLogin :: AcidState Blog -> ServerPart Response +processLogin acid = do + decodeBody tmpPolicy + account <- lookText' "account" + password <- look "password" + login <- query' acid (CheckUser (Username account) password) + if login + then createSession account + else ok $ toResponse adminLogin + where + createSession account = do + now <- liftIO getCurrentTime + let sId = hashString $ show now + addCookie (MaxAge 43200) (mkCookie "session" $ unpack sId) + addCookie (MaxAge 43200) (mkCookie "sUser" $ T.unpack account) + (Just user) <- query' acid (GetUser $ Username account) + let nSession = Session (T.pack $ unpack sId) user now + update' acid (AddSession nSession) + seeOther ("/admin?do=login" :: Text) (toResponse()) |