SideEffectsExample.hs

{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE OverloadedLabels #-}

module SideEffectsExample where

import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Lazy
import Data.Generics.Labels
import Data.Time.Clock
import GHC.Generics
import System.Directory
import Text.Printf

data Config = Config
  { database     :: String
  , user         :: String
  , pass         :: String
  , slackWebhook :: String
  , inFile       :: FilePath
  } deriving (Eq, Generic, Ord, Show)

data AppState = AppState
  { total      :: Int
  , done       :: Int
  , written    :: Int
  , started    :: UTCTime
  , lastLogged :: UTCTime
  } deriving (Eq, Generic, Ord, Show)

main :: IO ()
main = do
  config <- readConfig("conf.ini")
  db <- connectTo "mysql://" (config ^. #database) (config ^. #user) (config ^. #pass)
  slack <- newSlack $ config ^. #slackWebhook
  t <- getCurrentTime
  urls <- lines <$> readFile (config ^. #inFile)
  let initState = AppState
        { total      = length urls
        , done       = 0
        , written    = 0
        , started    = t
        , lastLogged = t
        }
  finalState <- flip execStateT initState $
    traverse (downloadNew $ config ^. #inFile) urls

  putStrLn "Finished"
  notify slack "#jobs" "Done processing" (config ^. #inFile)

downloadNew :: FilePath -> String -> StateT AppState IO ()
downloadNew inFile url = do
  #done += 1
  filePath <- getPathFor url
  status <- checkStatus filePath
  unless (status == Fresh) $ do
    html <- download url
    liftIO . writeFile filePath $ serialize (url, html)
    #written += 1

    ll <- use #lastLogged
    tsa <- tenSecondsAgo
    when (ll < tsa) $ do
      tm <- liftIO getCurrentTime
      #lastLogged .= tm
      d <- use #done
      t <- use #total
      w <- use #written
      let eta = computeEta tm d t
          msg = printf "Done %d / %d, written %d, ETA: %s" d t w eta
      liftIO $ putStrLn msg
      saveStatusFor inFile msg

checkStatus :: MonadIO m => FilePath -> m FileStatus
checkStatus path = liftIO $ do
  exists <- doesFileExist path
  if exists
    then do
      fresh <- isFresh path
      pure $ if fresh
        then Fresh
        else Stale
    else pure DoesNotExist

-- ================================================================ --

data FileStatus
  = DoesNotExist
  | Stale
  | Fresh
  deriving (Eq, Ord, Show)

isFresh :: MonadIO m => FilePath -> m Bool
isFresh = undefined

notify :: MonadIO m => Slack -> String -> String -> FilePath -> m ()
notify = undefined

saveStatusFor :: FilePath -> String -> StateT AppState IO ()
saveStatusFor = undefined

computeEta :: UTCTime -> Int -> Int -> String
computeEta = undefined

download :: MonadIO m => String -> m String
download = undefined

getPathFor :: MonadIO m => String -> m FilePath
getPathFor = undefined

tenSecondsAgo :: MonadIO m => m UTCTime
tenSecondsAgo = undefined

serialize :: (String, String) -> String
serialize = undefined

-- ================================================================ --

data Db    = Db
data Slack = Slack

newSlack :: String -> IO Slack
newSlack = undefined

connectTo :: String -> String -> String -> String -> IO Db
connectTo = undefined

readConfig :: FilePath -> IO Config
readConfig = undefined