diff options
| -rw-r--r-- | tools/acid-migrate/Acid.hs | 258 |
1 files changed, 258 insertions, 0 deletions
diff --git a/tools/acid-migrate/Acid.hs b/tools/acid-migrate/Acid.hs new file mode 100644 index 000000000000..ab81cdceeb63 --- /dev/null +++ b/tools/acid-migrate/Acid.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, +TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} + +module Main where +import Control.Applicative ((<$>), optional) +import Control.Exception (bracket) +import Control.Monad (msum, mzero) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Control.Monad.Trans (liftIO) +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.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Data.Time +import Happstack.Server hiding (Session) + +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 + + +{-CouchDB imports-} + +import Database.CouchDB +import Database.CouchDB.JSON +import Text.JSON +import Data.List (intersperse) +import System.Locale (defaultTimeLocale) + +-- data types and acid-state setup + +newtype EntryId = EntryId { unEntryId :: Integer } + deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy) + +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, 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) + +$(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 + +updateEntry :: Entry -> Update Blog Entry +updateEntry 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 + +latestPosts :: Query Blog [Entry] +latestPosts = + 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 + +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 + +-- various functions +hashString :: String -> ByteString +hashString = B64.encode . SHA.hash . B.pack + +$(makeAcidic ''Blog + [ 'insertEntry + , 'updateEntry + , 'getPost + , 'latestPosts + , 'addSession + , 'addUser + ]) + +-- CouchDB database functions +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) + +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 + + +getUnixTime :: UTCTime -> Integer +getUnixTime t = read $ formatTime defaultTimeLocale "%s" t + +parseSeconds :: Integer -> UTCTime +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 + +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 + +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) + +main :: IO() +main = do + bracket (openLocalState initialBlogState) + (createCheckpointAndClose) + (\acid -> convertEntries acid) + +convertEntries acid = do + entries <- parseOldEntries + let x = map (pasteToDB acid) entries + putStrLn "Conversion successful" |