Refactoring: Moved Happstack things to Server.hs
This commit is contained in:
parent
5f6841afa2
commit
a5481e70e4
4 changed files with 250 additions and 221 deletions
20
.stylish.haskell.yaml
Normal file
20
.stylish.haskell.yaml
Normal file
|
@ -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
|
|
@ -15,7 +15,6 @@ import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
|
||||||
import Data.Text (Text, pack)
|
import Data.Text (Text, pack)
|
||||||
import Data.Text.Lazy (toStrict)
|
import Data.Text.Lazy (toStrict)
|
||||||
import Data.Time
|
import Data.Time
|
||||||
import Happstack.Server (FromReqURI (..))
|
|
||||||
import System.Environment (getEnv)
|
import System.Environment (getEnv)
|
||||||
|
|
||||||
import qualified Crypto.Hash.SHA512 as SHA (hash)
|
import qualified Crypto.Hash.SHA512 as SHA (hash)
|
||||||
|
@ -40,13 +39,6 @@ instance Show BlogLang where
|
||||||
show DE = "de"
|
show DE = "de"
|
||||||
show EN = "en"
|
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)
|
$(deriveSafeCopy 0 'base ''BlogLang)
|
||||||
|
|
||||||
data Comment = Comment {
|
data Comment = Comment {
|
||||||
|
|
219
src/Main.hs
219
src/Main.hs
|
@ -1,34 +1,14 @@
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Control.Applicative (optional, pure, (<$>), (<*>))
|
import Control.Applicative (pure, (<$>), (<*>))
|
||||||
import Control.Exception (bracket)
|
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
|
||||||
import Data.Acid.Advanced
|
import Data.Acid.Local (createCheckpointAndClose)
|
||||||
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 Options
|
import Options
|
||||||
import System.Locale (defaultTimeLocale)
|
|
||||||
|
|
||||||
import Blog
|
import BlogDB (initialBlogState)
|
||||||
import BlogDB hiding (addComment, deleteComment,
|
import Locales (version)
|
||||||
updateEntry)
|
import Server
|
||||||
import Locales
|
|
||||||
import RSS
|
|
||||||
|
|
||||||
{- Server -}
|
{- Server -}
|
||||||
|
|
||||||
|
@ -47,199 +27,12 @@ instance Options MainOptions where
|
||||||
<*> simpleOption "res" "/usr/share/tazblog/res"
|
<*> simpleOption "res" "/usr/share/tazblog/res"
|
||||||
"Resources folder location."
|
"Resources folder location."
|
||||||
|
|
||||||
tmpPolicy :: BodyPolicy
|
|
||||||
tmpPolicy = defaultBodyPolicy "./tmp/" 0 200000 1000
|
|
||||||
|
|
||||||
main :: IO()
|
main :: IO()
|
||||||
main = do
|
main = do
|
||||||
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
||||||
runCommand $ \opts args ->
|
runCommand $ \opts args ->
|
||||||
bracket (openLocalStateFrom (optState opts ++ "BlogState") initialBlogState)
|
bracket (openLocalStateFrom (optState opts ++ "BlogState") initialBlogState)
|
||||||
createCheckpointAndClose
|
createCheckpointAndClose
|
||||||
(\acid -> simpleHTTP nullConf {port = optPort opts} $ tazBlog acid (optRes opts))
|
(\acid -> runBlog acid (optPort opts) (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
|
|
||||||
|
|
||||||
|
|
||||||
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())
|
|
||||||
|
|
||||||
|
|
224
src/Server.hs
Normal file
224
src/Server.hs
Normal file
|
@ -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())
|
Loading…
Reference in a new issue