6
\$\begingroup\$

I know that my let configFilePath = Prelude.head args is unsafe and was wondering how I could handle it better. My deployment almost always has a file at ~/config.cfg so I suppose I could have used mayHead then later maybe to safely default the filepath to ~/config.cfg.

This was all done a little rushed, so I'd like to know how I did, how you would do it, if it's idiomatic, what should be changed, and if there are pieces I could factor out. Most importantly, I'd like to know if there are any bugs or unsafe things I've used.

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}
import           Control.Monad                 (forM_)
import           Control.Monad.Logger
import           Control.Monad.Trans           (liftIO)
import           Control.Monad.Trans.Resource  (ResourceT, runResourceT)
import           Data.Configurator
import           Data.Text.Lazy                as T hiding (map)
import           Data.Time                     (UTCTime, getCurrentTime)
import           Database.Persist
import           Database.Persist.TH
import           System.IO                     (getLine)
import Prelude hiding (div)
import           Text.Blaze.Html
import           Text.Blaze.Html.Renderer.Text (renderHtml)
import           Text.Blaze.Html5              hiding (map)
import qualified Text.Blaze.Html5.Attributes as A   hiding (title)
import qualified Web.Scotty                    as S
import           MyBot.DomainChecker        (checkDomainAvail,
                                                getAuthCookies)
import Database.Persist.MySQL
import System.Environment (getArgs)

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
DomainItem
  domain String
  active Bool
  createdAt UTCTime
  lastChecked UTCTime Maybe
  UniqueName domain
  deriving Show

Settings
  username String
  password String
  ppUsername String
  ppPassword String
  checkerDelay Int default=10
|]

runDb du dp x = liftIO $ withMySQLConn info $ \conn -> do
  (flip runSqlPersistM) conn x
  where info = defaultConnectInfo { connectDatabase = "ExpiredDomainBuyer", connectUser = du, connectPassword = dp }

blaze = S.html . renderHtml

getDBDetails :: FilePath -> IO (String, String)
getDBDetails filepath = do cfg <- load [Required "config.cfg"]
                           du <- require cfg "dBUser"
                           dp <- require cfg "dBPass"
                           return (du, dp)

toPageLink :: String -> String
toPageLink d = "/domain/" ++ d

checkSettingsEmpty du dp redirect = do
  emptySettings <- runDb du dp $ selectFirst [SettingsUsername ==. ""] [] :: S.ActionM (Maybe (Entity Settings))
  case emptySettings of
    Just settings' -> do
      liftIO . putStrLn $ "found empty settings"
      liftIO . putStrLn $ settingsUsername . entityVal $ settings'
      -- if there are no settings entries with valid (non empty) username
      -- delete all rows in settings table
      runDb du dp $ deleteWhere ([] :: [Filter Settings])
      -- create initial settings row
      runDb du dp (insert $ Settings "" "" "" "" 10)
      S.redirect redirect
    Nothing -> do
      liftIO . putStrLn $ "settings with non empty username found, probably valid... redirect to main"
      -- don't make this "/" or you'll redirect ;)
      S.redirect "/domain/list"

main = do
  args <- getArgs
  let configFilePath = Prelude.head args
  putStrLn $ "config file: " ++ configFilePath
  -- (du,dp) <- getDBDetails configFilePath
  (du,dp) <- getDBDetails configFilePath
  runDb du dp $ runMigration migrateAll
  settings <- runDb du dp $ selectFirst [SettingsUsername !=. ""] []
  let checkerDelay = maybe 10 (settingsCheckerDelay . entityVal) settings
  putStrLn $ "Connected to db with username " ++ du

  S.scotty 3000 $ do
    S.get "/" $ do
      checkSettingsEmpty du dp "/settings"
    S.get "/domain/list" $ do
      -- checkSettingsEmpty du dp "/settings"
      domains_ <- liftIO $ runDb du dp $ selectList [] []
      let domains = map (domainItemDomain . entityVal) domains_
      blaze $ do
        body $ do
          h1 "Watched domains"
          p $ a ! A.href "/settings" $ "settings"
          addDomainForm
          deleteDomainForm
          ul $ do
            forM_ domains $ \domain -> do
              li $ a ! A.href (toValue . toPageLink $ domain ++ "/details") $ toHtml domain
    S.get "/domain/:domain/details" $ do
      domain_ <- S.param "domain"
      domain <- liftIO . (runDb du dp) . getBy $ UniqueName domain_
      case domain of
        Just domain' -> do
          let domainName = (domainItemDomain . entityVal $ domain')
          let timeCreatedStr = show . domainItemCreatedAt . entityVal $ domain'
          blaze $ do
            body $ do
              a ! A.href "/domain/list" $ "Back to domain list"
              h1 . toHtml . domainItemDomain . entityVal $ domain'
              if (domainItemActive  . entityVal $ domain') then do
                -- domain is active
                ul $ do
                  li $ pauseDomainBtn domainName
                  li $ deleteDomainBtn domainName
                else do
                -- domain is inactive
                ul $ do
                  li $ startDomainBtn domainName
                  li $ deleteDomainBtn domainName
        Nothing -> blaze $ h1 . toHtml $ domain_ ++ " not found"
    S.post "/domain/delete" $ do
      domain <- S.param "domain"
      _ <- liftIO . (runDb du dp)  . deleteBy $ UniqueName domain
      S.html $ T.pack $ "deleted " ++ domain
      S.redirect $ T.pack $ "/domain/list"
    S.get "/domain/add" $ do
      blaze $ do
        body $ do
          h1 "Add a domain"
          addDomainForm
    S.post "/domain/add" $ do
      now <- liftIO getCurrentTime
      domain <- S.param "domain"
      -- insert domain :domain :Active :created :lastChecked
      liftIO $ (runDb du dp) . insert $ DomainItem domain False now Nothing
      S.html $ T.pack $ "now watching " ++ domain
      S.redirect $ T.pack $ "/domain/" ++ domain ++ "/details"
    S.post "/domain/pause" $ do
      domain <- S.param "domain"
      liftIO $ runDb du dp $ updateWhere [DomainItemDomain ==. domain] [DomainItemActive =. False]
      S.html $ T.pack $ "paused " ++ domain
      S.redirect $ T.pack $ "/domain/" ++ domain ++ "/details"
    S.post "/domain/start" $ do
      domain <- S.param "domain"
      liftIO $ runDb du dp $ updateWhere [DomainItemDomain ==. domain] [DomainItemActive =. True]
      S.html $ T.pack $ "started " ++ domain
      S.redirect $ T.pack $ "/domain/" ++ domain ++ "/details"
    S.get "/settings" $ do
      settings <- runDb du dp $ selectFirst [SettingsUsername !=. ""] [] :: S.ActionM (Maybe (Entity Settings))
      case settings of
        Just settings' -> do
          let registrarEmail = settingsUsername . entityVal $ settings'
              registrarPass = settingsPassword . entityVal $ settings'
              paypalEmail = settingsPpUsername . entityVal $ settings'
              paypalPass = settingsPpPassword . entityVal $ settings'
          blaze $ do
            body $ do
              h1 "Expired Domain Bot Settings"
              updateSettingsForm registrarEmail registrarPass paypalEmail paypalPass checkerDelay
        Nothing -> do
          let registrarEmail = ""
              registrarPass = ""
              paypalEmail = ""
              paypalPass = ""

          blaze $ do
            body $ do
              h1 "Expired Domain Bot Settings"
              p " Initial setup, please enter your details"
              updateSettingsForm registrarEmail registrarPass paypalEmail paypalPass checkerDelay

    S.post "/settings/update" $ do
      u <- S.param "username"
      p <- S.param "password"
      pu <- S.param "paypalUsername"
      pp <- S.param "paypalPassword"
      checkerDelay <- S.param "checkerDelay"
      -- delete all entries since the valid settings are those we are getting
      runDb du dp $ deleteWhere ([] :: [Filter Settings])
      liftIO $ runDb du dp . insert $ Settings u p pu pp checkerDelay
      liftIO . print $ "redirecting to /domain/list"
      S.redirect "/domain/list"

addDomainForm = do form ! A.method "post" ! A.action "/domain/add" $ do
                     input ! A.name "domain"
                     input ! A.type_ "submit" ! A.value "Add Domain"

deleteDomainForm = do form ! A.method "post" ! A.action "/domain/delete" $ do
                        input ! A.name "domain"
                        input ! A.type_ "submit" ! A.value "Delete Domain"

-- updateSettingsForm :: String -> String -> String -> String -> Html
updateSettingsForm :: String -> String -> String -> String -> Int -> Html
updateSettingsForm user pass pe pp delay = do
  form ! A.method "post" ! A.action "/settings/update" $ do
    p $ do
      label "registrar email: "
      input ! A.name "username" ! A.value (toValue user)
    p $ do
      label "registrar password: "
      input ! A.name "password" ! A.type_ "password"  ! A.value (toValue pass)
    p $ do
      label "Paypal Username: "
      input ! A.name "paypalUsername" ! A.value (toValue pe)
    p $ do
      label "Paypal Password: "
      input ! A.name "paypalPassword" ! A.type_ "password" ! A.value (toValue pp)
    p $ do
      label "Checker Delay: "
      input ! A.name "checkerDelay" ! A.type_ "checkerDelay" ! A.value (toValue delay)
    p $ do
      input ! A.type_ "submit" ! A.value "Update Settings"


data DomainAction = Start | Pause | Delete
actionToStr Start = "start"
actionToStr Pause = "pause"
actionToStr Delete = "delete"
actionToStr _ = "invalid"

statusChangeBtn :: DomainAction -> String -> Html
statusChangeBtn a d = do form ! A.method "post" ! A.action (toValue $ "/domain/" ++ a') $ do
                           input ! A.name "domain" ! A.type_ "hidden" ! A.value (toValue d)
                           input ! A.type_ "submit" ! A.value (toValue $ a' ++ " Domain")
    where a' = actionToStr a :: String

pauseDomainBtn domain = statusChangeBtn Pause domain
startDomainBtn domain = statusChangeBtn Start domain
deleteDomainBtn domain = statusChangeBtn Delete domain
\$\endgroup\$
1
  • \$\begingroup\$ It has been almost four years. Do you want to review your own code by now? \$\endgroup\$
    – Zeta
    Mar 30, 2018 at 14:47

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.