{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Main where

import AutoTypes qualified as U
import AutoTypes.Unify qualified as U
import Control.Applicative ((<**>))
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (throwIO)
import Control.Monad
import Control.Monad.Catch (Exception)
import Control.Monad.Trans (liftIO)
import Data.Aeson qualified as J
import Data.Aeson.KeyMap qualified as JM
import Data.ByteString.Lazy.UTF8 qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.Function (on, (&))
import Data.List (find)
import Data.Map qualified as M
import Data.Map.Merge.Strict qualified as M
import Data.Maybe
import Data.String (IsString (fromString))
import Data.Tagged (Tagged (..), untag)
import Data.Text qualified as T
import Data.UUID qualified as U
import Data.UUID.V4 qualified as U
import Git qualified as G
import Git.Libgit2 qualified as GB
import Network.HTTP.Types.Status qualified as W
import Network.Wai qualified as W
import Network.Wai.Handler.Warp qualified as W
import Options.Applicative qualified as A
import Safe
import Store qualified as Q
import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory)
import System.Environment
import System.Exit
import System.FilePath
import System.INotify
import System.IO qualified as IO
import System.Random
import Text.Printf (printf)
import Version

getUUID :: IO U.UUID
getUUID = maybe U.nextRandom (const randomIO) =<< lookupEnv "UUID_SEED"

data Args = Args
  { cmd :: Cmd
  }

args :: A.Parser Args
args = Args <$> cmd'

data Cmd = Serve
  { serverPort :: Int,
    contentRepositoryPath :: FilePath
  }

cmd' :: A.Parser Cmd
cmd' =
  A.hsubparser . mconcat $
    [ A.command "serve" . A.info serveCmd $
        A.progDesc "Run webserver"
    ]

serveCmd :: A.Parser Cmd
serveCmd = do
  serverPort <- A.option A.auto (A.metavar "PORT" <> A.showDefault <> A.value 8081 <> A.long "port" <> A.short 'p' <> A.help "The server port")
  contentRepositoryPath <- A.strArgument (A.metavar "PATH" <> A.help "Path to the content repository")
  pure Serve {..}

data Repo = Repo
  { commits :: [Commit]
  }
  deriving (Show)

data Commit = Commit
  { id :: G.CommitOid GB.LgRepo,
    collections :: [Collection],
    schemaVersion :: Version
  }
  deriving (Show)

sameCommit :: Commit -> Commit -> Bool
sameCommit = (==) `on` (G.renderOid . untag . (.id))

data Collection = Collection
  { path :: FilePath,
    files :: [FilePath],
    schema :: U.T
  }
  deriving (Show)

data Schema = Schema {unSchema :: J.Value}
  deriving (Show)

instance J.ToJSON Schema where
  toJSON = J.toJSON . (.unSchema)

fromAutoTypes :: String -> U.T -> Schema
fromAutoTypes path (U.Object ps) =
  Schema $
    J.object
      [ ("$schema", J.toJSON @String "https://json-schema.org/draft/2020-12/schema"),
        ("$id", J.toJSON @String (path <> ".schema.json")),
        ("title", J.toJSON @String path),
        ("type", J.toJSON @String "object"),
        ("properties", J.toJSON ps),
        ("required", J.toJSON (M.keys (M.filter isRequired ps)))
      ]
  where
    isRequired (U.Option _) = False
    isRequired _ = True
fromAutoTypes _ _ = error "Only JSON objects are supported."

watch :: TMVar Repo -> FilePath -> G.RefName -> IO ()
watch repoT root ref = do
  i <- initINotify
  qT <- newTQueueIO
  _ <-
    addWatch i [Create, MoveIn] ".git/refs/heads" $ \e -> do
      when (e.filePath == B.fromString (takeBaseName (T.unpack ref))) do
        atomically (writeTQueue qT e)
  forever do
    repo <- initRepo root ref
    atomically do putTMVar repoT repo
    _ <- atomically do
      let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT
      readTQueue qT >> loop
    _ <- atomically do takeTMVar repoT
    pure ()

initRepo :: FilePath -> G.RefName -> IO Repo
initRepo root ref = do
  repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root}
  G.runRepository GB.lgFactory repo do
    Just cid <- fmap Tagged <$> G.resolveReference ref
    cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid
    fmap (Repo . reverse) $
      foldM
        ( \cs c -> do
            let cid = G.commitOid c
            fs <- liftIO $ Q.withStore root ref do
              Q.withCommit cid (Q.listFiles "/")
            let cls =
                  M.toList . M.unionsWith (++) $
                    map (\f -> M.singleton (takeDirectory f) [f]) fs
            colls <- forM cls $ \(path, files) -> do
              (value : values) <- do
                liftIO . Q.withStore root ref . Q.withCommit cid $ do
                  Q.query (fromString ("SELECT " <> path <> " FROM " <> path))
              let schema = U.autoTypes' value values
              pure $ Collection path files schema
            let schemaVersion =
                  case headMay cs of
                    Nothing -> Version 1 0 0
                    Just c' ->
                      let Version major' minor' patch' = c'.schemaVersion
                          schemas' =
                            M.fromList
                              ( (\coll -> (coll.path, coll.schema))
                                  <$> c'.collections
                              )
                          schemas =
                            M.fromList
                              ( (\coll -> (coll.path, coll.schema))
                                  <$> c.collections
                              )
                       in case compareSchemas schemas' schemas of
                            Just Major -> Version (major' + 1) 0 0
                            Just Minor -> Version major' (minor' + 1) 0
                            Just Patch -> Version major' minor' (patch' + 1)
                            Nothing -> Version major' minor' patch'
                c = Commit cid colls schemaVersion
            pure (c : cs)
        )
        []
        cs

compareSchemas ::
  M.Map String U.T ->
  M.Map String U.T ->
  Maybe SchemaDifference
compareSchemas schemas' schemas =
  maximumMay
    . catMaybes
    . M.elems
    . M.map (uncurry compareSchemas')
    $ M.merge
      (M.mapMissing (\_ schema' -> (Just schema', Nothing)))
      (M.mapMissing (\_ schema -> (Nothing, Just schema)))
      (M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema)))
      schemas'
      schemas
  where
    compareSchemas' Nothing Nothing = Nothing
    compareSchemas' Nothing (Just _) = Just Minor
    compareSchemas' (Just _) Nothing = Just Major
    compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema

compareSchema :: U.T -> U.T -> Maybe SchemaDifference
compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts
compareSchema t' t
  | t' == t = Nothing
  | t' `elem` (U.unify1 t' t) = Just Patch
  | t `elem` U.unify1 t' t = Just Minor
  | otherwise = Just Major

data SchemaDifference
  = Major
  | Minor
  | Patch
  deriving (Show, Eq, Ord)

logStderr :: String -> IO ()
logStderr = IO.hPutStrLn IO.stderr

main :: IO ()
main = do
  uuidSeed <- lookupEnv "UUID_SEED"
  maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed

  A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
    Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do
      contentRepositoryPath' <- makeAbsolute contentRepositoryPath
      contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' </> ".git")

      unless contentRepositoryPathExists $ do
        logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository."
        exitFailure

      setCurrentDirectory contentRepositoryPath'
      let root = "."
          ref = "refs/heads/master"
      repoT <- newEmptyTMVarIO
      _ <- forkIO do watch repoT root ref

      logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")

      stopM <- newEmptyMVar
      mapM_
        ( \hostPref -> flip forkFinally (either throwIO (putMVar stopM)) do
            W.runSettings
              ( W.defaultSettings
                  & W.setPort serverPort
                  & W.setHost hostPref
              )
              . restApi root ref repoT
              . queryApi root ref repoT
              $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found"))
        )
        ["!4", "::1"] -- XXX note !6 does not work..
      takeMVar stopM

data InvalidSchemaVersion = InvalidSchemaVersion String
  deriving (Show)

instance Exception InvalidSchemaVersion

queryApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware
queryApi root ref repoT app req resp = do
  schemaVersion <-
    case find ((== "schemaVersion") . fst) (W.queryString req) of
      Nothing -> pure Nothing
      Just (_, Nothing) -> throwIO (InvalidSchemaVersion "")
      Just (_, Just (B.toString -> v)) ->
        case versionFromString v of
          Just v -> pure (Just v)
          Nothing -> throwIO (InvalidSchemaVersion v)
  repo <- atomically (readTMVar repoT)
  let lastCompatibleCommit = lastCompatible schemaVersion repo.commits
      lastCommit = last repo.commits
  case W.pathInfo req of
    ["api", "query"] ->
      case W.requestMethod req of
        "POST" -> do
          when (not (sameCommit lastCompatibleCommit lastCommit)) $
            error "not implemented"
          q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req
          resp . W.responseLBS W.status200 [] . J.encode
            =<< Q.withStore root ref do Q.query q
    _ -> app req resp

restApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware
restApi root ref repoT app req resp = do
  schemaVersion <-
    case find ((== "schemaVersion") . fst) (W.queryString req) of
      Nothing -> pure Nothing
      Just (_, Nothing) -> throwIO (InvalidSchemaVersion "")
      Just (_, Just (B.toString -> v)) ->
        case versionFromString v of
          Just v -> pure (Just v)
          Nothing -> throwIO (InvalidSchemaVersion v)
  repo <- atomically (readTMVar repoT)
  let lastCompatibleCommit = lastCompatible schemaVersion repo.commits
      rev = lastCompatibleCommit.id
      lastCommit = last repo.commits
  case W.pathInfo req of
    ("api" : "rest" : rs) ->
      case (W.requestMethod req, rs) of
        ("GET", ["schemaVersion"]) -> do
          resp . W.responseLBS W.status200 [] $
            J.encode lastCompatibleCommit.schemaVersion
        ("GET", ["collection"]) -> do
          resp . W.responseLBS W.status200 [] $
            J.encode (map (.path) lastCompatibleCommit.collections)
        ("GET", ["collection", T.unpack -> c, "schema"]) -> do
          let [collection] = filter ((== c) . (.path)) lastCompatibleCommit.collections
          resp . W.responseLBS W.status200 [] $
            J.encode (fromAutoTypes c collection.schema)
        ("POST", ["collection"]) -> do
          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
          Right collection <- J.eitherDecode <$> W.lazyRequestBody req
          Q.withStore root ref do
            Q.writeFile (collection </> ".gitkeep") ""
            Q.commit
          resp $ W.responseLBS W.status200 [] "{}"
        ("GET", ["collection", c]) -> do
          resp . W.responseLBS W.status200 [] . J.encode
            =<< ( Q.withStore root ref $ Q.withCommit rev do
                    Q.query (fromString (printf "SELECT %s FROM %s" c c))
                )
        ("GET", ["collection", c, i]) -> do
          resp . W.responseLBS W.status200 [] . J.encode
            =<< ( Q.withStore root ref $ Q.withCommit rev do
                    Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                )
        ("PUT", ["collection", c, i]) -> do
          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
          o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
          resp . W.responseLBS W.status200 [] . J.encode
            =<< ( Q.withStore root ref do
                    Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i))
                )
        ("POST", ["collection", c]) -> do
          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
          i <- ((<> ".json") . U.toText) <$> getUUID
          o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
          resp . W.responseLBS W.status200 [] . J.encode
            =<< ( Q.withStore root ref do
                    _ <- Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c))
                    headMay <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                )
        ("DELETE", ["collection", c, i]) -> do
          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
          resp . W.responseLBS W.status200 [] . J.encode
            =<< ( Q.withStore root ref do
                    Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
                )
        (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported."
    _ -> app req resp

lastCompatible :: Maybe Version -> [Commit] -> Commit
lastCompatible Nothing commits = last commits
lastCompatible (Just v) commits
  | isCompatible v (last commits) = last commits
  | otherwise = lastCompatible (Just v) (init commits)

isCompatible :: Version -> Commit -> Bool
isCompatible v c = c.schemaVersion <= v