* added Acid-State conversion program (this is untested, but it compiles)

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"