mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

acid-migrate:

Browse source 
* show instance for EntryId
* Comment/Entry deriving Show
* trying to force explicit evaluation
This commit is contained in:
"Vincent Ambo ext:(%22) 2012-03-12 12:52:48 +01:00
parent c6124d9aa7
commit e6b91ce813
1 changed files with 122 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
tools/acid-migrate/Acid.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards,
TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
module Main where module Main where
import Control.Applicative ((<$>), optional) import Control.Applicative ((<$>), optional)
@ -33,7 +33,7 @@ import qualified Data.Text as Text
import Database.CouchDB hiding (runCouchDB') import Database.CouchDB hiding (runCouchDB')
import Database.CouchDB.JSON import Database.CouchDB.JSON
import Text.JSON import Text.JSON
import Data.List (intersperse) import Data.List (intersperse, (\\))
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
-- data types and acid-state setup -- data types and acid-state setup
@ -41,6 +41,9 @@ import System.Locale (defaultTimeLocale)
newtype EntryId = EntryId { unEntryId :: Integer } newtype EntryId = EntryId { unEntryId :: Integer }
deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy) deriving (Eq, Ord, Data, Enum, Typeable, SafeCopy)
instance Show EntryId where
show = show . unEntryId
data BlogLang = EN | DE data BlogLang = EN | DE
deriving (Eq, Ord, Data, Typeable) deriving (Eq, Ord, Data, Typeable)
@ -54,7 +57,7 @@ data Comment = Comment { 
cauthor :: Text, cauthor :: Text,
ctext :: Text, ctext :: Text,
cdate :: UTCTime cdate :: UTCTime
} deriving (Eq, Ord, Data, Typeable) } deriving (Eq, Ord, Show, Data, Typeable)
$(deriveSafeCopy 0 'base ''Comment) $(deriveSafeCopy 0 'base ''Comment)
@ -68,7 +71,7 @@ data Entry = Entry {
edate :: UTCTime, edate :: UTCTime,
tags :: [Text], tags :: [Text],
comments :: [Comment] comments :: [Comment]
} deriving (Eq, Ord, Data, Typeable) } deriving (Eq, Ord, Show, Data, Typeable)
$(deriveSafeCopy 0 'base ''Entry) $(deriveSafeCopy 0 'base ''Entry)
@ -189,7 +192,7 @@ $(makeAcidic ''Blog
-- CouchDB database functions -- CouchDB database functions
runCouchDB' :: CouchMonad a -> IO a runCouchDB' :: CouchMonad a -> IO a
runCouchDB' = runCouchDB "hackbox.local" 5984 runCouchDB' = runCouchDB "127.0.0.1" 5984
instance JSON Comment where instance JSON Comment where
showJSON = undefined showJSON = undefined
@ -210,11 +213,11 @@ instance JSON Entry where
month <- jsonField "month" obj month <- jsonField "month" obj
year <- jsonField "year" obj year <- jsonField "year" obj
stext <- jsonField "text" obj stext <- jsonField "text" obj
comments <- jsonField "comments" obj --comments <- jsonField "comments" obj
oldid <- jsonField "_id" obj oldid <- jsonField "_id" obj
let leTime = parseShittyTime year month day oldid let leTime = parseShittyTime year month day oldid
return $ Entry (EntryId $ getUnixTime leTime) DE (pack sauthor) (pack stitle) (pack stext) (Text.empty) return $ Entry (EntryId $ getUnixTime leTime) DE (pack sauthor) (pack $ stitle \\ "\n") (pack stext) (Text.empty)
leTime [] comments leTime [] []
getUnixTime :: UTCTime -> Integer getUnixTime :: UTCTime -> Integer
@ -248,7 +251,7 @@ stripResult (Ok z) = z
stripResult (Error s) = error $ "JSON error: " ++ s stripResult (Error s) = error $ "JSON error: " ++ s
pasteToDB :: AcidState Blog -> Entry -> IO (EventResult InsertEntry) pasteToDB :: AcidState Blog -> Entry -> IO (EventResult InsertEntry)
pasteToDB acid e = update' acid (InsertEntry e) pasteToDB acid !e = update' acid (InsertEntry e)
main :: IO() main :: IO()
main = do main = do
@ -259,5 +262,9 @@ main = do
convertEntries acid = do convertEntries acid = do
entries <- parseOldEntries entries <- parseOldEntries
let x = map (pasteToDB acid) entries let x = map (pasteToDB acid) entries
let titles = map (title) entries let y = map forceHack x
putStrLn $ show titles putStrLn $ show entries
where
forceHack !x = do
xy <- x
return x