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

This commit is contained in:
Vincent Ambo 2012-03-12 04:32:15 +01:00
parent 4eacefe854
commit 6d9144a7ee

258
tools/acid-migrate/Acid.hs Normal file
View file

@ -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"