diff options
Diffstat (limited to 'services/tazblog/src/BlogDB.hs')
| -rw-r--r-- | services/tazblog/src/BlogDB.hs | 229 |
1 files changed, 229 insertions, 0 deletions
diff --git a/services/tazblog/src/BlogDB.hs b/services/tazblog/src/BlogDB.hs new file mode 100644 index 0000000000..bc9c243933 --- /dev/null +++ b/services/tazblog/src/BlogDB.hs @@ -0,0 +1,229 @@ +module BlogDB where + +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid +import Data.Acid.Advanced +import Data.Acid.Remote +import Data.ByteString (ByteString) +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable (..), IxSet, Proxy (..), getOne, ixFun, ixSet, (@=)) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Text (Text, pack) +import Data.Time +import Network (PortID (..)) +import System.Environment (getEnv) + +import qualified Crypto.Hash.SHA512 as SHA (hash) +import qualified Data.ByteString.Base64 as B64 (encode) +import qualified Data.ByteString.Char8 as B +import qualified Data.IxSet as IxSet + +newtype EntryId = EntryId { unEntryId :: Integer } + deriving (Eq, Ord, Data, Enum, Typeable) + +$(deriveSafeCopy 2 'base ''EntryId) + +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 Entry = Entry { + entryId :: EntryId, + lang :: BlogLang, + author :: Text, + title :: Text, + btext :: Text, + mtext :: Text, + edate :: UTCTime +} deriving (Eq, Ord, Show, Data, Typeable) + +$(deriveSafeCopy 2 'base ''Entry) + +-- ixSet requires different datatypes for field indexes, so let's define some +newtype Author = Author Text deriving (Eq, Ord, Data, Typeable) +newtype Title = Title Text deriving (Eq, Ord, Data, Typeable) +newtype BText = BText Text deriving (Eq, Ord, Data, Typeable) -- standard text +newtype MText = MText Text deriving (Eq, Ord, Data, Typeable) -- "read more" text +newtype Tag = Tag Text deriving (Eq, Ord, Data, Typeable) +newtype EDate = EDate UTCTime deriving (Eq, Ord, Data, Typeable) +newtype SDate = SDate UTCTime deriving (Eq, Ord, Data, Typeable) +newtype Username = Username Text deriving (Eq, Ord, Data, Typeable) +newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable) + +$(deriveSafeCopy 2 'base ''Author) +$(deriveSafeCopy 2 'base ''Title) +$(deriveSafeCopy 2 'base ''BText) +$(deriveSafeCopy 2 'base ''MText) +$(deriveSafeCopy 2 'base ''Tag) +$(deriveSafeCopy 2 'base ''EDate) +$(deriveSafeCopy 2 'base ''SDate) +$(deriveSafeCopy 2 'base ''Username) +$(deriveSafeCopy 2 'base ''SessionID) + +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] + ] + +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 + +updateEntry :: Entry -> Update Blog Entry +updateEntry e = + do b@Blog{..} <- get + put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries } + return e + +deleteEntry :: EntryId -> Update Blog EntryId +deleteEntry entry = + do b@Blog{..} <- get + put $ b { blogEntries = IxSet.deleteIx entry blogEntries } + return entry + +getEntry :: EntryId -> Query Blog (Maybe Entry) +getEntry eId = + do Blog{..} <- ask + return $ getOne $ blogEntries @= eId + +latestEntries :: BlogLang -> Query Blog [Entry] +latestEntries lang = + do Blog{..} <- ask + return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang + +addSession :: Session -> Update Blog Session +addSession nSession = + do b@Blog{..} <- get + put $ b { blogSessions = IxSet.insert nSession blogSessions} + return nSession + +getSession :: SessionID -> Query Blog (Maybe Session) +getSession sId = + do Blog{..} <- ask + return $ getOne $ blogSessions @= sId + +clearSessions :: Update Blog [Session] +clearSessions = + do b@Blog{..} <- get + put $ b { blogSessions = empty } + return [] + +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 Blog{..} <- ask + return $ getOne $ blogUsers @= uN + +checkUser :: Username -> String -> Query Blog Bool +checkUser uN pw = + do 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 + , 'updateEntry + , 'deleteEntry + , 'getEntry + , 'latestEntries + , 'addSession + , 'getSession + , 'addUser + , 'getUser + , 'checkUser + , 'clearSessions + ]) + +interactiveUserAdd :: String -> IO () +interactiveUserAdd dbHost = do + acid <- openRemoteState skipAuthenticationPerform dbHost (PortNumber 8070) + putStrLn "Username:" + un <- getLine + putStrLn "Password:" + pw <- getLine + update' acid (AddUser (pack un) pw) + closeAcidState acid + +flushSessions :: IO () +flushSessions = do + tbDir <- getEnv "TAZBLOG" + acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState + update' acid ClearSessions + closeAcidState acid + +archiveState :: IO () +archiveState = do + tbDir <- getEnv "TAZBLOG" + acid <- openLocalStateFrom (tbDir ++ "/BlogState") initialBlogState + createArchive acid + closeAcidState acid |