{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

module Main where

import qualified Control.Foldl             as Fold
import qualified Data.Attoparsec.Text      as PT
import qualified Data.Text                 as T
import qualified Data.Text.IO              as TIO

import           Protolude          hiding ((%), FilePath, (<>), fold)
import           Turtle

import           Data.String               (String)
import           Data.Char                 (isSpace)
import           Data.Foldable             (maximumBy)
import           Data.Function             (on)
import           Data.Time                 (TimeOfDay (..), UTCTime (..),
                                            addUTCTime, defaultTimeLocale,
                                            diffUTCTime, getCurrentTime,
                                            parseTimeM, timeToTimeOfDay)

type ParsedBackups = Either String [BackupList]

data Options = Options { dest :: FilePath
                       , src  :: FilePath
                       , name :: Text
                       } deriving Show

data BackupList = BackupList { backupTag  :: Text
                             , backupTime :: UTCTime
                             } deriving (Show, Eq)

backupListParser :: PT.Parser BackupList
backupListParser = do
  name' <- PT.takeTill isSpace
  _ <- PT.skipSpace
  _weekDay <- PT.skipWhile (not . isSpace)
  dateStr <- PT.takeTill PT.isEndOfLine

  -- "Oct  5 12:23:45 2015"
  date' <- case parseTimeM True defaultTimeLocale "%b %e %X %Y" (T.unpack dateStr) of
    Just pd -> return pd
    Nothing -> error $ "Invalid date: " <> dateStr

  return BackupList { backupTag = name'
                    , backupTime = date'
                    }

getAtticRepo :: Options -> FilePath
getAtticRepo opts = dest opts </> fromText (name opts <> ".attic")

optionsParser :: Parser Options
optionsParser = Options <$> optPath "dest" 'd' "Destination (has to equal mount point in my case)"
                        <*> optPath "src" 's' "Source directory"
                        <*> optText "name" 'n' "Base identifier name"

getYesterday :: IO UTCTime
getYesterday = do
  let minimumDiff = -1 * 24 * 60 * 60 :: NominalDiffTime
  addUTCTime minimumDiff <$> getCurrentTime

-- | Based on the list of backups, decide whether or not to schedule a backup.
--
-- Don't barf on empty results.
-- >>> shouldBackup $ Right []
-- True
shouldBackup :: ParsedBackups -> IO Bool
shouldBackup backupList = do
  yesterday <- getYesterday
  let lastBackup = findLastBackup <$> backupList
  return $ all (maybe True $ backupOlderThan yesterday) lastBackup

doBackup :: FilePath -> FilePath -> Shell ExitCode
doBackup src' repo = do
  now <- liftIO getCurrentTime

  let dayStr :: Text
      dayStr = show . utctDay $ now
      hourStr :: Text
      hourStr = show . todHour . timeToTimeOfDay . utctDayTime $ now
      target :: Text
      target = format (fp%"::"%s%":"%s) repo dayStr hourStr

  echo $ "Creating new backup with target " <> target
  proc "attic" ["create", target, format fp src', "--stats"] empty

backupOlderThan :: UTCTime -> BackupList -> Bool
backupOlderThan time' backup = diffUTCTime time' (backupTime backup) > 0

mount :: FilePath -> IO ExitCode
mount path = proc "sudo" ["mount", format fp path] empty

obtainBackupList :: FilePath -> IO (Either String [BackupList])
obtainBackupList repo = do
  output' <- fold (inproc "attic" ["list", format fp repo] empty) Fold.list
  return $ sequence $ PT.parseOnly backupListParser <$> output'

-- | O(n) finds the last backup
-- >>> findLastBackup []
-- Nothing
findLastBackup :: [BackupList] -> Maybe BackupList
findLastBackup [] = Nothing
findLastBackup l  = pure . maximumBy (compare `on` backupTime) $ l

-- | Not really reliable way to check if something is possibly mounted.
--   If the given path is a sub-path of a mounted item, it will return a
--   false positive.
isPathMounted :: FilePath -> IO Bool
isPathMounted path = do
  mounts <- TIO.readFile "/proc/mounts"
  return $ format fp path `T.isInfixOf` mounts

main :: IO ()
main = do
  opts <- options "Attic Schedule" optionsParser
  let repo = getAtticRepo opts

  unlessM (isPathMounted $ dest opts) $ do
    echo $ format ("Doesn't seem like "%s%" is mounted. Let me do that for you …") (show $ dest opts)
    mount (dest opts) >>= \case
      ExitSuccess -> return ()
      ExitFailure _ -> error $ "Failed to mount " <> show (dest opts)

  backupList <- obtainBackupList repo
  shouldBackup' <- shouldBackup backupList

  if shouldBackup' then do
    echo "Last backup is older than 24h, let's do it!"
    view $ doBackup (src opts) repo
  else
    echo "Old backup isn't even a day old. I'll skip it for now."