259 lines
7.4 KiB
Haskell
259 lines
7.4 KiB
Haskell
|
{-# 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"
|