From fdefacf0cc9376b7a405e2ecd6ef3efb243c1862 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 3 Dec 2016 16:25:42 +0100 Subject: [PATCH] added migration script --- Migrations/0.1.4.0-0.1.5.0/Migration.hs | 95 +++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 Migrations/0.1.4.0-0.1.5.0/Migration.hs diff --git a/Migrations/0.1.4.0-0.1.5.0/Migration.hs b/Migrations/0.1.4.0-0.1.5.0/Migration.hs new file mode 100644 index 0000000..ac5849a --- /dev/null +++ b/Migrations/0.1.4.0-0.1.5.0/Migration.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} + +import Database.HDBC +import Database.HDBC.PostgreSQL +import System.IO +import Control.Exception +import qualified Data.Text as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +import Network.Mail.Mime +import Text.Hamlet +import System.Random +import Text.Blaze.Html.Renderer.Utf8 +import Numeric (showHex) + +main :: IO () +main = do + putStrLn "Enter app root (e.g.: \"https://eidolon.nek0.eu\"" + appRoot <- getLine + 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 + let dbString = "host=" ++ dbHost ++ " port=" ++ dbPort ++ " user=" ++ dbUser ++ " dbname=" ++ dbName ++ " password=" ++ dbPasswd + conn <- connectPostgreSQL dbString + stmt1 <- prepare conn "select * from \"user\"" + _ <- execute stmt1 [] + rows <- fetchAllRowsAL stmt1 + mapM_ (\entry -> + case entry of + [("id", SqlInteger theId), _, ("slug", SqlByteString uSlug), ("email", SqlByteString uEmail), _, _, _, _] -> do + rText <- (toHex . B.pack . take 16 . randoms) <$> newStdGen + _ <- run conn ("insert into \"token\" (kind, token, \"user\") values (" ++ + "'activate', " ++ + "'" ++ BC.unpack rText ++ "', " ++ + show theId ++ ")") [] + let link = appRoot ++ "/activate/" ++ BC.unpack rText + sendMail (BC.unpack uEmail) (BC.unpack uSlug) link + putStrLn $ "Notified " ++ (BC.unpack uSlug) + _ -> + error "Malformed entry" + ) rows + commit conn + disconnect conn + putStrLn "Migration successfull!!" + +sendMail :: String -> String -> String -> IO () +sendMail toEmail userSlug link = do + renderSendMail + Mail + { mailFrom = Address Nothing "noreply" + , mailTo = [Address Nothing (T.pack toEmail)] + , mailCc = [] + , mailBcc = [] + , mailHeaders = [("Subject", "Please update your password")] + , mailParts = [[Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partHeaders = [] + , partContent = renderHtml [shamlet| +

Hello #{userSlug}, +

+ Due to changes in the Database your Password has been reset. + Please reactivate your account by going to #{link} + |] + }]] + } + +toHex :: B.ByteString -> B.ByteString +toHex = BC.pack . concatMap mapByte . B.unpack + where mapByte = pad 2 '0' . flip showHex "" + pad len padding s + | length s < len = pad len padding $ padding:s + | otherwise = s + +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