{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- |
-- Copyright: Herbert Valerio Riedel
-- SPDX-License-Identifier: GPL-3.0-or-later
--
module Main (main) where

import           Utils

import qualified Data.List           as List
import qualified Data.Map.Strict     as Map
import qualified Data.Set            as Set
import qualified Data.Text           as T
import qualified Data.Text.IO        as T
import qualified Data.Version        as V
import           Options.Applicative as OA
import qualified Paths_hackage_index

import           CacheDb
import           HIX

----------------------------------------------------------------------------
-- CLI Interface

data Options = Options
    { optVerbose :: !Bool
    , optNoSync  :: !Bool
    , optCommand :: !Command
    } deriving Show

data LogOptions = LogOptions
    { logOptLimit      :: !Int
    , logOptReverse    :: !Bool
    , logOptNoMetaRevs :: !Bool
    , logOptNoTarRevs  :: !Bool
    , logOptUsers      :: [Text]
    , logOptPkgN       :: [Text]
    , logOptRange      :: TsRange
    } deriving Show

data Sha256SumOptions = Sha256SumOptions
    { optFlatStyle :: Bool
    , optBaseDir   :: Maybe FilePath
    } deriving Show

data Command
    = Sha256Sum   !Sha256SumOptions
    | Sync
    | Log !LogOptions
    | TsParse !TsRef
    | TsList !TsRange
    | ProvidesMod !Bool !Text
    | ProvidesTool !Bool !Text
    deriving Show

optionsParserInfo :: OA.ParserInfo Options
optionsParserInfo
    = info (helper <*> verOption <*> oParser)
           (fullDesc
            <> header "hit - Hackage index tool"
            <> footer "\
              \ Each command has a sub-`--help` text. \
              \ This tool reads the `~/.cabal/config` configuration file and honors the `CABAL_CONFIG` environemnt variable. \
              \ TSREF := [ '@' | ISOTS ], TSRANGE := TSREF [ '..' [ TSREF ] ]. ISOTS := e.g. '2014-11-22T12:39:07Z'. \
              \")

  where
    indexssParser = Sha256Sum <$> (Sha256SumOptions <$> switch (long "flat" <> help "flat filesystem layout (used by mirrors)")
                                                        <*> optional (OA.argument str (metavar "BASEDIR")))


    logCmdParser = Log <$> (
      LogOptions <$> OA.option auto ( OA.short 'n' <> OA.long "max-count" <> OA.value (-1) <> OA.metavar "NUM" <>
                                      OA.help "Limit the number of index entries printed")
                 <*> switch (long "reverse" <> OA.help "Output older index entries first")
                 <*> switch (long "no-revisions" <> OA.help "No metadata-only revisions")
                 <*> switch (long "no-uploads" <> OA.help "No source-dist uploads")
                 <*> many (OA.strOption ( OA.long "user" <> OA.help "Filter on user name; use multiple times for disjunction"))
                 <*> many (OA.strOption ( OA.long "package" <> OA.help "Filter on package name; use multiple times for disjunction"))
                 <*> OA.argument readm (metavar "TSRANGE" <> value (TsRange TsRef0 (TsRefLatest 0)))
      )

    oParser = Options <$> switch (long "verbose" <> help "enable verbose output")
                      <*> switch (long "no-sync" <> help "suppress automatic cache syncing against 01-index.tar")
                      <*> subparser (mconcat [ command "sha256sum" (info (helper <*> indexssParser)
                                                                    (progDesc "generate sha256sum-format file"))

                                             , command "sync" (info (helper <*> pure Sync)
                                                               (progDesc "sync index cache"))

                                             , command "log" (info (helper <*> logCmdParser)
                                                              (progDesc "show package index changelog"))
                                             , command "ts-parse" (info (helper <*> (TsParse <$> OA.argument readm (metavar "TSREF")))
                                                              (progDesc "resolve reference to timestamp suitable as --index-state argument"))
                                             , command "ts-list" (info (helper <*> (TsList <$> OA.argument readm (metavar "TSRANGE")))
                                                              (progDesc "resolve reference to timestamp suitable as --index-state argument"))
                                             , command "provides-module" (info (helper <*> (ProvidesMod
                                                                                            <$> switch (long "explicit" <> help "use explicit style")
                                                                                            <*> OA.argument str (metavar "MODULE-NAME")))
                                                              (progDesc "list packages potentially exposing/reexporting a given module"))
                                             , command "provides-tool" (info (helper <*> (ProvidesTool
                                                                                            <$> switch (long "explicit" <> help "use explicit style")
                                                                                            <*> OA.argument str (metavar "TOOL-NAME")))
                                                              (progDesc "list packages potentially providing a given tool/executable component"))
                                             ])

    verOption = infoOption verMsg (long "version" <> help "output version information and exit")
      where
        verMsg = "hit " <> V.showVersion Paths_hackage_index.version

----------------------------------------------------------------------------

main :: IO ()
main = do
    opts <- execParser optionsParserInfo
    mainWithOptions opts

mainWithOptions :: Options -> IO ()
mainWithOptions Options {..} = do
     case optCommand of
       Sha256Sum opts   -> doSha256Sum opts
       Sync             -> doSync
       Log opts         -> doLog opts
       TsParse tsref    -> doTsParse tsref
       TsList tsref     -> doTsList tsref
       ProvidesMod x m  -> doProvidesMod x m
       ProvidesTool x m -> doProvidesTool x m
     return ()
  where
    doSync :: IO ()
    doSync = withCacheDb optNoSync (pure ())

    doSha256Sum Sha256SumOptions{..} = withCacheDb optNoSync $ do
      rows <- dbQuery_ "SELECT pname,ver,hex(tarsha) FROM pkgids_str NATURAL JOIN tars WHERE srev=0 ORDER BY pname,ver"
      forM_ rows $ \(pn,pv,sha) -> do
        liftIO $ T.putStrLn $ if optFlatStyle
                              then mconcat [ sha, "  ", maybe "" T.pack optBaseDir, pn, "-", pv, ".tar.gz" ]
                              else mconcat [ sha, "  ", maybe "" T.pack optBaseDir, pn, "/", pv, "/", pn, "-", pv, ".tar.gz" ]
      pure ()

    ----------------------------------------------------------------------------

    doLog :: LogOptions -> IO ()
    doLog LogOptions{..} = withCacheDb optNoSync $ do
      let TsRange tref1 tref2 = logOptRange

      t1 <- resolveTsRef tref1
      t2 <- resolveTsRef tref2

      -- --user
      dbExecute_ "DROP TABLE IF EXISTS tmp_t1"
      dbExecute_  "CREATE TEMPORARY TABLE tmp_t1 (uname_id INTEGER NOT NULL)"
      forM_ logOptUsers $ \x -> do
        res <- dbQuery "SELECT uname_id FROM unames WHERE uname = ?" (Only x)
        case res of
          []  -> fail ("user " ++ show x ++ " not found")
          [y] -> dbExecute "INSERT INTO tmp_t1(uname_id) VALUES(?)" (y :: Only Int)
          (_:_:_) -> fail "impossible"

      -- --package
      dbExecute_ "DROP TABLE IF EXISTS tmp_t2"
      dbExecute_  "CREATE TEMPORARY TABLE tmp_t2 (pname_id INTEGER NOT NULL)"
      forM_ logOptPkgN $ \x -> do
        res <- dbQuery "SELECT pname_id FROM pnames WHERE pname = ?" (Only x)
        case res of
          []  -> fail ("user " ++ show x ++ " not found")
          [y] -> dbExecute "INSERT INTO tmp_t2(pname_id) VALUES(?)" (y :: Only Int)
          (_:_:_) -> fail "impossible"

      -- constructing this query would benefit from having a SQL EDSL...
      rows <- dbQuery (mconcat
              [ "SELECT ts,pname,ver,rev,uname \
                \  FROM revisions r, pkgids_str s, unames u, pkgids p \
                \  WHERE r.pkgid = s.pkgid AND r.uname_id = u.uname_id AND r.pkgid = p.pkgid \
                \        AND r.ts BETWEEN ? AND ? \
                \        AND (CASE (select count(*) from tmp_t1) WHEN 0 THEN 1 ELSE r.uname_id in (select uname_id from tmp_t1) END) \
                \        AND (CASE (select count(*) from tmp_t2) WHEN 0 THEN 1 ELSE p.pname_id in (select pname_id from tmp_t2) END)"
              , if logOptNoMetaRevs then " AND r.rev = 0 " else ""
              , if logOptNoTarRevs  then " AND r.rev > 0 " else ""
              , "  ORDER BY r.ts"
              , if logOptReverse then " ASC " else " DESC "
              , " LIMIT ?"
              ]) (t1, t2, (if logOptLimit > 0 then logOptLimit else 0xffffffff {- ugly hack -}))

      rows2 <- dbQuery (mconcat
               [ "SELECT ts,pname FROM prefs pr JOIN pnames pn USING (pname_id) WHERE "
               , " ts BETWEEN ? AND ? "
               , " AND (CASE (select count(*) from tmp_t2) WHEN 0 THEN 1 ELSE pr.pname_id in (select pname_id from tmp_t2) END)"
               , "  ORDER BY ts"
               , if logOptReverse then " ASC " else " DESC "
               , " LIMIT ?"
               ]) (t1, t2, (if logOptLimit > 0 then logOptLimit else 0xffffffff {- ugly hack -}))

      -- mergesort
      let go [] [] = []
          go [] rs2 = map Right rs2
          go rs1 [] = map Left rs1
          go rs1@(r1@(ts1,_,_,_,_):rows1') rs2@(r2@(ts2,_):rows2')
            | if logOptReverse then ts1 > ts2 else ts1 < ts2
            = Right r2 : go rs1 rows2'
            | otherwise
            = Left r1 : go rows1' rs2

      liftIO $ forM_ ((if logOptLimit > 0 then take logOptLimit else id) (go rows rows2)) $ \x -> do
        case x of
          Left (ts,pn,pv,prev,uname) -> T.putStrLn (T.pack $ mconcat [ fmtPkgIdxTs ts, "\t", uname , "\t", fmtPkgId pn pv prev ])
          Right (ts,pn)              -> T.putStrLn (T.pack $ mconcat [ fmtPkgIdxTs ts, "\t-\t", pn ])

      pure ()

    ----------------------------------------------------------------------------

    doTsParse :: TsRef -> IO ()
    doTsParse tsref = withCacheDb optNoSync $ do
      resolveTsRef tsref >>= \case
        Nothing -> liftIO exitFailure
        Just t' -> liftIO (putStrLn (fmtPkgIdxTs t'))

    ----------------------------------------------------------------------------

    doTsList :: TsRange -> IO ()
    doTsList (TsRange tref1 tref2) = withCacheDb optNoSync $ do
      t1 <- resolveTsRef tref1
      t2 <- resolveTsRef tref2

      tslst <- fmap (\(Only x) -> x) <$> dbQuery "SELECT ts FROM revisions WHERE ts BETWEEN ? AND ? UNION SELECT ts FROM prefs WHERE ts BETWEEN ? AND ? ORDER BY ts DESC" (t1, t2, t1, t2)
      liftIO $ forM_ tslst (T.putStrLn . T.pack . fmtPkgIdxTs)

    ----------------------------------------------------------------------------

    doProvidesMod = doProvides True
    doProvidesTool = doProvides False

    doProvides :: Bool -> Bool -> Text -> IO ()
    doProvides isMod explicit m = withCacheDb optNoSync $ do
      rows <- dbQuery (if isMod then
                      "SELECT s.pname,s.ver \
                      \  FROM pkgids_mnames pm, mnames m, pkgids_str s \
                      \  WHERE mname = ? AND m.mname_id = pm.mname_id AND s.pkgid = pm.pkgid"
                      else
                      "SELECT s.pname,s.ver \
                      \  FROM pkgids_tools pm, tools m, pkgids_str s \
                      \  WHERE tool = ? AND m.tool_id = pm.tool_id AND s.pkgid = pm.pkgid"
                      ) (Only m)

      let p2vs = Map.fromListWith mappend [ (k, Set.singleton (v :: V)) | (k,v) <- rows ]

      tmp <- forM (Map.keys p2vs) $ \pn -> do
        vs <- map (\(Only x) -> (x::V)) <$> dbQuery "SELECT ver FROM pnames n, pkgids pi, vers v \
                                                     \WHERE pname = ? AND n.pname_id = pi.pname_id AND pi.ver_id = v.ver_id \
                                                     \" (Only pn)
        pure (pn,Set.fromList vs)

      let p2vsAll = Map.fromList tmp

      liftIO $ forM_ (Map.toList p2vs) $ \(pname, pvers) -> do
        let pvers0 = Map.findWithDefault undefined pname p2vsAll
            npvers = (pvers0 Set.\\ pvers)
            allvers = Set.map (\x -> (x,True)) pvers <> Set.map (\x -> (x,False)) npvers
            gvers = List.groupBy (\x y -> snd x == snd y) $ Set.toList allvers

        if explicit then do
          forM_ gvers $ \vs@((_,isIn):_) -> do
            T.putStrLn (pname <> (if isIn then " == { " else " /= { ") <> T.intercalate ", " (map tdisp (map fst vs)) <> " }")
        else do
            T.putStrLn (pname <> "  " <> T.intercalate " || "
                        [ case mub of { Nothing -> "^>= " <> tdisp lb; Just ub -> "(^>= " <> tdisp lb <> " && < " <> tdisp (vstrip0s ub) <> ")" }
                        | (lb,mub) <- groupCaret allvers ])


        putStrLn ""

    ----------------------------------------------------------------------------

-- | Resolve a TSREF to a index-state value
resolveTsRef :: TsRef -> HIX (Maybe PkgIdxTs)
resolveTsRef (TsRefLatest _) = do
  (mts1,mts2) <- dbQuery1_ "SELECT (SELECT max(ts) FROM revisions), (SELECT max(ts) FROM prefs)"
  case onMaybes max mts1 mts2 of
    Nothing -> pure Nothing
    Just t' -> pure (Just t')
resolveTsRef TsRef0 = do
  (mts1,mts2) <- dbQuery1_ "SELECT (SELECT min(ts) FROM revisions), (SELECT min(ts) FROM prefs)"
  case onMaybes min mts1 mts2 of
    Nothing -> pure Nothing
    Just t' -> pure (Just t')
resolveTsRef (TsRefTs t0 _) = do
  (mts1,mts2) <- dbQuery1 "SELECT (SELECT max(ts) FROM revisions WHERE ts <= ?), (SELECT max(ts) FROM prefs WHERE ts <= ?)" (t0, t0)
  pure $ onMaybes max mts1 mts2