197 lines
7.2 KiB
Haskell
Executable file
197 lines
7.2 KiB
Haskell
Executable file
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Migrate2 where
|
|
|
|
import Prelude
|
|
import Yesod.Core (liftIO)
|
|
import Database.HDBC
|
|
import Database.HDBC.PostgreSQL
|
|
import System.IO
|
|
import Control.Exception
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (decodeUtf8)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.ByteString.Lazy.Char8 as BL
|
|
import Data.Aeson as A
|
|
import Data.Time.Clock
|
|
import Data.Yaml as Y
|
|
import Data.Time.LocalTime
|
|
import Database.Bloodhound
|
|
import Network.HTTP.Client
|
|
import Network.HTTP.Types.Status
|
|
|
|
data ESSettings = ESSettings
|
|
{ esHost :: T.Text
|
|
, esShards :: Int
|
|
, esReplicas :: Int
|
|
}
|
|
|
|
instance A.FromJSON ESSettings where
|
|
parseJSON = withObject "AppSettings" $ \o -> do
|
|
esHost <- o .: "searchhost"
|
|
esShards <- o .: "shards"
|
|
esReplicas <- o .: "replicas"
|
|
return ESSettings {..}
|
|
|
|
main :: IO ()
|
|
main = do
|
|
putStrLn "Enter database host"
|
|
dbHost <- getLine
|
|
putStrLn "Enter database port"
|
|
dbPort <- getLine
|
|
putStrLn "Enter database user"
|
|
dbUser <- getLine
|
|
putStrLn "Enter database name"
|
|
dbName <- getLine
|
|
putStrLn "Enter database password"
|
|
dbPasswd <- getPasswd
|
|
putStrLn "Enter location of eidolon settings.yml file"
|
|
settingsFP <- getLine
|
|
let dbString = "host=" ++ dbHost ++ " port=" ++ dbPort ++ " user=" ++ dbUser ++ " dbname=" ++ dbName ++ " password=" ++ dbPasswd
|
|
conn <- connectPostgreSQL dbString
|
|
settingsY <- decodeFile settingsFP :: IO (Maybe ESSettings)
|
|
elastic <- case settingsY of
|
|
Just el -> return el
|
|
Nothing -> error $ "Could not read settings from " ++ settingsFP
|
|
let server = Server $ esHost elastic
|
|
let indexSettings = IndexSettings (ShardCount $ esShards elastic) (ReplicaCount $ esReplicas elastic)
|
|
userStmt <- prepare conn "select * from \"user\""
|
|
_ <- execute userStmt []
|
|
userRows <- fetchAllRowsAL userStmt
|
|
albumStmt <- prepare conn "select * from \"album\""
|
|
_ <- execute albumStmt []
|
|
albumRows <- fetchAllRowsAL albumStmt
|
|
mediumStmt <- prepare conn "select * from \"medium\""
|
|
_ <- execute mediumStmt []
|
|
mediumRows <- fetchAllRowsAL mediumStmt
|
|
commentStmt <- prepare conn "select * from \"comment\""
|
|
_ <- execute commentStmt []
|
|
commentRows <- fetchAllRowsAL commentStmt
|
|
_ <- withBH defaultManagerSettings server $ do
|
|
_ <- createIndex indexSettings (IndexName "user")
|
|
_ <- createIndex indexSettings (IndexName "album")
|
|
_ <- createIndex indexSettings (IndexName "medium")
|
|
_ <- createIndex indexSettings (IndexName "comment")
|
|
_ <- mapM (\entry ->
|
|
case entry of
|
|
[("id", SqlInteger theId), ("name", SqlByteString name), ("slug", SqlByteString slug), _, _, _, _, _] -> do
|
|
let u = SUser (decodeUtf8 name) (decodeUtf8 slug)
|
|
let dId = DocId $ T.pack $ show theId
|
|
liftIO $ putStrLn $ (show u) ++ "\n"
|
|
resp <- indexDocument (IndexName "user") (MappingName "user") defaultIndexDocumentSettings u dId
|
|
case statusCode (responseStatus resp) of
|
|
200 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
201 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
_ -> liftIO $ putStrLn $ "!!Failure!!: " ++ (BL.unpack $ responseBody resp)
|
|
bla ->
|
|
error $ "malformed entry" ++ show bla
|
|
) userRows
|
|
_ <- mapM (\entry ->
|
|
case entry of
|
|
[("id", SqlInteger theId), ("title", SqlByteString title), _, _, _, _, _] -> do
|
|
let a = SAlbum (decodeUtf8 title)
|
|
let dId = DocId $ T.pack $ show theId
|
|
liftIO $ putStrLn $ (show a) ++ "\n"
|
|
resp <- indexDocument (IndexName "album") (MappingName "album") defaultIndexDocumentSettings a dId
|
|
case statusCode (responseStatus resp) of
|
|
200 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
201 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
_ -> liftIO $ putStrLn $ "!!Failure!!: " ++ (BL.unpack $ responseBody resp)
|
|
bla ->
|
|
error $ "malformed entry: " ++ show bla
|
|
) albumRows
|
|
_ <- mapM (\entry ->
|
|
case entry of
|
|
[("id", SqlInteger theId), ("title", SqlByteString title), _, _, _, ("time", SqlZonedTime time), _, ("description", SqlByteString desc), ("tags", SqlByteString tags), _, _, _, _, _] -> do
|
|
let m = SMedium (decodeUtf8 title) (zonedTimeToUTC time) (decodeUtf8 desc) (parseTags tags)
|
|
let dId = DocId $ T.pack $ show theId
|
|
liftIO $ putStrLn $ (show m) ++ "\n"
|
|
resp <- indexDocument (IndexName "medium") (MappingName "medium") defaultIndexDocumentSettings m dId
|
|
case statusCode (responseStatus resp) of
|
|
200 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
201 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
_ -> liftIO $ putStrLn $ "!!Failure!!: " ++ (BL.unpack $ responseBody resp)
|
|
bla ->
|
|
error $ "malformed entry" ++ show bla
|
|
) mediumRows
|
|
_ <- mapM (\entry ->
|
|
case entry of
|
|
[("id", SqlInteger theId), _, ("author_slug", SqlByteString author), _, _, ("time", SqlZonedTime time), ("content", SqlByteString content)] -> do
|
|
let c = SComment (decodeUtf8 author) (zonedTimeToUTC time) (decodeUtf8 content)
|
|
let dId = DocId $ T.pack $ show theId
|
|
liftIO $ putStrLn $ (show c) ++ "\n"
|
|
resp <- indexDocument (IndexName "comment") (MappingName "comment") defaultIndexDocumentSettings c dId
|
|
case statusCode (responseStatus resp) of
|
|
200 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
201 -> liftIO $ putStrLn $ "OK: " ++ (BL.unpack $ responseBody resp)
|
|
_ -> liftIO $ putStrLn $ "!!Failure!!: " ++ (BL.unpack $ responseBody resp)
|
|
bla ->
|
|
error $ "malformed entry" ++ show bla
|
|
) commentRows
|
|
return ()
|
|
putStrLn "Migration successful!!"
|
|
|
|
data SUser = SUser
|
|
{ suName :: T.Text
|
|
, suSlug :: T.Text
|
|
} deriving Show
|
|
|
|
instance A.ToJSON SUser where
|
|
toJSON (SUser n s) = object
|
|
[ "name" .= n
|
|
, "slug" .= s
|
|
]
|
|
|
|
data SAlbum = SAlbum
|
|
{ saName :: T.Text } deriving Show
|
|
|
|
instance A.ToJSON SAlbum where
|
|
toJSON (SAlbum n) = object
|
|
[ "name" .= n ]
|
|
|
|
data SMedium = SMedium
|
|
{ smName :: T.Text
|
|
, smTime :: UTCTime
|
|
, smDesc :: T.Text
|
|
, smTags :: [T.Text]
|
|
} deriving Show
|
|
|
|
instance A.ToJSON SMedium where
|
|
toJSON (SMedium n t d g) = object
|
|
[ "name" .= n
|
|
, "time" .= t
|
|
, "description" .= d
|
|
, "tags" .= g
|
|
]
|
|
|
|
data SComment = SComment
|
|
{ scAuthor :: T.Text
|
|
, scTime :: UTCTime
|
|
, scContent :: T.Text
|
|
} deriving Show
|
|
|
|
instance A.ToJSON SComment where
|
|
toJSON (SComment a t c) = object
|
|
[ "author" .= a
|
|
, "time" .= t
|
|
, "content" .= c
|
|
]
|
|
|
|
parseTags :: B.ByteString -> [T.Text]
|
|
parseTags bs = map handle' inner
|
|
where
|
|
inner = T.splitOn "," $ T.pack $ B.unpack $ B.init $ B.tail bs
|
|
handle' = T.dropEnd 1 . T.drop 2
|
|
|
|
getPasswd :: IO String
|
|
getPasswd = do
|
|
putStr "Password: "
|
|
hFlush stdout
|
|
pass <- withEcho False getLine
|
|
putChar '\n'
|
|
return pass
|
|
|
|
withEcho :: Bool -> IO a -> IO a
|
|
withEcho echo action = do
|
|
old <- hGetEcho stdin
|
|
bracket_ (hSetEcho stdin echo) (hSetEcho stdin old) action
|