* added Acid-State conversion program (this is untested, but it compiles)
This commit is contained in:
parent
4eacefe854
commit
6d9144a7ee
1 changed files with 258 additions and 0 deletions
258
tools/acid-migrate/Acid.hs
Normal file
258
tools/acid-migrate/Acid.hs
Normal 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"
|
Loading…
Reference in a new issue