aboutsummaryrefslogtreecommitdiffstats
path: root/backend/app/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'backend/app/Main.hs')
-rw-r--r--backend/app/Main.hs510
1 files changed, 0 insertions, 510 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs
deleted file mode 100644
index c9db2ea..0000000
--- a/backend/app/Main.hs
+++ /dev/null
@@ -1,510 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# 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
-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
generated by cgit v1.2.3 (git 2.25.1) at 2025-03-15 20:49:11 +0000