acms/backend/app/Main.hs

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.Monad
import Control.Monad.Trans (liftIO)
import Data.Aeson qualified as J
import Data.Attoparsec.Char8 as P
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as LB
import Data.ByteString.Lazy.UTF8 qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.List
import Data.Map qualified as M
import Data.String (IsString (fromString))
import Data.Tagged (Tagged (..), untag)
import Debug.Trace
import Git qualified as G
import Git.Libgit2 qualified as GB
import Network.HTTP.Types.Method qualified as W
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 Store qualified as Q
import System.Directory (setCurrentDirectory)
import System.FilePath
import System.INotify
import Text.Printf (printf)

data Args = Args
  { cmd :: Cmd
  }

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

data Cmd = Serve

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

serveCmd :: A.Parser Cmd
serveCmd = pure Serve

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

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

data Collection = Collection
  { path :: FilePath,
    files :: [FilePath],
    schema :: Schema
  }
  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 (M.mapWithKey toProperty ps))
      ]
  where
    toProperty k (U.Scalar "string") = "string" :: String

watch :: TMVar Repo -> FilePath -> G.RefName -> IO ()
watch repoT root ref = do
  i <- initINotify
  qT <- newTQueueIO
  wd <-
    addWatch i [MoveIn] ".git/refs/heads" $ \e ->
      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
    c <- G.lookupCommit cid
    cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid
    fmap Repo . forM cs $ \c -> do
      let cid = G.commitOid c
      fs <-
        fmap (filter ((== ".json") . takeExtension)) . liftIO $
          Q.withStore root ref do
            Q.withCommit cid Q.listAllFiles
      let cls =
            M.toList . M.unionsWith (++) $
              map (\f -> M.singleton (takeDirectory f) [f]) fs
      colls <- forM cls $ \(makeRelative "/" -> path, (file : files)) -> do
        (value : values) <- do
          liftIO $ Q.withStore root ref do
            mapM (Q.withCommit cid . Q.readFile) (file : files)
        let schema = fromAutoTypes path $ U.autoTypes' value values
        pure $ Collection path files schema
      pure (Commit cid colls)

main :: IO ()
main = do
  setCurrentDirectory "../blog"
  let root = "."
      ref = "refs/heads/master"
  repoT <- newEmptyTMVarIO
  _ <- forkIO do watch repoT root ref
  A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
    Args {cmd = Serve} -> do
      W.runEnv 8081 $ \req respond -> do
        case P.parseOnly routeP (W.rawPathInfo req) of
          Right (SchemaJson path) -> do
            repo <- atomically (readTMVar repoT)
            let [c] = filter ((== path) . (.path)) (last repo.commits).collections
            respond $ W.responseLBS W.status200 [] (J.encode c.schema)
          Right Query -> do
            q <-
              fromString @Q.Query . LB.toString
                <$> W.lazyRequestBody req
            r <- liftIO $ Q.withStore root ref (Q.query q)
            respond . W.responseLBS W.status200 [] $ J.encode r
          (Debug.Trace.traceShowId -> !_) ->
            respond $ W.responseLBS W.status200 [] "not implemented"

data Route
  = SchemaJson String
  | Query
  deriving (Show)

routeP :: P.Parser Route
routeP =
  ( P.choice
      [ SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
        pure Query <* (P.string "/")
      ]
  )
    <* P.endOfInput