acid-migrate:
* show instance for EntryId * Comment/Entry deriving Show * trying to force explicit evaluation
This commit is contained in:
"Vincent Ambo ext:(%22)
parent
c6124d9aa7
commit
e6b91ce813
1 changed files with 122 additions and 115 deletions
|
|
@ -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,34 +41,37 @@ 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)
|
||||
deriving (Eq, Ord, Data, Typeable)
|
||||
|
||||
instance Show BlogLang where
|
||||
show DE = "de"
|
||||
show EN = "en"
|
||||
show DE = "de"
|
||||
show EN = "en"
|
||||
|
||||
$(deriveSafeCopy 0 'base ''BlogLang)
|
||||
|
||||
data Comment = Comment {
|
||||
cauthor :: Text,
|
||||
ctext :: Text,
|
||||
cdate :: UTCTime
|
||||
} deriving (Eq, Ord, Data, Typeable)
|
||||
cauthor :: Text,
|
||||
ctext :: Text,
|
||||
cdate :: UTCTime
|
||||
} deriving (Eq, Ord, Show, 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)
|
||||
entryId :: EntryId,
|
||||
lang :: BlogLang,
|
||||
author :: Text,
|
||||
title :: Text,
|
||||
btext :: Text,
|
||||
mtext :: Text,
|
||||
edate :: UTCTime,
|
||||
tags :: [Text],
|
||||
comments :: [Comment]
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Entry)
|
||||
|
||||
|
|
@ -77,144 +80,144 @@ 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 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
|
||||
]
|
||||
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
|
||||
username :: Text,
|
||||
password :: ByteString
|
||||
} deriving (Eq, Ord, Data, Typeable)
|
||||
|
||||
$(deriveSafeCopy 0 'base ''User)
|
||||
|
||||
data Session = Session {
|
||||
sessionID :: Text,
|
||||
user :: User,
|
||||
sdate :: UTCTime
|
||||
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
|
||||
]
|
||||
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]
|
||||
]
|
||||
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
|
||||
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 }
|
||||
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
|
||||
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
|
||||
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
|
||||
do b@Blog{..} <- ask
|
||||
return $ getOne $ blogEntries @= eid
|
||||
|
||||
latestPosts :: Query Blog [Entry]
|
||||
latestPosts =
|
||||
do b@Blog{..} <- ask
|
||||
return $ IxSet.toDescList (Proxy :: Proxy UTCTime) $ blogEntries
|
||||
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
|
||||
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
|
||||
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
|
||||
])
|
||||
[ 'insertEntry
|
||||
, 'updateEntry
|
||||
, 'getPost
|
||||
, 'latestPosts
|
||||
, 'addSession
|
||||
, 'addUser
|
||||
])
|
||||
|
||||
-- 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
|
||||
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)
|
||||
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
|
||||
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 \\ "\n") (pack stext) (Text.empty)
|
||||
leTime [] []
|
||||
|
||||
|
||||
getUnixTime :: UTCTime -> Integer
|
||||
|
|
@ -225,39 +228,43 @@ 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
|
||||
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
|
||||
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)
|
||||
pasteToDB acid !e = update' acid (InsertEntry e)
|
||||
|
||||
main :: IO()
|
||||
main = do
|
||||
bracket (openLocalState initialBlogState)
|
||||
(createCheckpointAndClose)
|
||||
(\acid -> convertEntries acid)
|
||||
bracket (openLocalState initialBlogState)
|
||||
(createCheckpointAndClose)
|
||||
(\acid -> convertEntries acid)
|
||||
|
||||
convertEntries acid = do
|
||||
entries <- parseOldEntries
|
||||
let x = map (pasteToDB acid) entries
|
||||
let titles = map (title) entries
|
||||
putStrLn $ show titles
|
||||
entries <- parseOldEntries
|
||||
let x = map (pasteToDB acid) entries
|
||||
let y = map forceHack x
|
||||
putStrLn $ show entries
|
||||
where
|
||||
forceHack !x = do
|
||||
xy <- x
|
||||
return x
|
||||
|
|
|
|||
Loading…
Reference in a new issue