2012-03-07 17:31:42 +01:00
|
|
|
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving,
|
|
|
|
DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell,
|
2012-03-13 05:31:13 +01:00
|
|
|
TypeFamilies, RecordWildCards, BangPatterns #-}
|
2012-02-22 22:03:31 +01:00
|
|
|
|
|
|
|
module Main where
|
|
|
|
|
2012-03-07 12:59:44 +01:00
|
|
|
import Control.Applicative ((<$>), (<*>), optional, pure)
|
2012-03-08 11:42:10 +01:00
|
|
|
import Control.Exception (bracket)
|
|
|
|
import Control.Monad (msum, mzero, when, unless)
|
2012-03-13 19:50:13 +01:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
2012-03-07 17:31:42 +01:00
|
|
|
import Control.Monad.State (get, put)
|
|
|
|
import Control.Monad.Reader (ask)
|
2012-03-09 17:57:53 +01:00
|
|
|
import qualified Crypto.Hash.SHA512 as SHA
|
2012-03-07 17:31:42 +01:00
|
|
|
import Data.Acid
|
|
|
|
import Data.Acid.Advanced
|
|
|
|
import Data.Acid.Local
|
2012-03-09 17:57:53 +01:00
|
|
|
import qualified Data.ByteString.Base64 as B64 (encode)
|
2012-03-13 06:35:56 +01:00
|
|
|
import Data.ByteString.Char8 (ByteString, pack, unpack)
|
2012-03-07 17:31:42 +01:00
|
|
|
import Data.Data (Data, Typeable)
|
|
|
|
import Data.Monoid (mempty)
|
2012-03-06 19:39:54 +01:00
|
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Text as T
|
2012-02-23 03:30:14 +01:00
|
|
|
import Data.Time
|
2012-03-07 17:31:42 +01:00
|
|
|
import Data.SafeCopy (base, deriveSafeCopy)
|
2012-03-13 05:31:13 +01:00
|
|
|
import Happstack.Server hiding (Session)
|
2012-03-20 18:01:36 +01:00
|
|
|
import Happstack.Server.Compression
|
2012-03-25 19:29:38 +02:00
|
|
|
import Options
|
2012-03-07 12:59:44 +01:00
|
|
|
import System.Locale (defaultTimeLocale)
|
2012-02-22 22:03:31 +01:00
|
|
|
|
2012-02-23 03:30:14 +01:00
|
|
|
import Blog
|
2012-03-14 00:37:00 +01:00
|
|
|
import BlogDB hiding (addComment, updateEntry)
|
2012-02-24 16:06:33 +01:00
|
|
|
import Locales
|
2012-03-24 00:32:38 +01:00
|
|
|
import RSS
|
2012-02-22 22:03:31 +01:00
|
|
|
|
2012-03-09 17:57:53 +01:00
|
|
|
{- Server -}
|
|
|
|
|
2012-03-25 19:29:38 +02:00
|
|
|
defineOptions "MainOptions" $ do
|
|
|
|
stringOption "optState" "statedir" "../"
|
|
|
|
"Directory in which the /BlogState dir is located.\
|
|
|
|
\ The default is ../ (if run from src/)"
|
|
|
|
intOption "optPort" "port" 8000
|
|
|
|
"The port to run the web server on. Default is 8000"
|
|
|
|
|
2012-03-09 17:57:53 +01:00
|
|
|
tmpPolicy :: BodyPolicy
|
2012-03-14 00:37:00 +01:00
|
|
|
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 200000 1000)
|
2012-03-09 17:57:53 +01:00
|
|
|
|
|
|
|
main :: IO()
|
|
|
|
main = do
|
|
|
|
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
2012-03-25 19:29:38 +02:00
|
|
|
runCommand $ \opts args ->
|
|
|
|
bracket (openLocalStateFrom (optState opts ++ "BlogState") initialBlogState)
|
|
|
|
(createCheckpointAndClose)
|
|
|
|
(\acid -> simpleHTTP nullConf {port = optPort opts} $ tazBlog acid)
|
2012-03-09 17:57:53 +01:00
|
|
|
|
2012-03-13 05:31:13 +01:00
|
|
|
tazBlog :: AcidState Blog -> ServerPart Response
|
2012-03-20 18:01:36 +01:00
|
|
|
tazBlog acid = do
|
|
|
|
compr <- compressedResponseFilter
|
2012-03-24 00:32:38 +01:00
|
|
|
msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
|
|
|
|
, nullDir >> showIndex acid DE
|
|
|
|
, dir " " $ nullDir >>
|
|
|
|
seeOther ("https://plus.google.com/115916629925754851590" :: Text) (toResponse ())
|
2012-03-07 13:40:47 +01:00
|
|
|
, path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_
|
2012-02-23 03:30:14 +01:00
|
|
|
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
|
2012-03-06 23:34:04 +01:00
|
|
|
, dir "notice" $ ok $ toResponse showSiteNotice
|
2012-03-15 18:32:01 +01:00
|
|
|
{- :Admin handlers -}
|
2012-03-14 01:36:57 +01:00
|
|
|
, do dirs "admin/postentry" $ nullDir
|
|
|
|
guardSession acid
|
|
|
|
postEntry acid
|
2012-03-15 18:32:01 +01:00
|
|
|
, 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
|
2012-03-24 00:32:38 +01:00
|
|
|
, dirs "admin/updateentry" $ nullDir >> updateEntry acid
|
2012-03-14 01:36:57 +01:00
|
|
|
, do dir "admin" $ nullDir
|
|
|
|
guardSession acid
|
|
|
|
ok $ toResponse $ adminIndex ("tazjin" :: Text)
|
2012-03-14 00:37:00 +01:00
|
|
|
, dir "admin" $ ok $ toResponse $ adminLogin
|
2012-03-09 17:57:53 +01:00
|
|
|
, dir "dologin" $ processLogin acid
|
2012-03-22 14:34:04 +01:00
|
|
|
, do setHeaderM "cache-control" "max-age=630720000"
|
|
|
|
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
|
|
|
dir "static" $ serveDirectory DisableBrowsing [] "../res"
|
2012-02-23 03:30:14 +01:00
|
|
|
, serveDirectory DisableBrowsing [] "../res"
|
2012-03-18 23:49:50 +01:00
|
|
|
, notFound $ toResponse $ showError NotFound DE
|
2012-02-23 03:30:14 +01:00
|
|
|
]
|
2012-02-22 22:03:31 +01:00
|
|
|
|
2012-03-13 05:31:13 +01:00
|
|
|
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
|
|
|
|
blogHandler acid lang =
|
|
|
|
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
|
2012-03-14 00:37:00 +01:00
|
|
|
, do decodeBody tmpPolicy
|
|
|
|
dir "postcomment" $ path $
|
|
|
|
\(eId :: Integer) -> addComment acid lang $ EntryId eId
|
2012-03-24 00:32:38 +01:00
|
|
|
, nullDir >> showIndex acid lang
|
|
|
|
, dir "rss" $ nullDir >> showRSS acid lang
|
2012-03-18 23:49:50 +01:00
|
|
|
, notFound $ toResponse $ showError NotFound lang
|
2012-02-23 03:30:14 +01:00
|
|
|
]
|
2012-02-22 22:03:31 +01:00
|
|
|
|
2012-03-07 13:40:47 +01:00
|
|
|
formatOldLink :: Int -> Int -> String -> ServerPart Response
|
|
|
|
formatOldLink y m id_ =
|
|
|
|
flip seeOther (toResponse ()) $
|
|
|
|
concat $ intersperse' "/" ["de", show y, show m, replace '.' '/' id_]
|
|
|
|
|
2012-03-13 05:31:13 +01:00
|
|
|
showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
|
|
|
|
showEntry acid lang eId = do
|
|
|
|
entry <- query' acid (GetEntry eId)
|
2012-03-18 23:49:50 +01:00
|
|
|
tryEntry entry lang
|
2012-02-23 13:20:29 +01:00
|
|
|
|
2012-03-18 23:49:50 +01:00
|
|
|
tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
|
|
|
|
tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang
|
|
|
|
tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry
|
2012-02-23 13:20:29 +01:00
|
|
|
where
|
2012-03-13 05:31:13 +01:00
|
|
|
eTitle = T.append ": " (title entry)
|
2012-02-23 13:20:29 +01:00
|
|
|
eLang = lang entry
|
2012-02-22 22:03:31 +01:00
|
|
|
|
2012-03-13 05:31:13 +01:00
|
|
|
showIndex :: AcidState Blog -> BlogLang -> ServerPart Response
|
|
|
|
showIndex acid lang = do
|
|
|
|
entries <- query' acid (LatestEntries lang)
|
2012-03-03 16:39:15 +01:00
|
|
|
(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
|
2012-02-24 17:01:36 +01:00
|
|
|
|
2012-03-24 00:32:38 +01:00
|
|
|
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
|
|
|
|
|
2012-03-14 00:37:00 +01:00
|
|
|
addComment :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
|
|
|
|
addComment acid lang eId = do
|
2012-03-13 05:31:13 +01:00
|
|
|
now <- liftIO $ getCurrentTime >>= return
|
2012-03-15 20:51:53 +01:00
|
|
|
nCtext <- lookText' "ctext"
|
2012-03-14 00:37:00 +01:00
|
|
|
nComment <- Comment <$> pure now
|
|
|
|
<*> lookText' "cname"
|
2012-03-15 21:26:45 +01:00
|
|
|
<*> pure (commentEscape nCtext)
|
2012-03-13 05:31:13 +01:00
|
|
|
update' acid (AddComment eId nComment)
|
2012-03-14 00:37:00 +01:00
|
|
|
seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
|
|
|
|
|
2012-03-15 21:26:45 +01:00
|
|
|
commentEscape :: Text -> Text
|
|
|
|
commentEscape = newlineEscape . ltEscape . gtEscape . ampEscape
|
|
|
|
where
|
|
|
|
newlineEscape = T.replace "\n" "<br>"
|
|
|
|
ampEscape = T.replace "&" "&"
|
|
|
|
ltEscape = T.replace "<" "<"
|
|
|
|
gtEscape = T.replace ">" ">"
|
|
|
|
|
2012-03-15 18:32:01 +01:00
|
|
|
{- ADMIN stuff -}
|
2012-03-14 00:37:00 +01:00
|
|
|
|
|
|
|
postEntry :: AcidState Blog -> ServerPart Response
|
|
|
|
postEntry acid = do
|
2012-03-14 01:36:57 +01:00
|
|
|
decodeBody tmpPolicy
|
2012-03-14 00:37:00 +01:00
|
|
|
now <- liftIO $ getCurrentTime
|
|
|
|
let eId = timeToId now
|
2012-03-15 18:32:01 +01:00
|
|
|
lang <- look "lang"
|
|
|
|
nBtext <- lookText' "btext"
|
|
|
|
nMtext <- lookText' "mtext"
|
2012-03-14 00:37:00 +01:00
|
|
|
nEntry <- Entry <$> pure eId
|
|
|
|
<*> getLang lang
|
2012-03-20 00:26:50 +01:00
|
|
|
<*> readCookieValue "sUser"
|
2012-03-14 00:37:00 +01:00
|
|
|
<*> lookText' "title"
|
2012-03-15 18:32:01 +01:00
|
|
|
<*> pure (entryEscape nBtext)
|
|
|
|
<*> pure (entryEscape nMtext)
|
2012-03-14 00:37:00 +01:00
|
|
|
<*> pure now
|
|
|
|
<*> pure [] -- NYI
|
|
|
|
<*> pure []
|
|
|
|
update' acid (InsertEntry nEntry)
|
2012-03-15 18:32:01 +01:00
|
|
|
seeOther ("/" ++ lang ++ "/" ++ show eId) (toResponse())
|
2012-03-14 00:37:00 +01:00
|
|
|
where
|
|
|
|
timeToId :: UTCTime -> EntryId
|
|
|
|
timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
|
2012-03-15 18:32:01 +01:00
|
|
|
getLang :: String -> ServerPart BlogLang
|
2012-03-14 00:37:00 +01:00
|
|
|
getLang "de" = return DE
|
|
|
|
getLang "en" = return EN
|
|
|
|
|
2012-03-15 18:32:01 +01:00
|
|
|
entryEscape :: Text -> Text
|
2012-03-18 23:23:02 +01:00
|
|
|
entryEscape = newlineEscape . newlineRNEscape
|
|
|
|
where
|
|
|
|
newlineEscape = T.replace "\n" "<br>"
|
|
|
|
newlineRNEscape = T.replace "\r\n" "<br>"
|
2012-03-14 00:37:00 +01:00
|
|
|
|
2012-03-15 18:32:01 +01:00
|
|
|
entryList :: AcidState Blog -> BlogLang -> ServerPart Response
|
|
|
|
entryList acid lang = do
|
|
|
|
entries <- query' acid (LatestEntries lang)
|
|
|
|
ok $ toResponse $ adminEntryList entries
|
2012-03-14 00:37:00 +01:00
|
|
|
|
2012-03-15 18:32:01 +01:00
|
|
|
editEntry :: AcidState Blog -> Integer -> ServerPart Response
|
|
|
|
editEntry acid i = do
|
|
|
|
(Just entry) <- query' acid (GetEntry eId)
|
|
|
|
ok $ toResponse $ editPage entry
|
2012-03-14 00:37:00 +01:00
|
|
|
where
|
|
|
|
eId = EntryId i
|
|
|
|
|
2012-03-15 18:32:01 +01:00
|
|
|
updateEntry :: AcidState Blog -> ServerPart Response
|
|
|
|
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 = entryEscape nBtext
|
|
|
|
, mtext = entryEscape nMtext}
|
|
|
|
update' acid (UpdateEntry nEntry)
|
|
|
|
seeOther (concat $ intersperse' "/" [show $ lang entry, show eId])
|
|
|
|
(toResponse ())
|
|
|
|
|
|
|
|
|
2012-03-14 00:37:00 +01:00
|
|
|
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 (and [ uName == username user
|
|
|
|
, sessionTimeDiff now sdate])
|
|
|
|
mzero
|
|
|
|
where
|
|
|
|
sessionTimeDiff :: UTCTime -> UTCTime -> Bool
|
|
|
|
sessionTimeDiff now sdate = (diffUTCTime now sdate) < 43200
|
|
|
|
|
2012-03-06 00:50:53 +01:00
|
|
|
|
2012-03-13 05:31:13 +01:00
|
|
|
processLogin :: AcidState Blog -> ServerPart Response
|
2012-03-09 17:57:53 +01:00
|
|
|
processLogin acid = do
|
|
|
|
decodeBody tmpPolicy
|
2012-03-13 05:31:13 +01:00
|
|
|
account <- lookText' "account"
|
2012-03-09 17:57:53 +01:00
|
|
|
password <- look "password"
|
2012-03-13 05:31:13 +01:00
|
|
|
login <- query' acid (CheckUser (Username account) password)
|
|
|
|
if' login
|
2012-03-13 06:35:56 +01:00
|
|
|
(createSession account)
|
2012-03-14 00:37:00 +01:00
|
|
|
(ok $ toResponse $ adminLogin)
|
2012-03-03 03:35:20 +01:00
|
|
|
where
|
2012-03-13 06:35:56 +01:00
|
|
|
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())
|
|
|
|
|