diff options
| -rw-r--r-- | TODO | 1 | ||||
| -rw-r--r-- | src/Blog.hs | 12 | ||||
| -rw-r--r-- | src/BlogDB.hs | 21 | ||||
| -rw-r--r-- | src/Main.hs | 19 |
4 files changed, 38 insertions, 15 deletions
diff --git a/TODO b/TODO index 7c2dcaa91e2d..064ad8d364b5 100644 --- a/TODO +++ b/TODO @@ -1 +1,2 @@ * handle BlogErrors +* fix sessions \ No newline at end of file diff --git a/src/Blog.hs b/src/Blog.hs index 5f95d70058e0..da8dd24dc62f 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -117,12 +117,15 @@ renderComments comments lang = sequence_ $ map showComment comments showLinks :: Maybe Int -> BlogLang -> Html showLinks (Just i) lang | ( i > 1) = H.div ! A.class_ "centerbox" $ do - H.a ! A.href (toValue $ "/?page=" ++ show (i+1)) $ toHtml $ backText lang + H.a ! A.href (toValue $ "/" ++ show lang ++ "/?page=" ++ show (i+1)) $ + toHtml $ backText lang toHtml (" -- " :: Text) - H.a ! A.href (toValue $ "/?page=" ++ show (i-1)) $ toHtml $ nextText lang + H.a ! A.href (toValue $ "/" ++ show lang ++ "/?page=" ++ show (i-1)) $ + toHtml $ nextText lang | ( i <= 1 ) = showLinks Nothing lang showLinks Nothing lang = H.div ! A.class_ "centerbox" $ - H.a ! A.href "/?page=2" $ toHtml $ backText lang + H.a ! A.href (toValue $ "/" ++ show lang ++ "/?page=2") $ + toHtml $ backText lang showFooter :: BlogLang -> Text -> Html showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do @@ -164,12 +167,13 @@ adminTemplate body title = H.docTypeHtml $ do adminLogin :: Html adminLogin = H.div ! A.class_ "loginBox" $ do H.div ! A.class_ "loginBoxTop" $ "TazBlog Admin: Login" - H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/login" ! A.method "post" $ do + H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/dologin" ! A.method "post" $ do H.p $ "Account ID" H.p $ H.input ! A.type_ "text" ! A.style "font-size: 2;" ! A.name "account" ! A.value "tazjin" ! A.readonly "1" H.p $ "Passwort" 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" -- Error pages showError :: BlogError -> BlogLang -> Html diff --git a/src/BlogDB.hs b/src/BlogDB.hs index cade9327e7f1..9bffd79c3b30 100644 --- a/src/BlogDB.hs +++ b/src/BlogDB.hs @@ -16,7 +16,7 @@ import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.Text (Text, pack) import Data.Text.Lazy (toStrict) import Data.Time -import Happstack.Server (ServerPart) +import System.Environment(getEnv) import qualified Crypto.Hash.SHA512 as SHA (hash) import qualified Data.ByteString.Char8 as B @@ -157,12 +157,11 @@ latestEntries lang = do b@Blog{..} <- ask return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang -addSession :: Text -> User -> UTCTime -> Update Blog Session -addSession sId u t = +addSession :: Session -> Update Blog Session +addSession nSession = do b@Blog{..} <- get - let s = Session sId u t - put $ b { blogSessions = IxSet.insert s blogSessions} - return s + put $ b { blogSessions = IxSet.insert nSession blogSessions} + return nSession getSession :: SessionID -> Query Blog (Maybe Session) getSession sId = @@ -206,3 +205,13 @@ $(makeAcidic ''Blog , 'checkUser ]) +interactiveUserAdd :: IO () +interactiveUserAdd = do + tbDir <- getEnv "TAZBLOG" + acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState + putStrLn "Username:" + un <- getLine + putStrLn "Password:" + pw <- getLine + update' acid (AddUser (pack un) pw) + createCheckpointAndClose acid diff --git a/src/Main.hs b/src/Main.hs index 58de3221837e..3c585658a8a4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,7 @@ 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) +import Data.ByteString.Char8 (ByteString, pack, unpack) import Data.Data (Data, Typeable) import Data.Monoid (mempty) import Data.Text (Text) @@ -50,7 +50,7 @@ tazBlog acid = do , do nullDir showIndex acid DE , do dir " " $ nullDir - seeOther ("https://plus.google.com/115916629925754851590" :: String) (toResponse ()) + 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 @@ -131,7 +131,16 @@ processLogin acid = do password <- look "password" login <- query' acid (CheckUser (Username account) password) if' login - (addSessionCookie account) - (ok $ toResponse $ ("Fail?" :: Text)) + (createSession account) + (ok $ toResponse $ adminTemplate adminLogin "Login failed") where - addSessionCookie = undefined \ No newline at end of file + 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()) + |