eidolon/Migrations/0.0.4-0.0.5/Migration.hs

{-# 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