{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Utils
  ( Boundary (..),
    Options (..),
    ProductID,
    URL,
    UpdateEnv (..),
    Version,
    VersionMatcher (..),
    branchName,
    branchPrefix,
    getGithubToken,
    getGithubUser,
    logDir,
    nixBuildOptions,
    nixCommonOptions,
    overwriteErrorT,
    parseUpdates,
    prTitle,
    runLog,
    srcOrMain,
    stripQuotes,
    tRead,
    whenBatch,
  )
where

import Data.Bits ((.|.))
import Data.Maybe (fromJust)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField
  ( FieldParser,
    FromField,
    fromField,
    returnError,
  )
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (..))
import Database.SQLite.Simple.ToField (ToField, toField)
import qualified GitHub as GH
import OurPrelude
import Polysemy.Output
import System.Directory (doesDirectoryExist)
import System.Posix.Directory (createDirectory)
import System.Posix.Env (getEnv)
import System.Posix.Files
  ( directoryMode,
    fileExist,
    groupModes,
    otherExecuteMode,
    otherReadMode,
    ownerModes,
  )
import System.Posix.Temp (mkdtemp)
import System.Posix.Types (FileMode)
import Text.Read (readEither)
import Type.Reflection (Typeable)

default (T.Text)

type ProductID = Text

type Version = Text

type URL = Text

-- | The Ord instance is used to sort lists of matchers in order to compare them
-- as a set, it is not useful for comparing bounds since the ordering of bounds
-- depends on whether it is a start or end bound.
data Boundary a
  = Unbounded
  | Including a
  | Excluding a
  deriving (Eq, Ord, Show, Read)

-- | The Ord instance is used to sort lists of matchers in order to compare them
-- as a set, it is not useful for comparing versions.
data VersionMatcher
  = SingleMatcher Version
  | RangeMatcher (Boundary Version) (Boundary Version)
  deriving (Eq, Ord, Show, Read)

readField :: (Read a, Typeable a) => FieldParser a
readField f@(Field (SQLText t) _) =
  case readEither (T.unpack t) of
    Right x -> Ok x
    Left e -> returnError ConversionFailed f $ "read error: " <> e
readField f = returnError ConversionFailed f "expecting SQLText column type"

showField :: Show a => a -> SQLData
showField = toField . show

instance FromField VersionMatcher where
  fromField = readField

instance ToField VersionMatcher where
  toField = showField

data Options = Options
  { doPR :: Bool,
    batchUpdate :: Bool,
    githubUser :: GH.Name GH.Owner,
    githubToken :: Text,
    makeCVEReport :: Bool,
    runNixpkgsReview :: Bool,
    calculateOutpaths :: Bool
  }
  deriving (Show)

data UpdateEnv = UpdateEnv
  { packageName :: Text,
    oldVersion :: Version,
    newVersion :: Version,
    sourceURL :: Maybe URL,
    options :: Options
  }

whenBatch :: Applicative f => UpdateEnv -> f () -> f ()
whenBatch updateEnv = when (batchUpdate . options $ updateEnv)

prTitle :: UpdateEnv -> Text -> Text
prTitle updateEnv attrPath =
  let oV = oldVersion updateEnv
      nV = newVersion updateEnv
   in T.strip [interpolate| $attrPath: $oV -> $nV |]

regDirMode :: FileMode
regDirMode =
  directoryMode .|. ownerModes .|. groupModes .|. otherReadMode
    .|. otherExecuteMode

logsDirectory :: MonadIO m => ExceptT Text m FilePath
logsDirectory = do
  dir <-
    noteT "Could not get environment variable LOGS_DIRECTORY" $
      MaybeT $
        liftIO $
          getEnv "LOGS_DIRECTORY"
  dirExists <- liftIO $ doesDirectoryExist dir
  tryAssert ("LOGS_DIRECTORY " <> T.pack dir <> " does not exist.") dirExists
  unless
    dirExists
    ( liftIO $
        putStrLn "creating xdgRuntimeDir" >> createDirectory dir regDirMode
    )
  return dir

xdgRuntimeDir :: MonadIO m => ExceptT Text m FilePath
xdgRuntimeDir = do
  xDir <-
    noteT "Could not get environment variable XDG_RUNTIME_DIR" $
      MaybeT $
        liftIO $
          getEnv "XDG_RUNTIME_DIR"
  xDirExists <- liftIO $ doesDirectoryExist xDir
  tryAssert ("XDG_RUNTIME_DIR " <> T.pack xDir <> " does not exist.") xDirExists
  let dir = xDir <> "/nixpkgs-update"
  dirExists <- liftIO $ fileExist dir
  unless
    dirExists
    ( liftIO $
        putStrLn "creating xdgRuntimeDir" >> createDirectory dir regDirMode
    )
  return dir

tmpRuntimeDir :: MonadIO m => ExceptT Text m FilePath
tmpRuntimeDir = do
  dir <- liftIO $ mkdtemp "nixpkgs-update"
  dirExists <- liftIO $ doesDirectoryExist dir
  tryAssert
    ("Temporary directory " <> T.pack dir <> " does not exist.")
    dirExists
  return dir

logDir :: IO FilePath
logDir = do
  r <-
    runExceptT
      ( logsDirectory <|> xdgRuntimeDir <|> tmpRuntimeDir
          <|> throwE
            "Failed to create log directory."
      )
  case r of
    Right dir -> return dir
    Left e -> error $ T.unpack e

overwriteErrorT :: MonadIO m => Text -> ExceptT Text m a -> ExceptT Text m a
overwriteErrorT t = fmapLT (const t)

branchPrefix :: Text
branchPrefix = "auto-update/"

branchName :: UpdateEnv -> Text
branchName ue = branchPrefix <> packageName ue

parseUpdates :: Text -> [Either Text (Text, Version, Version, Maybe URL)]
parseUpdates = map (toTriple . T.words) . T.lines
  where
    toTriple :: [Text] -> Either Text (Text, Version, Version, Maybe URL)
    toTriple [package, oldVer, newVer] = Right (package, oldVer, newVer, Nothing)
    toTriple [package, oldVer, newVer, url] = Right (package, oldVer, newVer, Just url)
    toTriple line = Left $ "Unable to parse update: " <> T.unwords line

tRead :: Read a => Text -> a
tRead = read . T.unpack

srcOrMain :: MonadIO m => (Text -> ExceptT Text m a) -> Text -> ExceptT Text m a
srcOrMain et attrPath = et (attrPath <> ".src") <|> et attrPath

nixCommonOptions :: [String]
nixCommonOptions =
  [ "--arg",
    "config",
    "{ allowBroken = true; allowUnfree = true; allowAliases = false; }",
    "--arg",
    "overlays",
    "[ ]"
  ]

nixBuildOptions :: [String]
nixBuildOptions =
  [ "--option",
    "sandbox",
    "true",
    "--option",
    "restrict-eval",
    "true"
  ]
    <> nixCommonOptions

runLog ::
  Member (Embed IO) r =>
  (Text -> IO ()) ->
  Sem ((Output Text) ': r) a ->
  Sem r a
runLog logger =
  interpret \case
    Output o -> embed $ logger o

envToken :: IO (Maybe Text)
envToken = fmap tshow <$> getEnv "GITHUB_TOKEN"

localToken :: IO (Maybe Text)
localToken = do
  exists <- fileExist "github_token.txt"
  if exists
    then (Just . T.strip <$> T.readFile "github_token.txt")
    else (return Nothing)

hubFileLocation :: IO (Maybe FilePath)
hubFileLocation = do
  xloc <- fmap (<> "/hub") <$> getEnv "XDG_CONFIG_HOME"
  hloc <- fmap (<> "/.config/hub") <$> getEnv "HOME"
  return (xloc <|> hloc)

hubConfigField :: Text -> IO (Maybe Text)
hubConfigField field = do
  hubFile <- hubFileLocation
  case hubFile of
    Nothing -> return Nothing
    Just file -> do
      exists <- fileExist file
      if not exists
        then return Nothing
        else do
          contents <- T.readFile file
          let splits = T.splitOn field contents
              token = T.takeWhile (/= '\n') $ head (drop 1 splits)
          return $ Just token

getGithubToken :: IO Text
getGithubToken = do
  et <- envToken
  lt <- localToken
  ht <- hubConfigField "oauth_token: "
  return $ fromJust (et <|> lt <|> ht)

getGithubUser :: IO (GH.Name GH.Owner)
getGithubUser = do
  hubUser <- hubConfigField "user: "
  case hubUser of
    Just usr -> return $ GH.mkOwnerName usr
    Nothing -> return $ GH.mkOwnerName "r-ryantm"

stripQuotes :: Text -> Maybe Text
stripQuotes = T.stripPrefix "\"" >=> T.stripSuffix "\""