consolidate `backend, cli, common` -> `acms`

1 files changed, 503 insertions, 0 deletions

diff --git a/acms/src/ACMS/ACMS.hs b/acms/src/ACMS/ACMS.hs
new file mode 100644
index 0000000..12f8866
--- /dev/null
+++ b/acms/src/ACMS/ACMS.hs
@@ -0,0 +1,503 @@
+module ACMS.ACMS 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
+import Control.Monad.Trans (liftIO)
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.Bifunctor
+import Data.ByteString.Lazy.UTF8 qualified as LB
+import Data.ByteString.UTF8 qualified as B
+import Data.Function (on, (&))
+import Data.List
+import Data.Map qualified as M
+import Data.Map.Merge.Strict qualified as M
+import Data.Maybe
+import Data.Set qualified as S
+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 Data.Vector qualified as V
+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,
+    refMap :: RefMap
+  }
+  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)
+  repo <- initRepo root ref
+  atomically do putTMVar repoT repo
+  forever do
+    _ <- atomically do
+      let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT
+      readTQueue qT >> loop
+    repo' <- atomically do takeTMVar repoT
+    catches
+      ( do
+          repo <- initRepo root ref
+          atomically do putTMVar repoT repo
+      )
+      [ Handler
+          ( \(e :: ReferenceViolation) -> do
+              atomically do putTMVar repoT repo'
+              throwIO e
+          ),
+        Handler
+          ( \(e :: SomeException) -> do
+              printf "debug: %s\n" (displayException e)
+              atomically do putTMVar repoT repo'
+          )
+      ]
+    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
+              J.Array (V.toList -> (value : values)) <- do
+                liftIO . Q.withStore root ref . Q.withCommit cid $ do
+                  Q.query (fromString ("SELECT " <> path <> " FROM " <> path))
+              let schema =
+                    U.autoTypes'
+                      (fileNameToId value)
+                      (fileNameToId <$> values)
+              pure $ Collection path files schema
+            refMap <- liftIO . Q.withStore root ref . Q.withCommit cid $ do
+              buildRefMap
+            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 refMap
+            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
+
+data RefMap = RefMap
+  { references :: M.Map FilePath (S.Set FilePath),
+    referencees :: M.Map FilePath (S.Set FilePath)
+  }
+  deriving (Show)
+
+data ReferenceViolation
+  = ReferenceViolation
+  { referencee :: FilePath,
+    referencees :: S.Set FilePath
+  }
+  deriving (Show)
+
+instance Exception ReferenceViolation
+
+buildRefMap :: Q.StoreM RefMap
+buildRefMap = do
+  allIds <-
+    S.fromList
+      . map ((,) <$> takeDirectory <*> (dropExtension . takeBaseName))
+      <$> Q.listFiles ""
+  refMap <-
+    foldl'
+      ( \refMap (referencee, reference) ->
+          RefMap
+            { references = M.insertWith S.union referencee (S.singleton reference) refMap.references,
+              referencees = M.insertWith S.union reference (S.singleton referencee) refMap.referencees
+            }
+      )
+      (RefMap M.empty M.empty)
+      . concat
+      <$> mapM
+        ( \(c, i) -> do
+            v@(J.Object _) <- head <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE (T.pack i))))
+            pure (map (c </> i,) (collectReferences v))
+        )
+        (S.toList allIds)
+  checkRefMap allIds refMap
+  pure refMap
+  where
+    collectReferences (J.Object kvs) =
+      case map (first JK.toString) (JM.toList kvs) of
+        [("$ref", J.String i)] -> [T.unpack i]
+        _ -> concat (JM.elems (JM.map collectReferences kvs))
+    collectReferences (J.Array vs) = concatMap collectReferences vs
+    collectReferences _ = []
+
+    checkRefMap allIds (RefMap {referencees}) = do
+      mapM_
+        ( \(reference, referencees) ->
+            when (not (reference `S.member` S.map (uncurry (</>)) allIds)) do
+              liftIO (throwIO (ReferenceViolation reference referencees))
+        )
+        (M.toList referencees)
+
+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
+
+      stopM <- newEmptyMVar
+      flip forkFinally (putMVar stopM) do watch repoT root ref
+      mapM
+        ( \hostPref -> flip forkFinally (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..
+      logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
+      either throwIO pure =<< 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 . fileNameToId
+            =<< Q.withStore root ref do Q.query @J.Value q
+        _ -> do
+          error "not implemented"
+    _ -> 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
+          case find ((== c) . (.path)) lastCompatibleCommit.collections of
+            Nothing -> error "not implemented"
+            Just collection ->
+              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 . fileNameToId
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query @J.Value (fromString (printf "SELECT %s FROM %s" c c))
+                )
+        ("GET", ["collection", c, "paginated", read @Int . T.unpack -> limit, read @Int . T.unpack -> offset]) -> do
+          resp . W.responseLBS W.status200 [] . J.encode . fileNameToId
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query @J.Value
+                      ( fromString
+                          ( printf
+                              "SELECT %s FROM %s%s%s"
+                              c
+                              c
+                              (printf " LIMIT %d" limit :: String)
+                              (printf " OFFSET %d" offset :: String)
+                          )
+                      )
+                )
+        ("GET", ["collection", c, i]) -> do
+          resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE 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 . fileNameToId . head
+            =<< ( Q.withStore root ref do
+                    _ <- Q.query @J.Value (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName =~ /^%s\\.json$/" c (LB.toString (J.encode o)) c (escapePCRE i)))
+                    J.Array (V.toList -> [J.Object r]) <- Q.query @J.Value (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i)))
+                    _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c))
+                    _ <- buildRefMap
+                    Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i)))
+                )
+        ("POST", ["collection", c]) -> do
+          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
+          i <- U.toText <$> getUUID
+          o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req
+          resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head
+            =<< ( Q.withStore root ref do
+                    _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String (i <> ".json")) o))) c))
+                    _ <- buildRefMap
+                    Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i)))
+                )
+        ("DELETE", ["collection", c, i]) -> do
+          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
+          resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head
+            =<< ( Q.withStore root ref do
+                    r <- Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i)))
+                    Q.query @J.Value (fromString (printf "DELETE FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c (escapePCRE i)))
+                    _ <- buildRefMap
+                    pure r
+                )
+        (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
+
+dropNulls :: J.Object -> J.Object
+dropNulls =
+  JM.mapMaybe
+    ( \v ->
+        case v of
+          J.Null -> Nothing
+          (J.Object v') -> Just (J.Object (dropNulls v'))
+          _ -> Just v
+    )
+
+escapePCRE :: T.Text -> T.Text
+escapePCRE = T.pack . escapePCRE' . T.unpack
+
+escapePCRE' :: String -> String
+escapePCRE' [] = []
+escapePCRE' (c : cs) =
+  ((if c `elem` (".^$*+?()[{\\|" :: String) then ('\\' :) else id) [c])
+    <> escapePCRE' cs
+
+fileNameToId :: J.Value -> J.Value
+fileNameToId (J.Array xs) = J.Array (V.map fileNameToId xs)
+fileNameToId (J.Object kvs) =
+  J.Object
+    ( JM.foldrWithKey
+        ( \k v ->
+            case (k, v) of
+              ("$fileName", J.String v) ->
+                JM.insert "$id" (J.String (T.pack (dropExtension (T.unpack v))))
+              _ ->
+                JM.insert k (fileNameToId v)
+        )
+        JM.empty
+        $ kvs
+    )
+fileNameToId v = v