* changed comment structure to sort by UTCTime
* postEntry function done; adminHandler doesn't work?
This commit is contained in:
parent
f6446aec72
commit
e6746984f5
5 changed files with 121 additions and 44 deletions
2
TODO
2
TODO
|
@ -1,3 +1,3 @@
|
||||||
* handle BlogErrors
|
* handle BlogErrors
|
||||||
* fix sessions
|
|
||||||
* add readMore link
|
* add readMore link
|
||||||
|
* Twitter: http://twitter.github.com/bootstrap/index.html
|
27
src/Blog.hs
27
src/Blog.hs
|
@ -155,8 +155,8 @@ showSiteNotice = H.docTypeHtml $ do
|
||||||
|
|
||||||
{- Administration pages -}
|
{- Administration pages -}
|
||||||
|
|
||||||
adminTemplate :: Html -> Text -> Html
|
adminTemplate :: Text -> Html -> Html
|
||||||
adminTemplate body title = H.docTypeHtml $ do
|
adminTemplate title body = H.docTypeHtml $ do
|
||||||
H.head $ do
|
H.head $ do
|
||||||
H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/admin.css" ! A.media "all"
|
H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/admin.css" ! A.media "all"
|
||||||
H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
|
H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
|
||||||
|
@ -165,7 +165,8 @@ adminTemplate body title = H.docTypeHtml $ do
|
||||||
body
|
body
|
||||||
|
|
||||||
adminLogin :: Html
|
adminLogin :: Html
|
||||||
adminLogin = H.div ! A.class_ "loginBox" $ do
|
adminLogin = adminTemplate "Login" $
|
||||||
|
H.div ! A.class_ "loginBox" $ do
|
||||||
H.div ! A.class_ "loginBoxTop" $ "TazBlog Admin: Login"
|
H.div ! A.class_ "loginBoxTop" $ "TazBlog Admin: Login"
|
||||||
H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/dologin" ! A.method "post" $ do
|
H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/dologin" ! A.method "post" $ do
|
||||||
H.p $ "Account ID"
|
H.p $ "Account ID"
|
||||||
|
@ -175,6 +176,26 @@ adminLogin = H.div ! A.class_ "loginBox" $ do
|
||||||
H.p $ H.input ! A.type_ "password" ! A.style "font-size: 2;" ! A.name "password"
|
H.p $ H.input ! A.type_ "password" ! A.style "font-size: 2;" ! A.name "password"
|
||||||
H.p $ H.input ! A.alt "Anmelden" ! A.type_ "image" ! A.src "/res/signin.gif"
|
H.p $ H.input ! A.alt "Anmelden" ! A.type_ "image" ! A.src "/res/signin.gif"
|
||||||
|
|
||||||
|
adminIndex :: Text -> Html
|
||||||
|
adminIndex sUser = adminTemplate "Index" $
|
||||||
|
H.div ! A.style "float: center;" $
|
||||||
|
H.form ! A.action "/admin/postentry" ! A.method "POST" $ do
|
||||||
|
H.table $ do
|
||||||
|
H.tr $ do H.td $ "Titel:"
|
||||||
|
H.td $ H.input ! A.type_ "text" ! A.name "title"
|
||||||
|
H.tr $ do H.td $ "Sprache:"
|
||||||
|
H.td $ H.select ! A.name "lang" $ do
|
||||||
|
H.option ! A.value "de" $ "Deutsch"
|
||||||
|
H.option ! A.value "en" $ "Englisch"
|
||||||
|
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Text:"
|
||||||
|
H.td $ H.textarea ! A.name "btext" ! A.cols "100" ! A.rows "15" $ mempty
|
||||||
|
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Mehr Text:"
|
||||||
|
H.td $ H.textarea ! A.name "mtext" ! A.cols "100" ! A.rows "15" $ mempty
|
||||||
|
H.input ! A.type_ "hidden" ! A.name "author" ! A.value (toValue sUser)
|
||||||
|
H.input ! A.style "margin-left: 20px" ! A.type_ "submit" ! A.value "Absenden"
|
||||||
|
H.p $ do preEscapedText "<a href=/>Startseite</a> -- Entrylist: <a href=/admin/entrylist/de>DE</a>"
|
||||||
|
preEscapedText " & <a href=/admin/entrylist/en>EN</a> -- <a href=#>Backup</a> (NYI)"
|
||||||
|
|
||||||
-- Error pages
|
-- Error pages
|
||||||
showError :: BlogError -> BlogLang -> Html
|
showError :: BlogError -> BlogLang -> Html
|
||||||
showError NotFound l = undefined
|
showError NotFound l = undefined
|
||||||
|
|
|
@ -40,10 +40,10 @@ instance Show BlogLang where
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''BlogLang)
|
$(deriveSafeCopy 0 'base ''BlogLang)
|
||||||
|
|
||||||
data Comment = Comment {
|
data Comment = Comment {
|
||||||
|
cdate :: UTCTime,
|
||||||
cauthor :: Text,
|
cauthor :: Text,
|
||||||
ctext :: Text,
|
ctext :: Text
|
||||||
cdate :: UTCTime
|
|
||||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''Comment)
|
$(deriveSafeCopy 0 'base ''Comment)
|
||||||
|
@ -221,11 +221,18 @@ interactiveUserAdd = do
|
||||||
putStrLn "Password:"
|
putStrLn "Password:"
|
||||||
pw <- getLine
|
pw <- getLine
|
||||||
update' acid (AddUser (pack un) pw)
|
update' acid (AddUser (pack un) pw)
|
||||||
createCheckpointAndClose acid
|
closeAcidState acid
|
||||||
|
|
||||||
flushSessions :: IO ()
|
flushSessions :: IO ()
|
||||||
flushSessions = do
|
flushSessions = do
|
||||||
tbDir <- getEnv "TAZBLOG"
|
tbDir <- getEnv "TAZBLOG"
|
||||||
acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
|
acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
|
||||||
update' acid (ClearSessions)
|
update' acid (ClearSessions)
|
||||||
createCheckpointAndClose acid
|
closeAcidState acid
|
||||||
|
|
||||||
|
archiveState :: IO ()
|
||||||
|
archiveState = do
|
||||||
|
tbDir <- getEnv "TAZBLOG"
|
||||||
|
acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState
|
||||||
|
createArchive acid
|
||||||
|
closeAcidState acid
|
||||||
|
|
107
src/Main.hs
107
src/Main.hs
|
@ -27,13 +27,13 @@ import System.Environment(getEnv)
|
||||||
import System.Locale (defaultTimeLocale)
|
import System.Locale (defaultTimeLocale)
|
||||||
|
|
||||||
import Blog
|
import Blog
|
||||||
import BlogDB hiding (addComment)
|
import BlogDB hiding (addComment, updateEntry)
|
||||||
import Locales
|
import Locales
|
||||||
|
|
||||||
{- Server -}
|
{- Server -}
|
||||||
|
|
||||||
tmpPolicy :: BodyPolicy
|
tmpPolicy :: BodyPolicy
|
||||||
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
|
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 200000 1000)
|
||||||
|
|
||||||
main :: IO()
|
main :: IO()
|
||||||
main = do
|
main = do
|
||||||
|
@ -44,7 +44,7 @@ main = do
|
||||||
(\acid -> simpleHTTP nullConf $ tazBlog acid)
|
(\acid -> simpleHTTP nullConf $ tazBlog acid)
|
||||||
|
|
||||||
tazBlog :: AcidState Blog -> ServerPart Response
|
tazBlog :: AcidState Blog -> ServerPart Response
|
||||||
tazBlog acid = do
|
tazBlog acid =
|
||||||
msum [ dir (show DE) $ blogHandler acid DE
|
msum [ dir (show DE) $ blogHandler acid DE
|
||||||
, dir (show EN) $ blogHandler acid EN
|
, dir (show EN) $ blogHandler acid EN
|
||||||
, do nullDir
|
, do nullDir
|
||||||
|
@ -55,8 +55,8 @@ tazBlog acid = do
|
||||||
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
|
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
|
||||||
, dir "notice" $ ok $ toResponse showSiteNotice
|
, dir "notice" $ ok $ toResponse showSiteNotice
|
||||||
, do dir "admin" $ guardSession acid
|
, do dir "admin" $ guardSession acid
|
||||||
adminHandler
|
adminHandler acid
|
||||||
, dir "admin" $ ok $ toResponse $ adminTemplate adminLogin "Login"
|
, dir "admin" $ ok $ toResponse $ adminLogin
|
||||||
, dir "dologin" $ processLogin acid
|
, dir "dologin" $ processLogin acid
|
||||||
, serveDirectory DisableBrowsing [] "../res"
|
, serveDirectory DisableBrowsing [] "../res"
|
||||||
]
|
]
|
||||||
|
@ -64,29 +64,13 @@ tazBlog acid = do
|
||||||
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
|
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
|
||||||
blogHandler acid lang =
|
blogHandler acid lang =
|
||||||
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
|
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
|
||||||
, do
|
, do decodeBody tmpPolicy
|
||||||
decodeBody tmpPolicy
|
|
||||||
dir "postcomment" $ path $
|
dir "postcomment" $ path $
|
||||||
\(eId :: Integer) -> addComment acid $ EntryId eId
|
\(eId :: Integer) -> addComment acid lang $ EntryId eId
|
||||||
, do nullDir
|
, do nullDir
|
||||||
showIndex acid 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
|
|
||||||
|
|
||||||
formatOldLink :: Int -> Int -> String -> ServerPart Response
|
formatOldLink :: Int -> Int -> String -> ServerPart Response
|
||||||
formatOldLink y m id_ =
|
formatOldLink y m id_ =
|
||||||
flip seeOther (toResponse ()) $
|
flip seeOther (toResponse ()) $
|
||||||
|
@ -115,14 +99,79 @@ showIndex acid lang = do
|
||||||
eDrop (Just i) = drop ((i-1) * 6)
|
eDrop (Just i) = drop ((i-1) * 6)
|
||||||
eDrop Nothing = drop 0
|
eDrop Nothing = drop 0
|
||||||
|
|
||||||
addComment :: AcidState Blog -> EntryId -> ServerPart Response
|
addComment :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
|
||||||
addComment acid eId = do
|
addComment acid lang eId = do
|
||||||
now <- liftIO $ getCurrentTime >>= return
|
now <- liftIO $ getCurrentTime >>= return
|
||||||
nComment <- Comment <$> lookText' "cname"
|
nComment <- Comment <$> pure now
|
||||||
|
<*> lookText' "cname"
|
||||||
<*> lookText' "ctext"
|
<*> lookText' "ctext"
|
||||||
<*> pure now
|
|
||||||
update' acid (AddComment eId nComment)
|
update' acid (AddComment eId nComment)
|
||||||
seeOther ("/" ++ show eId) (toResponse())
|
seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
|
||||||
|
|
||||||
|
{- ADMIN stuff -}
|
||||||
|
|
||||||
|
adminHandler :: AcidState Blog -> ServerPart Response
|
||||||
|
adminHandler acid =
|
||||||
|
msum [ dir "postentry" $ postEntry acid
|
||||||
|
, dir "entrylist" $ dir (show DE) $ entryList DE
|
||||||
|
, dir "entrylist" $ dir (show EN) $ entryList EN
|
||||||
|
, dir "edit" $ path $ \(eId :: Integer) -> editEntry eId
|
||||||
|
, dir "doedit" $ updateEntry
|
||||||
|
, ok $ toResponse $ adminIndex ("tazjin" :: Text) --User NYI
|
||||||
|
]
|
||||||
|
|
||||||
|
updateEntry :: ServerPart Response
|
||||||
|
updateEntry = undefined
|
||||||
|
|
||||||
|
postEntry :: AcidState Blog -> ServerPart Response
|
||||||
|
postEntry acid = do
|
||||||
|
liftIO $ putStrLn "postEntry called"
|
||||||
|
--decodeBody tmpPolicy
|
||||||
|
now <- liftIO $ getCurrentTime
|
||||||
|
let eId = timeToId now
|
||||||
|
lang <- lookText' "lang"
|
||||||
|
nEntry <- Entry <$> pure eId
|
||||||
|
<*> getLang lang
|
||||||
|
<*> lookText' "author"
|
||||||
|
<*> lookText' "title"
|
||||||
|
<*> lookText' "btext"
|
||||||
|
<*> lookText' "mtext"
|
||||||
|
<*> pure now
|
||||||
|
<*> pure [] -- NYI
|
||||||
|
<*> pure []
|
||||||
|
update' acid (InsertEntry nEntry)
|
||||||
|
seeOther ("/" ++ (T.unpack lang) ++ "/" ++ show eId) (toResponse())
|
||||||
|
where
|
||||||
|
timeToId :: UTCTime -> EntryId
|
||||||
|
timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
|
||||||
|
getLang :: Text -> ServerPart BlogLang
|
||||||
|
getLang "de" = return DE
|
||||||
|
getLang "en" = return EN
|
||||||
|
|
||||||
|
|
||||||
|
entryList :: BlogLang -> ServerPart Response
|
||||||
|
entryList lang = undefined
|
||||||
|
|
||||||
|
editEntry :: Integer -> ServerPart Response
|
||||||
|
editEntry i = undefined
|
||||||
|
where
|
||||||
|
eId = EntryId i
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
processLogin :: AcidState Blog -> ServerPart Response
|
processLogin :: AcidState Blog -> ServerPart Response
|
||||||
processLogin acid = do
|
processLogin acid = do
|
||||||
|
@ -132,7 +181,7 @@ processLogin acid = do
|
||||||
login <- query' acid (CheckUser (Username account) password)
|
login <- query' acid (CheckUser (Username account) password)
|
||||||
if' login
|
if' login
|
||||||
(createSession account)
|
(createSession account)
|
||||||
(ok $ toResponse $ adminTemplate adminLogin "Login failed")
|
(ok $ toResponse $ adminLogin)
|
||||||
where
|
where
|
||||||
createSession account = do
|
createSession account = do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
|
|
|
@ -54,10 +54,10 @@ instance Show BlogLang where
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''BlogLang)
|
$(deriveSafeCopy 0 'base ''BlogLang)
|
||||||
|
|
||||||
data Comment = Comment {
|
data Comment = Comment {
|
||||||
|
cdate :: UTCTime,
|
||||||
cauthor :: Text,
|
cauthor :: Text,
|
||||||
ctext :: Text,
|
ctext :: Text
|
||||||
cdate :: UTCTime
|
|
||||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||||
|
|
||||||
$(deriveSafeCopy 0 'base ''Comment)
|
$(deriveSafeCopy 0 'base ''Comment)
|
||||||
|
@ -203,7 +203,7 @@ instance JSON Comment where
|
||||||
jsscdate <- jsonField "cdate" obj :: Result JSValue
|
jsscdate <- jsonField "cdate" obj :: Result JSValue
|
||||||
let rcdate = stripResult $ jsonInt jsscdate
|
let rcdate = stripResult $ jsonInt jsscdate
|
||||||
sctext <- jsonField "ctext" obj
|
sctext <- jsonField "ctext" obj
|
||||||
return $ Comment (pack scauthor) (pack sctext) (parseSeconds rcdate)
|
return $ Comment (parseSeconds rcdate) (pack scauthor) (pack sctext)
|
||||||
|
|
||||||
instance JSON Entry where
|
instance JSON Entry where
|
||||||
showJSON = undefined
|
showJSON = undefined
|
||||||
|
|
Loading…
Reference in a new issue