* updated some stuff, work on sessions

TODO

@@ -1 +1,2 @@
 * handle BlogErrors
+* fix sessions

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

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

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
+    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())
+