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