* broken version of Acid State stuff
* AccountState containing data of type Account * hashString functions
This commit is contained in:
parent
bbdfa3eae2
commit
4eacefe854
2 changed files with 78 additions and 22 deletions
|
@ -23,6 +23,11 @@ data Comment = Comment{
|
|||
cdate :: Integer
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
data Author = Author {
|
||||
username :: String,
|
||||
password :: String
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
data Entry = Entry{
|
||||
_id :: String,
|
||||
year :: Int,
|
||||
|
@ -196,7 +201,7 @@ adminLogin = H.div ! A.class_ "loginBox" $ do
|
|||
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 "pass"
|
||||
H.p $ H.input ! A.type_ "password" ! A.style "font-size: 2;" ! A.name "password"
|
||||
|
||||
-- Error pages
|
||||
showError :: BlogError -> BlogLang -> Html
|
||||
|
|
93
src/Main.hs
93
src/Main.hs
|
@ -9,10 +9,12 @@ import Control.Exception (bracket)
|
|||
import Control.Monad (msum, mzero, when, unless)
|
||||
import Control.Monad.State (get, put)
|
||||
import Control.Monad.Reader (ask)
|
||||
import qualified Crypto.Hash.SHA512 as SHA
|
||||
import Data.Acid
|
||||
import Data.Acid.Advanced
|
||||
import Data.Acid.Local
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Base64 as B64 (encode)
|
||||
import Data.ByteString.Char8 (ByteString, pack)
|
||||
import Data.Data (Data, Typeable)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Text (Text)
|
||||
|
@ -23,21 +25,30 @@ import Database.CouchDB
|
|||
import Happstack.Server
|
||||
import Network.CGI (liftIO)
|
||||
import Text.JSON.Generic
|
||||
import System.Environment(getEnv)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
|
||||
import Blog
|
||||
import Locales
|
||||
|
||||
{-session handling functions-}
|
||||
|
||||
data SessionState = SessionState { sessions :: [(String, Integer)] } -- id/date
|
||||
deriving (Eq, Ord, Read, Show, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''SessionState)
|
||||
|
||||
initialSession :: SessionState
|
||||
initialSession = SessionState []
|
||||
|
||||
$(deriveSafeCopy 0 'base ''SessionState)
|
||||
|
||||
|
||||
data AccountState = AccountState { accounts :: [Account] }
|
||||
deriving (Read, Show, Data, Typeable)
|
||||
|
||||
data Account = Account { account :: String
|
||||
, password :: ByteString
|
||||
} deriving (Read, Show, Data, Typeable)
|
||||
|
||||
{-session handling functions-}
|
||||
|
||||
addSession :: (String, Integer) -> Update SessionState [(String, Integer)]
|
||||
addSession newS = do
|
||||
s@SessionState{..} <- get
|
||||
|
@ -49,6 +60,42 @@ querySessions :: Query SessionState [(String, Integer)]
|
|||
querySessions = sessions <$> ask
|
||||
|
||||
$(makeAcidic ''SessionState ['addSession, 'querySessions])
|
||||
$(makeAcidic ''AccountState [])
|
||||
{- various functions -}
|
||||
|
||||
hashString :: String -> ByteString
|
||||
hashString = B64.encode . SHA.hash . pack
|
||||
|
||||
{- Server -}
|
||||
|
||||
tmpPolicy :: BodyPolicy
|
||||
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
|
||||
|
||||
main :: IO()
|
||||
main = do
|
||||
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
||||
tbDir <- getEnv "TAZBLOG"
|
||||
bracket (openLocalStateFrom (tbDir ++ "/State/SessionState") initialAccounts)
|
||||
(createCheckpointAndClose)
|
||||
(\sessionAcid -> bracket (openLocalStateFrom (tbDir ++ "/State/AccountState") )
|
||||
(createCheckpointAndClose)
|
||||
(\accountAcid -> simpleHTTP nullConf $
|
||||
tazBlog sessionAcid accountAcid))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
initialAccounts :: AccountState
|
||||
initialAccounts = []
|
||||
|
||||
askAccount :: IO Account
|
||||
askAccount = do
|
||||
putStrLn "Enter name for the account:"
|
||||
n <- getLine
|
||||
putStrLn "Enter password for the account:"
|
||||
p <- getLine
|
||||
return $ Account n $ hashString p
|
||||
|
||||
guardSession :: AcidState SessionState -> ServerPartT IO ()
|
||||
guardSession acid = do
|
||||
|
@ -61,18 +108,6 @@ guardSession acid = do
|
|||
when (32400 > (cDate - sDate))
|
||||
mzero
|
||||
|
||||
{- Server -}
|
||||
|
||||
tmpPolicy :: BodyPolicy
|
||||
tmpPolicy = (defaultBodyPolicy "./tmp/" 0 1000 1000)
|
||||
|
||||
main :: IO()
|
||||
main = do
|
||||
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
|
||||
bracket (openLocalState initialSession)
|
||||
(createCheckpointAndClose)
|
||||
(\acid -> simpleHTTP nullConf $ tazBlog acid)
|
||||
|
||||
tazBlog :: AcidState SessionState -> ServerPart Response
|
||||
tazBlog acid = do
|
||||
msum [ dir (show DE) $ blogHandler DE
|
||||
|
@ -85,9 +120,10 @@ tazBlog acid = do
|
|||
, path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_
|
||||
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
|
||||
, dir "notice" $ ok $ toResponse showSiteNotice
|
||||
, do adminSession <- lookCookieValue "session"
|
||||
ok $ toResponse ("Eingeloggt" :: String)
|
||||
, do dir "admin" $ guardSession acid
|
||||
adminHandler
|
||||
, dir "admin" $ ok $ toResponse $ adminTemplate adminLogin "Login"
|
||||
, dir "dologin" $ processLogin acid
|
||||
, serveDirectory DisableBrowsing [] "../res"
|
||||
]
|
||||
|
||||
|
@ -103,6 +139,9 @@ blogHandler lang =
|
|||
showIndex lang
|
||||
]
|
||||
|
||||
adminHandler :: ServerPart Response
|
||||
adminHandler = undefined
|
||||
|
||||
formatOldLink :: Int -> Int -> String -> ServerPart Response
|
||||
formatOldLink y m id_ =
|
||||
flip seeOther (toResponse ()) $
|
||||
|
@ -162,6 +201,14 @@ addComment id_ = do
|
|||
liftIO $ putStrLn $ show rev
|
||||
seeOther ("/" ++ id_) (toResponse())
|
||||
|
||||
processLogin :: AcidState SessionState -> ServerPart Response
|
||||
processLogin acid = do
|
||||
decodeBody tmpPolicy
|
||||
account <- look "account"
|
||||
password <- look "password"
|
||||
ok $ toResponse ("Shut up" :: String)
|
||||
|
||||
|
||||
-- http://tazj.in/2012/02/10.155234
|
||||
|
||||
currentSeconds :: IO Integer
|
||||
|
@ -170,7 +217,8 @@ currentSeconds = do
|
|||
let s = read (formatTime defaultTimeLocale "%s" now) :: Integer
|
||||
return s
|
||||
|
||||
-- CouchDB functions
|
||||
{- CouchDB functions -}
|
||||
|
||||
getLatest :: BlogLang -> [(String, JSValue)] -> ServerPart [Entry]
|
||||
getLatest lang arg = do
|
||||
queryResult <- queryDB view arg
|
||||
|
@ -221,7 +269,7 @@ getMonthCount lang y m = do
|
|||
view EN = "countEN"
|
||||
|
||||
|
||||
-- CouchDB View Setup
|
||||
{- CouchDB View Setup -}
|
||||
latestDEView = "function(doc){ if(doc.lang == 'DE'){ emit([doc.year, doc.month, doc.day, doc._id], doc); } }"
|
||||
latestENView = "function(doc){ if(doc.lang == 'EN'){ emit([doc.year, doc.month, doc.day, doc._id], doc); } }"
|
||||
countDEView = "function(doc){ if(doc.lang == 'DE'){ emit(['count', doc.year, doc.month, doc.day, doc._id], 1); } }"
|
||||
|
@ -236,3 +284,6 @@ countEN = ViewMapReduce "countEN" countENView countReduce
|
|||
setupBlogViews :: IO ()
|
||||
setupBlogViews = runCouchDB' $
|
||||
newView "tazblog" "entries" [latestDE, latestEN, countDE, countEN]
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Reference in a new issue