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