diff options
Diffstat (limited to 'src/BlogDB.hs')
| -rw-r--r-- | src/BlogDB.hs | 208 |
1 files changed, 208 insertions, 0 deletions
diff --git a/src/BlogDB.hs b/src/BlogDB.hs new file mode 100644 index 000000000000..cade9327e7f1 --- /dev/null +++ b/src/BlogDB.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, +TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables, BangPatterns #-} + +module BlogDB where + +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid +import Data.Acid.Advanced +import Data.Acid.Local +import Data.ByteString (ByteString) +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet) +import Data.List (insert) +import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Data.Time +import Happstack.Server (ServerPart) + +import qualified Crypto.Hash.SHA512 as SHA (hash) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Base64 as B64 (encode) +import qualified Data.IxSet as IxSet +import qualified Data.Text as Text + + +newtype EntryId = EntryId { unEntryId :: Integer } + deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy) + +instance Show EntryId where + show = show . unEntryId + +data BlogLang = EN | DE + deriving (Eq, Ord, Data, Typeable) + +instance Show BlogLang where + show DE = "de" + show EN = "en" + +$(deriveSafeCopy 0 'base ''BlogLang) + +data Comment = Comment { + cauthor :: Text, + ctext :: Text, + cdate :: UTCTime +} deriving (Eq, Ord, Show, Data, Typeable) + +$(deriveSafeCopy 0 'base ''Comment) + +data Entry = Entry { + entryId :: EntryId, + lang :: BlogLang, + author :: Text, + title :: Text, + btext :: Text, + mtext :: Text, + edate :: UTCTime, + tags :: [Text], + comments :: [Comment] +} deriving (Eq, Ord, Show, Data, Typeable) + +$(deriveSafeCopy 0 'base ''Entry) + +-- ixSet requires different datatypes for field indexes, so let's define some +newtype Author = Author Text deriving (Eq, Ord, Data, Typeable, SafeCopy) +newtype Title = Title Text deriving (Eq, Ord, Data, Typeable, SafeCopy) +newtype BText = BText Text deriving (Eq, Ord, Data, Typeable, SafeCopy) -- standard text +newtype MText = MText Text deriving (Eq, Ord, Data, Typeable, SafeCopy) -- "read more" text +newtype Tag = Tag Text deriving (Eq, Ord, Data, Typeable, SafeCopy) +newtype EDate = EDate UTCTime deriving (Eq, Ord, Data, Typeable, SafeCopy) +newtype SDate = SDate UTCTime deriving (Eq, Ord, Data, Typeable, SafeCopy) +newtype Username = Username Text deriving (Eq, Ord, Data, Typeable, SafeCopy) +newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable, SafeCopy) + +instance Indexable Entry where + empty = ixSet [ ixFun $ \e -> [ entryId e] + , ixFun $ (:[]) . lang + , ixFun $ \e -> [ Author $ author e ] + , ixFun $ \e -> [ Title $ title e] + , ixFun $ \e -> [ BText $ btext e] + , ixFun $ \e -> [ MText $ mtext e] + , ixFun $ \e -> [ EDate $ edate e] + , ixFun $ \e -> map Tag (tags e) + , ixFun $ comments + ] + +data User = User { + username :: Text, + password :: ByteString +} deriving (Eq, Ord, Data, Typeable) + +$(deriveSafeCopy 0 'base ''User) + +data Session = Session { + sessionID :: Text, + user :: User, + sdate :: UTCTime +} deriving (Eq, Ord, Data, Typeable) + +$(deriveSafeCopy 0 'base ''Session) + +instance Indexable User where + empty = ixSet [ ixFun $ \u -> [Username $ username u] + , ixFun $ (:[]) . password + ] + +instance Indexable Session where + empty = ixSet [ ixFun $ \s -> [SessionID $ sessionID s] + , ixFun $ (:[]) . user + , ixFun $ \s -> [SDate $ sdate s] + ] + +data Blog = Blog { + blogSessions :: IxSet Session, + blogUsers :: IxSet User, + blogEntries :: IxSet Entry +} deriving (Data, Typeable) + +$(deriveSafeCopy 0 'base ''Blog) + +initialBlogState :: Blog +initialBlogState = + Blog { blogSessions = empty + , blogUsers = empty + , blogEntries = empty } + +-- acid-state database functions (purity is necessary!) + +insertEntry :: Entry -> Update Blog Entry +insertEntry e = + do b@Blog{..} <- get + put $ b { blogEntries = IxSet.insert e blogEntries } + return e + +addComment :: EntryId -> Comment -> Update Blog Entry +addComment eId c = + do b@Blog{..} <- get + let (Just e) = getOne $ blogEntries @= eId + let newEntry = e { comments = insert c $ comments e } + put $ b { blogEntries = IxSet.updateIx eId newEntry blogEntries } + return newEntry + +updateEntry :: Entry -> Update Blog Entry +updateEntry e = + do b@Blog{..} <- get + put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries} + return e + +getEntry :: EntryId -> Query Blog (Maybe Entry) +getEntry eId = + do b@Blog{..} <- ask + return $ getOne $ blogEntries @= eId + +latestEntries :: BlogLang -> Query Blog [Entry] +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 = + do b@Blog{..} <- get + let s = Session sId u t + put $ b { blogSessions = IxSet.insert s blogSessions} + return s + +getSession :: SessionID -> Query Blog (Maybe Session) +getSession sId = + do b@Blog{..} <- ask + return $ getOne $ blogSessions @= sId + +addUser :: Text -> String -> Update Blog User +addUser un pw = + do b@Blog{..} <- get + let u = User un $ hashString pw + put $ b { blogUsers = IxSet.insert u blogUsers} + return u + +getUser :: Username -> Query Blog (Maybe User) +getUser uN = + do b@Blog{..} <- ask + return $ getOne $ blogUsers @= uN + +checkUser :: Username -> String -> Query Blog (Bool) +checkUser uN pw = + do b@Blog{..} <- ask + let user = getOne $ blogUsers @= uN + case user of + Nothing -> return False + (Just u) -> return $ (password u) == hashString pw + +-- various functions +hashString :: String -> ByteString +hashString = B64.encode . SHA.hash . B.pack + +$(makeAcidic ''Blog + [ 'insertEntry + , 'addComment + , 'updateEntry + , 'getEntry + , 'latestEntries + , 'addSession + , 'getSession + , 'addUser + , 'getUser + , 'checkUser + ]) + |