mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

acid-migrate:

Browse source 
* show instance for EntryId
* Comment/Entry deriving Show
* trying to force explicit evaluation
This commit is contained in:
"Vincent Ambo ext:(%22) 2012-03-12 12:52:48 +01:00
parent c6124d9aa7
commit e6b91ce813
1 changed files with 122 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

237
tools/acid-migrate/Acid.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards,
TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
module Main where module Main where
import Control.Applicative ((<$>), optional) import Control.Applicative ((<$>), optional)
@ -33,7 +33,7 @@ import qualified Data.Text as Text
import Database.CouchDB hiding (runCouchDB') import Database.CouchDB hiding (runCouchDB')
import Database.CouchDB.JSON import Database.CouchDB.JSON
import Text.JSON import Text.JSON
import Data.List (intersperse) import Data.List (intersperse, (\\))
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
-- data types and acid-state setup -- data types and acid-state setup
@ -41,34 +41,37 @@ import System.Locale (defaultTimeLocale)
newtype EntryId = EntryId { unEntryId :: Integer } newtype EntryId = EntryId { unEntryId :: Integer }
deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy) deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy)
instance Show EntryId where
show = show . unEntryId
data BlogLang = EN | DE data BlogLang = EN | DE
deriving (Eq, Ord, Data, Typeable) deriving (Eq, Ord, Data, Typeable)
instance Show BlogLang where instance Show BlogLang where
show DE = "de" show DE = "de"
show EN = "en" show EN = "en"
$(deriveSafeCopy 0 'base ''BlogLang) $(deriveSafeCopy 0 'base ''BlogLang)
data Comment = Comment {  data Comment = Comment { 
cauthor :: Text, cauthor :: Text,
ctext :: Text, ctext :: Text,
cdate :: UTCTime cdate :: UTCTime
} deriving (Eq, Ord, Data, Typeable) } deriving (Eq, Ord, Show, Data, Typeable)
$(deriveSafeCopy 0 'base ''Comment) $(deriveSafeCopy 0 'base ''Comment)
data Entry = Entry { data Entry = Entry {
entryId :: EntryId, entryId :: EntryId,
lang :: BlogLang, lang :: BlogLang,
author :: Text, author :: Text,
title :: Text, title :: Text,
btext :: Text, btext :: Text,
mtext :: Text, mtext :: Text,
edate :: UTCTime, edate :: UTCTime,
tags :: [Text], tags :: [Text],
comments :: [Comment] comments :: [Comment]
} deriving (Eq, Ord, Data, Typeable) } deriving (Eq, Ord, Show, Data, Typeable)
$(deriveSafeCopy 0 'base ''Entry) $(deriveSafeCopy 0 'base ''Entry)
@ -77,144 +80,144 @@ newtype Author = Author Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
newtype Title = Title 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 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 MText = MText Text deriving (Eq, Ord, Data, Typeable, SafeCopy) -- "read more" text
newtype Tag = Tag Text deriving (Eq, Ord, Data, Typeable, SafeCopy) newtype Tag = Tag Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
newtype EDate = EDate UTCTime 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 SDate = SDate UTCTime deriving (Eq, Ord, Data, Typeable, SafeCopy)
newtype Username = Username Text 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) newtype SessionID = SessionID Text deriving (Eq, Ord, Data, Typeable, SafeCopy)
instance Indexable Entry where instance Indexable Entry where
empty = ixSet [ ixFun $ \e -> [ entryId e] empty = ixSet [ ixFun $ \e -> [ entryId e]
, ixFun $ (:[]) . lang , ixFun $ (:[]) . lang
, ixFun $ \e -> [ Author $ author e ] , ixFun $ \e -> [ Author $ author e ]
, ixFun $ \e -> [ Title $ title e] , ixFun $ \e -> [ Title $ title e]
, ixFun $ \e -> [ BText $ btext e] , ixFun $ \e -> [ BText $ btext e]
, ixFun $ \e -> [ MText $ mtext e] , ixFun $ \e -> [ MText $ mtext e]
, ixFun $ \e -> [ EDate $ edate e] , ixFun $ \e -> [ EDate $ edate e]
, ixFun $ \e -> map Tag (tags e) , ixFun $ \e -> map Tag (tags e)
, ixFun $ comments , ixFun $ comments
] ]
data User = User { data User = User {
username :: Text, username :: Text,
password :: ByteString password :: ByteString
} deriving (Eq, Ord, Data, Typeable) } deriving (Eq, Ord, Data, Typeable)
$(deriveSafeCopy 0 'base ''User) $(deriveSafeCopy 0 'base ''User)
data Session = Session { data Session = Session {
sessionID :: Text, sessionID :: Text,
user :: User, user :: User,
sdate :: UTCTime sdate :: UTCTime
} deriving (Eq, Ord, Data, Typeable) } deriving (Eq, Ord, Data, Typeable)
$(deriveSafeCopy 0 'base ''Session) $(deriveSafeCopy 0 'base ''Session)
instance Indexable User where instance Indexable User where
empty = ixSet [ ixFun $ \u -> [Username $ username u] empty = ixSet [ ixFun $ \u -> [Username $ username u]
, ixFun $ (:[]) . password , ixFun $ (:[]) . password
] ]
instance Indexable Session where instance Indexable Session where
empty = ixSet [ ixFun $ \s -> [SessionID $ sessionID s] empty = ixSet [ ixFun $ \s -> [SessionID $ sessionID s]
, ixFun $ (:[]) . user , ixFun $ (:[]) . user
, ixFun $ \s -> [SDate $ sdate s] , ixFun $ \s -> [SDate $ sdate s]
] ]
data Blog = Blog { data Blog = Blog {
blogSessions :: IxSet Session, blogSessions :: IxSet Session,
blogUsers :: IxSet User, blogUsers :: IxSet User,
blogEntries :: IxSet Entry blogEntries :: IxSet Entry
} deriving (Data, Typeable) } deriving (Data, Typeable)
$(deriveSafeCopy 0 'base ''Blog) $(deriveSafeCopy 0 'base ''Blog)
initialBlogState :: Blog initialBlogState :: Blog
initialBlogState = initialBlogState =
Blog { blogSessions = empty Blog { blogSessions = empty
, blogUsers = empty , blogUsers = empty
, blogEntries = empty } , blogEntries = empty }
-- acid-state database functions (purity is necessary!) -- acid-state database functions (purity is necessary!)
insertEntry :: Entry -> Update Blog Entry insertEntry :: Entry -> Update Blog Entry
insertEntry e = insertEntry e =
do b@Blog{..} <- get do b@Blog{..} <- get
put $ b { blogEntries = IxSet.insert e blogEntries } put $ b { blogEntries = IxSet.insert e blogEntries }
return e return e
updateEntry :: Entry -> Update Blog Entry updateEntry :: Entry -> Update Blog Entry
updateEntry e = updateEntry e =
do b@Blog{..} <- get do b@Blog{..} <- get
put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries} put $ b { blogEntries = IxSet.updateIx (entryId e) e blogEntries}
return e return e
getPost :: EntryId -> Query Blog (Maybe Entry) getPost :: EntryId -> Query Blog (Maybe Entry)
getPost eid = getPost eid =
do b@Blog{..} <- ask do b@Blog{..} <- ask
return $ getOne $ blogEntries @= eid return $ getOne $ blogEntries @= eid
latestPosts :: Query Blog [Entry] latestPosts :: Query Blog [Entry]
latestPosts = latestPosts =
do b@Blog{..} <- ask do b@Blog{..} <- ask
return $ IxSet.toDescList (Proxy :: Proxy UTCTime) $ blogEntries return $ IxSet.toDescList (Proxy :: Proxy UTCTime) $ blogEntries
addSession :: Text -> User -> UTCTime -> Update Blog Session addSession :: Text -> User -> UTCTime -> Update Blog Session
addSession sId u t = addSession sId u t =
do b@Blog{..} <- get do b@Blog{..} <- get
let s = Session sId u t let s = Session sId u t
put $ b { blogSessions = IxSet.insert s blogSessions} put $ b { blogSessions = IxSet.insert s blogSessions}
return s return s
addUser :: Text -> String -> Update Blog User addUser :: Text -> String -> Update Blog User
addUser un pw = addUser un pw =
do b@Blog{..} <- get do b@Blog{..} <- get
let u = User un $ hashString pw let u = User un $ hashString pw
put $ b { blogUsers = IxSet.insert u blogUsers} put $ b { blogUsers = IxSet.insert u blogUsers}
return u return u
-- various functions -- various functions
hashString :: String -> ByteString hashString :: String -> ByteString
hashString = B64.encode . SHA.hash . B.pack hashString = B64.encode . SHA.hash . B.pack
$(makeAcidic ''Blog $(makeAcidic ''Blog
[ 'insertEntry [ 'insertEntry
, 'updateEntry , 'updateEntry
, 'getPost , 'getPost
, 'latestPosts , 'latestPosts
, 'addSession , 'addSession
, 'addUser , 'addUser
]) ])
-- CouchDB database functions -- CouchDB database functions
runCouchDB' :: CouchMonad a -> IO a runCouchDB' :: CouchMonad a -> IO a
runCouchDB' = runCouchDB "hackbox.local" 5984 runCouchDB' = runCouchDB "127.0.0.1" 5984
instance JSON Comment where instance JSON Comment where
showJSON = undefined showJSON = undefined
readJSON val = do readJSON val = do
obj <- jsonObject val obj <- jsonObject val
scauthor <- jsonField "cauthor" obj scauthor <- jsonField "cauthor" obj
scdate <- jsonField "cdate" obj scdate <- jsonField "cdate" obj
sctext <- jsonField "cdate" obj sctext <- jsonField "cdate" obj
return $ Comment (pack scauthor) (pack sctext) (parseSeconds scdate) return $ Comment (pack scauthor) (pack sctext) (parseSeconds scdate)
instance JSON Entry where instance JSON Entry where
showJSON = undefined showJSON = undefined
readJSON val = do readJSON val = do
obj <- jsonObject val obj <- jsonObject val
sauthor <- jsonField "author" obj sauthor <- jsonField "author" obj
stitle <- jsonField "title" obj stitle <- jsonField "title" obj
day <- jsonField "day" obj day <- jsonField "day" obj
month <- jsonField "month" obj month <- jsonField "month" obj
year <- jsonField "year" obj year <- jsonField "year" obj
stext <- jsonField "text" obj stext <- jsonField "text" obj
comments <- jsonField "comments" obj --comments <- jsonField "comments" obj
oldid <- jsonField "_id" obj oldid <- jsonField "_id" obj
let leTime = parseShittyTime year month day oldid let leTime = parseShittyTime year month day oldid
return $ Entry (EntryId $ getUnixTime leTime) DE (pack sauthor) (pack stitle) (pack stext) (Text.empty) return $ Entry (EntryId $ getUnixTime leTime) DE (pack sauthor) (pack $ stitle \\ "\n") (pack stext) (Text.empty)
leTime [] comments leTime [] []
getUnixTime :: UTCTime -> Integer getUnixTime :: UTCTime -> Integer
@ -225,39 +228,43 @@ parseSeconds t = readTime defaultTimeLocale "%s" $ show t
parseShittyTime :: Int -> Int -> Int -> String -> UTCTime parseShittyTime :: Int -> Int -> Int -> String -> UTCTime
parseShittyTime y m d i = readTime defaultTimeLocale "%Y %m %e %k:%M:%S" newPartTime parseShittyTime y m d i = readTime defaultTimeLocale "%Y %m %e %k:%M:%S" newPartTime
where where
firstPart = take 2 i firstPart = take 2 i
secondPart = take 2 $ drop 2 i secondPart = take 2 $ drop 2 i
thirdPart = drop 4 i thirdPart = drop 4 i
newPartTime = concat $ intersperse " " [show y, showMonth m, show d, " "] ++ newPartTime = concat $ intersperse " " [show y, showMonth m, show d, " "] ++
intersperse ":" [firstPart, secondPart, thirdPart] intersperse ":" [firstPart, secondPart, thirdPart]
showMonth mn showMonth mn
| mn < 10 = "0" ++ show mn | mn < 10 = "0" ++ show mn
| otherwise = show mn | otherwise = show mn
getOldEntries = runCouchDB' $ queryView (db "tazblog") (doc "entries") (doc "latestDE") [] getOldEntries = runCouchDB' $ queryView (db "tazblog") (doc "entries") (doc "latestDE") []
parseOldEntries :: IO [Entry] parseOldEntries :: IO [Entry]
parseOldEntries = do parseOldEntries = do
queryResult <- getOldEntries queryResult <- getOldEntries
let entries = map (stripResult . readJSON . snd) queryResult let entries = map (stripResult . readJSON . snd) queryResult
return entries return entries
stripResult :: Result a -> a stripResult :: Result a -> a
stripResult (Ok z) = z stripResult (Ok z) = z
stripResult (Error s) = error $ "JSON error: " ++ s stripResult (Error s) = error $ "JSON error: " ++ s
pasteToDB :: AcidState Blog -> Entry -> IO (EventResult InsertEntry) pasteToDB :: AcidState Blog -> Entry -> IO (EventResult InsertEntry)
pasteToDB acid e = update' acid (InsertEntry e) pasteToDB acid !e = update' acid (InsertEntry e)
main :: IO() main :: IO()
main = do main = do
bracket (openLocalState initialBlogState) bracket (openLocalState initialBlogState)
(createCheckpointAndClose) (createCheckpointAndClose)
(\acid -> convertEntries acid) (\acid -> convertEntries acid)
convertEntries acid = do convertEntries acid = do
entries <- parseOldEntries entries <- parseOldEntries
let x = map (pasteToDB acid) entries let x = map (pasteToDB acid) entries
let titles = map (title) entries let y = map forceHack x
putStrLn $ show titles putStrLn $ show entries
where
forceHack !x = do
xy <- x
return x